[r-cran-vgam] 19/63: Import Upstream version 0.8-1
Andreas Tille
tille at debian.org
Tue Jan 24 13:54:25 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 68e7e765abde180fce4eda913daf75bbfa38c45f
Author: Andreas Tille <tille at debian.org>
Date: Tue Jan 24 14:16:50 2017 +0100
Import Upstream version 0.8-1
---
BUGS | 10 +
DESCRIPTION | 10 +-
NAMESPACE | 18 +-
NEWS | 54 +-
R/cao.R | 15 +-
R/cao.fit.q | 881 ++++++++------
R/cqo.R | 97 +-
R/cqo.fit.q | 521 ++++----
R/family.basics.R | 69 +-
R/family.binomial.R | 1310 ++++++++++++--------
R/family.bivariate.R | 208 ++--
R/family.categorical.R | 705 ++++++-----
R/family.exp.R | 369 ++++++
R/family.glmgam.R | 769 ++++++------
R/family.nonlinear.R | 297 +++--
R/family.positive.R | 53 +-
R/family.qreg.R | 131 +-
R/family.rrr.R | 257 ++--
R/family.univariate.R | 744 ++++++-----
R/family.zeroinf.R | 150 +--
R/links.q | 58 +-
R/mux.q | 22 +
R/plot.vglm.q | 2 +-
R/predict.vgam.q | 77 +-
R/qrrvglm.control.q | 6 +-
R/qtplot.q | 122 +-
R/rrvglm.control.q | 13 +-
R/rrvglm.fit.q | 55 +-
R/s.vam.q | 300 ++---
R/vgam.R | 28 +-
R/vgam.control.q | 29 +-
R/vgam.fit.q | 83 +-
R/vgam.match.q | 144 +--
R/vglm.R | 29 +-
R/vglm.fit.q | 41 +-
R/vlm.R | 49 +-
R/vlm.wfit.q | 53 +-
R/vsmooth.spline.q | 564 +++++----
inst/doc/categoricalVGAM.Rnw | 3 +-
inst/doc/categoricalVGAM.pdf | Bin 2956343 -> 2958722 bytes
man/CommonVGAMffArguments.Rd | 6 +-
man/RayleighUC.Rd | 8 +-
man/SinmadUC.Rd | 21 +-
man/VGAM-package.Rd | 50 +-
man/acat.Rd | 4 +-
man/alaplaceUC.Rd | 4 +-
man/amh.Rd | 4 +-
man/amlbinomial.Rd | 3 +-
man/amlexponential.Rd | 4 +-
man/amlnormal.Rd | 1 +
man/benfUC.Rd | 11 +-
man/benini.Rd | 18 +-
man/beniniUC.Rd | 3 +
man/binomialff.Rd | 23 +-
man/bivgamma.mckay.Rd | 132 ++
man/borel.tanner.Rd | 1 +
man/brat.Rd | 5 +-
man/cao.control.Rd | 4 +-
man/cardioid.Rd | 15 +-
man/cqo.Rd | 181 ++-
man/dirichlet.Rd | 3 +-
man/eexpUC.Rd | 133 ++
man/enormUC.Rd | 133 ++
man/erlang.Rd | 6 +-
man/eunifUC.Rd | 174 +++
man/expexp.Rd | 20 +-
man/expexp1.Rd | 18 +-
man/fisk.Rd | 5 +
man/fitted.vlm.Rd | 16 +-
man/frechet.Rd | 5 +
man/freund61.Rd | 4 +
man/gamma2.Rd | 2 +-
man/gamma2.ab.Rd | 2 +-
man/{ggamma.Rd => gengamma.Rd} | 32 +-
man/gengammaUC.Rd | 76 ++
man/ggammaUC.Rd | 74 --
man/gpd.Rd | 30 +-
man/hypersecant.Rd | 22 +-
man/invbinomial.Rd | 7 +-
man/invlomax.Rd | 3 +
man/invparalogistic.Rd | 3 +
man/levy.Rd | 4 -
man/lgammaUC.Rd | 36 +-
man/lgammaff.Rd | 52 +-
man/lino.Rd | 17 +-
man/lirat.Rd | 7 +-
man/lms.bcg.Rd | 161 +--
man/lms.bcn.Rd | 226 ++--
man/lms.yjn.Rd | 75 +-
man/logUC.Rd | 25 +-
man/lomax.Rd | 3 +
man/mckaygamma2.Rd | 108 --
man/micmen.Rd | 45 +-
man/negbinomial.Rd | 58 +-
man/normal1.Rd | 27 +-
man/notdocumentedyet.Rd | 1 +
man/paralogistic.Rd | 3 +
man/pareto1.Rd | 5 +
man/poissonp.Rd | 2 +
man/predict.vglm.Rd | 24 +-
man/prentice74.Rd | 61 +-
man/propodds.Rd | 1 +
man/qrrvglm.control.Rd | 236 ++--
man/rayleigh.Rd | 1 +
man/rcqo.Rd | 78 +-
man/riceff.Rd | 11 +-
man/rrvglm.Rd | 146 ++-
man/rrvglm.control.Rd | 28 +-
man/seq2binomial.Rd | 25 +-
man/simplex.Rd | 91 +-
man/simplexUC.Rd | 72 ++
man/sinmad.Rd | 6 +-
man/vgam.Rd | 15 +-
man/vglm.Rd | 30 +-
man/vonmises.Rd | 3 +-
man/vsmooth.spline.Rd | 54 +-
man/weibull.Rd | 18 +-
man/yulesimon.Rd | 3 +-
man/zanegbinomial.Rd | 22 +-
man/zetaff.Rd | 2 +-
man/zipoisson.Rd | 4 +-
src/caqo3.c | 2640 ++++++++++++++++++++++++++++++++++++++++
src/cqof.f | 2114 --------------------------------
src/lms.f | 259 ++--
src/rgam.f | 765 ++++++------
src/rgam3.c | 746 ++++++++++++
src/testf90.f90 | 96 --
src/tyeepolygamma.f | 151 ---
src/tyeepolygamma3.c | 137 +++
src/vgam.f | 1817 +++++++++++++--------------
src/vgam3.c | 2003 ++++++++++++++++++++++++++++++
src/vlinpack1.f | 58 +-
src/vmux.f | 751 ++++++------
src/vmux3.c | 698 +++++++++++
src/zeta3.c | 188 +++
src/zeta4.c | 258 ----
136 files changed, 15194 insertions(+), 8885 deletions(-)
diff --git a/BUGS b/BUGS
index f3cbb77..7edde98 100755
--- a/BUGS
+++ b/BUGS
@@ -2,6 +2,16 @@ Here is a list of known bugs.
+2010-04-12
+cqo() should be working now. It uses new C code.
+Also, vgam() and vsmooth.spline() should not be noticeably different
+from before. But cao() is still working... getting it going soon hopefully.
+
+
+
+
+
+
2009/07/13
cqo() fails... I think it is due to initial values being faulty.
Hope to look into it soon.
diff --git a/DESCRIPTION b/DESCRIPTION
index c8bedf2..e700c2d 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,10 +1,10 @@
Package: VGAM
-Version: 0.7-10
-Date: 2010-01-05
+Version: 0.8-1
+Date: 2010-06-22
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>
-Depends: R (>= 2.5.0), splines, methods, stats, stats4
+Depends: R (>= 2.8.0), splines, methods, stats, stats4
Description: Vector generalized linear and additive models, and
associated models (Reduced-Rank VGLMs, Quadratic RR-VGLMs,
Reduced-Rank VGAMs). This package fits many models and
@@ -15,6 +15,6 @@ License: GPL-2
URL: http://www.stat.auckland.ac.nz/~yee/VGAM
LazyLoad: yes
LazyData: yes
-Packaged: 2010-01-05 11:25:57 UTC; zeileis
+Packaged: 2010-06-22 04:48:23 UTC; tyee001
Repository: CRAN
-Date/Publication: 2010-01-05 11:53:59
+Date/Publication: 2010-06-22 08:29:15
diff --git a/NAMESPACE b/NAMESPACE
index 5bb1270..66a1142 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -49,6 +49,7 @@ export( bs, ns, scale.default, poly )
export(iam,
fill, fill1, fill2, fill3,
amh, damh, pamh, ramh,
+bivgamma.mckay,
freund61,
frechet2, frechet3, dfrechet, pfrechet, qfrechet, rfrechet,
frank, dfrank, pfrank, rfrank,
@@ -155,6 +156,7 @@ process.binomial2.data.vgam, process.categorical.data.vgam,
qtplot,
qtplot.default, qtplot.gumbel, qtplot.lms.bcg,
qtplot.lms.bcn, qtplot.lms.yjn, qtplot.lms.yjn2, qtplot.vextremes, qtplot.vglm,
+explot.lms.bcn,
rlplot,
rlplot.egev, rlplot.gev,
rlplot.vextremes, rlplot.vglm,
@@ -292,10 +294,10 @@ exponential, G1G2G3)
export(
lgammaff, lgamma3ff)
export(
-mckaygamma2, gammahyp,
-ggamma, gamma1, gamma2, gamma2.ab, gammaff)
+gammahyp,
+gengamma, gamma1, gamma2, gamma2.ab, gammaff)
export(dlgamma, plgamma, qlgamma, rlgamma)
-export(dggamma, pggamma, qggamma, rggamma)
+export(dgengamma, pgengamma, qgengamma, rgengamma)
export(
@@ -318,6 +320,13 @@ dmultinomial, multinomial, margeff)
export(
slash, dslash, pslash, rslash)
+
+export(
+deunif, peunif, qeunif, reunif,
+denorm, penorm, qenorm, renorm,
+deexp, peexp, qeexp, reexp)
+
+
export(
meplot, meplot.default, meplot.vlm,
guplot, guplot.default, guplot.vlm,
@@ -335,7 +344,8 @@ rrar, rrvglm.control,
rrvglm.optim.control)
export(eta2theta,
-rrvglm, simplex,
+rrvglm,
+simplex, dsimplex, rsimplex,
sratio, s, studentt, Tol, trplot.qrrvglm,
trplot,
rcqo,
diff --git a/NEWS b/NEWS
index f369c06..2e2a0aa 100755
--- a/NEWS
+++ b/NEWS
@@ -1,9 +1,61 @@
**************************************************
* *
- * 0.7 SERIES NEWS *
+ * 0.8 SERIES NEWS *
* *
**************************************************
+ CHANGES IN VGAM VERSION 0.8-1
+
+NEW FEATURES
+
+ o Most of the Fortran 77 code has been converted to C.
+ This change will be largely hidden from most users
+ but there may be the occasional bug not detected.
+ Much of the heavy work was done by Alvin Sou.
+ o lms.bcn()@loglikelihood incorporates the constants in
+ the log-likelihood.
+ o Also, no more F90 code! This means less portability/platform
+ problems.
+ o bivgamma.mckay, formerly mckaygamma2(), has been modified
+ substantially.
+ o Improvements have been made to simplex() and
+ [dr]simplex() have been written.
+ o Expectile functions for the uniform, normal and
+ exponential distributions: [dpqr]-type functions.
+ o cqo() has EqualTolerances = TRUE and ITolerances = FALSE as
+ the default now. The result is that cqo() should work without
+ the environmental variables being scaled.
+ If it is scaled then setting ITolerances = TRUE will result
+ in greater speed and requiring less memory.
+ o Families that deal with proportions, such as binomialff() and
+ betabinomial(), incorporate weights separately from the weights
+ generated by the response/counts. So the weights argument can
+ now have any positive values.
+ o rrvglm(..., Norrr = NULL) can be used so that the reduced-rank
+ regression is applied to every variable including the intercept.
+ o Renaming: ggamma() is now gengamma(), etc.
+ o Improved functions: negbinomial() has a few new arguments.
+
+
+BUG FIXES
+
+ o Deviance.categorical.data.vgam did not handle small
+ fitted probabilities.
+ o binom2.rho() could produce small negative fitted probabilities.
+ o seq2binomial() did not initialize 'mvector'.
+ o zeta() crashed on some platforms.
+ o cqo() appears to be working again with the new C code.
+ o cao() still not working with the new C code.
+ o zapoisson() did not implement the elambda argument correctly.
+ o Tested ok on R 2.11.1.
+
+
+
+ **************************************************
+ * *
+ * 0.7 SERIES NEWS *
+ * *
+ **************************************************
CHANGES IN VGAM VERSION 0.7-10
diff --git a/R/cao.R b/R/cao.R
index ae5a586..2f4edf9 100644
--- a/R/cao.R
+++ b/R/cao.R
@@ -7,6 +7,7 @@
+
cao <- function(formula,
family, data=list(),
weights=NULL, subset=NULL, na.action=na.fail,
@@ -33,7 +34,8 @@ cao <- function(formula,
data <- environment(formula)
mf <- match.call(expand=FALSE)
- mf$family <- mf$method <- mf$model <- mf$x.arg <- mf$y.arg <- mf$control <-
+ mf$family <- mf$method <- mf$model <- mf$x.arg <- mf$y.arg <-
+ mf$control <-
mf$contrasts <- mf$constraints <- mf$extra <- mf$qr.arg <- NULL
mf$coefstart <- mf$etastart <- mf$... <- NULL
mf$smart <- NULL
@@ -81,7 +83,7 @@ cao <- function(formula,
cao.fitter <- get(method)
- deviance.Bestof = rep(as.numeric(NA), len=control$Bestof)
+ deviance.Bestof = rep(as.numeric(NA), len = control$Bestof)
for(tries in 1:control$Bestof) {
if (control$trace && (control$Bestof>1)) {
cat(paste("\n========================= Fitting model",
@@ -89,7 +91,7 @@ cao <- function(formula,
if (exists("flush.console"))
flush.console()
}
- it <- cao.fitter(x=x, y=y, w=w, offset=offset,
+ onefit <- cao.fitter(x=x, y=y, w=w, offset=offset,
etastart=etastart, mustart=mustart, coefstart=coefstart,
family=family,
control=control,
@@ -98,9 +100,10 @@ cao <- function(formula,
extra=extra,
qr.arg = qr.arg,
Terms=mt, function.name=function.name, ...)
- deviance.Bestof[tries] = it$crit.list$deviance
- if (tries==1 || min(deviance.Bestof[1:(tries-1)])>deviance.Bestof[tries])
- fit = it
+ deviance.Bestof[tries] = onefit$crit.list$deviance
+ if (tries == 1 ||
+ min(deviance.Bestof[1:(tries-1)]) > deviance.Bestof[tries])
+ fit = onefit
}
fit$misc$deviance.Bestof = deviance.Bestof
diff --git a/R/cao.fit.q b/R/cao.fit.q
index 894098c..e053fad 100644
--- a/R/cao.fit.q
+++ b/R/cao.fit.q
@@ -7,6 +7,7 @@
+
cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
etastart=NULL, mustart=NULL, coefstart=NULL,
offset=0, family,
@@ -31,7 +32,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
X_vlm_save <- NULL
intercept.only <- ncol(x) == 1 && dimnames(x)[[2]] == "(Intercept)"
- y.names <- predictors.names <- NULL # May be overwritten in @initialize
+ y.names <- predictors.names <- NULL # May be overwritten in @initialize
n.save <- n
@@ -41,7 +42,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
rrcontrol <- control #
if (length(family at initialize))
- eval(family at initialize) # Initialize mu and M (and optionally w)
+ eval(family at initialize) # Initialize mu and M (and optionally w)
n <- n.save
modelno = switch(family at vfamily[1], "poissonff"=2,
@@ -71,7 +72,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
eval(family at constraints)
- special.matrix = matrix(-34956.125, M, M) # An unlikely used matrix
+ special.matrix = matrix(-34956.125, M, M) # An unlikely used matrix
just.testing <- cm.vgam(special.matrix, x, rrcontrol$Norrr, constraints)
findex = trivial.constraints(just.testing, special.matrix)
tc1 = trivial.constraints(constraints)
@@ -90,27 +91,30 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
names(colx1.index) = names.colx1.index
}
- rrcontrol$colx1.index=control$colx1.index=colx1.index #Save it on the object
+ # Save it on the object:
+ rrcontrol$colx1.index = control$colx1.index = colx1.index
colx2.index = 1:ncol(x)
names(colx2.index) = dx2
colx2.index = colx2.index[-colx1.index]
p1 = length(colx1.index); p2 = length(colx2.index)
- rrcontrol$colx2.index=control$colx2.index=colx2.index #Save it on the object
+ # Save it on the object:
+ rrcontrol$colx2.index = control$colx2.index = colx2.index
- Cmat = if (length(rrcontrol$Cinit)) matrix(rrcontrol$Cinit,p2,Rank) else {
+ Cmat = if (length(rrcontrol$Cinit))
+ matrix(rrcontrol$Cinit,p2,Rank) else {
if (!rrcontrol$Use.Init.Poisson.QO) {
- matrix(rnorm(p2 * Rank, sd=rrcontrol$SD.Cinit), p2, Rank)
+ matrix(rnorm(p2*Rank, sd=rrcontrol$SD.Cinit), p2, Rank)
} else {
.Init.Poisson.QO(ymat=as.matrix(y),
- X1=x[,colx1.index,drop=FALSE],
- X2=x[,colx2.index,drop=FALSE],
- Rank=rrcontrol$Rank, trace=rrcontrol$trace,
- max.ncol.etamat = rrcontrol$Etamat.colmax,
- Crow1positive=rrcontrol$Crow1positive,
- constwt= any(family at vfamily[1] ==
- c("negbinomial","gamma2","gaussianff")),
+ X1=x[,colx1.index,drop=FALSE],
+ X2=x[,colx2.index,drop=FALSE],
+ Rank=rrcontrol$Rank, trace=rrcontrol$trace,
+ max.ncol.etamat = rrcontrol$Etamat.colmax,
+ Crow1positive=rrcontrol$Crow1positive,
+ constwt= any(family at vfamily[1] ==
+ c("negbinomial","gamma2","gaussianff")),
takelog= any(family at vfamily[1] != c("gaussianff")))
}
}
@@ -124,24 +128,26 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (nice31 != 1) stop("not nice")
ncolBlist <- unlist(lapply(Blist, ncol))
- lv.mat = x[,colx2.index,drop=FALSE] %*% Cmat
+ lv.mat = x[, colx2.index, drop = FALSE] %*% Cmat
rmfromVGAMenv(c("etamat", "beta"), prefix=".VGAM.CAO.")
- Nice21 = length(names.colx1.index)==1 && names.colx1.index == "(Intercept)"
- if (!Nice21) stop("Norrr = ~ 1 is supported only, without constraints")
- NOS = ifelse(modelno==3 || modelno==5, M/2, M)
- p1star. = if (Nice21) ifelse(modelno==3 || modelno==5,2,1) else M
+ Nice21 = length(names.colx1.index) == 1 &&
+ names.colx1.index == "(Intercept)"
+ if (!Nice21) stop("'Norrr = ~ 1' is supported only, without constraints")
+ NOS = ifelse(modelno %in% c(3, 5), M/2, M)
+ p1star. = if (Nice21) ifelse(modelno %in% c(3, 5), 2, 1) else M
p2star. = if (Nice21) Rank else stop("not Nice21")
pstar. = p1star. + p2star.
- nstar = if (Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (Nice21) ifelse(modelno %in% c(3, 5), n * 2, n) else n * M
lenbeta = pstar. * ifelse(Nice21, NOS, 1)
- othint = c(Rank,control$EqualTol, pstar. , dimw=1, inited=0, # w(,dimw) cols
- modelno, maxitl=control$maxitl, actnits=0, twice=0, p1star. ,
- p2star. , Nice21, lenbeta, controlITolerances=0, control$trace,
- p1, p2=p2, imethod=control$method.init, bchat=0)
+ othint = c(Rank, control$EqualTol, pstar. ,
+ dim2wz=1, inited=0, # w(,dimw) cols
+ modelno, maxitl=control$maxitl, actnits=0, twice=0, p1star. ,
+ p2star. , Nice21, lenbeta, controlITolerances=0, control$trace,
+ p1, p2=p2, imethod=control$method.init, bchat=0)
othdbl = c(small=control$SmallNo, fseps=control$epsilon,
.Machine$double.eps,
iKvector=rep(control$iKvector, len=NOS),
@@ -154,22 +160,22 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
flush.console()
}
- conjgrad = optim(par=c(Cmat), fn=callcaof,
- gr = if (control$GradientFunction) calldcaof else NULL,
- method="BFGS",
- control=list(fnscale=1, trace=as.integer(control$trace),
- maxit=control$Maxit.optim, REPORT=10),
- etamat=eta, xmat=x, ymat=y, # as.matrix(y),
- wvec=w, modelno=modelno,
- Control=control,
- Nice21=Nice21,
- p1star. = p1star. , p2star. = p2star. ,
- n=n, M=M,
- othint=othint, othdbl=othdbl,
- alldump=FALSE)
+ conjgrad = optim(par=c(Cmat), fn=callcaoc,
+ gr = if (control$GradientFunction) calldcaoc else NULL,
+ method="BFGS",
+ control=list(fnscale=1, trace=as.integer(control$trace),
+ maxit=control$Maxit.optim, REPORT=10),
+ etamat=eta, xmat=x, ymat=y, # as.matrix(y),
+ wvec=w, modelno=modelno,
+ Control=control,
+ Nice21=Nice21,
+ p1star. = p1star. , p2star. = p2star. ,
+ n=n, M=M,
+ othint=othint, othdbl=othdbl,
+ alldump=FALSE)
- Cmat = matrix(conjgrad$par, p2, Rank) # old because of scale(cmatrix)
+ Cmat = matrix(conjgrad$par, p2, Rank) # old becoz of scale(cmatrix)
# Cmat <- Cmat %*% Ut # Normalized
@@ -178,17 +184,17 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (!converged) {
if (maxitl > 1) {
- warning(paste("convergence not obtained in", maxitl, "iterations."))
+ warning("convergence not obtained in", maxitl, "iterations.")
} else {
- warning(paste("convergence not obtained"))
+ warning("convergence not obtained")
}
} else {
}
- Cmat = crow1C(Cmat, control$Crow1positive) # Make sure the signs are right
+ Cmat = crow1C(Cmat, control$Crow1positive) # Make sure signs are right
flush.console()
temp9 =
- callcaof(cmatrix=Cmat,
+ callcaoc(cmatrix=Cmat,
etamat=eta, xmat=x, ymat=y, wvec=w, modelno=modelno,
Control=control,
Nice21=Nice21,
@@ -199,18 +205,26 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (!is.list(extra))
extra = list()
extra$Cmat = temp9$Cmat
+
ynames = dimnames(y)[[2]]
extra$df1.nl = temp9$df1.nl
+ extra$lambda1 = temp9$lambda1
extra$spar1 = temp9$spar1
+ names(extra$df1.nl) =
+ names(extra$lambda1) =
names(extra$spar1) = ynames
- names(extra$df1.nl) = ynames
if (Rank == 2) {
extra$spar2 = temp9$spar2
+ extra$lambda2 = temp9$lambda2
extra$df2.nl = temp9$df2.nl
+ names(extra$df2.nl) =
+ names(extra$lambda2) =
names(extra$spar2) = ynames
- names(extra$df2.nl) = ynames
}
+ extra$alldeviance = temp9$alldeviance
+ names(extra$alldeviance) = ynames
+
mu = matrix(temp9$fitted, n, NOS, byrow=TRUE)
@@ -273,17 +287,17 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
structure(c(fit,
temp9,
list(
- contrasts=attr(x, "contrasts"),
- control=control,
- crit.list=crit.list,
- extra=extra,
- family=family,
- iter=iter,
- misc=misc,
+ contrasts = attr(x, "contrasts"),
+ control = control,
+ crit.list = crit.list,
+ extra = extra,
+ family = family,
+ iter = iter,
+ misc = misc,
post = post,
- x=x,
- y=y)),
- vclass=family at vfamily)
+ x = x,
+ y = y)),
+ vclass = family at vfamily)
}
@@ -305,27 +319,30 @@ cao.control = function(Rank=1,
Use.Init.Poisson.QO=TRUE,
Bestof = if (length(Cinit)) 1 else 10,
- maxitl = 40,
+ maxitl = 10, # was 40 prior to 20100420
method.init = 1,
bf.epsilon = 1.0e-7,
- bf.maxit = 40,
+ bf.maxit = 10, # was 40 prior to 20100420
Maxit.optim = 250,
optim.maxit = 20,
SD.sitescores = 1.0,
SD.Cinit = 0.02,
trace = TRUE,
- df1.nl = 2.5, # About 1.5-2.5 gives the flexibility of a quadratic
- df2.nl = 2.5, # About 1.5-2.5 gives the flexibility of a quadratic
+ df1.nl = 2.5, # About 1.5--2.5 gives the flexibility of a quadratic
+ df2.nl = 2.5, # About 1.5--2.5 gives the flexibility of a quadratic
spar1 = 0, # 0 means df1.nl is used
spar2 = 0, # 0 means df2.nl is used
...)
{
- if (!is.Numeric(iShape, posit=TRUE)) stop("bad input for 'iShape'")
- if (!is.Numeric(iKvector, posit=TRUE)) stop("bad input for 'iKvector'")
+ if (!is.Numeric(iShape, posit=TRUE))
+ stop("bad input for 'iShape'")
+ if (!is.Numeric(iKvector, posit=TRUE))
+ stop("bad input for 'iKvector'")
if (!is.Numeric(method.init, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'method.init'")
- if (criterion != "deviance") stop("'criterion' must be \"deviance\"")
- if (GradientFunction) stop("14/1/05; GradientFunction=TRUE not working yet")
+ if (criterion != "deviance") stop("'criterion' must be 'deviance'")
+ if (GradientFunction)
+ stop("14/1/05; GradientFunction = TRUE not working yet")
se.fit = as.logical(FALSE)
if (se.fit) stop("se.fit = FALSE handled only")
@@ -339,7 +356,8 @@ cao.control = function(Rank=1,
stop("Bad input for 'bf.epsilon'")
if (!is.Numeric(bf.maxit, integ=TRUE, posit=TRUE, allow=1))
stop("Bad input for 'bf.maxit'")
- if (!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
+ if (!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) ||
+ Etamat.colmax < Rank)
stop("bad input for 'Etamat.colmax'")
if (!is.Numeric(Maxit.optim, integ=TRUE, posit=TRUE, allow=1))
stop("Bad input for 'Maxit.optim'")
@@ -352,75 +370,76 @@ cao.control = function(Rank=1,
if (!is.Numeric(df1.nl) || any(df1.nl < 0))
stop("Bad input for 'df1.nl'")
if (any(df1.nl >= 0 & df1.nl < 0.05)) {
- warning("df1.nl values between 0 and 0.05 converted to 0.05")
+ warning("'df1.nl' values between 0 and 0.05 converted to 0.05")
df1.nl[df1.nl < 0.05] = 0.05
}
if (!is.Numeric(df2.nl) || any(df2.nl < 0))
stop("Bad input for 'df2.nl'")
if (any(df2.nl >= 0 & df2.nl < 0.05)) {
- warning("df2.nl values between 0 and 0.05 converted to 0.05")
+ warning("'df2.nl' values between 0 and 0.05 converted to 0.05")
df2.nl[df2.nl < 0.05] = 0.05
}
if (!is.Numeric(spar1) || any(spar1 < 0))
stop("Bad input for 'spar1'")
if (!is.Numeric(spar2) || any(spar2 < 0))
stop("Bad input for 'spar2'")
- if (!is.Numeric(epsilon, posit=TRUE, allow=1))
+ if (!is.Numeric(epsilon, posit = TRUE, allow = 1))
stop("Bad input for 'epsilon'")
- if (!is.Numeric(SmallNo, posit=TRUE, allow=1))
+ if (!is.Numeric(SmallNo, posit = TRUE, allow = 1))
stop("Bad input for 'SmallNo'")
if ((SmallNo < .Machine$double.eps) ||
- (SmallNo > .0001)) stop("SmallNo is out of range")
+ (SmallNo > .0001)) stop("'SmallNo' is out of range")
ans = list(
- Corner=FALSE, # A constant, not a control parameter; unneeded?
- EqualTolerances=FALSE, # A constant, not a control parameter; needed
- ITolerances=FALSE, # A constant, not a control parameter; unneeded?
- Quadratic=FALSE, # A constant, not a control parameter; unneeded?
- all.knots = as.logical(all.knots)[1],
- Bestof = Bestof,
- Cinit=Cinit,
- ConstrainedO = TRUE, # A constant, not a control parameter
- criterion=criterion,
- Crow1positive=as.logical(rep(Crow1positive, len=Rank)),
- epsilon = epsilon,
- Etamat.colmax = Etamat.colmax,
- FastAlgorithm = TRUE, # A constant, not a control parameter
- GradientFunction = as.logical(GradientFunction),
- maxitl = maxitl,
- bf.epsilon = bf.epsilon,
- bf.maxit = bf.maxit,
- method.init = method.init,
- Maxit.optim = Maxit.optim,
- optim.maxit = optim.maxit,
- Norrr=Norrr,
- Rank = Rank,
- SD.sitescores = SD.sitescores,
- SD.Cinit = SD.Cinit,
- se.fit = se.fit, # If TRUE, then would need storage for S QR fits
- SmallNo = SmallNo,
- trace = as.integer(trace),
- Use.Init.Poisson.QO=Use.Init.Poisson.QO,
- iKvector = as.numeric(iKvector),
- iShape = as.numeric(iShape),
- DF1 = 2.5, # Used as Default value if df1.nl has no default
- DF2 = 2.5, # Used as Default value if df2.nl has no default
- SPAR1 = 0, # Used as Default value if spar1 has no default
- SPAR2 = 0, # Used as Default value if spar2 has no default
- df1.nl = df1.nl,
- df2.nl = df2.nl,
- spar1 = spar1,
- spar2 = spar2)
+ Corner=FALSE, # A constant, not a control parameter; unneeded?
+ EqualTolerances=FALSE, # A constant, not a control parameter; needed
+ ITolerances=FALSE, # A constant, not a control parameter; unneeded?
+ Quadratic=FALSE, # A constant, not a control parameter; unneeded?
+ all.knots = as.logical(all.knots)[1],
+ Bestof = Bestof,
+ Cinit=Cinit,
+ ConstrainedO = TRUE, # A constant, not a control parameter
+ criterion=criterion,
+ Crow1positive=as.logical(rep(Crow1positive, len=Rank)),
+ epsilon = epsilon,
+ Etamat.colmax = Etamat.colmax,
+ FastAlgorithm = TRUE, # A constant, not a control parameter
+ GradientFunction = as.logical(GradientFunction),
+ maxitl = maxitl,
+ bf.epsilon = bf.epsilon,
+ bf.maxit = bf.maxit,
+ method.init = method.init,
+ Maxit.optim = Maxit.optim,
+ optim.maxit = optim.maxit,
+ Norrr=Norrr,
+ Rank = Rank,
+ SD.sitescores = SD.sitescores,
+ SD.Cinit = SD.Cinit,
+ se.fit = se.fit, # If TRUE, then would need storage for S QR fits
+ SmallNo = SmallNo,
+ trace = as.integer(trace),
+ Use.Init.Poisson.QO=Use.Init.Poisson.QO,
+ iKvector = as.numeric(iKvector),
+ iShape = as.numeric(iShape),
+ DF1 = 2.5, # Used as Default value if df1.nl has no default
+ DF2 = 2.5, # Used as Default value if df2.nl has no default
+ SPAR1 = 0, # Used as Default value if spar1 has no default
+ SPAR2 = 0, # Used as Default value if spar2 has no default
+ df1.nl = df1.nl,
+ df2.nl = df2.nl,
+ spar1 = spar1,
+ spar2 = spar2)
ans
}
-create.cms <- function(Rank=1, M, MSratio=1, which, p1=1) {
- if (!is.Numeric(p1, allow=1, integ=TRUE, pos=TRUE)) stop("bad input for p1")
- Blist. = vector("list", p1+Rank)
- for(r in 1:(p1+Rank))
- Blist.[[r]] = diag( M )
+create.cms <- function(Rank = 1, M, MSratio = 1, which, p1 = 1) {
+ if (!is.Numeric(p1, allow = 1, integ = TRUE, pos = TRUE))
+ stop("bad input for 'p1'")
+ Blist. = vector("list", p1 + Rank)
+ for(rr in 1:(p1+Rank))
+ Blist.[[rr]] = diag( M )
names(Blist.) = if (p1 == 1) c("(Intercept)", names(which)) else stop()
if (MSratio == 2) {
for(r in 1:Rank)
@@ -432,13 +451,14 @@ create.cms <- function(Rank=1, M, MSratio=1, which, p1=1) {
-callcaof = function(cmatrix,
+callcaoc = function(cmatrix,
etamat, xmat, ymat, wvec, modelno,
Control, Nice21=TRUE,
- p1star. = if (any(modelno==c(3,5))) 2 else 1, p2star. =Rank,
+ p1star. = if (modelno %in% c(3, 5)) 2 else 1,
+ p2star. = Rank,
n, M,
othint, othdbl,
- alldump=FALSE) {
+ alldump = FALSE) {
flush.console()
control = Control
@@ -446,33 +466,36 @@ callcaof = function(cmatrix,
p1 = length(control$colx1.index)
p2 = length(control$colx2.index)
yn = dimnames(ymat)[[2]]
- if (length(yn) != ncol(ymat)) stop("the column names of ymat must be given")
+ if (length(yn) != ncol(ymat))
+ stop("the column names of 'ymat' must be given")
queue = qbig = Rank # 19/10/05; number of smooths per species
- NOS = if (any(modelno==c(3,5))) M/2 else M
- df1.nl = procVec(control$df1.nl, yn= yn , Def=control$DF1)
- spar1 = procVec(control$spar1, yn= yn , Def= control$SPAR1)
- df2.nl = procVec(control$df2.nl, yn= yn , Def=control$DF2)
- spar2 = procVec(control$spar2, yn= yn , Def= control$SPAR2)
- if (any(c(length(spar1),length(spar2),length(df1.nl),length(df2.nl)) != NOS))
- stop("wrong length in at least one of df1.nl, df2.nl, spar1, spar2")
-
- cmatrix = matrix(cmatrix, p2, Rank) # crow1C() needs a matrix as input
- cmatrix = crow1C(cmatrix, crow=control$Crow1positive)
- numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
- evnu = eigen(var(numat))
- temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
- evnu$vector %*% evnu$value^(-0.5)
- cmatrix = cmatrix %*% temp7
- cmatrix = crow1C(cmatrix, crow=control$Crow1positive)
- numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
+ NOS = if (modelno %in% c(3, 5)) M/2 else M
+ df1.nl = procVec(control$df1.nl, yn= yn , Def = control$DF1)
+ spar1 = procVec(control$spar1, yn= yn , Def = control$SPAR1)
+ df2.nl = procVec(control$df2.nl, yn= yn , Def = control$DF2)
+ spar2 = procVec(control$spar2, yn= yn , Def = control$SPAR2)
+ if (any(c(length(spar1), length(spar2), length(df1.nl),
+ length(df2.nl)) != NOS))
+ stop("wrong length in at least one of ",
+ "'df1.nl', 'df2.nl', 'spar1', 'spar2'")
+
+ cmatrix = matrix(cmatrix, p2, Rank) # crow1C() needs a matrix as input
+ cmatrix = crow1C(cmatrix, crow=control$Crow1positive)
+ numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
+ evnu = eigen(var(numat))
+ temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
+ evnu$vector %*% evnu$value^(-0.5)
+ cmatrix = cmatrix %*% temp7
+ cmatrix = crow1C(cmatrix, crow=control$Crow1positive)
+ numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
dim(numat) = c(n, Rank)
- mynames5 = if (Rank==1) "lv" else paste("lv", 1:Rank, sep="")
- nu1mat = cbind("(Intercept)"=1, lv=numat)
+ mynames5 = if (Rank == 1) "lv" else paste("lv", 1:Rank, sep="")
+ nu1mat = cbind("(Intercept)" = 1, lv = numat)
dimnames(nu1mat) = list(dimnames(xmat)[[1]], c("(Intercept)", mynames5))
- temp.smooth.frame = vector("list", p1+Rank) # A temporary makeshift frame
+ temp.smooth.frame = vector("list", p1+Rank) # Temporary makeshift frame
names(temp.smooth.frame) = c(names(control$colx1.index), mynames5)
for(uu in 1:(p1+Rank)) {
temp.smooth.frame[[uu]] = nu1mat[,uu]
@@ -484,32 +507,33 @@ callcaof = function(cmatrix,
}
pstar. = p1star. + p2star. # = Mdot + Rank
- nstar = if (Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (Nice21) ifelse(modelno %in% c(3, 5), n * 2, n) else n * M
lenbeta = pstar. * ifelse(Nice21, NOS, 1) # Holds the linear coeffs
inited = if (exists(".VGAM.CAO.etamat", envir=VGAMenv)) 1 else 0
- usethiseta = if (inited==1)
+ usethiseta = if (inited == 1)
getfromVGAMenv("etamat", prefix = ".VGAM.CAO.") else t(etamat)
if (any(is.na(usethiseta))) {
- usethiseta = t(etamat) # So that dim(usethiseta)==c(M,n)
+ usethiseta = t(etamat) # So that dim(usethiseta) == c(M,n)
rmfromVGAMenv("etamat", prefix=".VGAM.CAO.")
}
- usethisbeta = if (inited==2)
+ usethisbeta = if (inited == 2)
getfromVGAMenv("beta", prefix = ".VGAM.CAO.") else double(lenbeta)
- othint[5] = inited # Refine initialization within FORTRAN
+ othint[5] = inited # Refine initialization within C
pstar = NOS * pstar.
- bnumat = if (Nice21) matrix(0,nstar,pstar.) else stop("code not written here")
+ bnumat = if (Nice21) matrix(0, nstar, pstar.) else
+ stop("code not written here")
M. = MSratio = M / NOS # 1 or 2 usually
which = p1 + (1:Rank) # These columns are smoothed
nwhich = names(which) = mynames5
- origBlist = Blist. = create.cms(Rank=Rank, M=M., MSratio=MSratio,
+ origBlist = Blist. = create.cms(Rank=Rank, M=M., MSratio=MSratio,
which=which, p1=p1) # For 1 species only
ncolBlist. <- unlist(lapply(Blist. , ncol))
- smooth.frame = s.vam(x=nu1mat, z=NULL, wz=NULL, s=NULL,
+ smooth.frame = s.vam(x=nu1mat, zedd=NULL, wz=NULL, smomat=NULL,
which=which,
smooth.frame=temp.smooth.frame,
bf.maxit=control$bf.maxit,
@@ -517,89 +541,90 @@ callcaof = function(cmatrix,
trace=FALSE, se.fit=control$se.fit,
X_vlm_save=bnumat, Blist=Blist. ,
ncolBlist=ncolBlist. ,
- M= M. , qbig=NULL, U=NULL, # NULL implies not needed
+ M= M. , qbig=NULL, Umat=NULL, # NULL ==> unneeded
all.knots=control$all.knots, nk=NULL,
sf.only=TRUE)
ldk <- 3 * max(ncolBlist.[nwhich]) + 1 # 11/7/02
dimw. = M. # Smoothing one spp. at a time
- dimu. = M.
+ dim1U. = M.
wz. = matrix(0, n, dimw. )
- U. = matrix(0, dimu. , n)
if (names(Blist.)[1] != "(Intercept)") stop("something wrong here")
Blist.[[1]] <- NULL
- trivc = rep(2 - M. , len=queue) # All of queue smooths are basic smooths
+ trivc = rep(2 - M. , len=queue) # All of queue smooths are basic smooths
ncbvec <- ncolBlist.[nwhich]
ncolb <- max(ncbvec)
- pmax.mwk <- pmax(ncbvec*(ncbvec+1)/2, dimw. )
- size.twk <- max((4+4*smooth.frame$nef)*ncbvec + dimu. * smooth.frame$nef)
- size.twk <- max(size.twk, M*smooth.frame$n)
qbig. = NOS * qbig # == NOS * Rank; holds all the smooths
if (!all.equal(as.vector(ncbvec), rep(1, len=queue)))
- stop("ncbvec not right---should be a queue-vector of ones")
+ stop("'ncbvec' not right---should be a queue-vector of ones")
pbig = pstar. #
- npetc = c(n=nrow(nu1mat), p. =ncol(nu1mat), q=Rank, # q=length(which),
+ contr.sp <- list(low = -1.5,## low = 0. was default till R 1.3.x
+ high = 1.5,
+ tol = 1e-4,## tol = 0.001 was default till R 1.3.x
+ eps = 2e-8,## eps = 0.00244 was default till R 1.3.x
+ maxit = 500 )
+
+ if (FALSE)
+ contr.sp <- list(low = -1.5,## low = 0. was default till R 1.3.x
+ high = 1.5,
+ tol = 0.001, # was default till R 1.3.x
+ eps = 0.00244, # was default till R 1.3.x
+ maxit = 500 )
+
+ npetc = c(n=nrow(nu1mat), p. =ncol(nu1mat), q=length(which),
se.fit=control$se.fit, 0,
control$bf.maxit, qrank=0, M= M. , nbig=nstar, pbig=pbig,
- qbig=qbig, dimw= dimw. , dimu= dimu. , ier=0, ldk=ldk)
-
+ qbig=qbig, dim2wz= dimw. , dim1U= dim1U. , ierror=0, ldk=ldk,
+ contr.sp$maxit, iinfo = 0)
if (Rank == 2) {
- spardf = (c(spar1,1+df1.nl,spar2,1+df2.nl))[interleave.VGAM(4*NOS,M=2)]
+ smopar = (c(spar1, spar2))[interleave.VGAM(4*NOS, M=2)]
+ dofvec = (1.0 + c(df1.nl, df2.nl))[interleave.VGAM(4*NOS, M=2)]
+ lamvec = 0 * dofvec
+ stop("20100414; havent got Rank=2 going yet")
} else {
- spardf = c(spar1, 1.0+df1.nl)
+ smopar = c(spar1, spar2)
+ dofvec = c(df1.nl, df2.nl) + 1.0
+ lamvec = 0 * dofvec
}
- ans1 <- dotFortran(name = "vcao6f",
- numat=as.double(numat),
- ymat=as.double(ymat), wvec=as.double(wvec),
- etamat=as.double(usethiseta),
- fv=double(NOS*n), z=double(n*M), wz=double(n*M),
- U=double(M*n), # bnumat=as.double(bnumat),
- qr=double(nstar*pstar.), qraux=double(pstar.), qpivot=integer(pstar.),
- n=as.integer(n), M=as.integer(M), NOS=as.integer(NOS),
- nstar=as.integer(nstar), dimu=as.integer( M ), # for U, not U.
- errcode=integer(1), othint=as.integer(othint),
- deviance=double(1), beta=as.double(usethisbeta),
- twk=double(if(Nice21) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
- othdbl=as.double(othdbl),
- npetc = as.integer(npetc), M. = as.integer( M. ),
- spardf = as.double(spardf),
- match=as.integer(smooth.frame$o), as.integer(smooth.frame$nef),
- which=as.integer(which),
- etal = double( M. * n ),
- smomat = as.double(matrix(0, n, qbig. )),
- s0 = double((2* M. )*(2* M. )*2),
- U. = as.double( U. ), etapmat = as.double( U. ),
- nu1mat=as.double(nu1mat),
- blist=as.double(unlist( Blist. )), as.integer(ncbvec),
- smap=as.integer(1:(Rank+1)), #
- rcind = integer( M. *( M. +1)), trivc = as.integer(trivc),
- work1 = double(3*qbig + (9+2*4+max(smooth.frame$nknots))*
- max(smooth.frame$nknots)),
- wk2 = double(n* M. *3),
- wwkmm = double( M. * M. *16 + M. * pbig),
- work3 = double(max(max(2 * smooth.frame$nef * ncbvec^2),
- max(smooth.frame$nknots * ncbvec * (4*ncbvec+1)))),
- sgdub = double(max(smooth.frame$nknots) * max(4,ncolb)),
- bmb = double( M. * M. ),
- lev = double(NOS * max(smooth.frame$nef * ncbvec)),
- mwk = double(max(smooth.frame$nef * (1 + 2* M. + pmax.mwk)) ),
- ttwk = double(size.twk),
- bcoefficients = double(NOS * sum(smooth.frame$nknots*ncbvec)),
- knots = as.double(unlist(smooth.frame$knots)),
- bindex = as.integer(smooth.frame$bindex),
- nknots = as.integer(smooth.frame$nknots),
- itwk = integer(2 * M. ),
- kindex = as.integer(smooth.frame$kindex))
+ ans1 <- dotC(name = "vcao6",
+ numat=as.double(numat), ymat=as.double(ymat), wvec=as.double(wvec),
+ etamat=as.double(usethiseta), fv=double(NOS*n), zedd=double(n*M),
+ wz=double(n*M), U=double(M*n), # bnumat=as.double(bnumat),
+ qr=double(nstar*pstar.), qraux=double(pstar.), qpivot=integer(pstar.),
+ n=as.integer(n), M=as.integer(M), NOS=as.integer(NOS),
+ nstar=as.integer(nstar), dim1U=as.integer( M ), # for U, not U.
+ errcode=integer(1), othint=as.integer(othint),
+ deviance=double(1 + NOS), # NOS more elts added 20100413
+ beta=as.double(usethisbeta),
+ othdbl=as.double(othdbl),
+ npetc = as.integer(npetc), M. = as.integer( M. ),
+ dofvec = as.double(dofvec),
+ lamvec = as.double(lamvec),
+ smopar = as.double(smopar),
+ match=as.integer(smooth.frame$o), as.integer(smooth.frame$nef),
+ which=as.integer(which),
+ smomat = as.double(matrix(0, n, qbig. )),
+ nu1mat=as.double(nu1mat),
+ blist=as.double(unlist( Blist. )),
+ as.integer(ncbvec),
+ smap=as.integer(1:(Rank+1)), #
+ trivc = as.integer(trivc),
+ levmat = as.double(matrix(0, n, qbig. )),
+ bcoefficients = double(NOS * sum(smooth.frame$nknots*ncbvec)),
+ xknots = as.double(unlist(smooth.frame$knots)),
+ bindex = as.integer(smooth.frame$bindex),
+ nknots = as.integer(smooth.frame$nknots),
+ kindex = as.integer(smooth.frame$kindex))
flush.console()
@@ -607,8 +632,8 @@ flush.console()
assign2VGAMenv(c("etamat", "beta"), ans1, prefix=".VGAM.CAO.")
assign(".VGAM.CAO.cmatrix", matrix(cmatrix,p2,Rank), envir=VGAMenv)
} else {
- cat("warning in callcaof: error code =", ans1$errcode, "\n")
- cat("warning in callcaof: npetc[14] =", ans1$npetc[14], "\n")
+ cat("warning in callcaoc: error code =", ans1$errcode, "\n")
+ cat("warning in callcaoc: npetc[14] =", ans1$npetc[14], "\n")
flush.console()
rmfromVGAMenv(c("etamat", "beta"), prefix=".VGAM.CAO.")
}
@@ -623,10 +648,10 @@ flush.console()
ind9 = 0 # moving index
for(sppno in 1:NOS) {
for(ii in 1:length(nwhich)) {
- ind7 = (smooth.frame$bindex[ii]):(smooth.frame$bindex[ii+1]-1)
- ans = ans1$bcoeff[ind9+ind7]
- ans = matrix(ans, ncol=ncolBlist[nwhich[ii]])
- Bspline[[ii]] = new(Class="vsmooth.spline.fit",
+ ind7 = (smooth.frame$bindex[ii]):(smooth.frame$bindex[ii+1]-1)
+ ans = ans1$bcoeff[ind9+ind7]
+ ans = matrix(ans, ncol=ncolBlist[nwhich[ii]])
+ Bspline[[ii]] = new(Class="vsmooth.spline.fit",
"Bcoefficients" = ans,
"xmax" = smooth.frame$xmax[ii],
"xmin" = smooth.frame$xmin[ii],
@@ -638,17 +663,21 @@ flush.console()
qrank = npetc[7] # Assume all species have the same qrank value
dim(ans1$etamat) = c(M,n) # was c(n,M) prior to 22/8/06
+
+
+
+ df1.nl = ans1$dofvec[1:NOS] - 1.0
+ lambda1 = ans1$lamvec[1:NOS]
+ spar1 = ans1$smopar[1:NOS]
if (Rank == 2) {
- spardf = array(ans1$spardf, c(Rank,NOS,2))
- df1.nl = spardf[1,,2] - 1
- df2.nl = spardf[2,,2] - 1
- spar1 = spardf[1,,1]
- spar2 = spardf[2,,1]
- } else {
- df1.nl = ans1$spardf[ NOS+(1:NOS)] - 1
- spar1 = ans1$spardf[1:NOS]
+ stop("20100414; this isnt working yet")
+ df2.nl = ans1$dofvec[NOS + (1:NOS)] - 1.0
+ lambda2 = ans1$lamvec[NOS + (1:NOS)]
+ spar2 = ans1$smopar[NOS + (1:NOS)]
}
- list(deviance=ans1$deviance,
+
+ list(deviance = ans1$deviance[1],
+ alldeviance = ans1$deviance[-1],
bcoefficients = ans1$bcoefficients,
bindex = ans1$bindex,
Bspline = Bspline2,
@@ -660,31 +689,34 @@ flush.console()
df.residual = n*M - qrank - sum(ans1$df - 1),
fitted = ans1$fv, # NOS x n
kindex = ans1$kindex,
+ lambda1 = lambda1,
+ lambda2 = if (Rank == 2) lambda2 else NULL,
predictors = matrix(ans1$etamat, n, M, byrow=TRUE),
- wresiduals = ans1$z - t(ans1$etamat), # n x M
+ wresiduals = ans1$zedd - t(ans1$etamat), # n x M
spar1 = spar1,
spar2 = if (Rank == 2) spar2 else NULL)
} else
- ans1$deviance
+ ans1$deviance[1]
flush.console()
returnans
}
-calldcaof = function(cmatrix,
+calldcaoc = function(cmatrix,
etamat, xmat, ymat, wvec, modelno,
- Control, Nice21=TRUE,
- p1star. = if (any(modelno==c(3,5))) 2 else 1, p2star. =Rank,
+ Control, Nice21 = TRUE,
+ p1star. = if (modelno %in% c(3, 5)) 2 else 1,
+ p2star. = Rank,
n, M,
othint, othdbl,
- alldump=FALSE) {
+ alldump = FALSE) {
if (alldump) stop("really used?")
flush.console()
- if (!Nice21) stop("Nice21 must be TRUE")
+ if (!Nice21) stop("'Nice21' must be TRUE")
control = Control
Rank = control$Rank
p2 = length(control$colx2.index)
@@ -697,8 +729,8 @@ calldcaof = function(cmatrix,
xmat2 <- xmat[,control$colx2.index,drop=FALSE] #ccc
numat <- xmat2 %*% matrix(cmatrix, p2, Rank)
dim(numat) <- c(nrow(xmat), Rank)
- temp.smooth.frame = vector("list", 1+Rank) # A temporary makeshift frame
- mynames5 = if (Rank==1) "lv" else paste("lv",1:Rank,sep="")
+ temp.smooth.frame = vector("list", 1+Rank) # Temporary makeshift frame
+ mynames5 = if (Rank == 1) "lv" else paste("lv",1:Rank,sep="")
names(temp.smooth.frame) = c("(Intercept)", mynames5)
temp.smooth.frame[[1]] = rep(1, len=n)
for(uu in 1:Rank) {
@@ -710,16 +742,16 @@ calldcaof = function(cmatrix,
attr(temp.smooth.frame[,uu+1], "df") = 4 # any old value
}
pstar. = p1star. + p2star.
- nstar = if (Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
- NOS = ifelse(modelno == 3 || modelno==5, M/2, M)
+ nstar = if (Nice21) ifelse(modelno %in% c(3, 5), n * 2, n) else n * M
+ NOS = ifelse(modelno %in% c(3, 5), M / 2, M)
lenbeta = pstar. * ifelse(Nice21, NOS, 1)
if (TRUE) {
inited = if (exists(".VGAM.CAO.etamat", envir = VGAMenv)) 1 else 0
- usethiseta = if (inited==1) get(".VGAM.CAO.etamat",
+ usethiseta = if (inited == 1) get(".VGAM.CAO.etamat",
envir = VGAMenv) else t(etamat)
}
- usethisbeta = if (inited==2) get(".VGAM.CAO.beta",
+ usethisbeta = if (inited == 2) get(".VGAM.CAO.beta",
envir = VGAMenv) else double(lenbeta)
@@ -727,29 +759,33 @@ calldcaof = function(cmatrix,
pstar = NOS * pstar.
- bnumat = if (Nice21) matrix(0,nstar,pstar) else stop("need Nice21")
+ bnumat = if (Nice21) matrix(0,nstar,pstar) else stop("need 'Nice21'")
M. = MSratio = M / NOS # 1 or 2 usually
+
+
+ p1 = 1
+
which = p1 + (1:Rank) # The first 1 is the intercept term
nwhich = names(which) = mynames5
origBlist = Blist. = create.cms(Rank=Rank, M=M., MSratio=MSratio,
- which=which,p1=p1) # For 1 species
+ which=which, p1 = p1) # For 1 species
ncolBlist. <- unlist(lapply(Blist. , ncol))
nu1mat = cbind("(Intercept)"=1, lv=numat)
dimnames(nu1mat) = list(dimnames(xmat)[[1]], c("(Intercept)","lv"))
- smooth.frame = s.vam(x=nu1mat, z=NULL, wz=NULL, s=NULL,
- which=which,
- smooth.frame=temp.smooth.frame,
- bf.maxit=control$bf.maxit,
- bf.epsilon=control$bf.epsilon,
- trace=FALSE, se.fit=control$se.fit,
- X_vlm_save=bnumat, Blist=Blist.,
- ncolBlist=ncolBlist. ,
- M= M. , qbig=NULL, U=U, # NULL value implies not needed
- all.knots=control$all.knots, nk=NULL,
- sf.only=TRUE)
+ smooth.frame = s.vam(x=nu1mat, zedd=NULL, wz=NULL, smomat=NULL,
+ which=which,
+ smooth.frame=temp.smooth.frame,
+ bf.maxit=control$bf.maxit,
+ bf.epsilon=control$bf.epsilon,
+ trace=FALSE, se.fit=control$se.fit,
+ X_vlm_save=bnumat, Blist=Blist.,
+ ncolBlist=ncolBlist. ,
+ M= M. , qbig=NULL, Umat=U, # NULL value ==> not needed
+ all.knots=control$all.knots, nk=NULL,
+ sf.only=TRUE)
ldk <- 4 * max(ncolBlist.[nwhich]) # was M; # Prior to 11/7/02
ldk <- 3 * max(ncolBlist.[nwhich]) + 1 # 11/7/02
@@ -757,92 +793,116 @@ calldcaof = function(cmatrix,
wz. = matrix(0, n, M. ) # not sure
- U. = matrix(0, M. , n)
dimw. = if (is.matrix( wz. )) ncol( wz. ) else 1
- dimu. <- if (is.matrix( U. )) nrow( U. ) else 1
+
+
+ dim1U. <- M. # 20100410
+
+
+
+
+ queue = qbig = Rank # 19/10/05; number of smooths per species
+
+
+
Blist.[[1]] <- NULL
- trivc = rep(2 - M. , len=queue) # All of queue smooths are basic smooths
+ trivc = rep(2 - M. , len=queue) # All of queue smooths are basic smooths
ncbvec <- ncolBlist.[nwhich]
ncolb <- max(ncbvec)
- pmax.mwk <- rep( dimw. , length(trivc))
- pmax.mwk <- pmax(ncbvec*(ncbvec+1)/2, dimw. )
- size.twk <- max((4+4*smooth.frame$nef)*ncbvec + dimu. *smooth.frame$nef)
- size.twk <- max(size.twk, M*smooth.frame$n)
qbig. = NOS * qbig # == NOS * Rank
pbig = pstar. # Not sure
if (FALSE) {
df1.nl = rep(control$df1.nl, len=NOS) # This is used
- spar1 = rep(control$spar1, len=NOS) # This is used
+ df2.nl = rep(control$df2.nl, len=NOS) # This is used
+ spar1 = rep(control$spar1, len=NOS) # This is used
+ spar2 = rep(control$spar2, len=NOS) # This is used
} else {
# This is used
- df1.nl = procVec(control$df1.nl, yn= yn , Def=control$DF1)
- spar1 = procVec(control$spar1, yn= yn , Def= control$SPAR1)
+ df1.nl = procVec(control$df1.nl, yn= yn , Def = control$DF1)
+ df2.nl = df1.nl # 20100417; stopgap
+ spar1 = procVec(control$spar1, yn= yn , Def = control$SPAR1)
+ spar2 = spar1 # 20100417; stopgap
+ dofvec = c(df1.nl, df2.nl)
+ lamvec = 0 * dofvec
+ smopar = c(spar1, spar2)
}
+
+
+
+ contr.sp <- list(low = -1.5,## low = 0. was default till R 1.3.x
+ high = 1.5,
+ tol = 1e-4,## tol = 0.001 was default till R 1.3.x
+ eps = 2e-8,## eps = 0.00244 was default till R 1.3.x
+ maxit = 500 )
+
+ if (FALSE)
+ contr.sp <- list(low = -1.5,## low = 0. was default till R 1.3.x
+ high = 1.5,
+ tol = 0.001, # was default till R 1.3.x
+ eps = 0.00244, # was default till R 1.3.x
+ maxit = 500 )
+
+
+warning("20100405; this is old:")
npetc = c(n=n, p=1+Rank, length(which), se.fit=control$se.fit, 0,
maxitl=control$maxitl, qrank=0, M= M. , n.M = n* M. ,
pbig=sum( ncolBlist.),
- qbig=qbig, dimw= dimw. , dimu= dimu. , ier=0, ldk=ldk)
+ qbig=qbig, dimw= dimw. , dim1U= dim1U. , ierror=0, ldk=ldk)
+
+warning("20100405; this is new:")
+ npetc = c(n=nrow(nu1mat), p. =ncol(nu1mat),
+ q=length(which),
+ se.fit=control$se.fit, 0,
+ control$bf.maxit, qrank=0, M= M. , nbig=nstar, pbig=pbig,
+ qbig=qbig, dim2wz= dimw. , dim1U= dim1U. , ierror=0, ldk=ldk,
+ contr.sp$maxit, iinfo = 0)
flush.console()
ans1 <-
- dotFortran(name = if (Nice21) "vdcaof" else stop("need Nice21"),
- numat=as.double(numat),
- as.double(ymat), as.double(wvec),
- etamat=as.double(usethiseta),
- fv=double(NOS*n), z=double(n*M), wz=double(n*M),
- U=double(M*n), # bnumat=as.double(bnumat),
- qr=double(nstar*pstar.), qraux=double(pstar.), qpivot=integer(pstar.),
- as.integer(n), as.integer(M), NOS=as.integer(NOS),
- as.integer(nstar), dimu=as.integer(M),
- errcode=integer(1), othint=as.integer(othint),
- deviance=double(1), beta=as.double(usethisbeta),
- twk=double(if(Nice21) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
- othdbl=as.double(othdbl),
- xmat2=as.double(xmat2), onumat=as.double(numat), cmat=as.double(cmatrix),
- p2=as.integer(p2), deriv=double(p2*Rank),
- betasave=double(lenbeta),
- npetc = as.integer(npetc), M. = as.integer( M. ),
- spardf = as.double(c(spar1, 1.0+df1.nl, spar2, 1.0+df2.nl)),
- match=as.integer(smooth.frame$o), as.integer(smooth.frame$nef),
- as.integer(which),
- etal = double( M. * n ),
- smomat = as.double(matrix(0, n, qbig. )),
- s0 = double((2* M. )*(2* M. )*2),
- U. = as.double( U. ), etapmat = as.double( U. ),
- nu1mat=as.double(nu1mat),
- as.double(unlist( Blist. )),
- as.integer(ncbvec), smap=as.integer(1:(Rank+1)),
- rcind = integer( M. *( M. +1)), trivc = as.integer(trivc),
- work1 = double(3*qbig + (9+2*4+max(smooth.frame$nknots))*
- max(smooth.frame$nknots)),
- wk2 = double(n* M. *3),
- wwkmm = double( M. * M. *16 + M. *pbig),
- work3 = double(max(max(2 * smooth.frame$nef * ncbvec^2),
- max(smooth.frame$nknots * ncbvec * (4*ncbvec+1)))),
- sgdub = double(max(smooth.frame$nknots) * max(4,ncolb)),
- bmb = double( M. * M. ),
- lev = double(NOS * max(smooth.frame$nef * ncbvec)),
- mwk = double(max(smooth.frame$nef * (1 + 2* M. + pmax.mwk)) ),
- ttwk = double(size.twk),
- bcoefficients = double(NOS * sum(smooth.frame$nknots*ncbvec)),
- knots = as.double(unlist(smooth.frame$knots)),
- bindex = as.integer(smooth.frame$bindex),
- nknots = as.integer(smooth.frame$nknots),
- itwk = integer(2* M. ),
- kindex = as.integer(smooth.frame$kindex))
+ dotC(name = if (Nice21) "vdcao6" else stop("need 'Nice21'"),
+ numat=as.double(numat), as.double(ymat), as.double(wvec),
+ etamat=as.double(usethiseta), fv=double(NOS*n), zedd=double(n*M),
+ wz=double(n*M), U=double(M*n), # bnumat=as.double(bnumat),
+ qr=double(nstar*pstar.), qraux=double(pstar.), qpivot=integer(pstar.),
+ as.integer(n), as.integer(M), NOS=as.integer(NOS),
+ as.integer(nstar), dim1U=as.integer(M),
+ errcode=integer(1), othint=as.integer(othint),
+ deviance = double(1 + NOS), beta=as.double(usethisbeta),
+ othdbl=as.double(othdbl),
+ as.double(xmat2),
+ cmat=as.double(cmatrix),
+ p2=as.integer(p2), deriv=double(p2*Rank),
+ betasave=double(lenbeta),
+ npetc = as.integer(npetc), M. = as.integer( M. ),
+ dofvec = as.double(dofvec + 1.0),
+ lamvec = as.double(0 * dofvec),
+ smopar = as.double(smopar),
+ match=as.integer(smooth.frame$o), as.integer(smooth.frame$nef),
+ as.integer(which),
+ smomat = as.double(matrix(0, n, qbig. )),
+ nu1mat=as.double(nu1mat),
+ as.double(unlist( Blist. )),
+ as.integer(ncbvec), smap=as.integer(1:(Rank+1)),
+ trivc = as.integer(trivc),
+ levmat = as.double(matrix(0, n, qbig. )),
+ bcoefficients = double(NOS * sum(smooth.frame$nknots*ncbvec)),
+ xknots = as.double(unlist(smooth.frame$knots)),
+ bindex = as.integer(smooth.frame$bindex),
+ nknots = as.integer(smooth.frame$nknots),
+ kindex = as.integer(smooth.frame$kindex))
flush.console()
- assign(".VGAM.CAO.etamat", ans1$etamat, envir = VGAMenv)
- assign(".VGAM.CAO.z", ans1$z, envir=VGAMenv) # z; minus any offset
- assign(".VGAM.CAO.U", ans1$U, envir=VGAMenv) # U
+ assign(".VGAM.CAO.etamat", ans1$etamat, envir = VGAMenv)
+ assign(".VGAM.CAO.z", ans1$zedd, envir=VGAMenv) # z; minus any offset
+ assign(".VGAM.CAO.U", ans1$U, envir=VGAMenv) # U
if (ans1$errcode == 0) {
} else {
- cat("warning in calldcaof: error code =", ans1$errcode, "\n")
+ cat("warning in calldcaoc: error code =", ans1$errcode, "\n")
flush.console()
}
@@ -854,40 +914,44 @@ calldcaof = function(cmatrix,
Bspline <- vector("list", length(nwhich))
names(Bspline) <- nwhich
ind9 = 0 # moving index
- for(j in 1:NOS) {
- for(i in 1:length(nwhich)) {
- ind9 = ind9[length(ind9)] + (bindex[i]):(bindex[i+1]-1)
+ for(jay in 1:NOS) {
+ for(ii in 1:length(nwhich)) {
+ ind9 = ind9[length(ind9)] + (bindex[ii]):(bindex[ii+1]-1)
ans = ans1$bcoeff[ind9]
- ans = matrix(ans, ncol=ncolBlist[nwhich[i]])
- Bspline[[i]] = new(Class="vsmooth.spline.fit",
+ ans = matrix(ans, ncol=ncolBlist[nwhich[ii]])
+ Bspline[[ii]] = new(Class="vsmooth.spline.fit",
"Bcoefficients" = ans,
- "xmax" = smooth.frame$xmax[i],
- "xmin" = smooth.frame$xmin[i],
- "knots" = as.vector(smooth.frame$knots[[i]]))
+ "xmax" = smooth.frame$xmax[ii],
+ "xmin" = smooth.frame$xmin[ii],
+ "knots" = as.vector(smooth.frame$knots[[ii]]))
}
- Bspline2[[j]] = Bspline
+ Bspline2[[jay]] = Bspline
}
qrank = npetc[7] # Assume all species have the same qrank value
dim(ans1$etamat) = c(M,n) # bug: was c(n,M) prior to 22/8/06
- list(deviance=ans1$deviance,
+ list(deviance = ans1$deviance[1],
+ alldeviance = ans1$deviance[-1],
bcoefficients = ans1$bcoefficients,
bindex = ans1$bindex,
Bspline = Bspline2,
Cmat=matrix(cmatrix, p2, Rank, dimnames=list(
names(control$colx2.index), mynames5)),
coefficients=ans1$beta,
- df1.nl=ans1$spardf[ NOS+(1:NOS)] - 1,
- df2.nl=ans1$spardf[3*NOS+(1:NOS)] - 1,
+ df1.nl = ans1$dofvec[1:NOS] - 1,
+ df2.nl = if (Rank == 2) ans1$dofvec[2*(1:NOS) - 1] - 1 else NULL,
+ lambda1 = ans1$lambda[1:NOS],
+ lambda2 = if (Rank == 2) ans1$lambda[2*(1:NOS) - 1] else NULL,
df.residual = n*M - qrank - sum(ans1$df - 1),
fitted=ans1$fv,
kindex = ans1$kindex,
predictors=matrix(ans1$etamat, n, M, byrow=TRUE),
- wresiduals = ans1$z - t(ans1$etamat), # n x M
- spar1=ans1$spardf[1:NOS],
- spar2=ans1$spardf[2*NOS+(1:NOS)])
- } else
+ wresiduals = ans1$zedd - t(ans1$etamat), # n x M
+ spar1 = ans1$smopar[1:NOS],
+ spar2 = if (Rank == 2) ans1$smopar[2*(1:NOS) - 1] else NULL)
+ } else {
ans1$deriv
+ }
flush.console()
returnans
}
@@ -920,7 +984,7 @@ setClass(Class="Coef.cao", representation(
Coef.cao = function(object,
epsOptimum = 0.00001, # determines how accurately Optimum is estimated
gridlen = 40, # Number of points on the grid (one level at a time)
- maxgriditer = 10, # Maximum number of iterations allowed for grid search
+ maxgriditer = 10, # Maximum number of iterations allowed for grid search
smallno = 0.05,
...) {
@@ -928,7 +992,8 @@ Coef.cao = function(object,
stop("bad input for argument 'epsOptimum'")
if (!is.Numeric(gridlen, posit=TRUE, integer=TRUE) || gridlen < 5)
stop("bad input for argument 'gridlen'")
- if (!is.Numeric(maxgriditer, posit=TRUE, allow=1, int=TRUE) || maxgriditer<3)
+ if (!is.Numeric(maxgriditer, posit=TRUE, allow=1, int=TRUE) ||
+ maxgriditer<3)
stop("bad input for argument 'maxgriditer'")
if (!is.logical(ConstrainedO <- object at control$ConstrainedO))
stop("cannot determine whether the model is constrained or not")
@@ -936,16 +1001,16 @@ Coef.cao = function(object,
smallno > 0.5 || smallno < 0.0001)
stop("bad input for argument 'smallno'")
ocontrol = object at control
- if ((Rank <- ocontrol$Rank) > 2) stop("Rank must be 1 or 2")
+ if ((Rank <- ocontrol$Rank) > 2) stop("'Rank' must be 1 or 2")
gridlen = rep(gridlen, length=Rank)
M = if (any(slotNames(object) == "predictors") &&
is.matrix(object at predictors)) ncol(object at predictors) else
object at misc$M
NOS = if (length(object at y)) ncol(object at y) else M
- MSratio = M / NOS # 1 or 2; First value is g(mean) = quadratic form in lv
+ MSratio = M / NOS # 1 or 2; First value is g(mean)=quadratic form in lv
nice21 = (length(ocontrol$colx1.index) == 1) &&
(names(ocontrol$colx1.index) == "(Intercept)")
- if (!nice21) stop("Can only handle Norrr = ~ 1")
+ if (!nice21) stop("Can only handle 'Norrr = ~ 1'")
p1 = length(ocontrol$colx1.index)
p2 = length(ocontrol$colx2.index)
@@ -957,7 +1022,7 @@ Coef.cao = function(object,
lp.names = object at misc$predictors.names
if (!length(lp.names)) lp.names = NULL
- lv.names = if (Rank==1) "lv" else paste("lv", 1:Rank, sep="")
+ lv.names = if (Rank == 1) "lv" else paste("lv", 1:Rank, sep="")
Cmat = object at extra$Cmat # p2 x Rank (provided maxitl > 1)
if (ConstrainedO)
dimnames(Cmat) = list(names(ocontrol$colx2.index), lv.names)
@@ -967,7 +1032,8 @@ Coef.cao = function(object,
object at lv
}
- optimum = matrix(as.numeric(NA), Rank, NOS, dimnames=list(lv.names, ynames))
+ optimum = matrix(as.numeric(NA), Rank, NOS,
+ dimnames=list(lv.names, ynames))
extents = apply(lv.mat, 2, range) # 2 by R
maximum = rep(as.numeric(NA), len=NOS)
@@ -985,7 +1051,7 @@ Coef.cao = function(object,
for(sppno in 1:length(whichSpecies)) {
gridd = gridd.orig
gridres1 = gridd[2,1] - gridd[1,1]
- gridres2 = if (Rank==2) gridd[2,2] - gridd[1,2] else 0
+ gridres2 = if (Rank == 2) gridd[2,2] - gridd[1,2] else 0
griditer = 1
thisSpecies = whichSpecies[sppno]
@@ -1005,7 +1071,7 @@ Coef.cao = function(object,
if (length(temp$eta2)) eta2matrix[sppno,1] = temp$eta2
nnn = length(yvals)
- index = (1:nnn)[yvals==max(yvals)]
+ index = (1:nnn)[yvals == max(yvals)]
if (length(index)!=1) warning("could not find a single maximum")
if (Rank == 2) {
initvalue = rep(xvals[index,], length=Rank) # for optim()
@@ -1037,7 +1103,7 @@ Coef.cao = function(object,
} # of while
if (Rank == 2) {
- # Rank = 2, so use optim(). The above was to get initial values.
+ # Rank = 2, so use optim(). The above was to get initial values.
myfun = function(x, object, sppno, Rank=1, deriv=0, MSratio=1) {
# x is a 2-vector
x = matrix(x, 1, length(x))
@@ -1050,13 +1116,13 @@ Coef.cao = function(object,
control=list(fnscale = -1), # maximize!
object=object, sppno=sppno, Rank=Rank,
deriv=0, MSratio=MSratio)
- # Check to see if the soln is at the boundary. If not, assign it.
+ # Check to see if the soln is @ boundary. If not, assign it.
for(rindex in 1:Rank)
- if (abs(answer$par[rindex] - extents[1,rindex]) > smallno &&
- abs(answer$par[rindex] - extents[2,rindex]) > smallno) {
- optimum[rindex,sppno] = answer$par[rindex]
- maximum[sppno] = answer$value
- }
+ if (abs(answer$par[rindex] - extents[1,rindex]) > smallno &&
+ abs(answer$par[rindex] - extents[2,rindex]) > smallno) {
+ optimum[rindex,sppno] = answer$par[rindex]
+ maximum[sppno] = answer$value
+ }
} # end of Rank=2
} # end of sppno
myetamat = rbind(maximum)
@@ -1099,8 +1165,8 @@ Coef.cao = function(object,
M = object at misc$M
NOS = if (length(object at y)) ncol(object at y) else M
pstar = p + length(Cmat) # Adjustment
- adjusted.dispersion = object at misc$dispersion * (n*M - p) /
- (n*M - pstar)
+ adjusted.dispersion = object at misc$dispersion *
+ (n*M - p) / (n*M - pstar)
ans at dispersion = adjusted.dispersion
}
if (MSratio == 2) {
@@ -1119,7 +1185,8 @@ printCoef.cao = function(object, digits = max(2, options()$digits-2), ...) {
NOS = object at NOS
M = object at M
- Maximum = if (length(object at Maximum)) cbind(Maximum=object at Maximum) else NULL
+ Maximum = if (length(object at Maximum))
+ cbind(Maximum=object at Maximum) else NULL
optmat = cbind(t(object at Optimum))
dimnames(optmat) = list(dimnames(optmat)[[1]],
if (Rank > 1) paste("Optimum", dimnames(optmat)[[2]], sep=".")
@@ -1152,7 +1219,8 @@ setMethod("print", "Coef.cao", function(x, ...)
printCoef.cao(object=x, ...))
setMethod("coef", "cao", function(object, ...) Coef.cao(object, ...))
-setMethod("coefficients", "cao", function(object, ...) Coef.cao(object, ...))
+setMethod("coefficients", "cao", function(object, ...)
+ Coef.cao(object, ...))
setMethod("Coef", "cao", function(object, ...) Coef.cao(object, ...))
@@ -1161,7 +1229,7 @@ setMethod("Coef", "cao", function(object, ...) Coef.cao(object, ...))
lvplot.cao = function(object,
add= FALSE, plot.it= TRUE, rugplot = TRUE, y = FALSE,
type=c("fitted.values", "predictors"),
- xlab=paste("Latent Variable", if (Rank==1) "" else " 1", sep=""),
+ xlab=paste("Latent Variable", if (Rank == 1) "" else " 1", sep=""),
ylab = if (Rank == 1) switch(type, predictors="Predictors",
fitted.values="Fitted values") else "Latent Variable 2",
pcex=par()$cex, pcol=par()$col, pch=par()$pch,
@@ -1175,7 +1243,7 @@ lvplot.cao = function(object,
type <- match.arg(type, c("fitted.values", "predictors"))[1]
if ((Rank <- object at control$Rank) > 2)
- stop("can only handle rank 1 or 2 models")
+ stop("can only handle 'Rank' = 1 or 2 models")
M = if (any(slotNames(object) == "predictors") &&
is.matrix(object at predictors)) ncol(object at predictors) else
object at misc$M
@@ -1186,8 +1254,8 @@ lvplot.cao = function(object,
cx1i = object at control$colx1.index
if (!length(whichSpecies)) whichSpecies = 1:NOS
if (check.ok)
- if (!(length(cx1i)==1 && names(cx1i)=="(Intercept)"))
- stop("latent variable plots allowable only for Norrr = ~ 1 models")
+ if (!(length(cx1i) == 1 && names(cx1i) == "(Intercept)"))
+ stop("latent variable plots allowable only for 'Norrr = ~ 1' models")
Coeflist = Coef(object)
Cmat = Coeflist at C
@@ -1200,13 +1268,13 @@ lvplot.cao = function(object,
stop("can only plot the predictors if M = S")
MorS = ncol(r.curves) # Actually, here, the value is S always.
if (!add) {
- if (Rank==1) {
+ if (Rank == 1) {
matplot(lvmat,
- if ( y && type=="fitted.values")
+ if ( y && type == "fitted.values")
object at y[,whichSpecies,drop=FALSE] else
r.curves[,whichSpecies,drop=FALSE],
type="n", xlab=xlab, ylab=ylab, ...)
- } else { # Rank==2
+ } else { # Rank == 2
matplot(c(Coeflist at Optimum[1,whichSpecies], lvmat[,1]),
c(Coeflist at Optimum[2,whichSpecies], lvmat[,2]),
type="n", xlab=xlab, ylab=ylab, ...)
@@ -1222,13 +1290,13 @@ lvplot.cao = function(object,
llwd <- rep(llwd, leng=length(whichSpecies))
adj.arg <- rep(adj.arg, leng=length(whichSpecies))
- sppnames = if (type=="predictors") dimnames(r.curves)[[2]] else
+ sppnames = if (type == "predictors") dimnames(r.curves)[[2]] else
dimnames(object at y)[[2]]
- if (Rank==1) {
+ if (Rank == 1) {
for(sppno in 1:length(whichSpecies)) {
thisSpecies = whichSpecies[sppno]
indexSpecies = if (is.character(whichSpecies))
- match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
+ match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
if (is.na(indexSpecies))
stop("mismatch found in 'whichSpecies'")
xx = lvmat
@@ -1237,7 +1305,7 @@ lvplot.cao = function(object,
xx = xx[ o ]
yy = yy[ o ]
lines(xx, yy, col=lcol[sppno], lwd=llwd[sppno], lty=llty[sppno])
- if ( y && type=="fitted.values") {
+ if ( y && type == "fitted.values") {
ypts = object at y
if (ncol(as.matrix(ypts)) == ncol(r.curves))
points(xx, ypts[o,sppno], col=pcol[sppno],
@@ -1248,13 +1316,14 @@ lvplot.cao = function(object,
} else {
if (sites) {
text(lvmat[,1], lvmat[,2], adj=0.5,
- labels = if (is.null(spch)) dimnames(lvmat)[[1]] else
- rep(spch, length=nrow(lvmat)), col=scol, cex=scex, font=sfont)
+ labels = if (is.null(spch)) dimnames(lvmat)[[1]] else
+ rep(spch, length=nrow(lvmat)), col=scol, cex=scex, font=sfont)
}
for(sppno in 1:length(whichSpecies)) {
thisSpecies = whichSpecies[sppno]
indexSpecies = if (is.character(whichSpecies))
- match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
+ match(whichSpecies[sppno], sppnames) else
+ whichSpecies[sppno]
if (is.na(indexSpecies))
stop("mismatch found in 'whichSpecies'")
points(Coeflist at Optimum[1,indexSpecies],
@@ -1265,10 +1334,11 @@ lvplot.cao = function(object,
for(sppno in 1:length(whichSpecies)) {
thisSpecies = whichSpecies[sppno]
indexSpecies = if (is.character(whichSpecies))
- match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
+ match(whichSpecies[sppno], sppnames) else
+ whichSpecies[sppno]
text(Coeflist at Optimum[1,indexSpecies],
Coeflist at Optimum[2,indexSpecies],
- labels=(dimnames(Coeflist at Optimum)[[2]])[indexSpecies],
+ labels=(dimnames(Coeflist at Optimum)[[2]])[indexSpecies],
adj=adj.arg[sppno], col=pcol[sppno], cex=pcex[sppno])
}
}
@@ -1288,15 +1358,16 @@ predict.cao <- function (object, newdata=NULL,
deriv = 0, ...) {
type <- match.arg(type, c("link", "response", "terms"))[1]
if (type != "link" && deriv != 0)
- stop("Setting deriv=<positive integer> requires type=\"link\"")
+ stop("Setting deriv = <positive integer> requires type='link'")
na.act = object at na.action
object at na.action = list()
ocontrol = object at control
nice21 = (length(ocontrol$colx1.index) == 1) &&
(names(ocontrol$colx1.index) == "(Intercept)")
- if (!nice21) stop("Can only handle Norrr = ~ 1")
+ if (!nice21) stop("Can only handle 'Norrr = ~ 1'")
- if (!length(newdata) && type=="response" && length(object at fitted.values)) {
+ if (!length(newdata) && type == "response" &&
+ length(object at fitted.values)) {
if (length(na.act)) {
return(napredict(na.act[[1]], object at fitted.values))
} else {
@@ -1317,8 +1388,8 @@ predict.cao <- function (object, newdata=NULL,
tt <- terms(object) # 11/8/03; object at terms$terms
X <- model.matrix(delete.response(tt), newdata, contrasts =
- if (length(object at contrasts)) object at contrasts else NULL,
- xlev = object at xlevels)
+ if (length(object at contrasts)) object at contrasts else NULL,
+ xlev = object at xlevels)
if (nice21 && nrow(X)!=nrow(newdata)) {
as.save = attr(X, "assign")
@@ -1352,7 +1423,7 @@ predict.cao <- function (object, newdata=NULL,
object at misc$M
MSratio = M / NOS # First value is g(mean) = quadratic form in lv
if (type == "terms") {
- terms.mat = matrix(0, nrow(X), Rank*NOS) # 1st R colns for spp.1, etc.
+ terms.mat = matrix(0,nrow(X),Rank*NOS) # 1st R cols for spp.1, etc.
interceptvector = rep(0, len=NOS)
} else {
etamat = matrix(0, nrow(X), M) # Could contain derivatives
@@ -1368,7 +1439,7 @@ predict.cao <- function (object, newdata=NULL,
temp345 = predictcao(object, grid=lvmat, sppno=thisSpecies,
Rank=Rank, deriv=deriv, MSratio=MSratio,
- type=ifelse(type=="response", "link", type))
+ type=ifelse(type == "response", "link", type))
if (MSratio == 2) {
if (any(type == c("link", "response"))) {
etamat[,2*sppno-1] = temp345$yvals
@@ -1442,19 +1513,22 @@ predictcao <- function(object, grid, sppno, Rank=1, deriv=0, MSratio=1,
}
# Get the linear part of the additive predictor (intercept and slopes)
- lcoef = object at coefficients # linear coeffs; dont use coef() (==Coef)
+ lcoef = object at coefficients # linear coefs; dont use coef() (== Coef)
llcoef = lcoef[(1+(sppno-1)*(MSratio+Rank)):(sppno*(MSratio+Rank))]
if (type == "terms") {
interceptvector = llcoef[1]
for(rindex in 1:Rank) {
- answer[,rindex] = answer[,rindex] +
- (grid[,rindex] - meanlv[rindex]) * llcoef[MSratio+rindex]
+ answer[,rindex] = answer[,rindex] + (grid[,rindex] -
+ meanlv[rindex]) * llcoef[MSratio+rindex]
interceptvector = interceptvector +
meanlv[rindex] * llcoef[MSratio+rindex]
}
} else {
- linpar = if (deriv==0) {llcoef[1]+grid %*% llcoef[-(1:MSratio)]} else
- {if(deriv==1) llcoef[MSratio+rindex] else 0}
+ linpar = if (deriv == 0) {
+ llcoef[1]+grid %*% llcoef[-(1:MSratio)]
+ } else {
+ if(deriv == 1) llcoef[MSratio+rindex] else 0
+ }
nlfunvalues = nlfunvalues + linpar # Now complete
}
if (type == "terms") {
@@ -1489,20 +1563,20 @@ plot.cao = function(x,
if (!is.logical(center.cf) || length(center.cf) != 1)
stop("bad input for argument 'center.cf'")
if (Rank > 1 && !center.cf)
- stop("center.cf=TRUE is needed for models with Rank>1")
+ stop("center.cf = TRUE is needed for models with Rank > 1")
NOS = ncol(x at y)
sppnames = dimnames(x at y)[[2]]
modelno = x at control$modelno # 1,2,3, or 0
M = if (any(slotNames(x) == "predictors") &&
is.matrix(x at predictors)) ncol(x at predictors) else x at misc$M
if (all((MSratio <- M / NOS) != c(1,2))) stop("bad value for 'MSratio'")
- pcol = rep(pcol, length=Rank*NOS)
- pcex = rep(pcex, length=Rank*NOS)
- pch = rep(pch, length=Rank*NOS)
- lcol = rep(lcol, length=Rank*NOS)
- lwd = rep(lwd, length=Rank*NOS)
- lty = rep(lty, length=Rank*NOS)
- xlab = rep(xlab, length=Rank)
+ pcol = rep(pcol, length = Rank*NOS)
+ pcex = rep(pcex, length = Rank*NOS)
+ pch = rep(pch, length = Rank*NOS)
+ lcol = rep(lcol, length = Rank*NOS)
+ lwd = rep(lwd, length = Rank*NOS)
+ lty = rep(lty, length = Rank*NOS)
+ xlab = rep(xlab, length = Rank)
if (!length(whichSpecies)) whichSpecies = 1:NOS
if (length(ylab))
ylab = rep(ylab, len=length(whichSpecies)) # Too long if overlay
@@ -1531,20 +1605,20 @@ plot.cao = function(x,
yvals = yvals[ o ]
if (!center.cf) yvals = yvals + attr(terms.mat, "constant")
if (!add)
- if (sppno==1 || !overlay) {
+ if (sppno == 1 || !overlay) {
ylim.use = if (length(ylim)) ylim else
ylim.scale(range(yvals), scale)
- matplot(xvals, yvals, type="n",
+ matplot(xvals, yvals, type = "n",
xlab=xlab[rindex],
ylab = if (length(ylab)) ylab[sppno] else
- ifelse(overlay, "Fitted functions", "Fitted function"),
+ ifelse(overlay, "Fitted functions", "Fitted function"),
main = if (length(main)) main[sppno] else
ifelse(overlay, "", sppnames[thisSpecies]),
ylim=ylim.use,
...)
}
if (residuals.arg) {
- stop("cannot handle residuals=TRUE yet")
+ stop("cannot handle residuals = TRUE yet")
}
counter = counter + 1
lines(xvals, yvals,
@@ -1566,22 +1640,22 @@ setMethod("plot", "cao",
persp.cao = function(x,
- plot.it=TRUE,
- xlim=NULL, ylim=NULL, zlim=NULL, # zlim ignored if Rank==1
- gridlength = if (Rank==1) 301 else c(51,51),
- whichSpecies = NULL,
- xlab= if (Rank==1) "Latent Variable" else "Latent Variable 1",
- ylab= if (Rank==1) "Expected Value" else "Latent Variable 2",
- zlab="Expected value",
- labelSpecies = FALSE, # For Rank==1 only
- stretch = 1.05, # quick and dirty, Rank==1 only
- main="",
- ticktype = "detailed",
- col = if (Rank==1) par()$col else "white",
- lty=par()$lty,
- lwd=par()$lwd,
- rugplot=FALSE,
- ...) {
+ plot.it=TRUE,
+ xlim=NULL, ylim=NULL, zlim=NULL, # zlim ignored if Rank == 1
+ gridlength = if (Rank == 1) 301 else c(51,51),
+ whichSpecies = NULL,
+ xlab= if (Rank == 1) "Latent Variable" else "Latent Variable 1",
+ ylab= if (Rank == 1) "Expected Value" else "Latent Variable 2",
+ zlab="Expected value",
+ labelSpecies = FALSE, # For Rank == 1 only
+ stretch = 1.05, # quick and dirty, Rank == 1 only
+ main="",
+ ticktype = "detailed",
+ col = if (Rank == 1) par()$col else "white",
+ lty=par()$lty,
+ lwd=par()$lwd,
+ rugplot=FALSE,
+ ...) {
object = x # don't like x as the primary argument
coefobj = Coef(object)
if ((Rank <- coefobj at Rank) > 2)
@@ -1595,7 +1669,8 @@ persp.cao = function(x,
xlim = if (length(xlim)) xlim else range(coefobj at lv[,1])
if (!length(ylim.orig <- ylim)) {
- ylim = if (Rank==1) c(0, max(fvmat)*stretch) else range(coefobj at lv[,2])
+ ylim = if (Rank == 1) c(0, max(fvmat)*stretch) else
+ range(coefobj at lv[,2])
}
xlim = rep(xlim, length=2)
ylim = rep(ylim, length=2)
@@ -1615,7 +1690,7 @@ persp.cao = function(x,
} else
whichSpecies.numer = match(whichSpecies, sppNames)
- LP = matrix(as.numeric(NA), nrow(lvmat), NOS) # For first eta for each spp.
+ LP = matrix(as.numeric(NA),nrow(lvmat),NOS) # For 1st eta for each spp.
for(sppno in 1:NOS) {
temp = predictcao(object=object, grid=lvmat, sppno=sppno,
Rank=Rank, deriv=0, MSratio=MSratio)
@@ -1627,10 +1702,10 @@ persp.cao = function(x,
fitvals = object at family@inverse(LP, extra=object at extra) # n by NOS
dimnames(fitvals) = list(NULL, dimnames(fvmat)[[2]])
- if (Rank==1) {
+ if (Rank == 1) {
if (plot.it) {
if (!length(ylim.orig))
- ylim = c(0, max(fitvals[,whichSpecies.numer])*stretch) # A revision
+ ylim = c(0, max(fitvals[,whichSpecies.numer])*stretch) # A revision
col = rep(col, len=length(whichSpecies.numer))
lty = rep(lty, len=length(whichSpecies.numer))
lwd = rep(lwd, len=length(whichSpecies.numer))
@@ -1642,7 +1717,8 @@ persp.cao = function(x,
lines(lv1, fitvals[,ptr2], col=col[sppno],
lty=lty[sppno], lwd=lwd [sppno], ...)
if (labelSpecies) {
- ptr1=(1:nrow(fitvals))[max(fitvals[,ptr2])==fitvals[,ptr2]]
+ ptr1 = (1:nrow(fitvals))[max(fitvals[,ptr2]) ==
+ fitvals[,ptr2]]
ptr1 = ptr1[1]
text(lv1[ptr1], fitvals[ptr1,ptr2]+(stretch-1) *
diff(range(ylim)), label=sppNames[sppno],
@@ -1651,7 +1727,8 @@ persp.cao = function(x,
}
}
} else {
- maxfitted = matrix(fitvals[,whichSpecies[1]], length(lv1), length(lv2))
+ maxfitted = matrix(fitvals[,whichSpecies[1]], length(lv1),
+ length(lv2))
if (length(whichSpecies) > 1)
for(sppno in whichSpecies[-1]) {
maxfitted = pmax(maxfitted, matrix(fitvals[,sppno],
@@ -1707,11 +1784,9 @@ setClass(Class="summary.cao",
summary.cao = function(object, ...) {
answer = Coef(object, ...)
- print("20090417; in summary.cao()")
answer = as(answer, "summary.cao")
- print('20090417 get warning; need to stop "class(answer) = "summary.cao"" ')
answer at misc = object at misc
answer at call = object at call
@@ -1765,11 +1840,13 @@ if(!isGeneric("ccoef"))
setGeneric("ccoef", function(object, ...) standardGeneric("ccoef"))
setMethod("ccoef", "cao", function(object, ...) ccoef.cao(object, ...))
-setMethod("ccoef", "Coef.cao", function(object, ...) ccoef.Coef.cao(object, ...))
+setMethod("ccoef", "Coef.cao", function(object, ...)
+ ccoef.Coef.cao(object, ...))
if(!isGeneric("calibrate"))
- setGeneric("calibrate", function(object, ...) standardGeneric("calibrate"))
+ setGeneric("calibrate", function(object, ...)
+ standardGeneric("calibrate"))
setMethod("calibrate", "cao", function(object, ...)
calibrate.qrrvglm(object, ...))
@@ -1779,7 +1856,7 @@ setMethod("calibrate", "qrrvglm", function(object, ...)
Tol.cao = function(object, ...) {
- stop("The tolerance for a \"cao\" object is undefined")
+ stop("The tolerance for a 'cao' object is undefined")
}
if(!isGeneric("Tol"))
diff --git a/R/cqo.R b/R/cqo.R
index 277b155..24fe945 100644
--- a/R/cqo.R
+++ b/R/cqo.R
@@ -4,39 +4,39 @@
cqo <- function(formula,
- family, data=list(),
- weights=NULL, subset=NULL, na.action=na.fail,
- etastart=NULL, mustart=NULL, coefstart=NULL,
- control=qrrvglm.control(...),
- offset=NULL,
- method="cqo.fit",
- model=FALSE, x.arg=TRUE, y.arg=TRUE,
- contrasts=NULL,
- constraints=NULL,
- extra=NULL,
- smart=TRUE, ...)
+ family, data = list(),
+ weights = NULL, subset = NULL, na.action = na.fail,
+ etastart = NULL, mustart = NULL, coefstart = NULL,
+ control = qrrvglm.control(...),
+ offset = NULL,
+ method = "cqo.fit",
+ model = FALSE, x.arg = TRUE, y.arg = TRUE,
+ contrasts = NULL,
+ constraints = NULL,
+ extra = NULL,
+ smart = TRUE, ...)
{
- dataname <- as.character(substitute(data)) # "list" if no data=
+ dataname <- as.character(substitute(data)) # "list" if no data =
function.name <- "cqo"
ocall <- match.call()
- if(smart)
+ if (smart)
setup.smart("write")
mt <- terms(formula, data = data)
- if(missing(data))
+ if (missing(data))
data <- environment(formula)
mf <- match.call(expand=FALSE)
- mf$family <- mf$method <- mf$model <- mf$x.arg <- mf$y.arg <- mf$control <-
- mf$contrasts <- mf$constraints <- mf$extra <- NULL
+ mf$family <- mf$method <- mf$model <- mf$x.arg <- mf$y.arg <-
+ mf$control <- mf$contrasts <- mf$constraints <- mf$extra <- NULL
mf$coefstart <- mf$etastart <- mf$... <- NULL
mf$smart <- NULL
mf$drop.unused.levels <- TRUE
mf[[1]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
- if(method == "model.frame")
+ if (method == "model.frame")
return(mf)
na.act <- attr(mf, "na.action")
@@ -52,26 +52,26 @@ cqo <- function(formula,
x <- model.matrix(mt, mf, contrasts)
attr(x, "assign") = attrassigndefault(x, mt)
offset <- model.offset(mf)
- if(is.null(offset))
+ if (is.null(offset))
offset <- 0 # yyy ???
w <- model.weights(mf)
- if(!length(w))
+ if (!length(w))
w <- rep(1, nrow(mf))
- else if(ncol(as.matrix(w))==1 && any(w < 0))
+ else if (ncol(as.matrix(w)) == 1 && any(w < 0))
stop("negative weights not allowed")
- if(is.character(family))
+ if (is.character(family))
family <- get(family)
- if(is.function(family))
+ if (is.function(family))
family <- family()
- if(!inherits(family, "vglmff")) {
+ if (!inherits(family, "vglmff")) {
stop("'family=", family, "' is not a VGAM family function")
}
- control$criterion = "coefficients" # Specifically for vcontrol.expression
+ control$criterion = "coefficients" # Specifically 4 vcontrol.expression
eval(vcontrol.expression)
- if(!is.null(family at first))
+ if (!is.null(family at first))
eval(family at first)
@@ -80,24 +80,25 @@ cqo <- function(formula,
deviance.Bestof = rep(as.numeric(NA), len=control$Bestof)
for(tries in 1:control$Bestof) {
- if(control$trace && (control$Bestof>1))
+ if (control$trace && (control$Bestof>1))
cat(paste("\n========================= Fitting model", tries,
"=========================\n"))
- it <- cqo.fitter(x=x, y=y, w=w, offset=offset,
+ onefit <- cqo.fitter(x=x, y=y, w=w, offset=offset,
etastart=etastart, mustart=mustart, coefstart=coefstart,
family=family, control=control, constraints=constraints,
extra=extra, Terms=mt, function.name=function.name, ...)
- deviance.Bestof[tries] = if(length(it$crit.list$deviance))
- it$crit.list$deviance else it$crit.list$loglikelihood
- if(tries==1 || min(deviance.Bestof[1:(tries-1)])>deviance.Bestof[tries])
- fit = it
+ deviance.Bestof[tries] = if (length(onefit$crit.list$deviance))
+ onefit$crit.list$deviance else onefit$crit.list$loglikelihood
+ if (tries == 1 ||
+ min(deviance.Bestof[1:(tries-1)]) > deviance.Bestof[tries])
+ fit = onefit
}
fit$misc$deviance.Bestof = deviance.Bestof
fit$misc$dataname <- dataname
- if(smart) {
+ if (smart) {
fit$smart.prediction <- get.smart.prediction()
wrapup.smart()
}
@@ -108,40 +109,41 @@ cqo <- function(formula,
"call" = ocall,
"coefficients" = fit$coefficients,
"constraints" = fit$constraints,
- "criterion" = list("deviance"=min(deviance.Bestof)),
+ "criterion" = fit$crit.list, # list("deviance" = min(deviance.Bestof)),
"dispersion" = 1,
"family" = fit$family,
"misc" = fit$misc,
- "model" = if(model) mf else data.frame(),
+ "model" = if (model) mf else data.frame(),
"residuals" = as.matrix(fit$residuals),
"smart.prediction" = as.list(fit$smart.prediction),
"terms" = list(terms=mt))
- if(!smart) answer at smart.prediction <- list(smart.arg=FALSE)
+ if (!smart) answer at smart.prediction <- list(smart.arg = FALSE)
- if(length(attr(x, "contrasts")))
+ if (length(attr(x, "contrasts")))
slot(answer, "contrasts") = attr(x, "contrasts")
- if(length(fit$fitted.values))
+ if (length(fit$fitted.values))
slot(answer, "fitted.values") = as.matrix(fit$fitted.values)
- slot(answer, "na.action") = if(length(na.act)) list(na.act) else list()
- if(length(offset))
+ slot(answer, "na.action") = if (length(na.act)) list(na.act) else list()
+ if (length(offset))
slot(answer, "offset") = as.matrix(offset)
- if(length(fit$weights))
+ if (length(fit$weights))
slot(answer, "weights") = as.matrix(fit$weights)
- if(x.arg)
+ if (x.arg)
slot(answer, "x") = fit$x # The 'small' design matrix
- if(length(xlev))
+ if (length(xlev))
slot(answer, "xlevels") = xlev
- if(y.arg)
+ if (y.arg)
slot(answer, "y") = as.matrix(fit$y)
fit$control$min.criterion = TRUE # needed for calibrate; a special case
slot(answer, "control") = fit$control
- slot(answer, "extra") = if(length(fit$extra)) {
- if(is.list(fit$extra)) fit$extra else {
- warning("\"extra\" is not a list, therefore placing \"extra\" into a list")
+ slot(answer, "extra") = if (length(fit$extra)) {
+ if (is.list(fit$extra)) fit$extra else {
+ warning("'extra' is not a list, therefore placing ",
+ "'extra' into a list")
list(fit$extra)
}
} else list() # R-1.5.0
@@ -150,9 +152,8 @@ cqo <- function(formula,
dimnames(fit$predictors) = list(dimnames(fit$predictors)[[1]],
fit$misc$predictors.names)
slot(answer, "predictors") = fit$predictors
- if(length(fit$prior.weights))
+ if (length(fit$prior.weights))
slot(answer, "prior.weights") = fit$prior.weights
-
answer
}
attr(cqo, "smart") <- TRUE
diff --git a/R/cqo.fit.q b/R/cqo.fit.q
index adacadd..74bdd09 100644
--- a/R/cqo.fit.q
+++ b/R/cqo.fit.q
@@ -4,12 +4,10 @@
-callcqof = function(cmatrix, etamat, xmat, ymat, wvec,
+
+callcqoc = function(cmatrix, etamat, xmat, ymat, wvec,
X_vlm_1save, modelno, Control,
n, M, p1star, p2star, nice31, allofit=FALSE) {
- print("in callcqof 20090729")
- print("cmatrix")
- print( cmatrix )
ocmatrix = cmatrix
control = Control
Rank = control$Rank
@@ -17,7 +15,7 @@ callcqof = function(cmatrix, etamat, xmat, ymat, wvec,
dim(cmatrix) = c(p2, Rank) # for crow1C
pstar = p1star + p2star
maxMr = max(M, Rank)
- nstar = if (nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (nice31) ifelse(modelno == 3 || modelno == 5,n*2,n) else n*M
NOS = ifelse(modelno == 3 || modelno==5, M/2, M)
lenbeta = pstar * ifelse(nice31, NOS, 1)
@@ -28,17 +26,16 @@ callcqof = function(cmatrix, etamat, xmat, ymat, wvec,
cmatrix = cmatrix %*% evnu$vector
}
- print("control$isdlv")
- print( control$isdlv )
cmatrix = crow1C(cmatrix, control$Crow1positive)
- numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
+ numat = xmat[, control$colx2.index, drop = FALSE] %*% cmatrix
sdnumat = sd(numat)
for(lookat in 1:Rank)
- if (sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
- muxer = control$isdlv[lookat] * control$MUXfactor[lookat] /
- sdnumat[lookat]
+ if (sdnumat[lookat] >
+ control$MUXfactor[lookat] * control$isdlv[lookat]) {
+ muxer = control$isdlv[lookat] *
+ control$MUXfactor[lookat] / sdnumat[lookat]
numat[,lookat] = numat[,lookat] * muxer
- cmatrix[,lookat] = cmatrix[,lookat]*muxer # unneeded in callcqof
+ cmatrix[,lookat] = cmatrix[,lookat] * muxer
if (control$trace) {
cat(paste("Taking evasive action for latent variable ",
lookat, ".\n", sep=""))
@@ -48,15 +45,13 @@ callcqof = function(cmatrix, etamat, xmat, ymat, wvec,
"cmatrix", "ocmatrix"), prefix=".VGAM.CQO.")
}
} else {
- numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
+ numat = xmat[, control$colx2.index, drop = FALSE] %*% cmatrix
evnu = eigen(var(numat))
temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
evnu$vector %*% evnu$value^(-0.5)
cmatrix = cmatrix %*% temp7
cmatrix = crow1C(cmatrix, control$Crow1positive)
- numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
- print("var(numat) 20090729nn")
- print( var(numat) )
+ numat = xmat[, control$colx2.index, drop = FALSE] %*% cmatrix
}
inited = if (is.R()) {
@@ -64,106 +59,85 @@ callcqof = function(cmatrix, etamat, xmat, ymat, wvec,
} else 0
- usethiseta = if (inited==1)
+ usethiseta = if (inited == 1)
getfromVGAMenv("etamat", prefix = ".VGAM.CQO.") else t(etamat)
- usethisbeta = if (inited==2)
+ usethisbeta = if (inited == 2)
getfromVGAMenv("beta", prefix = ".VGAM.CQO.") else double(lenbeta)
- othint = c(Rank=Rank, control$EqualTol, pstar=pstar, dimw=1, inited=inited,
- modelno=modelno, maxitl=control$maxitl, actnits=0, twice=0,
- p1star=p1star, p2star=p2star, nice31=nice31, lenbeta=lenbeta,
- itol=itol, control$trace, p1=p1, p2=p2, control$method.init)
- print("X_vlm_1save 20090729")
- print( X_vlm_1save )
+ othint = c(Rank = Rank, control$EqualTol, pstar = pstar,
+ dimw = 1, inited = inited, modelno = modelno,
+ maxitl = control$maxitl, actnits = 0, twice = 0,
+ p1star = p1star, p2star = p2star, nice31 = nice31,
+ lenbeta = lenbeta, itol = itol, control$trace,
+ p1 = p1, p2 = p2, control$method.init)
bnumat = if (nice31) matrix(0,nstar,pstar) else
cbind(matrix(0,nstar,p2star), X_vlm_1save)
- print("M")
- print( M )
- print("NOS")
- print( NOS )
- print("othint")
- print( othint )
- if (TRUE) {
-}
- print("usethiseta")
- print( usethiseta )
- print("c(p1,p2,p1star,p2star,pstar)")
- print( c(p1,p2,p1star,p2star,pstar) )
- print('in callcqof: nice31')
- print( nice31 )
- print('if (nice31) "cqo1f" else "cqo2f"')
- print( if (nice31) "cqo1f" else "cqo2f" )
+
ans1 <-
- dotFortran(name=if (nice31) "cqo1f" else "cqo2f",
- numat=as.double(numat), as.double(ymat),
+ dotC(name = if (nice31) "cqo_1" else "cqo_2",
+ numat = as.double(numat), as.double(ymat),
as.double(if (p1) xmat[,control$colx1.index] else 999),
- as.double(wvec), etamat=as.double(usethiseta),
- moff=double(if (itol) n else 1),
- fv=double(NOS*n), z=double(n*M), wz=double(n*M),
- U=double(M*n), bnumat=as.double(bnumat),
- qr=double(nstar*pstar), qraux=double(pstar), qpivot=integer(pstar),
- as.integer(n), as.integer(M), NOS=as.integer(NOS),
- as.integer(nstar), dimu=as.integer(M),
- errcode=integer(1), othint=as.integer(othint),
- rowind=integer(maxMr*(maxMr+1)/2), colind=integer(maxMr*(maxMr+1)/2),
- deviance=double(1), beta=as.double(usethisbeta),
- twk=double(if (nice31) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
- othdbl=as.double(c(small=control$SmallNo, epsilon=control$epsilon,
- .Machine$double.eps,
- iKvector=rep(control$iKvector, len=NOS),
- iShape=rep(control$iShape, len=NOS))))
-
- print("Out of Fortran now; ans1$deviance")
- print( ans1$deviance )
- print("ans1$qpivot")
- print( ans1$qpivot )
- print(paste("out of fortran", if (nice31) "cqo1f" else "cqo2f"))
- print("hi 44 20090729")
-
- if (ans1$errcode == 0) {
- print("hi 77 20090729")
+ as.double(wvec), etamat = as.double(usethiseta),
+ moff = double(if (itol) n else 1),
+ fv = double(NOS*n), z = double(n*M), wz = double(n*M),
+ U = double(M*n), bnumat = as.double(bnumat),
+ qr = double(nstar*pstar), qraux = double(pstar),
+ qpivot = integer(pstar),
+ as.integer(n), as.integer(M), NOS = as.integer(NOS),
+ as.integer(nstar), dim1U = as.integer(M),
+ errcode = integer(1 + NOS), othint = as.integer(othint),
+ deviance = double(1+NOS), beta = as.double(usethisbeta),
+ othdbl = as.double(c(small = control$SmallNo,
+ epsilon = control$epsilon, .Machine$double.eps,
+ iKvector = rep(control$iKvector, len = NOS),
+ iShape = rep(control$iShape, len = NOS))))
+
+
+ if (ans1$errcode[1] == 0) {
assign2VGAMenv(c("etamat", "z", "U", "beta", "deviance"),
ans1, prefix=".VGAM.CQO.")
if (is.R()) {
- assign(".VGAM.CQO.cmatrix", cmatrix, envir = VGAMenv)
+ assign(".VGAM.CQO.cmatrix", cmatrix, envir = VGAMenv)
assign(".VGAM.CQO.ocmatrix", ocmatrix, envir = VGAMenv)
} else {
- .VGAM.CQO.cmatrix <<- cmatrix
+ .VGAM.CQO.cmatrix <<- cmatrix
.VGAM.CQO.ocmatrix <<- ocmatrix
}
} else {
- print("hi 88 20090729")
- warning(paste("error code in callcqof =", ans1$errcode))
+ print("hi 88 20100402; all the species did not converge in callcqo")
+ warning("error code in callcqoc = ", ans1$errcode[1])
+ if (nice31) {
+ print("ans1$errcode[-1]") # Only if (nice31)
+ print( ans1$errcode[-1] )
+ }
rmfromVGAMenv(c("etamat", "z", "U", "beta", "deviance",
"cmatrix", "ocmatrix"), prefix=".VGAM.CQO.")
}
- print("ans1$beta")
- print( ans1$beta )
if (control$trace)
flush.console()
- print("out of callcqof 20090729")
- if (allofit) list(deviance=ans1$deviance, coefficients=ans1$beta) else
- ans1$deviance
+ if (allofit) list(deviance = ans1$deviance[1],
+ alldeviance = ans1$deviance[-1],
+ coefficients = ans1$beta) else ans1$deviance[1]
}
-calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
+calldcqo = function(cmatrix, etamat, xmat, ymat, wvec,
X_vlm_1save, modelno, Control,
- n, M, p1star, p2star, nice31, allofit=FALSE) {
+ n, M, p1star, p2star, nice31, allofit = FALSE) {
control = Control
Rank = control$Rank
p1 = length(control$colx1.index); p2 = length(control$colx2.index)
dim(cmatrix) = c(p2, Rank) # for crow1C
- xmat2 <- xmat[,control$colx2.index,drop=FALSE] #ccc
+ xmat2 <- xmat[, control$colx2.index, drop = FALSE] #ccc
numat <- double(n*Rank) #ccc
pstar = p1star + p2star
maxMr = max(M, Rank)
- nstar = if (nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
- NOS = ifelse(modelno == 3 || modelno==5, M/2, M)
+ nstar = if (nice31) ifelse(modelno == 3 || modelno == 5,n*2,n) else n*M
+ NOS = ifelse(modelno == 3 || modelno == 5, M/2, M)
lenbeta = pstar * ifelse(nice31, NOS, 1)
if (itol <- control$ITolerances) {
@@ -177,9 +151,10 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
sdnumat = sd(numat)
for(lookat in 1:Rank)
- if (sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
- muxer = control$isdlv[lookat] * control$MUXfactor[lookat] /
- sdnumat[lookat]
+ if (sdnumat[lookat] > control$MUXfactor[lookat] *
+ control$isdlv[lookat]) {
+ muxer = control$isdlv[lookat] *
+ control$MUXfactor[lookat] / sdnumat[lookat]
cmatrix[,lookat] = cmatrix[,lookat] * muxer
if (control$trace) {
cat(paste("Taking evasive action for latent variable ",
@@ -188,15 +163,15 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
}
rmfromVGAMenv(c("etamat", "z", "U", "beta", "deviance",
"cmatrix", "ocmatrix"), prefix=".VGAM.CQO.")
- }
+ }
} else {
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
evnu = eigen(var(numat))
temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
- evnu$vector %*% evnu$value^(-0.5)
+ evnu$vector %*% evnu$value^(-0.5)
cmatrix = cmatrix %*% temp7
cmatrix = crow1C(cmatrix, control$Crow1positive)
- numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
+ numat = xmat[, control$colx2.index, drop = FALSE] %*% cmatrix
}
inited = if (is.R()) {
@@ -204,46 +179,46 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
} else 0
- usethiseta = if (inited==1)
+ usethiseta = if (inited == 1)
getfromVGAMenv("etamat", prefix = ".VGAM.CQO.") else t(etamat)
- usethisbeta = if (inited==2)
+ usethisbeta = if (inited == 2)
getfromVGAMenv("beta", prefix = ".VGAM.CQO.") else double(lenbeta)
- othint = c(Rank, control$EqualTol, pstar, dimw=1, inited=inited,
- modelno, maxitl=control$maxitl, actnits=0, twice=0,
- p1star=p1star, p2star=p2star, nice31=nice31, lenbeta,
- itol=itol, control$trace,
+ othint = c(Rank, control$EqualTol, pstar, dimw = 1, inited = inited,
+ modelno, maxitl = control$maxitl, actnits = 0, twice = 0,
+ p1star = p1star, p2star = p2star, nice31 = nice31, lenbeta,
+ itol = itol, control$trace,
p1, p2, control$method.init) # other ints
bnumat = if (nice31) matrix(0,nstar,pstar) else
cbind(matrix(0,nstar,p2star), X_vlm_1save)
- print("X_vlm_1save 20090729")
- print( X_vlm_1save )
flush.console()
ans1 <-
- dotFortran(name="dcqof", numat=as.double(numat), as.double(ymat),
+ dotC(name="dcqo1", numat=as.double(numat), as.double(ymat),
as.double(if (p1) xmat[,control$colx1.index] else 999),
as.double(wvec), etamat=as.double(usethiseta),
moff=double(if (itol) n else 1),
- fv=double(NOS*n), z=double(n*M), wz=double(n*M),
- U=double(M*n), bnumat=as.double(bnumat),
- qr=double(nstar*pstar), qraux=double(pstar), qpivot=integer(pstar),
+ fv = double(NOS*n), z = double(n*M), wz = double(n*M),
+ U = double(M*n), bnumat = as.double(bnumat),
+ qr=double(nstar * pstar), qraux=double(pstar), qpivot=integer(pstar),
as.integer(n), as.integer(M), NOS=as.integer(NOS),
- as.integer(nstar), dimu=as.integer(M),
- errcode=integer(1), othint=as.integer(othint),
- rowind=integer(maxMr*(maxMr+1)/2), colind=integer(maxMr*(maxMr+1)/2),
- deviance=double(1), beta=as.double(usethisbeta),
- twk=double(if (nice31) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
- othdbl=as.double(c(small=control$SmallNo, epsilon=control$epsilon,
- .Machine$double.eps,
- iKvector=rep(control$iKvector, len=NOS),
- iShape=rep(control$iShape, len=NOS))),
- xmat2=as.double(xmat2), onumat=as.double(numat), cmat=as.double(cmatrix),
- p2=as.integer(p2), deriv=double(p2*Rank), hstep=as.double(control$Hstep),
- betasave=double(lenbeta))
-
- if (ans1$errcode != 0) {
- warning(paste("error code in calldcqof =", ans1$errcode))
+ as.integer(nstar), dim1U=as.integer(M),
+ errcode = integer(1 + NOS), othint = as.integer(othint),
+ deviance=double(1 + NOS), beta=as.double(usethisbeta),
+ othdbl = as.double(c(small=control$SmallNo,
+ epsilon=control$epsilon, .Machine$double.eps,
+ iKvector=rep(control$iKvector, len=NOS),
+ iShape=rep(control$iShape, len=NOS))),
+ xmat2 = as.double(xmat2),
+ cmat=as.double(cmatrix),
+ p2=as.integer(p2), deriv=double(p2*Rank),
+ hstep=as.double(control$Hstep))
+
+ if (ans1$errcode[1] != 0) {
+ warning("error code in calldcqo = ", ans1$errcode[1])
+ print("hi 88 20100402; all the species did not converge in calldcqo")
+ print("ans1$errcode[]")
+ print( ans1$errcode[] )
}
flush.console()
@@ -263,30 +238,33 @@ checkCMCO <- function(Blist, control, modelno) {
stop("an intercept term must be in the argument 'Norrr' formula")
Blist1 = vector("list", p1)
Blist2 = vector("list", p2)
- for(k in 1:p1)
- Blist1[[k]] = Blist[[(colx1.index[k])]]
- for(k in 1:p2)
- Blist2[[k]] = Blist[[(colx2.index[k])]]
+ for(kk in 1:p1)
+ Blist1[[kk]] = Blist[[(colx1.index[kk])]]
+ for(kk in 1:p2)
+ Blist2[[kk]] = Blist[[(colx2.index[kk])]]
if (modelno == 3 || modelno == 5) {
if (p1 > 1)
- for(k in 2:p1)
- Blist1[[k]] = (Blist1[[k]])[c(TRUE,FALSE),,drop=FALSE]
- for(k in 1:p2)
- Blist2[[k]] = (Blist2[[k]])[c(TRUE,FALSE),,drop=FALSE]
+ for(kk in 2:p1)
+ Blist1[[kk]] = (Blist1[[kk]])[c(TRUE,FALSE),,drop=FALSE]
+ for(kk in 1:p2)
+ Blist2[[kk]] = (Blist2[[kk]])[c(TRUE,FALSE),,drop=FALSE]
}
if (!all(trivial.constraints(Blist2) == 1))
- stop("the constraint matrices for the non-Norrr terms are not trivial")
+ stop("the constraint matrices for the non-Norrr terms ",
+ "are not trivial")
if (!trivial.constraints(Blist1[[1]]))
- stop("the constraint matrices for intercept term is not trivial")
+ stop("the constraint matrices for intercept term is ",
+ "not trivial")
if (p1 > 1)
- for(k in 2:p1)
- if (!trivial.constraints(list(Blist1[[k]])))
- stop("the constraint matrices for some Norrr terms is not trivial")
+ for(kk in 2:p1)
+ if (!trivial.constraints(list(Blist1[[kk]])))
+ stop("the constraint matrices for some 'Norrr' ",
+ "terms is not trivial")
nice31 = if (control$Quadratic)
- (!control$EqualTol || control$ITolerances) else TRUE
+ (!control$EqualTol || control$ITolerances) else TRUE
as.numeric(nice31)
}
@@ -315,7 +293,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
intercept.only <- ncol(x) == 1 && dimnames(x)[[2]] == "(Intercept)"
- y.names <- predictors.names <- NULL # May be overwritten in @initialize
+ y.names <- predictors.names <- NULL # May be overwritten in @initialize
n.save <- n
@@ -326,7 +304,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
rrcontrol <- control #
if (length(family at initialize))
- eval(family at initialize) # Initialize mu and M (and optionally w)
+ eval(family at initialize) # Initialize mu and M (and optionally w)
n <- n.save
eval(rrr.init.expression)
@@ -356,16 +334,16 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
eval(family at constraints)
- special.matrix = matrix(-34956.125, M, M) # An unlikely used matrix
+ special.matrix = matrix(-34956.125, M, M) # An unlikely used matrix
just.testing <- cm.vgam(special.matrix, x, rrcontrol$Norrr, constraints)
findex = trivial.constraints(just.testing, special.matrix)
tc1 = trivial.constraints(constraints)
if (!control$Quadratic && sum(!tc1)) {
for(ii in names(tc1))
- if (!tc1[ii] && !any(ii == names(findex)[findex==1]))
- warning(paste("\"", ii, "\"", " is a non-trivial constraint",
- " that will be overwritten by reduced-rank regression", sep=""))
+ if (!tc1[ii] && !any(ii == names(findex)[findex == 1]))
+ warning("'", ii, "' is a non-trivial constraint that will ",
+ "be overwritten by reduced-rank regression")
}
if (all(findex == 1))
@@ -381,12 +359,12 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
names(colx1.index) = names.colx1.index
}
- rrcontrol$colx1.index=control$colx1.index=colx1.index #Save it on the object
+ rrcontrol$colx1.index=control$colx1.index = colx1.index
colx2.index = 1:ncol(x)
names(colx2.index) = dx2
colx2.index = colx2.index[-colx1.index]
p1 = length(colx1.index); p2 = length(colx2.index)
- rrcontrol$colx2.index=control$colx2.index=colx2.index #Save it on the object
+ rrcontrol$colx2.index=control$colx2.index = colx2.index
@@ -394,33 +372,34 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
Amat <- if (length(rrcontrol$Ainit)) rrcontrol$Ainit else
matrix(rnorm(M * Rank, sd=rrcontrol$SD.Cinit), M, Rank)
- Cmat = if (length(rrcontrol$Cinit)) matrix(rrcontrol$Cinit, p2, Rank) else {
+ Cmat = if (length(rrcontrol$Cinit)) {
+ matrix(rrcontrol$Cinit, p2, Rank)
+ } else {
if (!rrcontrol$Use.Init.Poisson.QO) {
- matrix(rnorm(p2 * Rank, sd=rrcontrol$SD.Cinit), p2, Rank)
+ matrix(rnorm(p2 * Rank, sd=rrcontrol$SD.Cinit), p2, Rank)
} else
- .Init.Poisson.QO(ymat=as.matrix(y),
- X1=x[,colx1.index,drop=FALSE],
- X2=x[,colx2.index,drop=FALSE],
- Rank=rrcontrol$Rank, trace=rrcontrol$trace,
- max.ncol.etamat = rrcontrol$Etamat.colmax,
- Crow1positive=rrcontrol$Crow1positive,
- isdlv=rrcontrol$isdlv,
- constwt= any(family at vfamily[1] ==
- c("negbinomial","gamma2","gaussianff")),
- takelog= any(family at vfamily[1] != c("gaussianff")))
+ .Init.Poisson.QO(ymat = as.matrix(y),
+ X1 = x[, colx1.index, drop = FALSE],
+ X2 = x[, colx2.index, drop = FALSE],
+ Rank = rrcontrol$Rank, trace = rrcontrol$trace,
+ max.ncol.etamat = rrcontrol$Etamat.colmax,
+ Crow1positive = rrcontrol$Crow1positive,
+ isdlv = rrcontrol$isdlv,
+ constwt = any(family at vfamily[1] ==
+ c("negbinomial","gamma2","gaussianff")),
+ takelog = any(family at vfamily[1] != c("gaussianff")))
}
if (rrcontrol$ITolerances) {
- lvmat = x[,rrcontrol$colx2.index,drop=FALSE] %*% Cmat
+ lvmat = x[, rrcontrol$colx2.index, drop = FALSE] %*% Cmat
lvmatmeans = t(lvmat) %*% matrix(1/n, n, 1)
if (!all(abs(lvmatmeans) < 4))
- warning(paste("ITolerances=TRUE but the variables making up the",
- "latent variable(s) do not appear to be centered,"))
+ warning("ITolerances=TRUE but the variables making up the ",
+ "latent variable(s) do not appear to be centered.")
}
- if (modelno==3 || modelno==5)
+ if (modelno == 3 || modelno == 5)
Amat[c(FALSE,TRUE),] <- 0 # Intercept only for log(k)
-
if (length(control$Structural.zero))
Amat[control$Structural.zero,] = 0
@@ -435,9 +414,10 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
X_vlm_save <- if (nice31) {
NULL
} else {
- tmp500=lm2qrrvlm.model.matrix(x=x,Blist=Blist,C=Cmat,control=control)
+ tmp500 = lm2qrrvlm.model.matrix(x = x, Blist = Blist,
+ C = Cmat, control = control)
xsmall.qrr = tmp500$new.lv.model.matrix
- B.list = tmp500$constraints # Doesn't change or contain \bI_{Rank} \bnu
+ B.list = tmp500$constraints
lv.mat = tmp500$lv.mat
if (length(tmp500$offset)) {
offset = tmp500$offset
@@ -456,17 +436,12 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
"cmatrix", "ocmatrix"), prefix=".VGAM.CQO.")
eval(cqo.init.derivative.expression)
- print("hi 20090729a")
for(iter in 1:control$optim.maxit) {
- print("hi 20090729b")
eval(cqo.derivative.expression)
- print("hi 20090729c")
if (!quasi.newton$convergence) break
- print("hi 20090729d")
}
- print("hi 20090729e")
- if (maxitl>1 && iter>=maxitl && quasi.newton$convergence)
- warning(paste("convergence not obtained in", maxitl, "iterations."))
+ if (maxitl > 1 && iter >= maxitl && quasi.newton$convergence)
+ warning("convergence not obtained in", maxitl, "iterations.")
if (length(family at fini))
eval(family at fini)
@@ -485,7 +460,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
yn <- dn[[1]]
xn <- dn[[2]]
residuals <- z - fv
- if (M==1) {
+ if (M == 1) {
residuals <- as.vector(residuals)
names(residuals) <- yn
} else {
@@ -502,6 +477,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
dimnames(mu) <- list(yn, y.names)
} else {
names(mu) <- names(fv)
+ y.names <- NULL
}
df.residual <- 55 - 8 - Rank*p2
@@ -515,7 +491,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
residuals=residuals,
terms=Terms) # terms: This used to be done in vglm()
- if (M==1) {
+ if (M == 1) {
wz <- as.vector(wz) # Convert wz into a vector
}
fit$weights <- if (save.weight) wz else NULL
@@ -539,21 +515,24 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (length(family at last))
eval(family at last)
- deviance = getfromVGAMenv("deviance", prefix = ".VGAM.CQO.")
- crit.list = list(deviance = deviance)
- structure(c(fit, list(predictors=matrix(eta,n,M),
- contrasts=attr(x, "contrasts"),
- control=control,
+ edeviance = getfromVGAMenv("deviance", prefix = ".VGAM.CQO.")
+ crit.list = list(deviance = edeviance[1], alldeviance = edeviance[-1])
+ if (is.character(y.names) &&
+ length(y.names) == length(crit.list$alldeviance))
+ names(crit.list$alldeviance) = y.names
+ structure(c(fit, list(predictors = matrix(eta, n, M),
+ contrasts = attr(x, "contrasts"),
+ control = control,
crit.list = crit.list,
- extra=extra,
- family=family,
- iter=iter,
- misc=misc,
+ extra = extra,
+ family = family,
+ iter = iter,
+ misc = misc,
post = post,
- rss=000,
- x=x,
- y=y)),
- vclass=family at vfamily)
+ rss = 000,
+ x = x,
+ y = y)),
+ vclass = family at vfamily)
}
@@ -564,13 +543,13 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
isdlv = rep(1, lengt=Rank),
constwt=FALSE, takelog=TRUE) {
-
print.CQO.expression = expression({
if (trace && length(X2)) {
cat("\nUsing initial values\n")
dimnames(ans) = list(dimnames(X2)[[2]],
- if (Rank==1) "lv" else paste("lv", 1:Rank, sep=""))
- if (p2>5) print(ans, dig=3) else print(t(ans), dig=3)
+ if (Rank == 1) "lv" else
+ paste("lv", 1:Rank, sep=""))
+ if (p2 > 5) print(ans, dig=3) else print(t(ans), dig=3)
}
flush.console()
})
@@ -583,15 +562,16 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
})
- Crow1positive = if (length(Crow1positive)) rep(Crow1positive, len=Rank) else
- rep(TRUE, len=Rank) # Not nice. Because $Crow1positive==NULL for RRVGLMs
+ Crow1positive = if (length(Crow1positive))
+ rep(Crow1positive, len=Rank) else
+ rep(TRUE, len=Rank)
if (epsilon <= 0)
stop("epsilon > 0 is required")
- ymat = cbind(ymat) + epsilon # ymat==0 cause problems
+ ymat = cbind(ymat) + epsilon # ymat == 0 cause problems
NOS = ncol(ymat)
p2 = ncol(X2)
if (NOS < 2*Rank) {
- ans = crow1C(matrix(rnorm(p2*Rank, sd=0.02), p2, Rank), Crow1positive)
+ ans=crow1C(matrix(rnorm(p2*Rank, sd=0.02), p2, Rank), Crow1positive)
eval(sd.scale.X2.expression)
if (NOS == 1) {
eval(print.CQO.expression)
@@ -601,16 +581,19 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
calS = 1:NOS # Set of all species available for the approximation
effrank = min(Rank, floor(NOS/2)) # effective rank
- ncol.etamat = min(if (length(X2)) floor(NOS/2) else effrank, max.ncol.etamat)
- etamat = wts = matrix(0, nrow=nrow(ymat), ncol=ncol.etamat) # has >=1 coln
+ ncol.etamat = min(if (length(X2)) floor(NOS/2) else effrank,
+ max.ncol.etamat)
+ etamat =
+ wts = matrix(0, nrow=nrow(ymat), ncol=ncol.etamat) # has >=1 coln
rr = 1
for(ii in 1:floor(NOS/2)) {
if (length(calS) < 2) break
index = sample(calS, size=2) # Randomness here
etamat[,rr] = etamat[,rr] + (if (takelog)
log(ymat[,index[1]] / ymat[,index[2]]) else
- ymat[,index[1]] - ymat[,index[2]])
- wts[,rr]=wts[,rr]+(if (constwt) 1 else ymat[,index[1]]+ymat[,index[2]])
+ ymat[,index[1]] - ymat[,index[2]])
+ wts[,rr] = wts[,rr] +
+ (if (constwt) 1 else ymat[,index[1]] + ymat[,index[2]])
calS = setdiff(calS, index)
rr = (rr %% ncol.etamat) + 1
}
@@ -619,14 +602,17 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (length(X2)) {
alt = valt(x=cbind(X1, X2), z=etamat, U=sqrt(t(wts)), Rank=effrank,
- Blist=NULL, Cinit=NULL, trace=FALSE, colx1.index=1:ncol(X1),
- Criterion="rss")
- temp.control = list(Rank=effrank, colx1.index = 1:ncol(X1), Alpha=0.5,
- colx2.index = (ncol(X1)+1):(ncol(X1) + ncol(X2)),
- Corner=FALSE, Svd.arg=TRUE, Uncorrelated.lv=TRUE, Quadratic=FALSE)
+ Blist=NULL, Cinit=NULL, trace=FALSE,
+ colx1.index=1:ncol(X1), Criterion="rss")
+ temp.control = list(Rank=effrank, colx1.index = 1:ncol(X1),
+ Alpha=0.5,
+ colx2.index = (ncol(X1)+1):(ncol(X1) + ncol(X2)),
+ Corner=FALSE, Svd.arg=TRUE,
+ Uncorrelated.lv=TRUE, Quadratic=FALSE)
- ans2 = if (Rank > 1) rrr.normalize(rrcontrol=temp.control, A=alt$A,
- C=alt$C, x=cbind(X1, X2)) else alt
+ ans2 = if (Rank > 1)
+ rrr.normalize(rrcontrol=temp.control, A=alt$A,
+ C=alt$C, x=cbind(X1, X2)) else alt
ans = crow1C(ans2$C, rep(Crow1positive, len=effrank))
Rank.save = Rank
@@ -637,11 +623,12 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (effrank < Rank) {
ans = cbind(ans, ans.save[,-(1:effrank)]) # ans is better
}
- eval(print.CQO.expression)
+ eval(print.CQO.expression)
} else {
xij = NULL # temporary measure
U = t(sqrt(wts))
- tmp = vlm.wfit(xmat=X1, zmat=etamat, Blist=NULL, U=U, matrix.out=TRUE,
+ tmp = vlm.wfit(xmat=X1, zmat=etamat, Blist=NULL, U=U,
+ matrix.out=TRUE,
is.vlmX=FALSE, rss=TRUE, qr=FALSE, xij=xij)
ans = crow1C(as.matrix(tmp$resid), rep(Crow1positive, len=effrank))
if (effrank < Rank) {
@@ -660,9 +647,11 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
ans = crow1C(ans, rep(Crow1positive, len=Rank))
dimnames(ans) = list(dimnames(X1)[[1]],
- if (Rank==1) "lv" else paste("lv", 1:Rank, sep=""))
- if (trace)
- {if (nrow(ans) > 10) print(t(ans), dig=3) else print(ans, dig=3)}
+ if (Rank == 1) "lv" else paste("lv", 1:Rank, sep=""))
+ if (trace) {
+ if (nrow(ans) > 10) print(t(ans), dig = 3) else
+ print(ans, dig = 3)
+ }
}
ans
}
@@ -672,9 +661,9 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
cqo.init.derivative.expression <- expression({
which.optimizer = if (is.R()) {
if (control$Quadratic && control$FastAlgorithm) {
- "BFGS"
+ "BFGS"
} else {
- if (iter <= rrcontrol$Switch.optimizer) "Nelder-Mead" else "BFGS"
+ if (iter <= rrcontrol$Switch.optimizer) "Nelder-Mead" else "BFGS"
}
} else "Quasi-Newton"
if (trace && control$OptimizeWrtC) {
@@ -684,13 +673,14 @@ cqo.init.derivative.expression <- expression({
if (FALSE) {
- constraints=replace.constraints(constraints,diag(M),rrcontrol$colx2.index)
+ constraints = replace.constraints(constraints, diag(M),
+ rrcontrol$colx2.index)
nice31 = (!control$EqualTol || control$ITolerances) &&
all(trivial.constraints(constraints) == 1)
}
- NOS = ifelse(modelno==3 || modelno==5, M/2, M)
+ NOS = ifelse(modelno == 3 || modelno == 5, M/2, M)
canfitok = if (is.R())
(exists("CQO.FastAlgorithm", envir=VGAMenv) &&
get("CQO.FastAlgorithm", envir = VGAMenv)) else
@@ -701,7 +691,7 @@ cqo.init.derivative.expression <- expression({
p2star = if (nice31)
ifelse(control$IToleran, Rank, Rank+0.5*Rank*(Rank+1)) else
(NOS*Rank + Rank*(Rank+1)/2 * ifelse(control$EqualTol,1,NOS))
- p1star = if (nice31) ifelse(modelno==3 || modelno==5,1+p1,p1) else
+ p1star = if (nice31) ifelse(modelno == 3 || modelno == 5,1+p1,p1) else
(ncol(X_vlm_save)-p2star)
X_vlm_1save = if (p1star > 0) X_vlm_save[,-(1:p2star)] else NULL
})
@@ -712,14 +702,9 @@ cqo.init.derivative.expression <- expression({
cqo.derivative.expression <- expression({
- if (is.R()) {
if (iter == 1 || quasi.newton$convergence) {
- print("hi 20090729; nice31")
- print( nice31 )
- print("hi 20090729; X_vlm_1save")
- print( X_vlm_1save )
- quasi.newton = optim(par=Cmat, fn=callcqof,
- gr = if (control$GradientFunction) calldcqof else NULL,
+ quasi.newton = optim(par=Cmat, fn=callcqoc,
+ gr = if (control$GradientFunction) calldcqo else NULL,
method=which.optimizer,
control=list(fnscale=1,trace=as.integer(control$trace),
parscale=rep(control$Parscale, len=length(Cmat)),
@@ -728,62 +713,58 @@ cqo.derivative.expression <- expression({
X_vlm_1save = X_vlm_1save,
modelno=modelno, Control=control,
n=n, M=M, p1star=p1star, p2star=p2star, nice31=nice31)
- print("hi 20090729; quasi.newton$par")
- print( quasi.newton$par )
- print("hi 20090729; quasi.newton$value")
- print( quasi.newton$value )
z = matrix(getfromVGAMenv("z", prefix=".VGAM.CQO."), n, M)
U = matrix(getfromVGAMenv("U", prefix=".VGAM.CQO."), M, n)
}
-} else {
- stop("not written for Splus yet")
-}
-
-ocmatrix = getfromVGAMenv("ocmatrix", prefix = ".VGAM.CQO.")
-maxdiff = max(abs(c(ocmatrix) - c(quasi.newton$par)) / (1+abs(c(ocmatrix))))
- if (maxdiff < 1.0e-4) {
- Cmat = getfromVGAMenv("cmatrix", prefix = ".VGAM.CQO.")
-} else {
- warning("solution does not correspond to .VGAM.CQO.cmatrix")
-}
+ ocmatrix = getfromVGAMenv("ocmatrix", prefix = ".VGAM.CQO.")
+ maxdiff = max(abs(c(ocmatrix) - c(quasi.newton$par)) / (1 +
+ abs(c(ocmatrix))))
+ if (maxdiff < 1.0e-4) {
+ Cmat = getfromVGAMenv("cmatrix", prefix = ".VGAM.CQO.")
+ } else {
+ warning("solution does not correspond to .VGAM.CQO.cmatrix")
+ }
-alt = valt.1iter(x=x, z=z, U=U, Blist=Blist, C=Cmat, nice31=nice31,
- control=rrcontrol, lp.names=predictors.names,
- MSratio=M/NOS)
+ alt = valt.1iter(x=x, z=z, U=U, Blist=Blist, C=Cmat, nice31=nice31,
+ control=rrcontrol, lp.names=predictors.names,
+ MSratio=M/NOS)
- if (length(alt$offset))
- offset = alt$offset
+ if (length(alt$offset))
+ offset = alt$offset
-B1.save = alt$B1 # Put later into extra
-tmp.fitted = alt$fitted # contains \bI_{Rank} \bnu if Corner
+ B1.save = alt$B1 # Put later into extra
+ tmp.fitted = alt$fitted # contains \bI_{Rank} \bnu if Corner
- if (trace && control$OptimizeWrtC) {
- cat("\n")
- cat(which.optimizer, "using", if (is.R()) "optim():" else "nlminb():", "\n")
- cat("Objective =", quasi.newton$value, "\n")
- cat("Parameters (= c(C)) = ", if (length(quasi.newton$par) < 5) "" else "\n")
- cat( if (is.R()) alt$Cmat else format(alt$Cmat), fill=TRUE)
- cat("\n")
- if (!is.R()) {
- cat("Gradient norm =", format(quasi.newton$grad.norm), "\n")
- cat("Number of gradient evaluations =", quasi.newton$g.evals, "\n")
+ if (trace && control$OptimizeWrtC) {
+ cat("\n")
+ cat(which.optimizer, "using", if (is.R()) "optim():" else
+ "nlminb():", "\n")
+ cat("Objective =", quasi.newton$value, "\n")
+ cat("Parameters (= c(C)) = ", if (length(quasi.newton$par) < 5) ""
+ else "\n")
+ cat( if (is.R()) alt$Cmat else format(alt$Cmat), fill=TRUE)
+ cat("\n")
+ if (!is.R()) {
+ cat("Gradient norm =", format(quasi.newton$grad.norm), "\n")
+ cat("Number of gradient evaluations =", quasi.newton$g.evals,
+ "\n")
+ }
+ cat("Number of function evaluations =", if (is.R())
+ quasi.newton$count[1] else quasi.newton$f.evals, "\n")
+ if (length(quasi.newton$message))
+ cat("Message =", quasi.newton$message, "\n")
+ cat("\n")
+ flush.console()
}
- cat("Number of function evaluations =", if (is.R())
- quasi.newton$count[1] else quasi.newton$f.evals, "\n")
- if (length(quasi.newton$message))
- cat("Message =", quasi.newton$message, "\n")
- cat("\n")
- flush.console()
-}
-Amat = alt$Amat #
-Cmat = alt$Cmat #
-Dmat = alt$Dmat #
+ Amat = alt$Amat #
+ Cmat = alt$Cmat #
+ Dmat = alt$Dmat #
-eval(cqo.end.expression) #
+ eval(cqo.end.expression) #
})
@@ -820,9 +801,12 @@ cqo.end.expression = expression({
z <- eta + vbacksub(U, tvfor, M=M, n=n) - offset # Contains \bI \bnu
+
+
})
-crow1C = function(cmat, crow1positive=rep(TRUE, len=ncol(cmat)), amat=NULL) {
+crow1C = function(cmat, crow1positive=rep(TRUE, len=ncol(cmat)),
+ amat=NULL) {
if (!is.logical(crow1positive) || length(crow1positive) != ncol(cmat))
stop("bad input in crow1C")
for(LV in 1:ncol(cmat))
@@ -859,18 +843,19 @@ printqrrvglm <- function(x, ...)
if (length(deviance(x)))
cat("Residual Deviance:", format(deviance(x)), "\n")
- if (length(x at criterion)) {
+ if (FALSE && length(x at criterion)) {
ncrit <- names(x at criterion)
- for(i in ncrit)
- if (i != "loglikelihood" && i != "deviance")
- cat(paste(i, ":", sep=""), format(x at criterion[[i]]), "\n")
+ for(ii in ncrit)
+ if (ii != "loglikelihood" && ii != "deviance")
+ cat(paste(ii, ":", sep=""), format(x at criterion[[ii]]), "\n")
}
invisible(x)
}
-setMethod("Coef", "qrrvglm", function(object, ...) Coef.qrrvglm(object, ...))
+setMethod("Coef", "qrrvglm", function(object, ...)
+ Coef.qrrvglm(object, ...))
setMethod("coef", "qrrvglm", function(object, ...)
Coef.qrrvglm(object, ...))
@@ -878,17 +863,21 @@ setMethod("coefficients", "qrrvglm", function(object, ...)
Coef.qrrvglm(object, ...))
if (!isGeneric("deviance"))
- setGeneric("deviance", function(object, ...) standardGeneric("deviance"))
-setMethod("deviance", "qrrvglm", function(object,...) object at criterion$deviance)
+ setGeneric("deviance", function(object, ...)
+ standardGeneric("deviance"))
+setMethod("deviance", "qrrvglm", function(object,...)
+ object at criterion$deviance)
-setMethod("fitted", "qrrvglm", function(object, ...) fitted.vlm(object))
-setMethod("fitted.values", "qrrvglm", function(object, ...) fitted.vlm(object))
+setMethod("fitted", "qrrvglm", function(object, ...)
+ fitted.vlm(object))
+setMethod("fitted.values", "qrrvglm", function(object, ...)
+ fitted.vlm(object))
setMethod("print", "qrrvglm", function(x, ...) printqrrvglm(x, ...))
- setMethod("show", "qrrvglm", function(object) printqrrvglm(object))
+setMethod("show", "qrrvglm", function(object) printqrrvglm(object))
diff --git a/R/family.basics.R b/R/family.basics.R
index dff753f..174d882 100644
--- a/R/family.basics.R
+++ b/R/family.basics.R
@@ -14,7 +14,7 @@ getind <- function(constraints, M, ncolx) {
if (!length(constraints)) {
constraints = vector("list", ncolx)
- for(ii in 1:ncolx)
+ for (ii in 1:ncolx)
constraints[[ii]] <- diag(M)
}
@@ -22,9 +22,9 @@ getind <- function(constraints, M, ncolx) {
names(ans) <- c(paste("eta", 1:M, sep=""), "ncolX_vlm")
temp2 <- matrix(unlist(constraints), nrow=M)
- for(kk in 1:M) {
+ for (kk in 1:M) {
ansx <- NULL
- for(ii in 1:length(constraints)) {
+ for (ii in 1:length(constraints)) {
temp <- constraints[[ii]]
isfox <- any(temp[kk,] != 0)
if (isfox) {
@@ -41,20 +41,25 @@ getind <- function(constraints, M, ncolx) {
-cm.vgam <- function(cm, x, bool, constraints,
- intercept.apply=FALSE, overwrite=FALSE)
+ cm.vgam <- function(cm, x, bool, constraints,
+ intercept.apply=FALSE, overwrite=FALSE)
{
+ if (is.null(bool)) return(NULL)
+
M <- nrow(cm)
asgn <- attr(x, "assign")
+ if(is.null(asgn))
+ stop("the 'assign' attribute is missing from 'x'; this ",
+ "may be due to some missing values") # 20100306
nasgn <- names(asgn)
ninasgn <- nasgn[nasgn != "(Intercept)"]
if (!length(constraints)) {
constraints <- vector("list", length(nasgn))
- for(ii in 1:length(nasgn)) {
+ for (ii in 1:length(nasgn)) {
constraints[[ii]] <- diag(M)
}
names(constraints) <- nasgn
@@ -64,9 +69,11 @@ cm.vgam <- function(cm, x, bool, constraints,
if (length(constraints) != length(nasgn) ||
any(sort(names(constraints)) != sort(nasgn))) {
- cat("names(constraints)\n")
- cat("The above don't match;\n")
- stop("'constraints' is half-pie")
+ cat("\nnames(constraints)\n")
+ print(names(constraints) )
+ cat("\nnames(attr(x, 'assign'))\n")
+ print( nasgn )
+ stop("The above don't match; 'constraints' is half-pie")
}
if (is.logical(bool)) {
@@ -74,7 +81,7 @@ cm.vgam <- function(cm, x, bool, constraints,
if (intercept.apply && any(nasgn=="(Intercept)"))
constraints[["(Intercept)"]] <- cm
if (length(ninasgn))
- for(ii in ninasgn)
+ for (ii in ninasgn)
constraints[[ii]] <- cm
} else {
return(constraints)
@@ -100,7 +107,7 @@ cm.vgam <- function(cm, x, bool, constraints,
if (attr(tbool, "intercept"))
tl <- c("(Intercept)", tl)
- for(ii in nasgn) {
+ for (ii in nasgn) {
if (default && any(tl == ii))
constraints[[ii]] <- cm
if (!default && !any(tl == ii))
@@ -124,7 +131,7 @@ cm.nointercept.vgam <- function(constraints, x, nointercept, M)
}
if (!is.list(constraints))
stop("'constraints' must be a list")
- for(ii in 1:length(asgn))
+ for (ii in 1:length(asgn))
constraints[[nasgn[ii]]] <- if (is.null(constraints[[nasgn[ii]]]))
diag(M) else eval(constraints[[nasgn[ii]]])
@@ -162,7 +169,7 @@ cm.zero.vgam <- function(constraints, x, zero, M)
names(constraints) <- nasgn
}
if (!is.list(constraints)) stop("'constraints' must be a list")
- for(ii in 1:length(asgn))
+ for (ii in 1:length(asgn))
constraints[[nasgn[ii]]] <- if (is.null(constraints[[nasgn[ii]]]))
diag(M) else eval(constraints[[nasgn[ii]]])
@@ -175,11 +182,11 @@ cm.zero.vgam <- function(constraints, x, zero, M)
stop("cannot fit an intercept to a no-intercept model")
if (2 <= length(constraints))
- for(ii in 2:length(constraints)) {
+ for (ii in 2:length(constraints)) {
temp <- constraints[[nasgn[ii]]]
temp[zero,] <- 0
index <- NULL
- for(kk in 1:ncol(temp))
+ for (kk in 1:ncol(temp))
if (all(temp[,kk] == 0)) index <- c(index,kk)
if (length(index) == ncol(temp))
stop("constraint matrix has no columns!")
@@ -202,7 +209,7 @@ process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
if (is.null(constraints)) {
constraints <- vector("list", length(nasgn))
- for(ii in 1:length(nasgn))
+ for (ii in 1:length(nasgn))
constraints[[ii]] <- diag(M)
names(constraints) <- nasgn
}
@@ -215,7 +222,7 @@ process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
lenconstraints <- length(constraints)
if (lenconstraints > 0)
- for(i in 1:lenconstraints) {
+ for (i in 1:lenconstraints) {
constraints[[i]] <- eval(constraints[[i]])
if (!is.null(constraints[[i]]) && !is.matrix(constraints[[i]]))
stop("'constraints[[",i,"]]' is not a matrix")
@@ -229,12 +236,12 @@ process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
names(junk) <- nasgn
junk
}
- for(i in 1:length(nasgn))
+ for (i in 1:length(nasgn))
temp[[nasgn[i]]] <-
if (is.null(constraints[[nasgn[i]]])) diag(M) else
eval(constraints[[nasgn[i]]])
- for(i in 1:length(asgn)) {
+ for (i in 1:length(asgn)) {
if (!is.matrix(temp[[i]])) {
stop("not a constraint matrix")
}
@@ -247,10 +254,10 @@ process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
constraints <- temp
Blist <- vector("list", ncol(x))
- for(ii in 1:length(asgn)) {
+ for (ii in 1:length(asgn)) {
cols <- asgn[[ii]]
ictr = 0
- for(jay in cols) {
+ for (jay in cols) {
ictr = ictr + 1
cm = if (is.list(specialCM) && any(nasgn[ii] == names(specialCM))) {
slist = specialCM[[(nasgn[ii])]]
@@ -266,7 +273,7 @@ process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
-trivial.constraints <- function(Blist, target=diag(M))
+ trivial.constraints <- function(Blist, target = diag(M))
{
if (is.null(Blist))
@@ -282,7 +289,7 @@ trivial.constraints <- function(Blist, target=diag(M))
trivc <- rep(1, length(Blist))
names(trivc) <- names(Blist)
- for(ii in 1:length(Blist)) {
+ for (ii in 1:length(Blist)) {
d <- dim(Blist[[ii]])
if (d[1] != dimtar[1]) trivc[ii] <- 0
if (d[2] != dimtar[2]) trivc[ii] <- 0
@@ -320,7 +327,7 @@ add.constraints <- function(constraints, new.constraints,
stop("lists must have names")
if (!empty.list(constraints) && !empty.list(new.constraints)) {
- for(i in nn) {
+ for (i in nn) {
if (any(i==nc)) {
if (check &&
(!(all(dim(constraints[[i]])==dim(new.constraints[[i]])) &&
@@ -532,12 +539,12 @@ wweights = function(object, matrix.arg=TRUE, deriv.arg=FALSE,
y <- object at y
if (any(slotNames(object)=="control"))
- for(i in names(object at control)) {
+ for (i in names(object at control)) {
assign(i, object at control[[i]])
}
if (length(object at misc))
- for(i in names(object at misc)) {
+ for (i in names(object at misc)) {
assign(i, object at misc[[i]])
}
@@ -756,7 +763,7 @@ VGAM.matrix.norm = function(A, power=2, suppressWarning=FALSE) {
rmfromVGAMenv = function(varnames, prefix="") {
evarnames = paste(prefix, varnames, sep="")
if (is.R()) {
- for(i in evarnames) {
+ for (i in evarnames) {
mytext1 = "exists(x=i, envir = VGAMenv)"
myexp1 = parse(text=mytext1)
is.there = eval(myexp1)
@@ -766,7 +773,7 @@ rmfromVGAMenv = function(varnames, prefix="") {
}
} else {
warning("this code needs checking 9")
- for(i in evarnames)
+ for (i in evarnames)
while(exists(i, inherits=TRUE))
rm(i, inherits=TRUE)
@@ -777,7 +784,7 @@ existsinVGAMenv = function(varnames, prefix="") {
evarnames = paste(prefix, varnames, sep="")
ans = NULL
if (is.R()) {
- for(i in evarnames) {
+ for (i in evarnames) {
mytext1 = "exists(x=i, envir = VGAMenv)"
myexp1 = parse(text=mytext1)
is.there = eval(myexp1)
@@ -785,7 +792,7 @@ existsinVGAMenv = function(varnames, prefix="") {
}
} else {
warning("this code needs checking 8")
- for(i in evarnames) {
+ for (i in evarnames) {
is.there = exists(i, inherits=TRUE)
ans = c(ans, is.there)
}
@@ -796,7 +803,7 @@ existsinVGAMenv = function(varnames, prefix="") {
assign2VGAMenv = function(varnames, mylist, prefix="") {
evarnames = paste(prefix, varnames, sep="")
if (is.R()) {
- for(i in 1:length(varnames)) {
+ for (i in 1:length(varnames)) {
assign(evarnames[i], mylist[[(varnames[i])]], envir = VGAMenv)
}
} else {
diff --git a/R/family.binomial.R b/R/family.binomial.R
index 5624d4e..8b406a7 100644
--- a/R/family.binomial.R
+++ b/R/family.binomial.R
@@ -10,9 +10,16 @@
+
+
process.binomial2.data.vgam <- expression({
+
+ if (!all(w == 1))
+ extra$orig.w = w
+
+
if (!is.matrix(y)) {
yf <- as.factor(y)
lev <- levels(yf)
@@ -25,8 +32,8 @@ process.binomial2.data.vgam <- expression({
colnamesy <- paste(lev, ":", c("00","01","10","11"), sep="")
dimnames(y) <- list(names(yf), colnamesy)
input.type <- 1
- } else if (ncol(y)==2) {
- if (!all(y==0 | y==1))
+ } else if (ncol(y) == 2) {
+ if (!all(y == 0 | y == 1))
stop("response must contains 0's and 1's only")
col.index <- y[,2] + 2*y[,1] + 1 # 1:4
nn <- nrow(y)
@@ -34,20 +41,19 @@ process.binomial2.data.vgam <- expression({
y[cbind(1:nn,col.index)] <- 1
dimnames(y) <- list(dimnames(y)[[1]], c("00","01","10","11"))
input.type <- 2
- } else if (ncol(y)==4) {
+ } else if (ncol(y) == 4) {
input.type <- 3
} else
stop("response unrecognized")
- nvec <- drop(y %*% rep(1,ncol(y)))
+ nvec <- drop(y %*% rep(1, ncol(y)))
w <- w * nvec
y <- y / nvec # Convert to proportions
mu <- y + (1/ncol(y) - y)/nvec
dimnames(mu) <- dimnames(y)
-
})
@@ -85,32 +91,38 @@ betabinomial.control <- function(save.weight=TRUE, ...)
}
new("vglmff",
- blurb=c("Beta-binomial model\n",
- "Links: ",
- namesof("mu", lmu, earg= emu), ", ",
- namesof("rho", lrho, earg= erho), "\n",
- "Mean: mu", "\n",
- "Variance: mu*(1-mu)*(1+(w-1)*rho)/w"),
- constraints=eval(substitute(expression({
+ blurb = c("Beta-binomial model\n",
+ "Links: ",
+ namesof("mu", lmu, earg = emu), ", ",
+ namesof("rho", lrho, earg = erho), "\n",
+ "Mean: mu", "\n",
+ "Variance: mu*(1-mu)*(1+(w-1)*rho)/w"),
+ constraints = eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ if (!all(w == 1))
+ extra$orig.w = w
+
if (is.null( .nsimEIM)) {
save.weight <- control$save.weight <- FALSE
}
eval(binomialff()@initialize) # Note: n,w,y,mustart is changed
- ycounts = y * w # Convert proportions to counts
- if (max(abs(ycounts-round(ycounts))) > 1.0e-6)
- warning("the response (as counts) does not appear to be integer-valued. ",
- "Am rounding to integer values.")
+
+
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ if (max(abs(ycounts - round(ycounts))) > 1.0e-6)
+ warning("the response (as counts) does not appear to ",
+ "be integer-valued. Am rounding to integer values.")
ycounts = round(ycounts) # Make sure it is an integer
- predictors.names = c(namesof("mu", .lmu, earg= .emu, tag=FALSE),
- namesof("rho", .lrho, earg= .erho, tag=FALSE))
+ predictors.names = c(namesof("mu", .lmu, earg = .emu, tag=FALSE),
+ namesof("rho", .lrho, earg = .erho, tag=FALSE))
if (!length(etastart)) {
betabinomial.Loglikfun = function(rhoval, y, x, w, extraargs) {
- shape1 = extraargs$mustart*(1-rhoval)/rhoval
- shape2 = (1-extraargs$mustart)*(1-rhoval)/rhoval
+ shape1 = extraargs$mustart * (1-rhoval) / rhoval
+ shape2 = (1-extraargs$mustart) * (1-rhoval) / rhoval
ycounts = extraargs$ycounts # Ought to be integer-valued
nvec = extraargs$nvec
sum(dbetabin.ab(x=ycounts, size=nvec, shape1=shape1,
@@ -124,44 +136,48 @@ betabinomial.control <- function(save.weight=TRUE, ...)
} else if ( .method.init == 3) {
y.matrix = cbind(y)
mat.temp = matrix(colMeans(y.matrix), nrow(y.matrix),
- ncol(y.matrix), byrow=TRUE)
+ ncol(y.matrix), byrow = TRUE)
0.5 * mustart + 0.5 * mat.temp
} else {
mustart
}
try.this = getMaxMin(rho.grid, objfun=betabinomial.Loglikfun,
y=y, x=x, w=w, extraargs=list(
- ycounts=ycounts, nvec=w,
+ ycounts=ycounts,
+ nvec = if (is.numeric(extra$orig.w))
+ round(w / extra$orig.w) else round(w),
mustart=mustart.use))
init.rho = if (is.Numeric( .irho )) rep( .irho, length=n) else
rep(try.this, len=n)
}
- 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, .sinit=shrinkage.init,
- .nsimEIM=nsimEIM, .irho=irho ))),
- inverse=eval(substitute(function(eta, extra=NULL)
- eta2theta(eta[,1], .lmu, earg= .emu),
- list( .lmu=lmu, .emu=emu ))),
- last=eval(substitute(expression({
+ 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, .sinit = shrinkage.init,
+ .nsimEIM = nsimEIM, .irho=irho ))),
+ inverse = eval(substitute(function(eta, extra = NULL)
+ eta2theta(eta[,1], .lmu, earg = .emu),
+ list( .lmu = lmu, .emu = emu ))),
+ last = eval(substitute(expression({
misc$link <- c(mu = .lmu, rho = .lrho)
misc$earg <- list(mu = .emu, rho = .erho)
misc$zero <- .zero
misc$expected <- TRUE
misc$nsimEIM = .nsimEIM
- }), list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho,
- .nsimEIM=nsimEIM, .zero=zero ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
- ycounts = y * w # Convert proportions to counts
- mymu = eta2theta(eta[,1], .lmu, earg= .emu)
- rho = eta2theta(eta[,2], .lrho, earg= .erho)
+ }), list( .lmu = lmu, .lrho = lrho,
+ .emu = emu, .erho = erho,
+ .nsimEIM = nsimEIM, .zero = zero ))),
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals=FALSE, eta, extra = NULL) {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+
+ mymu = eta2theta(eta[,1], .lmu, earg = .emu)
+ rho = eta2theta(eta[,2], .lrho, earg = .erho)
smallno = 1.0e4 * .Machine$double.eps
- if (max(abs(ycounts - round(y * w))) > smallno)
+ if (max(abs(ycounts - round(ycounts))) > smallno)
warning("converting 'ycounts' to integer in @loglikelihood")
ycounts = round(ycounts)
@@ -169,20 +185,28 @@ betabinomial.control <- function(save.weight=TRUE, ...)
rho = pmin(rho, 1-smallno)
shape1 = mymu * (1 - rho) / rho
shape2 = (1-mymu) * (1 - rho) / rho
- nvec = w
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dbetabin.ab(x=ycounts, size=nvec, shape1=shape1,
- shape2=shape2, log=TRUE))
+
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dbetabin.ab(x = ycounts, size = nvec, shape1 = shape1,
+ shape2 = shape2, log = TRUE ))
}
- }, list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho ))),
- vfamily=c("betabinomial"),
- deriv=eval(substitute(expression({
- nvec = w # extra$nvec # for summary()
- ycounts = y * w # Convert proportions to counts
+ }, list( .lmu = lmu, .lrho = lrho,
+ .emu = emu, .erho = erho ))),
+ vfamily = c("betabinomial"),
+ deriv = eval(substitute(expression({
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+
ycounts = round(ycounts)
- mymu = eta2theta(eta[,1], .lmu, earg= .emu)
- rho = eta2theta(eta[,2], .lrho, earg= .erho)
+ 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)
@@ -192,8 +216,8 @@ betabinomial.control <- function(save.weight=TRUE, ...)
dshape2.dmu = -(1 - rho) / rho
dshape1.drho = -mymu / rho^2
dshape2.drho = -(1 - mymu) / rho^2
- dmu.deta = dtheta.deta(mymu, .lmu, earg= .emu)
- drho.deta = dtheta.deta(rho, .lrho, earg= .erho)
+ dmu.deta = dtheta.deta(mymu, .lmu, earg = .emu)
+ drho.deta = dtheta.deta(rho, .lrho, earg = .erho)
dl.dmu = dshape1.dmu * (digamma(shape1+ycounts) -
digamma(shape2+nvec-ycounts) -
digamma(shape1) + digamma(shape2))
@@ -202,10 +226,11 @@ betabinomial.control <- function(save.weight=TRUE, ...)
digamma(shape1+shape2+nvec) -
mymu * digamma(shape1) -
(1-mymu)*digamma(shape2) + digamma(shape1+shape2))
+ (if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
cbind(dl.dmu * dmu.deta, dl.drho * drho.deta)
- }), list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho ))),
- weight=eval(substitute(expression({
+ }), list( .lmu = lmu, .lrho = lrho,
+ .emu = emu, .erho = erho ))),
+ weight = eval(substitute(expression({
if (is.null( .nsimEIM)) {
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(2)
wz11 = -(expected.betabin.ab(nvec, shape1, shape2, TRUE) -
@@ -224,14 +249,15 @@ betabinomial.control <- function(save.weight=TRUE, ...)
wz[,iam(2,1,M)] = dmu.deta * drho.deta *
(dshape1.dmu*(wz11*dshape1.drho + wz21*dshape2.drho) +
dshape2.dmu*(wz21*dshape1.drho + wz22*dshape2.drho))
- wz
+ wz * (if (is.numeric(extra$orig.w)) extra$orig.w else 1)
} else {
run.varcov = 0
ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
dthetas.detas = cbind(dmu.deta, drho.deta)
- for(ii in 1:( .nsimEIM )) {
- ysim = rbetabin.ab(n=n, size=nvec, shape1=shape1, shape2=shape2)
+ for (ii in 1:( .nsimEIM )) {
+ ysim = rbetabin.ab(n=n, size=nvec, shape1=shape1,
+ shape2=shape2)
dl.dmu = dshape1.dmu * (digamma(shape1+ysim) -
digamma(shape2+nvec-ysim) -
digamma(shape1) + digamma(shape2))
@@ -248,13 +274,13 @@ betabinomial.control <- function(save.weight=TRUE, ...)
}
wz = if (intercept.only)
matrix(colMeans(run.varcov),
- n, ncol(run.varcov), byrow=TRUE) else run.varcov
+ n, ncol(run.varcov), byrow = TRUE) else run.varcov
wz = wz * dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
- wz
+ wz * (if (is.numeric(extra$orig.w)) extra$orig.w else 1)
}
- }), list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho,
+ }), list( .lmu = lmu, .lrho = lrho,
+ .emu = emu, .erho = erho,
.nsimEIM = nsimEIM ))))
}
@@ -264,12 +290,12 @@ betabinomial.control <- function(save.weight=TRUE, ...)
dbinom2.or = function(mu1,
- mu2 = if (exchangeable) mu1 else stop("'mu2' not specified"),
- oratio=1,
- exchangeable=FALSE,
- tol=0.001,
- colnames=c("00", "01", "10", "11"),
- ErrorCheck=TRUE)
+ mu2 = if (exchangeable) mu1 else stop("'mu2' not specified"),
+ oratio = 1,
+ exchangeable = FALSE,
+ tol = 0.001,
+ colnames = c("00", "01", "10", "11"),
+ ErrorCheck = TRUE)
{
if (ErrorCheck) {
if (!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
@@ -281,7 +307,7 @@ dbinom2.or = function(mu1,
if (!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
stop("bad input for argument 'tol'")
if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
- stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
+ stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
}
n = max(length(mu1), length(mu2), length(oratio))
@@ -296,7 +322,7 @@ dbinom2.or = function(mu1,
p01 = mu2 - p11
p10 = mu1 - p11
p00 = 1 - p11 - p01 - p10
- matrix(c(p00,p01,p10,p11), n, 4, dimnames=list(NULL,colnames))
+ matrix(c(p00, p01, p10, p11), n, 4, dimnames = list(NULL, colnames))
}
@@ -311,25 +337,26 @@ rbinom2.or = function(n, mu1,
colnames = if (twoCols) c("y1","y2") else c("00", "01", "10", "11"),
ErrorCheck=TRUE)
{
- if (ErrorCheck) {
- if (!is.Numeric(n, integer=TRUE, posit=TRUE, allow=1))
- stop("bad input for argument 'n'")
- if (!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
- stop("bad input for argument 'mu1'")
- if (!is.Numeric(mu2, positive=TRUE) || max(mu2) >= 1)
- stop("bad input for argument 'mu2'")
- if (!is.Numeric(oratio, positive=TRUE))
- stop("bad input for argument 'oratio'")
- if (!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
- stop("bad input for argument 'tol'")
- if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
- stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
- }
+ if (ErrorCheck) {
+ if (!is.Numeric(n, integer=TRUE, posit=TRUE, allow=1))
+ stop("bad input for argument 'n'")
+ if (!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
+ stop("bad input for argument 'mu1'")
+ if (!is.Numeric(mu2, positive=TRUE) || max(mu2) >= 1)
+ stop("bad input for argument 'mu2'")
+ if (!is.Numeric(oratio, positive=TRUE))
+ stop("bad input for argument 'oratio'")
+ if (!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
+ stop("bad input for argument 'tol'")
+ if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
+ stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
+ }
dmat = dbinom2.or(mu1=mu1, mu2=mu2, oratio=oratio, exchang=exchangeable,
tol=tol, ErrorCheck=ErrorCheck)
- answer = matrix(0, n, 2, dimnames=list(NULL, if (twoCols) colnames else NULL))
+ answer = matrix(0, n, 2,
+ dimnames=list(NULL, if (twoCols) colnames else NULL))
yy = runif(n)
cs1 = dmat[,"00"] + dmat[,"01"]
cs2 = cs1 + dmat[,"10"]
@@ -349,10 +376,11 @@ rbinom2.or = function(n, mu1,
- binom2.or = function(lmu="logit", lmu1=lmu, lmu2=lmu, loratio="loge",
- emu=list(), emu1=emu, emu2=emu, eoratio=list(),
- imu1=NULL, imu2=NULL, ioratio = NULL,
- zero=3, exchangeable=FALSE, tol=0.001, morerobust=FALSE)
+ binom2.or = function(lmu = "logit", lmu1 = lmu, lmu2 = lmu, loratio = "loge",
+ emu = list(), emu1 = emu, emu2 = emu, eoratio = list(),
+ imu1 = NULL, imu2 = NULL, ioratio = NULL,
+ zero = 3, exchangeable = FALSE, tol = 0.001,
+ morerobust = FALSE)
{
if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
@@ -372,23 +400,23 @@ rbinom2.or = function(n, mu1,
if (!is.list(eoratio)) eoratio = list()
new("vglmff",
- blurb=c("Bivariate binomial regression with an odds ratio\n",
- "Links: ",
- namesof("mu1", lmu1, earg=emu1), ", ",
- namesof("mu2", lmu2, earg=emu2), "; ",
- namesof("oratio", loratio, earg=eoratio)),
- constraints=eval(substitute(expression({
+ blurb = c("Bivariate binomial regression with an odds ratio\n",
+ "Links: ",
+ namesof("mu1", lmu1, earg=emu1), ", ",
+ namesof("mu2", lmu2, earg=emu2), "; ",
+ namesof("oratio", loratio, earg=eoratio)),
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(c(1,1,0,0,0,1),3,2), x,
.exchangeable, constraints,
intercept.apply=TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .exchangeable=exchangeable, .zero=zero ))),
- deviance=Deviance.categorical.data.vgam,
- initialize=eval(substitute(expression({
+ }), list( .exchangeable = exchangeable, .zero = zero ))),
+ deviance = Deviance.categorical.data.vgam,
+ initialize = eval(substitute(expression({
eval(process.binomial2.data.vgam)
- predictors.names = c(namesof("mu1", .lmu1, earg= .emu1, short=TRUE),
- namesof("mu2", .lmu2, earg= .emu2, short=TRUE),
- namesof("oratio", .loratio, earg= .eoratio, short=TRUE))
+ predictors.names = c(namesof("mu1", .lmu1, earg = .emu1, short=TRUE),
+ namesof("mu2", .lmu2, earg = .emu2, short=TRUE),
+ namesof("oratio", .loratio, earg = .eoratio, short=TRUE))
if (!length(etastart)) {
pmargin = cbind(mu[,3]+mu[,4], mu[,2]+mu[,4])
@@ -396,17 +424,17 @@ rbinom2.or = function(n, mu1,
mu[,4]*mu[,1]/(mu[,2]*mu[,3])
if (length( .imu1)) pmargin[,1] = .imu1
if (length( .imu2)) pmargin[,2] = .imu2
- etastart = cbind(theta2eta(pmargin[,1], .lmu1, earg= .emu1),
- theta2eta(pmargin[,2], .lmu2, earg= .emu2),
- theta2eta(ioratio, .loratio, earg= .eoratio))
+ etastart = cbind(theta2eta(pmargin[,1], .lmu1, earg = .emu1),
+ theta2eta(pmargin[,2], .lmu2, earg = .emu2),
+ theta2eta(ioratio, .loratio, earg = .eoratio))
}
- }), list( .lmu1=lmu1, .lmu2=lmu2, .loratio=loratio,
- .emu1=emu1, .emu2=emu2, .eoratio=eoratio,
- .imu1=imu1, .imu2=imu2, .ioratio=ioratio ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- pmargin = cbind(eta2theta(eta[,1], .lmu1, earg= .emu1),
- eta2theta(eta[,2], .lmu2, earg= .emu2))
- oratio = eta2theta(eta[,3], .loratio, earg= .eoratio)
+ }), list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
+ .emu1 = emu1, .emu2 = emu2, .eoratio = eoratio,
+ .imu1 = imu1, .imu2 = imu2, .ioratio = ioratio ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ pmargin = cbind(eta2theta(eta[,1], .lmu1, earg = .emu1),
+ eta2theta(eta[,2], .lmu2, earg = .emu2))
+ oratio = eta2theta(eta[,3], .loratio, earg = .eoratio)
a.temp = 1 + (pmargin[,1]+pmargin[,2])*(oratio-1)
b.temp = -4 * oratio * (oratio-1) * pmargin[,1] * pmargin[,2]
temp = sqrt(a.temp^2 + b.temp)
@@ -415,38 +443,52 @@ rbinom2.or = function(n, mu1,
pj2 = pmargin[,2] - pj4
pj3 = pmargin[,1] - pj4
cbind("00" = 1-pj4-pj2-pj3, "01" = pj2, "10" = pj3, "11" = pj4)
- }, list( .tol=tol, .lmu1=lmu1, .lmu2=lmu2,
- .emu1=emu1, .emu2=emu2, .eoratio=eoratio,
- .loratio=loratio ))),
- last=eval(substitute(expression({
+ }, list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
+ .emu1 = emu1, .emu2 = emu2, .eoratio = eoratio,
+ .tol = tol ))),
+ last = eval(substitute(expression({
misc$link = c("mu1"= .lmu1, "mu2"= .lmu2, "oratio"= .loratio)
misc$earg = list(mu1 = .emu1, mu2 = .emu2, oratio = .eoratio)
misc$tol = .tol
misc$expected = TRUE
- }), list( .tol=tol, .lmu1=lmu1, .lmu2=lmu2,
- .emu1=emu1, .emu2=emu2, .eoratio=eoratio,
- .loratio=loratio ))),
- link=eval(substitute(function(mu, extra=NULL) {
+ }), list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
+ .emu1 = emu1, .emu2 = emu2, .eoratio = eoratio,
+ .tol = tol ))),
+ link = eval(substitute(function(mu, extra = NULL) {
pmargin = cbind(mu[,3]+mu[,4], mu[,2]+mu[,4])
oratio = mu[,4]*mu[,1] / (mu[,2]*mu[,3])
- cbind(theta2eta(pmargin[,1], .lmu1, earg= .emu1),
- theta2eta(pmargin[,2], .lmu2, earg= .emu2),
- theta2eta(oratio, .loratio, earg= .eoratio))
- }, list( .lmu1=lmu1, .lmu2=lmu2,
- .emu1=emu1, .emu2=emu2, .eoratio=eoratio,
- .loratio=loratio ))),
- loglikelihood=eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ cbind(theta2eta(pmargin[,1], .lmu1, earg = .emu1),
+ theta2eta(pmargin[,2], .lmu2, earg = .emu2),
+ theta2eta(oratio, .loratio, earg = .eoratio))
+ }, list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
+ .emu1 = emu1, .emu2 = emu2, .eoratio = eoratio ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
if ( .morerobust) {
vsmallno = 1.0e4 * .Machine$double.xmin
mu[mu < vsmallno] = vsmallno
}
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
+
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
+
}
- }, list( .morerobust=morerobust ))),
- vfamily=c("binom2.or", "binom2"),
- deriv=eval(substitute(expression({
+ }, list( .morerobust = morerobust ))),
+ vfamily = c("binom2.or", "binom2"),
+ deriv = eval(substitute(expression({
smallno = 1.0e4 * .Machine$double.eps
mu.use = mu
mu.use[mu.use < smallno] = smallno
@@ -470,37 +512,38 @@ rbinom2.or = function(n, mu1,
dl.dmu2 = coeff12[,1] * (y[,1]/mu.use[,1]-y[,2]/mu.use[,2]) -
(1+coeff12[,1]) * (y[,3]/mu.use[,3]-y[,4]/mu.use[,4])
- coeff3 = (y[,1]/mu.use[,1] - y[,2]/mu.use[,2] - y[,3]/mu.use[,3] + y[,4]/mu.use[,4])
- Vab = pmax(smallno, 1 / (1/mu.use[,1] + 1/mu.use[,2] + 1/mu.use[,3] + 1/mu.use[,4]))
+ coeff3 = (y[,1]/mu.use[,1] - y[,2]/mu.use[,2] -
+ y[,3]/mu.use[,3] + y[,4]/mu.use[,4])
+ Vab = pmax(smallno, 1 / (1/mu.use[,1] + 1/mu.use[,2] +
+ 1/mu.use[,3] + 1/mu.use[,4]))
dp11.doratio = Vab / use.oratio
dl.doratio = coeff3 * dp11.doratio
- w * cbind(dl.dmu1 * dtheta.deta(pmargin[,1], .lmu1, earg= .emu1),
- dl.dmu2 * dtheta.deta(pmargin[,2], .lmu2, earg= .emu2),
- dl.doratio * dtheta.deta(oratio, .loratio, earg= .eoratio))
- }), list( .lmu1=lmu1, .lmu2=lmu2,
- .emu1=emu1, .emu2=emu2, .eoratio=eoratio,
- .loratio=loratio ))),
- weight=eval(substitute(expression({
+ w * cbind(dl.dmu1 * dtheta.deta(pmargin[,1], .lmu1, earg = .emu1),
+ dl.dmu2 * dtheta.deta(pmargin[,2], .lmu2, earg = .emu2),
+ dl.doratio * dtheta.deta(oratio, .loratio, earg = .eoratio))
+ }), list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
+ .emu1 = emu1, .emu2 = emu2, .eoratio = eoratio ))),
+ weight = eval(substitute(expression({
Deltapi = mu.use[,3]*mu.use[,2] - mu.use[,4]*mu.use[,1]
- myDelta = pmax(smallno, mu.use[,1] * mu.use[,2] * mu.use[,3] * mu.use[,4])
+ myDelta = pmax(smallno, mu.use[,1] * mu.use[,2] *
+ mu.use[,3] * mu.use[,4])
pqmargin = pmargin * (1-pmargin)
pqmargin[pqmargin < smallno] = smallno
wz = matrix(0, n, 4)
wz[,iam(1,1,M)] = (pqmargin[,2] * Vab / myDelta) *
- dtheta.deta(pmargin[,1], .lmu1, earg= .emu1)^2
+ dtheta.deta(pmargin[,1], .lmu1, earg = .emu1)^2
wz[,iam(2,2,M)] = (pqmargin[,1] * Vab / myDelta) *
- dtheta.deta(pmargin[,2], .lmu2, earg= .emu2)^2
+ dtheta.deta(pmargin[,2], .lmu2, earg = .emu2)^2
wz[,iam(3,3,M)] = (Vab / use.oratio^2) *
- dtheta.deta(use.oratio, .loratio, earg= .eoratio)^2
+ dtheta.deta(use.oratio, .loratio, earg = .eoratio)^2
wz[,iam(1,2,M)] = (Vab * Deltapi / myDelta) *
- dtheta.deta(pmargin[,1], .lmu1, earg= .emu1) *
- dtheta.deta(pmargin[,2], .lmu2, earg= .emu2)
+ dtheta.deta(pmargin[,1], .lmu1, earg = .emu1) *
+ dtheta.deta(pmargin[,2], .lmu2, earg = .emu2)
w * wz
- }), list( .lmu1=lmu1, .lmu2=lmu2,
- .emu1=emu1, .emu2=emu2, .eoratio=eoratio,
- .loratio=loratio ))))
+ }), list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
+ .emu1 = emu1, .emu2 = emu2, .eoratio = eoratio ))))
}
@@ -561,7 +604,8 @@ rbinom2.rho = function(n, mu1,
dmat = dbinom2.rho(mu1=mu1, mu2=mu2, rho=rho, exchang=exchangeable,
ErrorCheck=ErrorCheck)
- answer = matrix(0, n, 2, dimnames=list(NULL, if (twoCols) colnames else NULL))
+ answer = matrix(0, n, 2,
+ dimnames=list(NULL, if (twoCols) colnames else NULL))
yy = runif(n)
cs1 = dmat[,"00"] + dmat[,"01"]
cs2 = cs1 + dmat[,"10"]
@@ -606,30 +650,32 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
}
new("vglmff",
- blurb=c("Bivariate probit model\n",
- "Links: ",
- namesof("mu1", lmu12, earg= emu12), ", ",
- namesof("mu2", lmu12, earg= emu12), ", ",
- namesof("rho", lrho, earg= erho)),
- constraints=eval(substitute(expression({
- constraints = cm.vgam(matrix(c(1,1,0,0,0,1),3,2), x,
- .exchangeable, constraints, intercept.apply=TRUE)
+ blurb = c("Bivariate probit model\n",
+ "Links: ",
+ namesof("mu1", lmu12, earg = emu12), ", ",
+ namesof("mu2", lmu12, earg = emu12), ", ",
+ namesof("rho", lrho, earg = erho)),
+ constraints = eval(substitute(expression({
+ constraints = cm.vgam(matrix(c(1, 1, 0, 0, 0, 1), 3, 2), x,
+ .exchangeable, constraints, intercept.apply = TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .exchangeable=exchangeable, .zero=zero ))),
- deviance=Deviance.categorical.data.vgam,
- initialize=eval(substitute(expression({
+ }), list( .exchangeable = exchangeable, .zero = zero ))),
+ deviance = Deviance.categorical.data.vgam,
+ initialize = eval(substitute(expression({
eval(process.binomial2.data.vgam)
predictors.names = c(
- namesof("mu1", .lmu12, earg= .emu12, short=TRUE),
- namesof("mu2", .lmu12, earg= .emu12, short=TRUE),
- namesof("rho", .lrho, earg= .erho, short=TRUE))
+ namesof("mu1", .lmu12, earg = .emu12, short=TRUE),
+ namesof("mu2", .lmu12, earg = .emu12, short=TRUE),
+ namesof("rho", .lrho, earg = .erho, short=TRUE))
if (is.null( .nsimEIM)) {
save.weight <- control$save.weight <- FALSE
}
if (is.null(etastart)) {
- mu1.init= if (is.Numeric(.imu1)) rep(.imu1, len=n) else mu[,3]+mu[,4]
- mu2.init= if (is.Numeric(.imu2)) rep(.imu2, len=n) else mu[,2]+mu[,4]
+ mu1.init= if (is.Numeric(.imu1)) rep(.imu1, len=n) else
+ mu[,3] + mu[,4]
+ mu2.init= if (is.Numeric(.imu2)) rep(.imu2, len=n) else
+ mu[,2] + mu[,4]
rho.init = if (is.Numeric(.init.rho)) rep( .init.rho, len=n) else {
temp4 = oratio = mu[,1] * mu[,4] / (mu[,2] * mu[,3])
temp4[oratio <= 0.1] = -0.6
@@ -642,41 +688,59 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
temp4[oratio > 15.0] = 0.8
temp4
}
- etastart = cbind(theta2eta(mu1.init, .lmu12, earg= .emu12),
- theta2eta(mu2.init, .lmu12, earg= .emu12),
- theta2eta(rho.init, .lrho, earg= .erho))
+ etastart = cbind(theta2eta(mu1.init, .lmu12, earg = .emu12),
+ theta2eta(mu2.init, .lmu12, earg = .emu12),
+ theta2eta(rho.init, .lrho, earg = .erho))
}
- }), list( .lmu12=lmu12, .emu12=emu12, .nsimEIM=nsimEIM,
- .lrho=lrho, .erho=erho,
- .imu1=imu1, .imu2=imu2, .init.rho=init.rho ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- pmargin = cbind(eta2theta(eta[,1], .lmu12, earg= .emu12),
- eta2theta(eta[,2], .lmu12, earg= .emu12))
- rho = eta2theta(eta[,3], .lrho, earg= .erho)
+ }), list( .lmu12 = lmu12, .emu12 = emu12, .nsimEIM = nsimEIM,
+ .lrho = lrho, .erho = erho,
+ .imu1 = imu1, .imu2 = imu2, .init.rho = init.rho ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ pmargin = cbind(eta2theta(eta[,1], .lmu12, earg = .emu12),
+ eta2theta(eta[,2], .lmu12, earg = .emu12))
+ rho = eta2theta(eta[,3], .lrho, earg = .erho)
p11 = pnorm2(eta[,1], eta[,2], rho)
- p01 = pmargin[,2]-p11
- p10 = pmargin[,1]-p11
- p00 = 1-p01-p10-p11
- cbind("00"=p00, "01"=p01, "10"=p10, "11"=p11)
- }, list( .lmu12=lmu12, .emu12=emu12, .lrho=lrho, .erho=erho ))),
- last=eval(substitute(expression({
+ p01 = pmin(pmargin[,2] - p11, pmargin[,2])
+ p10 = pmin(pmargin[,1] - p11, pmargin[,1])
+ p00 = 1 - p01 - p10 - p11
+ ansmat = abs(cbind("00"=p00, "01"=p01, "10"=p10, "11"=p11))
+ ansmat / rowSums(ansmat)
+ }, list( .lmu12 = lmu12, .emu12 = emu12, .lrho = lrho, .erho = erho ))),
+ last = eval(substitute(expression({
misc$link = c(mu1 = .lmu12, mu2 = .lmu12, rho = .lrho)
misc$earg = list(mu1 = .emu12, mu2 = .emu12, rho = .erho)
misc$nsimEIM = .nsimEIM
misc$expected = TRUE
- }), list( .lmu12=lmu12, .emu12=emu12, .lrho=lrho, .erho=erho,
- .nsimEIM=nsimEIM ))),
- loglikelihood=eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
+ }), list( .lmu12 = lmu12, .lrho = lrho,
+ .emu12 = emu12, .erho = erho,
+ .nsimEIM = nsimEIM ))),
+
+
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
}
- }, list( .erho=erho ))),
- vfamily=c("binom2.rho", "binom2"),
- deriv=eval(substitute(expression({
- pmargin = cbind(eta2theta(eta[,1], .lmu12, earg= .emu12),
- eta2theta(eta[,2], .lmu12, earg= .emu12))
- rhovec = eta2theta(eta[,3], .lrho, earg= .erho)
+ }, list( .erho = erho ))),
+ vfamily = c("binom2.rho", "binom2"),
+ deriv = eval(substitute(expression({
+ pmargin = cbind(eta2theta(eta[,1], .lmu12, earg = .emu12),
+ eta2theta(eta[,2], .lmu12, earg = .emu12))
+ rhovec = eta2theta(eta[,3], .lrho, earg = .erho)
p11 = pnorm2(eta[,1], eta[,2], rhovec)
p01 = pmargin[,2]-p11
p10 = pmargin[,1]-p11
@@ -698,14 +762,14 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
dl.dprob1 = PhiB*(y[,4]/p11-y[,2]/p01) + onemPhiB*(y[,3]/p10-y[,1]/p00)
dl.dprob2 = PhiA*(y[,4]/p11-y[,3]/p10) + onemPhiA*(y[,2]/p01-y[,1]/p00)
dl.drho = (y[,4]/p11-y[,3]/p10-y[,2]/p01+y[,1]/p00) * dprob00
- dprob1.deta = dtheta.deta(pmargin[,1], .lmu12, earg= .emu12)
- dprob2.deta = dtheta.deta(pmargin[,2], .lmu12, earg= .emu12)
- drho.deta = dtheta.deta(rhovec, .lrho, earg= .erho)
+ dprob1.deta = dtheta.deta(pmargin[,1], .lmu12, earg = .emu12)
+ dprob2.deta = dtheta.deta(pmargin[,2], .lmu12, earg = .emu12)
+ drho.deta = dtheta.deta(rhovec, .lrho, earg = .erho)
dthetas.detas = cbind(dprob1.deta, dprob2.deta, drho.deta)
w * cbind(dl.dprob1, dl.dprob2, dl.drho) * dthetas.detas
- }), list( .lmu12=lmu12, .emu12=emu12, .lrho=lrho, .erho=erho ))),
- weight=eval(substitute(expression({
+ }), list( .lmu12 = lmu12, .emu12 = emu12, .lrho = lrho, .erho = erho ))),
+ weight = eval(substitute(expression({
if (is.null( .nsimEIM)) {
d2l.dprob1prob1 = PhiB^2 *(1/p11+1/p01) + onemPhiB^2 *(1/p10+1/p00)
d2l.dprob2prob2 = PhiA^2 *(1/p11+1/p10) + onemPhiA^2 *(1/p01+1/p00)
@@ -726,7 +790,7 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
} else {
run.varcov = 0
ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
- for(ii in 1:( .nsimEIM )) {
+ for (ii in 1:( .nsimEIM )) {
ysim = rbinom2.rho(n=n, mu1=pmargin[,1], mu2=pmargin[,2],
twoCols=FALSE, rho=rhovec)
dl.dprob1 = PhiB * (ysim[,4]/p11-ysim[,2]/p01) +
@@ -739,17 +803,17 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
rm(ysim)
temp3 = cbind(dl.dprob1, dl.dprob2, dl.drho)
run.varcov = ((ii-1) * run.varcov +
- temp3[,ind1$row.index] * temp3[,ind1$col.index]) / ii
+ temp3[,ind1$row.index] * temp3[,ind1$col.index]) / ii
}
wz = if (intercept.only)
matrix(colMeans(run.varcov),
- n, ncol(run.varcov), byrow=TRUE) else run.varcov
+ n, ncol(run.varcov), byrow = TRUE) else run.varcov
wz = wz * dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
}
w * wz
- }), list( .nsimEIM=nsimEIM, .lmu12=lmu12, .emu12=emu12, .lrho=lrho,
- .erho=erho ))))
+ }), list( .nsimEIM = nsimEIM, .lmu12 = lmu12, .emu12 = emu12,
+ .lrho = lrho, .erho = erho ))))
}
@@ -762,7 +826,7 @@ pnorm2 <- function(ah, ak, r) {
ans <- ah
size <- length(ah)
- singler <- ifelse(length(r)==1,1,0)
+ singler <- ifelse(length(r) == 1, 1, 0)
dotC(name="pnorm2", ah=as.double(-ah), ak=as.double(-ak), r=as.double(r),
size=as.integer(size), singler=as.integer(singler),
ans=as.double(ans))$ans
@@ -783,76 +847,77 @@ my.dbinom <- function(x,
-size.binomial <- function(prob=0.5, link="loge", earg=list())
+ size.binomial <- function(prob = 0.5, link = "loge", earg = list())
{
- if (any(prob<=0 || prob>=1))
+ if (any(prob <= 0 || prob >= 1))
stop("some values of prob out of range")
if (!missing(link)) link <- as.character(substitute(link))
if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Binomial with n unknown, prob known (prob=",prob,")\n",
- "Links: ",
- namesof("size", link, tag=TRUE),
- " (treated as real-valued)\n",
- "Variance: Var(Y) = size * prob * (1-prob);",
- " Var(size) is intractable"),
- initialize=eval(substitute(expression({
+ blurb = c("Binomial with n unknown, prob known (prob=",prob,")\n",
+ "Links: ",
+ namesof("size", link, tag=TRUE),
+ " (treated as real-valued)\n",
+ "Variance: Var(Y) = size * prob * (1-prob);",
+ " Var(size) is intractable"),
+ initialize = eval(substitute(expression({
predictors.names <- "size"
extra$temp2 <- rep( .prob , length=n)
if (is.null(etastart)) {
nvec <- (y+0.1)/extra$temp2
etastart <- theta2eta(nvec, .link)
}
- }), list( .prob =prob, .link=link ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
+ }), list( .prob = prob, .link = link ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
nvec <- eta2theta(eta, .link)
- nvec*extra$temp2
- }, list( .link=link ))),
- last=eval(substitute(expression({
+ nvec * extra$temp2
+ }, list( .link = link ))),
+ last = eval(substitute(expression({
misc$link <- c(size = .link)
misc$prob <- extra$temp2
- }), list( .link=link ))),
- link=eval(substitute(function(mu, extra=NULL) {
- nvec <- mu/extra$temp2
+ }), list( .link = link ))),
+ link = eval(substitute(function(mu, extra = NULL) {
+ nvec <- mu / extra$temp2
theta2eta(nvec, .link)
- }, list( .link=link ))),
- loglikelihood=eval(substitute(
- function(mu, y, w, res=FALSE,eta, extra=NULL) {
- nvec <- mu/extra$temp2
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ }, list( .link = link ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, res=FALSE,eta, extra = NULL) {
+ nvec <- mu / extra$temp2
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
sum(w * (lgamma(nvec+1) - lgamma(y+1) - lgamma(nvec-y+1) +
y * log(.prob / (1- .prob)) + nvec * log1p(- .prob)))
}
- }, list( .prob=prob ))),
- vfamily=c("size.binomial"),
- deriv=eval(substitute(expression({
+ }, list( .prob = prob ))),
+ vfamily = c("size.binomial"),
+ deriv = eval(substitute(expression({
nvec <- mu/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 ))),
- weight=eval(substitute(expression({
+ }), list( .link = link ))),
+ weight = eval(substitute(expression({
d2ldnvec2 <- trigamma(nvec+1) - trigamma(nvec-y+1)
- # Note: if y==0 then d2ldnvec2 is 0. Below is a quick fix.
- d2ldnvec2[y==0] = -sqrt(.Machine$double.eps)
+ # Note: if y == 0 then d2ldnvec2 is 0. Below is a quick fix.
+ d2ldnvec2[y == 0] = -sqrt(.Machine$double.eps)
wz = -w * dnvecdeta^2 * d2ldnvec2
wz
- }), list( .link=link ))))
+ }), list( .link = link ))))
}
-dbetabin.ab = function(x, size, shape1, shape2, log = FALSE) {
+ dbetabin.ab = function(x, size, shape1, shape2, log = FALSE) {
log.arg = log
rm(log)
- if (!is.Numeric(x)) stop("bad input for argument 'x'")
- if (!is.Numeric(size, posit=TRUE, integer=TRUE))
- stop("bad input for argument 'size'")
- if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+ if (!is.Numeric(x)) stop("bad input for argument 'x'")
+ if (!is.Numeric(size, posit=TRUE, integer=TRUE))
+ stop("bad input for argument 'size'")
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
LLL = max(length(x), length(size), length(shape1), length(shape2))
if (length(x) != LLL) x = rep(x, len=LLL)
@@ -861,7 +926,7 @@ dbetabin.ab = function(x, size, shape1, shape2, log = FALSE) {
if (length(shape2) != LLL) shape2 = rep(shape2, len=LLL)
answer = 0 * x
- ok <- (round(x) == x) & (x >= 0) & (x <= size)
+ ok = (round(x) == x) & (x >= 0) & (x <= size)
answer[ok] = lchoose(size[ok], x[ok]) +
lbeta(shape1[ok]+x[ok], shape2[ok]+size[ok]-x[ok]) -
lbeta(shape1[ok], shape2[ok])
@@ -874,47 +939,47 @@ dbetabin.ab = function(x, size, shape1, shape2, log = FALSE) {
}
-pbetabin.ab = function(q, size, shape1, shape2, log.p=FALSE) {
- if (!is.Numeric(q)) stop("bad input for argument 'q'")
- if (!is.Numeric(size, posit=TRUE, integer=TRUE))
- stop("bad input for argument 'size'")
- if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
- LLL = max(length(q), length(size), length(shape1), length(shape2))
-
- if (length(q) != LLL) q = rep(q, len=LLL)
- if (length(shape1) != LLL) shape1 = rep(shape1, len=LLL)
- if (length(shape1) != LLL) shape2 = rep(shape2, len=LLL)
- if (length(size) != LLL) size = rep(size, len=LLL);
-
- ans = q * 0 # Retains names(q)
- if (max(abs(size-size[1])) < 1.0e-08 &&
- max(abs(shape1-shape1[1])) < 1.0e-08 &&
- max(abs(shape2-shape2[1])) < 1.0e-08) {
- qstar = floor(q)
- temp = if (max(qstar) >= 0) dbetabin.ab(0:max(qstar),
- size=size[1], shape1=shape1[1], shape2=shape2[1]) else 0*qstar
- unq = unique(qstar)
- for(ii in unq) {
- index = qstar == ii
- ans[index] = if (ii >= 0) sum(temp[1:(1+ii)]) else 0
- }
- } else
- for(ii in 1:LLL) {
- qstar = floor(q[ii])
- ans[ii] = if (qstar >= 0) sum(dbetabin.ab(x=0:qstar, size=size[ii],
- shape1=shape1[ii], shape2=shape2[ii])) else 0
- }
- if (log.p) log(ans) else ans
+ pbetabin.ab = function(q, size, shape1, shape2, log.p=FALSE) {
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(size, posit=TRUE, integer=TRUE))
+ stop("bad input for argument 'size'")
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+ LLL = max(length(q), length(size), length(shape1), length(shape2))
+
+ if (length(q) != LLL) q = rep(q, len=LLL)
+ if (length(shape1) != LLL) shape1 = rep(shape1, len=LLL)
+ if (length(shape1) != LLL) shape2 = rep(shape2, len=LLL)
+ if (length(size) != LLL) size = rep(size, len=LLL);
+
+ ans = q * 0 # Retains names(q)
+ if (max(abs(size - size[1])) < 1.0e-08 &&
+ max(abs(shape1-shape1[1])) < 1.0e-08 &&
+ max(abs(shape2-shape2[1])) < 1.0e-08) {
+ qstar = floor(q)
+ temp = if (max(qstar) >= 0) dbetabin.ab(0:max(qstar),
+ size=size[1], shape1=shape1[1], shape2=shape2[1]) else 0*qstar
+ unq = unique(qstar)
+ for (ii in unq) {
+ index = qstar == ii
+ ans[index] = if (ii >= 0) sum(temp[1:(1+ii)]) else 0
+ }
+ } else
+ for (ii in 1:LLL) {
+ qstar = floor(q[ii])
+ ans[ii] = if (qstar >= 0) sum(dbetabin.ab(x=0:qstar, size=size[ii],
+ shape1=shape1[ii], shape2=shape2[ii])) else 0
+ }
+ if (log.p) log(ans) else ans
}
-rbetabin.ab = function(n, size, shape1, shape2) {
- if (!is.Numeric(size, posit=TRUE, integer=TRUE))
- stop("bad input for argument 'size'")
- if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+ rbetabin.ab = function(n, size, shape1, shape2) {
+ if (!is.Numeric(size, posit=TRUE, integer=TRUE))
+ stop("bad input for argument 'size'")
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
use.n = if ((length.n <- length(n)) > 1) length.n else
if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
@@ -926,17 +991,17 @@ rbetabin.ab = function(n, size, shape1, shape2) {
}
-dbetabin = function(x, size, prob, rho, log = FALSE) {
+ dbetabin = function(x, size, prob, rho, log = FALSE) {
dbetabin.ab(x=x, size=size, shape1=prob*(1-rho)/rho,
shape2=(1-prob)*(1-rho)/rho, log=log)
}
-pbetabin = function(q, size, prob, rho, log.p = FALSE) {
+ pbetabin = function(q, size, prob, rho, log.p = FALSE) {
pbetabin.ab(q=q, size=size, shape1=prob*(1-rho)/rho,
shape2=(1-prob)*(1-rho)/rho, log.p=log.p)
}
-rbetabin = function(n, size, prob, rho) {
+ rbetabin = function(n, size, prob, rho) {
rbetabin.ab(n=n, size=size, shape1=prob*(1-rho)/rho,
shape2=(1-prob)*(1-rho)/rho)
}
@@ -947,7 +1012,7 @@ rbetabin = function(n, size, prob, rho) {
NN = length(nvec)
ans = rep(0.0, len=NN)
if (first) {
- for(ii in 1:NN) {
+ for (ii in 1:NN) {
temp639 = lbeta(shape1[ii], shape2[ii])
yy = 0:nvec[ii]
ans[ii] = ans[ii] + sum(trigamma(shape1[ii]+yy) *
@@ -955,7 +1020,7 @@ rbetabin = function(n, size, prob, rho) {
lbeta(shape1[ii]+yy, shape2[ii]+nvec[ii]-yy) - temp639))
}
} else {
- for(ii in 1:NN) {
+ for (ii in 1:NN) {
temp639 = lbeta(shape1[ii], shape2[ii])
yy = 0:nvec[ii]
ans[ii] = ans[ii] + sum(trigamma(nvec[ii]+shape2[ii]-yy) *
@@ -974,9 +1039,11 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
}
- betabin.ab = function(lshape12="loge", earg = list(),
- i1=1, i2=NULL, method.init=1,
- shrinkage.init=0.95, nsimEIM=NULL, zero=NULL) {
+
+
+ betabin.ab = function(lshape12 = "loge", earg = list(),
+ i1 = 1, i2 = NULL, method.init = 1,
+ shrinkage.init = 0.95, nsimEIM = NULL, zero = NULL) {
if (mode(lshape12) != "character" && mode(lshape12) != "name")
lshape12 = as.character(substitute(lshape12))
if (!is.Numeric(i1, positive=TRUE)) stop("bad input for argument 'i1'")
@@ -994,28 +1061,33 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
stop("argument 'method.init' must be 1, 2 or 3")
new("vglmff",
- blurb=c("Beta-binomial model\n",
- "Links: ",
- namesof("shape1", lshape12, earg= earg), ", ",
- namesof("shape2", lshape12, earg= earg), "\n",
- "Mean: mu = shape1/(shape1+shape2)", "\n",
- "Variance: mu*(1-mu)(1+(w-1)*rho)/w, where rho = 1/(shape1+shape2+1)"),
- constraints=eval(substitute(expression({
+ blurb = c("Beta-binomial model\n",
+ "Links: ",
+ namesof("shape1", lshape12, earg = earg), ", ",
+ namesof("shape2", lshape12, earg = earg), "\n",
+ "Mean: mu = shape1 / (shape1+shape2)", "\n",
+ "Variance: mu * (1-mu) * (1+(w-1)*rho) / w, ",
+ "where rho = 1 / (shape1+shape2+1)"),
+ constraints = eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ if (!all(w == 1))
+ extra$orig.w = w
+
if (is.null( .nsimEIM)) {
save.weight <- control$save.weight <- FALSE
}
# Compute initial values for mustart -------
eval(binomialff()@initialize) # Note: n,w,y,mustart is changed
- predictors.names=c(namesof("shape1", .lshape12, earg= .earg, tag=FALSE),
- namesof("shape2", .lshape12, earg= .earg, tag=FALSE))
+ predictors.names =
+ c(namesof("shape1", .lshape12, earg = .earg, tag=FALSE),
+ namesof("shape2", .lshape12, earg = .earg, tag=FALSE))
if (!length(etastart)) {
- shape1 = rep( .i1, len=n)
- shape2 = if (length( .i2)) rep( .i2,len=n) else {
+ shape1 = rep( .i1, len = n)
+ shape2 = if (length( .i2 )) rep( .i2, len = n) else {
if ( .method.init == 1) {
shape1 * (1 / weighted.mean(y, w) - 1)
} else if ( .method.init == 2) {
@@ -1025,84 +1097,96 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
shape1 * (1 / weighted.mean(mustart, w) - 1)
}
}
- ycounts = y * w # Convert proportions to counts
- if (max(abs(ycounts-round(ycounts))) > 1.0e-6)
- warning("the response (as counts) does not appear to be integer-valued. ",
- "Am rounding to integer values.")
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ if (max(abs(ycounts - round(ycounts))) > 1.0e-6)
+ warning("the response (as counts) does not appear to ",
+ "be integer-valued. Am rounding to integer values.")
ycounts = round(ycounts) # Make sure it is an integer
- etastart = cbind(theta2eta(shape1, .lshape12, earg= .earg),
- theta2eta(shape2, .lshape12, earg= .earg))
+ etastart = cbind(theta2eta(shape1, .lshape12, earg = .earg),
+ theta2eta(shape2, .lshape12, earg = .earg))
}
- }), list( .lshape12=lshape12, .earg=earg, .i1=i1, .i2=i2, .nsimEIM=nsimEIM,
- .method.init=method.init, .sinit=shrinkage.init ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- shape1 = eta2theta(eta[,1], .lshape12, earg= .earg)
- shape2 = eta2theta(eta[,2], .lshape12, earg= .earg)
+ }), list( .lshape12 = lshape12, .earg = earg, .i1 = i1, .i2 = i2,
+ .nsimEIM = nsimEIM,
+ .method.init = method.init, .sinit = shrinkage.init ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ shape1 = eta2theta(eta[,1], .lshape12, earg = .earg)
+ shape2 = eta2theta(eta[,2], .lshape12, earg = .earg)
shape1 / (shape1 + shape2)
- }, list( .lshape12=lshape12, .earg=earg ))),
- last=eval(substitute(expression({
+ }, list( .lshape12 = lshape12, .earg = earg ))),
+ last = eval(substitute(expression({
misc$link = c("shape1" = .lshape12, "shape2" = .lshape12)
misc$earg <- list(shape1 = .earg, shape2 = .earg)
- shape1 = eta2theta(eta[,1], .lshape12, earg= .earg)
- shape2 = eta2theta(eta[,2], .lshape12, earg= .earg)
+ shape1 = eta2theta(eta[,1], .lshape12, earg = .earg)
+ shape2 = eta2theta(eta[,2], .lshape12, earg = .earg)
misc$rho = 1 / (shape1 + shape2 + 1)
misc$expected = TRUE
misc$nsimEIM = .nsimEIM
- }), list( .lshape12=lshape12, .earg=earg, .nsimEIM=nsimEIM ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals=FALSE,eta, extra=NULL) {
- ycounts = y * w # Convert proportions to counts
+ }), list( .lshape12 = lshape12, .earg = earg, .nsimEIM = nsimEIM ))),
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals=FALSE,eta, extra = NULL) {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
smallno = 1.0e4 * .Machine$double.eps
- if (max(abs(ycounts - round(y * w))) > smallno)
+ if (max(abs(ycounts - round(ycounts))) > smallno)
warning("converting 'ycounts' to integer in @loglikelihood")
ycounts = round(ycounts)
- shape1 = eta2theta(eta[,1], .lshape12, earg= .earg)
- shape2 = eta2theta(eta[,2], .lshape12, earg= .earg)
- nvec = w
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dbetabin.ab(x=ycounts, size=nvec, shape1=shape1,
- shape2=shape2, log=TRUE))
+ shape1 = eta2theta(eta[,1], .lshape12, earg = .earg)
+ shape2 = eta2theta(eta[,2], .lshape12, earg = .earg)
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dbetabin.ab(x = ycounts, size = nvec, shape1 = shape1,
+ shape2 = shape2, log = TRUE ))
}
- }, list( .lshape12=lshape12, .earg=earg ))),
- vfamily=c("betabin.ab"),
- deriv=eval(substitute(expression({
- nvec = w # extra$nvec # for summary()
- ycounts = y * w # Convert proportions to counts
- shape1 = eta2theta(eta[,1], .lshape12, earg= .earg)
- shape2 = eta2theta(eta[,2], .lshape12, earg= .earg)
- dshape1.deta = dtheta.deta(shape1, .lshape12, earg= .earg)
- dshape2.deta = dtheta.deta(shape2, .lshape12, earg= .earg)
+ }, list( .lshape12 = lshape12, .earg = earg ))),
+ vfamily = c("betabin.ab"),
+ deriv = eval(substitute(expression({
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ shape1 = eta2theta(eta[,1], .lshape12, earg = .earg)
+ shape2 = eta2theta(eta[,2], .lshape12, earg = .earg)
+ dshape1.deta = dtheta.deta(shape1, .lshape12, earg = .earg)
+ dshape2.deta = dtheta.deta(shape2, .lshape12, earg = .earg)
dl.dshape1 = digamma(shape1+ycounts) - digamma(shape1+shape2+nvec) -
digamma(shape1) + digamma(shape1+shape2)
- dl.dshape2 = digamma(nvec+shape2-ycounts) -
- digamma(shape1+shape2+nvec) -
- digamma(shape2) + digamma(shape1+shape2)
+ dl.dshape2 = digamma(nvec + shape2 - ycounts) -
+ digamma(shape1 + shape2 + nvec) -
+ digamma(shape2) + digamma(shape1 + shape2)
+ (if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
cbind(dl.dshape1 * dshape1.deta, dl.dshape2 * dshape2.deta)
- }), list( .lshape12=lshape12, .earg=earg ))),
- weight=eval(substitute(expression({
+ }), list( .lshape12 = lshape12, .earg = earg ))),
+ weight = eval(substitute(expression({
if (is.null( .nsimEIM)) {
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(2)
- wz[,iam(1,1,M)] = -(expected.betabin.ab(nvec,shape1,shape2, TRUE) -
+ wz[,iam(1,1,M)] = -(expected.betabin.ab(nvec,shape1,shape2,
+ TRUE) -
trigamma(shape1+shape2+nvec) -
trigamma(shape1) + trigamma(shape1+shape2)) *
dshape1.deta^2
- wz[,iam(2,2,M)] = -(expected.betabin.ab(nvec,shape1,shape2, FALSE)-
+ wz[,iam(2,2,M)] = -(expected.betabin.ab(nvec,shape1,shape2,
+ FALSE) -
trigamma(shape1+shape2+nvec) -
trigamma(shape2) + trigamma(shape1+shape2)) *
dshape2.deta^2
wz[,iam(2,1,M)] = -(trigamma(shape1+shape2) -
trigamma(shape1+shape2+nvec)) *
dshape1.deta * dshape2.deta
- wz
+ wz * (if (is.numeric(extra$orig.w)) extra$orig.w else 1)
} else {
run.varcov = 0
ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
dthetas.detas = cbind(dshape1.deta, dshape2.deta)
- for(ii in 1:( .nsimEIM )) {
- ysim = rbetabin.ab(n=n, size=nvec, shape1=shape1, shape2=shape2)
+ for (ii in 1:( .nsimEIM )) {
+ ysim = rbetabin.ab(n=n, size=nvec, shape1=shape1,
+ shape2=shape2)
dl.dshape1 = digamma(shape1+ysim) -
digamma(shape1+shape2+nvec) -
digamma(shape1) + digamma(shape1+shape2)
@@ -1112,16 +1196,16 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
rm(ysim)
temp3 = cbind(dl.dshape1, dl.dshape2) # n x M matrix
run.varcov = ((ii-1) * run.varcov +
- temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
+ temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
wz = if (intercept.only)
matrix(colMeans(run.varcov),
- n, ncol(run.varcov), byrow=TRUE) else run.varcov
+ n, ncol(run.varcov), byrow = TRUE) else run.varcov
wz = wz * dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
- wz
+ wz * (if (is.numeric(extra$orig.w)) extra$orig.w else 1)
}
- }), list( .lshape12=lshape12, .earg=earg, .nsimEIM=nsimEIM ))))
+ }), list( .lshape12 = lshape12, .earg = earg, .nsimEIM = nsimEIM ))))
}
@@ -1129,7 +1213,7 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
betageometric = function(lprob="logit", lshape="loge",
eprob=list(), eshape=list(),
iprob = NULL, ishape = 0.1,
- moreSummation=c(2,100), tolerance=1.0e-10, zero=NULL)
+ moreSummation=c(2,100), tolerance=1.0e-10, zero = NULL)
{
if (mode(lprob) != "character" && mode(lprob) != "name")
lprob = as.character(substitute(lprob))
@@ -1139,40 +1223,42 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
stop("bad input for argument 'ishape'")
if (!is.Numeric(moreSummation, positive=TRUE, allow=2, integ=TRUE))
stop("bad input for argument 'moreSummation'")
- if (!is.Numeric(tolerance, positive=TRUE, allow=1) || 1.0-tolerance >= 1.0)
+ if (!is.Numeric(tolerance, positive=TRUE, allow=1) ||
+ 1.0-tolerance >= 1.0)
stop("bad input for argument 'tolerance'")
if (!is.list(eprob)) eprob = list()
if (!is.list(eshape)) eshape = list()
new("vglmff",
- blurb=c("Beta-geometric distribution\n",
- "Links: ", namesof("prob", lprob, earg= eprob), ", ",
- namesof("shape", lshape, earg= eshape)),
- constraints=eval(substitute(expression({
+ blurb = c("Beta-geometric distribution\n",
+ "Links: ", namesof("prob", lprob, earg = eprob), ", ",
+ namesof("shape", lshape, earg = eshape)),
+ constraints = eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
eval(geometric()@initialize)
- predictors.names = c(namesof("prob", .lprob, earg= .eprob, tag=FALSE),
- namesof("shape", .lshape, earg= .eshape, short=FALSE))
+ predictors.names =
+ c(namesof("prob", .lprob, earg = .eprob, tag=FALSE),
+ namesof("shape", .lshape, earg = .eshape, short=FALSE))
if (length( .iprob))
prob.init = rep( .iprob, len=n)
if (!length(etastart) || ncol(cbind(etastart)) != 2) {
shape.init = rep( .ishape, len=n)
- etastart = cbind(theta2eta(prob.init, .lprob, earg= .eprob),
- theta2eta(shape.init, .lshape, earg= .eshape))
+ etastart = cbind(theta2eta(prob.init, .lprob, earg = .eprob),
+ theta2eta(shape.init, .lshape, earg = .eshape))
}
- }), list( .iprob=iprob, .ishape=ishape, .lprob=lprob,
- .eprob=eprob, .eshape=eshape,
- .lshape=lshape ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- prob = eta2theta(eta[,1], .lprob, earg= .eprob)
- shape = eta2theta(eta[,2], .lshape, earg= .eshape)
+ }), list( .iprob=iprob, .ishape=ishape, .lprob = lprob,
+ .eprob = eprob, .eshape = eshape,
+ .lshape = lshape ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ prob = eta2theta(eta[,1], .lprob, earg = .eprob)
+ shape = eta2theta(eta[,2], .lshape, earg = .eshape)
mymu = (1-prob) / (prob - shape)
ifelse(mymu >= 0, mymu, NA)
- }, list( .lprob=lprob, .lshape=lshape,
- .eprob=eprob, .eshape=eshape ))),
- last=eval(substitute(expression({
+ }, list( .lprob = lprob, .lshape = lshape,
+ .eprob = eprob, .eshape = eshape ))),
+ last = eval(substitute(expression({
misc$link = c("prob" = .lprob, "shape" = .lshape)
misc$earg <- list(prob = .eprob, shape = .eshape)
if (intercept.only) {
@@ -1183,20 +1269,21 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
misc$tolerance = .tolerance
misc$zero = .zero
misc$moreSummation = .moreSummation
- }), list( .lprob=lprob, .lshape=lshape, .tolerance=tolerance,
- .eprob=eprob, .eshape=eshape,
- .moreSummation=moreSummation, .zero=zero ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals=FALSE,eta, extra=NULL) {
- prob = eta2theta(eta[,1], .lprob, earg= .eprob)
- shape = eta2theta(eta[,2], .lshape, earg= .eshape)
+ }), list( .lprob = lprob, .lshape = lshape, .tolerance = tolerance,
+ .eprob = eprob, .eshape = eshape,
+ .moreSummation = moreSummation, .zero = zero ))),
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals=FALSE,eta, extra = NULL) {
+ prob = eta2theta(eta[,1], .lprob, earg = .eprob)
+ shape = eta2theta(eta[,2], .lshape, earg = .eshape)
ans = log(prob)
maxy = max(y)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- for(ii in 1:maxy) {
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+ for (ii in 1:maxy) {
index = ii <= y
- ans[index]=ans[index] + log1p(-prob[index]+(ii-1)*shape[index])-
- log1p((ii-1)*shape[index])
+ ans[index] = ans[index] + log1p(-prob[index]+(ii-1) *
+ shape[index]) - log1p((ii-1)*shape[index])
}
ans = ans - log1p((y+1-1)*shape)
@@ -1205,19 +1292,19 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
sum(w * ans)
}
- }, list( .lprob=lprob, .lshape=lshape,
- .eprob=eprob, .eshape=eshape ))),
- vfamily=c("betageometric"),
- deriv=eval(substitute(expression({
- prob = eta2theta(eta[,1], .lprob, earg= .eprob)
- shape = eta2theta(eta[,2], .lshape, earg= .eshape)
+ }, list( .lprob = lprob, .lshape = lshape,
+ .eprob = eprob, .eshape = eshape ))),
+ vfamily = c("betageometric"),
+ deriv = eval(substitute(expression({
+ prob = eta2theta(eta[,1], .lprob, earg = .eprob)
+ shape = eta2theta(eta[,2], .lshape, earg = .eshape)
shape1 = prob / shape; shape2 = (1-prob) / shape;
- dprob.deta = dtheta.deta(prob, .lprob, earg= .eprob)
- dshape.deta = dtheta.deta(shape, .lshape, earg= .eshape)
+ dprob.deta = dtheta.deta(prob, .lprob, earg = .eprob)
+ dshape.deta = dtheta.deta(shape, .lshape, earg = .eshape)
dl.dprob = 1 / prob
dl.dshape = 0 * y
maxy = max(y)
- for(ii in 1:maxy) {
+ for (ii in 1:maxy) {
index = ii <= y
dl.dprob[index] = dl.dprob[index] -
1/(1-prob[index]+(ii-1)*shape[index])
@@ -1227,14 +1314,14 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
}
dl.dshape = dl.dshape - (y+1 -1)/(1+(y+1 -1)*shape)
w * cbind(dl.dprob * dprob.deta, dl.dshape * dshape.deta)
- }), list( .lprob=lprob, .lshape=lshape,
- .eprob=eprob, .eshape=eshape ))),
- weight=eval(substitute(expression({
+ }), list( .lprob = lprob, .lshape = lshape,
+ .eprob = eprob, .eshape = eshape ))),
+ weight = eval(substitute(expression({
wz = matrix(0, n, dimm(M)) #3=dimm(2)
wz[,iam(1,1,M)] = 1 / prob^2
moresum = .moreSummation
maxsummation = round(maxy * moresum[1] + moresum[2])
- for(ii in 3:maxsummation) {
+ for (ii in 3:maxsummation) {
temp7 = 1 - pbetageom(q=ii-1-1, shape1=shape1, shape2=shape2)
denom1 = (1-prob+(ii-2)*shape)^2
denom2 = (1+(ii-2)*shape)^2
@@ -1254,9 +1341,9 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] * dshape.deta^2
wz[,iam(2,1,M)] = wz[,iam(2,1,M)] * dprob.deta * dshape.deta
w * wz
- }), list( .lprob=lprob, .lshape=lshape, .moreSummation=moreSummation,
- .eprob=eprob, .eshape=eshape,
- .tolerance=tolerance ))))
+ }), list( .lprob = lprob, .lshape = lshape, .moreSummation = moreSummation,
+ .eprob = eprob, .eshape = eshape,
+ .tolerance = tolerance ))))
}
@@ -1265,7 +1352,7 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
seq2binomial = function(lprob1="logit", lprob2="logit",
eprob1=list(), eprob2=list(),
iprob1 = NULL, iprob2 = NULL,
- zero=NULL)
+ zero = NULL)
{
if (mode(lprob1) != "character" && mode(lprob1) != "name")
lprob1 = as.character(substitute(lprob1))
@@ -1281,105 +1368,111 @@ seq2binomial = function(lprob1="logit", lprob2="logit",
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({
+ 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({
+ }), 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 (any(abs(w - round(w)) > 0.000001))
+ stop("the 'weights' argument does not seem to be integer-valued")
if (ncol(y <- cbind(y)) != 2)
stop("the response must be a 2-column matrix")
if (any(y < 0 | y > 1))
stop("the response must have values between 0 and 1")
+
+ w = round(w)
rvector = w * y[,1]
if (any(abs(rvector - round(rvector)) > 1.0e-8))
- warning("number of successes in column one should be integer-valued")
+ 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))
+ 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))
+ 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)
+ }), list( .iprob1 = iprob1, .iprob2 = iprob2,
+ .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2 ))),
+ 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({
+ }, 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)
+ }), list( .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2,
+ .zero = zero ))),
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals=FALSE,eta, extra = NULL) {
+ prob1 = eta2theta(eta[,1], .lprob1, earg = .eprob1)
+ prob2 = eta2theta(eta[,2], .lprob2, earg = .eprob2)
smallno = 100 * .Machine$double.eps
prob1 = pmax(prob1, smallno)
prob1 = pmin(prob1, 1-smallno)
prob2 = pmax(prob2, smallno)
prob2 = pmin(prob2, 1-smallno)
+ mvector = w
rvector = w * y[,1]
svector = rvector * y[,2]
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(rvector * log(prob1) + (mvector-rvector)*log1p(-prob1) +
- svector * log(prob2) + (rvector-svector)*log1p(-prob2))
+ 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)
+ }, 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)
+ dprob1.deta = dtheta.deta(prob1, .lprob1, earg = .eprob1)
+ dprob2.deta = dtheta.deta(prob2, .lprob2, earg = .eprob2)
+ mvector = w
rvector = w * y[,1]
svector = rvector * y[,2]
dl.dprob1 = rvector / prob1 - (mvector-rvector) / (1-prob1)
dl.dprob2 = svector / prob2 - (rvector-svector) / (1-prob2)
cbind(dl.dprob1 * dprob1.deta, dl.dprob2 * dprob2.deta)
- }), list( .lprob1=lprob1, .lprob2=lprob2,
- .eprob1=eprob1, .eprob2=eprob2 ))),
- weight=eval(substitute(expression({
+ }), 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 ))))
+ }), list( .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2 ))))
}
-zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
- emu12=list(), ephi12=list(), eoratio=list(),
- imu12=NULL, iphi12=NULL, ioratio = NULL,
- zero=2:3, tol=0.001,
- addRidge=0.001)
+zipebcom = function(lmu12 = "cloglog", lphi12 = "logit", loratio = "loge",
+ emu12 = list(), ephi12 = list(), eoratio = list(),
+ imu12 = NULL, iphi12 = NULL, ioratio = NULL,
+ zero = 2:3, tol = 0.001, addRidge = 0.001)
{
if (mode(lphi12) != "character" && mode(lphi12) != "name")
@@ -1397,27 +1490,28 @@ zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
warning("argument 'lmu12' should be 'cloglog'")
new("vglmff",
- blurb=c("Exchangeable bivariate ", lmu12, " odds-ratio model based on\n",
- "a zero-inflated Poisson distribution\n\n",
- "Links: ",
- namesof("mu12", lmu12, earg=emu12), ", ",
- namesof("phi12", lphi12, earg=ephi12), ", ",
- namesof("oratio", loratio, earg=eoratio)),
- constraints=eval(substitute(expression({
+ blurb = c("Exchangeable bivariate ", lmu12,
+ " odds-ratio model based on\n",
+ "a zero-inflated Poisson distribution\n\n",
+ "Links: ",
+ namesof("mu12", lmu12, earg = emu12), ", ",
+ namesof("phi12", lphi12, earg = ephi12), ", ",
+ namesof("oratio", loratio, earg = eoratio)),
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
eval(process.binomial2.data.vgam)
predictors.names = c(
- namesof("mu12", .lmu12, earg= .emu12, short=TRUE),
- namesof("phi12", .lphi12, earg= .ephi12, short=TRUE),
- namesof("oratio", .loratio, earg= .eoratio, short=TRUE))
+ namesof("mu12", .lmu12, earg = .emu12, short=TRUE),
+ namesof("phi12", .lphi12, earg = .ephi12, short=TRUE),
+ namesof("oratio", .loratio, earg = .eoratio, short=TRUE))
propY1.eq.0 = weighted.mean(y[,'00'], w) + weighted.mean(y[,'01'], w)
propY2.eq.0 = weighted.mean(y[,'00'], w) + weighted.mean(y[,'10'], w)
- if (length( .iphi12) && any(.iphi12 > propY1.eq.0))
+ if (length( .iphi12) && any( .iphi12 > propY1.eq.0))
warning("iphi12 must be less than the sample proportion of Y1==0")
- if (length( .iphi12) && any(.iphi12 > propY2.eq.0))
+ if (length( .iphi12) && any( .iphi12 > propY2.eq.0))
warning("iphi12 must be less than the sample proportion of Y2==0")
if (!length(etastart)) {
@@ -1429,18 +1523,18 @@ zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
mu12.init = if (length(.imu12)) rep(.imu12, len=n) else
pstar.init / (1-phi.init)
etastart = cbind(
- theta2eta(mu12.init, .lmu12, earg= .emu12),
- theta2eta(phi.init, .lphi12, earg= .ephi12),
- theta2eta(oratio.init, .loratio, earg= .eoratio))
+ theta2eta(mu12.init, .lmu12, earg = .emu12),
+ theta2eta(phi.init, .lphi12, earg = .ephi12),
+ theta2eta(oratio.init, .loratio, earg = .eoratio))
}
- }), list( .lmu12=lmu12, .lphi12=lphi12, .loratio=loratio,
- .emu12=emu12, .ephi12=ephi12, .eoratio=eoratio,
- .imu12=imu12, .iphi12=iphi12, .ioratio=ioratio ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- A1vec = eta2theta(eta[,1], .lmu12, earg= .emu12)
- phivec = eta2theta(eta[,2], .lphi12, earg= .ephi12)
+ }), list( .lmu12 = lmu12, .lphi12 = lphi12, .loratio = loratio,
+ .emu12 = emu12, .ephi12 = ephi12, .eoratio = eoratio,
+ .imu12 = imu12, .iphi12 = iphi12, .ioratio = ioratio ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ A1vec = eta2theta(eta[,1], .lmu12, earg = .emu12)
+ phivec = eta2theta(eta[,2], .lphi12, earg = .ephi12)
pmargin = matrix((1 - phivec) * A1vec, nrow(eta), 2)
- oratio = eta2theta(eta[,3], .loratio, earg= .eoratio)
+ oratio = eta2theta(eta[,3], .loratio, earg = .eoratio)
a.temp = 1 + (pmargin[,1]+pmargin[,2])*(oratio-1)
b.temp = -4 * oratio * (oratio-1) * pmargin[,1] * pmargin[,2]
temp = sqrt(a.temp^2 + b.temp)
@@ -1449,31 +1543,45 @@ zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
pj2 = pmargin[,2] - pj4
pj3 = pmargin[,1] - pj4
cbind("00" = 1-pj4-pj2-pj3, "01" = pj2, "10" = pj3, "11" = pj4)
- }, list( .tol=tol,
- .lmu12=lmu12, .lphi12=lphi12, .loratio=loratio,
- .emu12=emu12, .ephi12=ephi12, .eoratio=eoratio ))),
- last=eval(substitute(expression({
+ }, list( .tol = tol,
+ .lmu12 = lmu12, .lphi12 = lphi12, .loratio = loratio,
+ .emu12 = emu12, .ephi12 = ephi12, .eoratio = eoratio ))),
+ last = eval(substitute(expression({
misc$link = c("mu12"= .lmu12, "phi12" = .lphi12, "oratio"= .loratio)
misc$earg = list("mu12"= .emu12, "phi12"= .ephi12, "oratio"= .eoratio)
misc$tol = .tol
misc$expected = TRUE
misc$addRidge = .addRidge
- }), list( .tol=tol, .addRidge = addRidge,
- .lmu12=lmu12, .lphi12=lphi12, .loratio=loratio,
- .emu12=emu12, .ephi12=ephi12, .eoratio=eoratio ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
+ }), list( .tol = tol, .addRidge = addRidge,
+ .lmu12 = lmu12, .lphi12 = lphi12, .loratio = loratio,
+ .emu12 = emu12, .ephi12 = ephi12, .eoratio = eoratio ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
},
- vfamily=c("zipebcom"),
- deriv=eval(substitute(expression({
- A1vec = eta2theta(eta[,1], .lmu12, earg= .emu12)
+ vfamily = c("zipebcom"),
+ deriv = eval(substitute(expression({
+ A1vec = eta2theta(eta[,1], .lmu12, earg = .emu12)
smallno = .Machine$double.eps^(2/4)
A1vec[A1vec > 1.0 -smallno] = 1.0 - smallno
- phivec = eta2theta(eta[,2], .lphi12, earg= .ephi12)
+ phivec = eta2theta(eta[,2], .lphi12, earg = .ephi12)
pmargin = matrix((1 - phivec) * A1vec, n, 2)
- oratio = eta2theta(eta[,3], .loratio, earg= .eoratio)
+ oratio = eta2theta(eta[,3], .loratio, earg = .eoratio)
Vab = 1 / (1/mu[,1] + 1/mu[,2] + 1/mu[,3] + 1/mu[,4])
Vabc = 1/mu[,1] + 1/mu[,2]
@@ -1490,13 +1598,13 @@ zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
dl.dmu1 = dp11star.dp1unstar * yandmu + (1-phivec) * cyandmu
dl.dphi1 = dp11star.dphi1 * yandmu - A1vec * cyandmu
dl.doratio = check.dl.doratio
- dthetas.detas = cbind(dtheta.deta(A1vec, .lmu12, earg= .emu12),
- dtheta.deta(phivec, .lphi12, earg= .ephi12),
- dtheta.deta(oratio, .loratio, earg= .eoratio))
+ dthetas.detas = cbind(dtheta.deta(A1vec, .lmu12, earg = .emu12),
+ dtheta.deta(phivec, .lphi12, earg = .ephi12),
+ dtheta.deta(oratio, .loratio, earg = .eoratio))
w * cbind(dl.dmu1, dl.dphi1, dl.doratio) * dthetas.detas
- }), list( .lmu12=lmu12, .lphi12=lphi12, .loratio=loratio,
- .emu12=emu12, .ephi12=ephi12, .eoratio=eoratio ))),
- weight=eval(substitute(expression({
+ }), list( .lmu12 = lmu12, .lphi12 = lphi12, .loratio = loratio,
+ .emu12 = emu12, .ephi12 = ephi12, .eoratio = eoratio ))),
+ weight = eval(substitute(expression({
wz = matrix(0, n, 4)
alternwz11 = 2*(1-phivec)^2 *(2/mu[,1] + 1/mu[,2] - 2*Vab*Vabc^2) *
(dthetas.detas[,1])^2
@@ -1521,3 +1629,205 @@ zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
+
+
+
+ lusted68 = function(lrhopos = "loge", lrhoneg = "loge",
+ erhopos = list(), erhoneg = list(),
+ irhopos = NULL, irhoneg = NULL,
+ iprob1 = NULL, iprob2 = NULL, zero = NULL)
+{
+ print("hi 20100603")
+ if (mode(lrhopos) != "character" && mode(lrhopos) != "name")
+ lrhopos = as.character(substitute(lrhopos))
+ if (mode(lrhoneg) != "character" && mode(lrhoneg) != "name")
+ lrhoneg = as.character(substitute(lrhoneg))
+ if (!is.list(erhopos)) erhopos = list()
+ if (!is.list(erhoneg)) erhoneg = list()
+
+ new("vglmff",
+ blurb = c("Lusted (1968)'s model\n",
+ "Links: ",
+ namesof("rhopos", lrhopos, earg = erhopos), ", ",
+ namesof("rhoneg", lrhoneg, earg = erhoneg)),
+ initialize = eval(substitute(expression({
+ print("head(y, 3) start")
+ print( head(y, 3) )
+ eval(process.binomial2.data.vgam)
+ print("head(mu, 3)")
+ print( head(mu, 3) )
+ print("head(y, 3) processed")
+ print( head(y, 3) )
+ print("head(w, 3)")
+ print( head(w, 3) )
+
+
+
+
+ predictors.names = c(
+ namesof("rhopos", .lrhopos, earg = .erhopos, short = TRUE),
+ namesof("rhoneg", .lrhoneg, earg = .erhoneg, short = TRUE))
+
+
+ if (!length(etastart)) {
+ nnn1 = round(w * (y[, 1] + y[, 2]))
+ nnn2 = round(w * (y[, 3] + y[, 4]))
+ print("head(nnn1, 3)")
+ print( head(nnn1, 3) )
+ print("head(nnn2, 3)")
+ print( head(nnn2, 3) )
+ init.pee1 = if (length( .iprob1 )) rep( .iprob1, len = n) else
+ mu[, 1] / (mu[, 1] + mu[, 2])
+ init.pee2 = if (length( .iprob2 )) rep( .iprob2, len = n) else
+ mu[, 3] / (mu[, 3] + mu[, 4])
+ init.rhopos = pmax(1.1, init.pee1 / init.pee2) # Should be > 1
+ init.rhoneg = pmin(0.4, (1 - init.pee1) / (1 - init.pee2)) # c. 0
+ print("head(init.rhopos, 3)")
+ print( head(init.rhopos, 3) )
+ print("head(init.rhoneg, 3)")
+ print( head(init.rhoneg, 3) )
+
+ if (length( .irhopos)) init.rhopos = rep( .irhopos, len = n)
+ if (length( .irhoneg)) init.rhoneg = rep( .irhoneg, len = n)
+ etastart = cbind(theta2eta(init.rhopos, .lrhopos, earg = .erhopos),
+ theta2eta(init.rhoneg, .lrhoneg, earg = .erhoneg))
+ print("etastart[1:3,]")
+ print( etastart[1:3,] )
+ }
+ }), list( .lrhopos = lrhopos, .lrhoneg = lrhoneg,
+ .erhopos = erhopos, .erhoneg = erhoneg,
+ .iprob1 = iprob1, .iprob2 = iprob2,
+ .irhopos = irhopos, .irhoneg = irhoneg ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ rhopos = eta2theta(eta[,1], .lrhopos, earg = .erhopos)
+ rhoneg = eta2theta(eta[,2], .lrhoneg, earg = .erhoneg)
+ pee2 = (1 - rhoneg) / (rhopos - rhoneg)
+ pee1 = pee2 * rhopos
+ cbind(rhopos, rhoneg, "mu1" = pee1, "mu2" = pee2)
+ }, list( .lrhopos = lrhopos, .lrhoneg = lrhoneg,
+ .erhopos = erhopos, .erhoneg = erhoneg ))),
+ last = eval(substitute(expression({
+ misc$link = c("rhopos" = .lrhopos, "rhoneg" = .lrhoneg)
+ misc$earg = list("rhopos" = .erhopos, "rhoneg" = .erhoneg)
+ misc$expected = TRUE
+ }), list( .lrhopos = lrhopos, .lrhoneg = lrhoneg,
+ .erhopos = erhopos, .erhoneg = erhoneg,
+ .irhopos = irhopos, .irhoneg = irhoneg ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ rhopos = eta2theta(eta[,1], .lrhopos, earg = .erhopos)
+ rhoneg = eta2theta(eta[,2], .lrhoneg, earg = .erhoneg)
+ pee2 = (1 - rhoneg) / (rhopos - rhoneg)
+ pee1 = pee2 * rhopos
+ if (min(pee1) <= 0.5) {
+ warning("too small pee1 values")
+ pee1[pee1 <= 0.5] = 0.66
+ }
+ if (max(pee1) >= 1) {
+ warning("large pee1 values")
+ pee1[pee1 >= 1] = 0.99
+ }
+ if (min(pee2) <= 0.0) {
+ warning("too small pee2 values")
+ pee2[pee2 <= 0.0] = 0.01
+ }
+ if (max(pee2) >= 0.5) {
+ warning("too large pee2 values")
+ pee2[pee2 >= 0.5] = 0.44
+ }
+
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+ nnn1 = round(w * (y[, 1] + y[, 2]))
+ nnn2 = round(w * (y[, 3] + y[, 4]))
+ index1 = nnn1 > 0
+ index2 = nnn2 > 0
+
+ print("head(round(w[index1] * y[index1, 1]), 18)")
+ print( head(round(w[index1] * y[index1, 1]), 18) )
+ print("head(nnn1[index1], 18)")
+ print( head(nnn1[index1], 18) )
+ print("head(pee1[index1], 18)")
+ print( head(pee1[index1], 18) )
+ print("summary(pee1[index1])")
+ print( summary(pee1[index1]) )
+ print("summary(pee2[index2])")
+ print( summary(pee2[index2]) )
+ print(head(dbinom(round(w[index1] * y[index1, 1]), nnn1[index1],
+ prob = pee1[index1], log = TRUE), 18))
+
+
+ sum(dbinom(round(w[index1] * y[index1, 1]), nnn1[index1],
+ prob = pee1[index1], log = TRUE)) +
+ sum(dbinom(round(w[index2] * y[index2, 3]), nnn2[index2],
+ prob = pee2[index2], log = TRUE))
+ }
+ }, list( .lrhopos = lrhopos, .lrhoneg = lrhoneg,
+ .erhopos = erhopos, .erhoneg = erhoneg,
+ .irhopos = irhopos, .irhoneg = irhoneg ))),
+ vfamily = c("lusted68", "binom2"),
+ deriv = eval(substitute(expression({
+ rhopos = eta2theta(eta[,1], .lrhopos, earg = .erhopos)
+ rhoneg = eta2theta(eta[,2], .lrhoneg, earg = .erhoneg)
+ pee2 = (1 - rhoneg) / (rhopos - rhoneg)
+ pee1 = pee2 * rhopos
+ nnn1 = round(w * (y[, 1] + y[, 3]))
+ nnn2 = round(w * (y[, 2] + y[, 4]))
+
+ print("summary(pee1)")
+ print( summary(pee1) )
+ print("summary(pee2)")
+ print( summary(pee2) )
+ rhodif = rhopos - rhoneg
+ drhopos.deta = dtheta.deta(rhopos, .lrhopos, earg = .erhopos)
+ drhoneg.deta = dtheta.deta(rhoneg, .lrhoneg, earg = .erhoneg)
+
+ dl1.drhopos = y[, 1] / rhopos + y[, 2] / (rhopos - 1) - 1 / rhodif
+ dl1.drhoneg = -y[, 1] / (1 - rhoneg) + y[, 2] / rhoneg + 1 / rhodif
+ dl2.drhopos = y[, 4] / (rhopos - 1) - 1 / rhodif
+ dl2.drhoneg = -y[, 3] / (1 - rhoneg) + 1 / rhodif
+ cbind((nnn1 * dl1.drhopos + nnn2 * dl2.drhopos) * drhopos.deta,
+ (nnn1 * dl1.drhoneg + nnn2 * dl2.drhoneg) * drhoneg.deta)
+ }), list( .lrhopos = lrhopos, .lrhoneg = lrhoneg,
+ .erhopos = erhopos, .erhoneg = erhoneg,
+ .irhopos = irhopos, .irhoneg = irhoneg ))),
+ weight = eval(substitute(expression({
+ wz = matrix(0, n, dimm(M)) # 3 = dimm(2)
+
+
+ wz[, iam(1, 1, M)] = wz[, iam(1, 1, M)] + nnn1 *
+ (pee1 / rhopos^2 + (1 - pee1) / (rhopos - 1)^2 - 1 / rhodif^2)
+
+ wz[, iam(2, 2, M)] = wz[, iam(2, 2, M)] + nnn1 *
+ (pee1 / (1 - rhoneg)^2 + (1 - pee1) / rhoneg^2 - 1 / rhodif^2)
+
+ wz[, iam(1, 2, M)] = wz[, iam(1, 2, M)] + nnn1 / rhodif^2
+
+ wz[, iam(1, 1, M)] = wz[, iam(1, 1, M)] + nnn2 *
+ ((1 - pee2) / (rhopos - 1)^2 - 1 / rhodif^2)
+
+ wz[, iam(2, 2, M)] = wz[, iam(2, 2, M)] + nnn2 *
+ (pee2 / (1 - rhoneg)^2 - 1 / rhodif^2)
+
+ wz[, iam(1, 2, M)] = wz[, iam(1, 2, M)] + nnn2 / rhodif^2
+
+ wz[, iam(1, 1, M)] = wz[, iam(1, 1, M)] * drhopos.deta^2
+ wz[, iam(2, 2, M)] = wz[, iam(2, 2, M)] * drhoneg.deta^2
+ wz[, iam(1, 2, M)] = wz[, iam(1, 2, M)] * drhopos.deta * drhoneg.deta
+
+ print("summary(wz)")
+ print( summary(wz) )
+ print("head(wz)")
+ print( head(wz) )
+
+ wz
+ }), list( .lrhopos = lrhopos, .lrhoneg = lrhoneg,
+ .erhopos = erhopos, .erhoneg = erhoneg,
+ .irhopos = irhopos, .irhoneg = irhoneg ))))
+}
+
+
+
+
+
+
diff --git a/R/family.bivariate.R b/R/family.bivariate.R
index 9c4c35a..4e062d8 100644
--- a/R/family.bivariate.R
+++ b/R/family.bivariate.R
@@ -309,109 +309,157 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
- mckaygamma2 = function(la="loge",
- lp="loge",
- lq="loge",
- ia=NULL,
- ip=1,
- iq=1,
- zero=NULL) {
- if (mode(la) != "character" && mode(la) != "name")
- la = as.character(substitute(la))
- if (mode(lp) != "character" && mode(lp) != "name")
- lp = as.character(substitute(lp))
- if (mode(lq) != "character" && mode(lq) != "name")
- lq = as.character(substitute(lq))
- if (!is.Numeric(ip, positive = TRUE) || !is.Numeric(iq, positive = TRUE))
- stop("initial values for 'ip' and 'iq' must be positive")
- if (is.Numeric(ia) && any(ia <= 0))
- stop("'ia' must be positive or NULL")
+
+
+
+ bivgamma.mckay = function(lscale="loge",
+ lshape1="loge",
+ lshape2="loge",
+ iscale=NULL,
+ ishape1=NULL,
+ ishape2=NULL,
+ method.init=1,
+ zero=1) {
+ if (mode(lscale) != "character" && mode(lscale) != "name")
+ lscale = as.character(substitute(lscale))
+ if (mode(lshape1) != "character" && mode(lshape1) != "name")
+ lshape1 = as.character(substitute(lshape1))
+ if (mode(lshape2) != "character" && mode(lshape2) != "name")
+ lshape2 = as.character(substitute(lshape2))
+ if (!is.null(iscale))
+ if (!is.Numeric(iscale, positive = TRUE))
+ stop("'iscale' must be positive or NULL")
+ if (!is.null(ishape1))
+ if (!is.Numeric(ishape1, positive = TRUE))
+ stop("'ishape1' must be positive or NULL")
+ if (!is.null(ishape2))
+ if (!is.Numeric(ishape2, positive = TRUE))
+ stop("'ishape2' must be positive or NULL")
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
+ method.init > 2.5)
+ stop("argument 'method.init' must be 1 or 2")
new("vglmff",
- blurb=c("McKay's Bivariate Gamma Distribution\n",
+ blurb=c("Bivariate Gamma: McKay's Distribution\n",
"Links: ",
- namesof("a", la), ", ",
- namesof("p", lp), ", ",
- namesof("q", lq)),
+ namesof("scale", lscale), ", ",
+ namesof("shape1", lshape1), ", ",
+ namesof("shape2", lshape2)),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list(.zero=zero))),
+ }), list( .zero=zero ))),
initialize=eval(substitute(expression({
if (!is.matrix(y) || ncol(y) != 2)
- stop("the response must be a 2 column matrix")
- sorty1 = pmin(y[,1], y[,2])
- sorty2 = pmax(y[,1], y[,2])
- if (any(sorty2 - sorty1 <= 0))
- stop("Delete those observations that are identical")
- predictors.names = c(namesof("a", .la, short=TRUE),
- namesof("p", .lp, short=TRUE),
- namesof("q", .lq, short=TRUE))
+ stop("the response must be a 2 column matrix")
+ if (any(y[,1] >= y[,2]))
+ stop("the second column minus the first column must be a vector ",
+ "of positive values")
+ predictors.names = c(namesof("scale", .lscale, short=TRUE),
+ namesof("shape1", .lshape1, short=TRUE),
+ namesof("shape2", .lshape2, short=TRUE))
if (!length(etastart)) {
- pinit = rep(.ip, len=n)
- qinit = rep(.iq, len=n)
- ainit = if (length(.ia)) {
- rep(.ia, len=n)
- } else (pinit+qinit)/(sorty1+0.1)
- etastart = cbind(theta2eta(ainit, .la),
- theta2eta(pinit, .lp),
- theta2eta(qinit, .lq))
+ momentsY = if ( .method.init == 1) {
+ cbind(median(y[,1]), # This may not be monotonic
+ median(y[,2])) + 0.01
+ } else {
+ cbind(weighted.mean(y[,1], w),
+ weighted.mean(y[,2], w))
+ }
+
+ mcg2.loglik = function(thetaval, y, x, w, extraargs) {
+ ainit = a = thetaval
+ momentsY = extraargs$momentsY
+ p = (1/a) * abs(momentsY[1]) + 0.01
+ q = (1/a) * abs(momentsY[2] - momentsY[1]) + 0.01
+ sum(w * (-(p+q)*log(a) - lgamma(p) - lgamma(q) +
+ (p-1)*log(y[,1]) + (q-1)*log(y[,2]-y[,1]) - y[,2] / a ))
+ }
+
+ a.grid = if (length( .iscale )) c( .iscale ) else
+ c(0.01, 0.02, 0.05, 0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50, 100)
+ extraargs = list(momentsY = momentsY)
+ ainit = getMaxMin(a.grid, objfun=mcg2.loglik,
+ y=y, x=x, w=w, maximize=TRUE,
+ extraargs = extraargs)
+ ainit = rep(if(is.Numeric( .iscale )) .iscale else ainit, len=n)
+ pinit = (1/ainit) * abs(momentsY[1]) + 0.01
+ qinit = (1/ainit) * abs(momentsY[2] - momentsY[1]) + 0.01
+
+ pinit = rep(if(is.Numeric( .ishape1 )) .ishape1 else pinit, len=n)
+ qinit = rep(if(is.Numeric( .ishape2 )) .ishape2 else qinit, len=n)
+
+ etastart = cbind(theta2eta(ainit, .lscale),
+ theta2eta(pinit, .lshape1),
+ theta2eta(qinit, .lshape2))
}
- }), list(.la=la, .lp=lp, .lq=lq, .ia=ia, .ip=ip, .iq=iq))),
+ }), list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2,
+ .iscale=iscale, .ishape1=ishape1, .ishape2=ishape2,
+ .method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- a = eta2theta(eta[,1], .la)
- p = eta2theta(eta[,2], .lp)
- q = eta2theta(eta[,3], .lq)
- cbind("pmin(y1,y2)"=(p+q)/a, "pmax(y1,y2)"=NA)
- }, list(.la=la, .lp=lp, .lq=lq))),
+ a = eta2theta(eta[,1], .lscale)
+ p = eta2theta(eta[,2], .lshape1)
+ q = eta2theta(eta[,3], .lshape2)
+ cbind("y1"=p*a, "y2"=(p+q)*a)
+ }, list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2 ))),
last=eval(substitute(expression({
- misc$link = c("a"= .la, "p"= .lp, "q"= .lq)
- }), list(.la=la, .lp=lp, .lq=lq))),
+ misc$link = c("scale"= .lscale, "shape1"= .lshape1, "shape2"= .lshape2)
+ misc$ishape1 = .ishape1
+ misc$ishape2 = .ishape2
+ misc$iscale = .iscale
+ misc$expected = TRUE
+ }), list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2,
+ .iscale=iscale, .ishape1=ishape1, .ishape2=ishape2 ))),
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- a = eta2theta(eta[,1], .la)
- p = eta2theta(eta[,2], .lp)
- q = eta2theta(eta[,3], .lq)
- y = cbind(pmin(y[,1], y[,2]), pmax(y[,1], y[,2])) # Sort so y[,1]<y[,2]
- # Note that, after sorting, y[,1] < y[,2] is needed:
+ a = eta2theta(eta[,1], .lscale)
+ p = eta2theta(eta[,2], .lshape1)
+ q = eta2theta(eta[,3], .lshape2)
if (residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * ((p+q)*log(a) - lgamma(p) - lgamma(q) +
- (p-1)*log(y[,1]) + (q-1)*log(y[,2]-y[,1]) - a*y[,2] ))
- }, list(.la=la, .lp=lp, .lq=lq))),
- vfamily=c("mckaygamma2"),
+ sum(w * (-(p+q)*log(a) - lgamma(p) - lgamma(q) +
+ (p-1)*log(y[,1]) + (q-1)*log(y[,2]-y[,1]) - y[,2] / a))
+ }, list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2 ))),
+ vfamily=c("bivgamma.mckay"),
deriv=eval(substitute(expression({
- a = eta2theta(eta[,1], .la)
- p = eta2theta(eta[,2], .lp)
- q = eta2theta(eta[,3], .lq)
- sorty = y
- sorty[,1] = pmin(y[,1], y[,2])
- sorty[,2] = pmax(y[,1], y[,2])
- d1 = (p+q)/a - sorty[,2]
- d2 = log(a) - digamma(p) + log(sorty[,1])
- d3 = log(a) - digamma(q) + log(sorty[,2]-sorty[,1])
- w * cbind(d1 * dtheta.deta(a, .la),
- d2 * dtheta.deta(p, .lp),
- d3 * dtheta.deta(q, .lq))
- }), list(.la=la, .lp=lp, .lq=lq))),
+ aparam = eta2theta(eta[,1], .lscale)
+ shape1 = eta2theta(eta[,2], .lshape1)
+ shape2 = eta2theta(eta[,3], .lshape2)
+ dl.da = (-(shape1+shape2) + y[,2] / aparam) / aparam
+ dl.dshape1 = -log(aparam) - digamma(shape1) + log(y[,1])
+ dl.dshape2 = -log(aparam) - digamma(shape2) + log(y[,2]-y[,1])
+ w * cbind(dl.da * dtheta.deta(aparam, .lscale),
+ dl.dshape1 * dtheta.deta(shape1, .lshape1),
+ dl.dshape2 * dtheta.deta(shape2, .lshape2))
+ }), list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2 ))),
weight=eval(substitute(expression({
- d11 = (p+q)/a^2
- d22 = trigamma(p)
- d33 = trigamma(q)
- d12 = -1/a
- d13 = -1/a
+ d11 = (shape1+shape2) / aparam^2
+ d22 = trigamma(shape1)
+ d33 = trigamma(shape2)
+ d12 = 1 / aparam
+ d13 = 1 / aparam
d23 = 0
wz = matrix(0, n, dimm(M))
- wz[,iam(1,1,M)] = dtheta.deta(a, .la)^2 * d11
- wz[,iam(2,2,M)] = dtheta.deta(p, .lp)^2 * d22
- wz[,iam(3,3,M)] = dtheta.deta(q, .lq)^2 * d33
- wz[,iam(1,2,M)] = dtheta.deta(a, .la) * dtheta.deta(p, .lp) * d12
- wz[,iam(1,3,M)] = dtheta.deta(a, .la) * dtheta.deta(q, .lq) * d13
- wz[,iam(2,3,M)] = dtheta.deta(p, .lp) * dtheta.deta(q, .lq) * d23
+ wz[,iam(1,1,M)] = dtheta.deta(aparam, .lscale)^2 * d11
+ wz[,iam(2,2,M)] = dtheta.deta(shape1, .lshape1)^2 * d22
+ wz[,iam(3,3,M)] = dtheta.deta(shape2, .lshape2)^2 * d33
+ wz[,iam(1,2,M)] = dtheta.deta(aparam, .lscale) *
+ dtheta.deta(shape1, .lshape1) * d12
+ wz[,iam(1,3,M)] = dtheta.deta(aparam, .lscale) *
+ dtheta.deta(shape2, .lshape2) * d13
+ wz[,iam(2,3,M)] = dtheta.deta(shape1, .lshape1) *
+ dtheta.deta(shape2, .lshape2) * d23
w * wz
- }), list(.la=la, .lp=lp, .lq=lq))))
+ }), list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2 ))))
}
+
+
+
+
+
+
+
rfrank = function(n, alpha) {
if (!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
if (!is.Numeric(alpha, posit=TRUE)) stop("bad input for 'alpha'")
diff --git a/R/family.categorical.R b/R/family.categorical.R
index 216a5bd..d39e0d7 100644
--- a/R/family.categorical.R
+++ b/R/family.categorical.R
@@ -52,6 +52,11 @@ process.categorical.data.vgam = expression({
+ if (!all(w == 1))
+ extra$orig.w = w
+ print("head(extra$orig.w)")
+ print( head(extra$orig.w) )
+
if (!is.matrix(y)) {
yf = as.factor(y)
lev = levels(yf)
@@ -63,8 +68,9 @@ process.categorical.data.vgam = expression({
if (llev <= 1)
stop("the response matrix does not have 2 or more columns")
- } else
+ } else {
nn = nrow(y)
+ }
nvec = rowSums(y)
@@ -99,8 +105,7 @@ process.categorical.data.vgam = expression({
y = prop.table(y, 1) # Convert to proportions
if (!length(mustart)) {
- mustart = (nvec * y + 1/ncol(y)) / (nvec+1)
- mustart = y + (1/ncol(y) - y)/nvec
+ mustart = y + (1 / ncol(y) - y) / nvec
}
})
@@ -109,26 +114,30 @@ process.categorical.data.vgam = expression({
Deviance.categorical.data.vgam <-
- function(mu, y, w, residuals = FALSE, eta, extra=NULL)
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
{
+
if (ncol(y) == 1 || ncol(mu) == 1)
- stop("y and mu must have at least 2 columns")
+ stop("'y' and 'mu' must have at least 2 columns")
- double.eps = .Machine$double.eps # ^0.75
+ double.eps = .Machine$double.xmin # ^0.75
devy = y
- nz = y != 0
- devy[nz] = y[nz] * log(y[nz])
- devmu = y * log(mu)
- if (any((small <- mu * (1 - mu)) < double.eps)) {
+ nonz = (y != 0)
+ devy[nonz] = y[nonz] * log(y[nonz])
+
+ devmu = 0 * y # filler; y*log(mu) gives a warning (fixed up anyway).
+ if (any(smallmu <- (mu * (1 - mu) < double.eps))) {
warning("fitted values close to 0 or 1")
- smu = mu[small]
- sy = y[small]
+ smu = mu[smallmu]
+ smy = y[smallmu]
smu = ifelse(smu < double.eps, double.eps, smu)
- devmu[small] = sy * log(smu)
+ devmu[smallmu] = smy * log(smu)
}
+ devmu[!smallmu] = y[!smallmu] * log(mu[!smallmu])
+
devi = 2 * (devy - devmu)
if (residuals) {
@@ -145,8 +154,8 @@ Deviance.categorical.data.vgam <-
- sratio = function(link="logit", earg=list(),
- parallel=FALSE, reverse=FALSE, zero=NULL)
+ sratio = function(link = "logit", earg = list(),
+ parallel = FALSE, reverse = FALSE, zero = NULL)
{
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -155,50 +164,50 @@ Deviance.categorical.data.vgam <-
stop("argument 'reverse' must be a single logical")
new("vglmff",
- blurb=c("Stopping Ratio model\n\n",
+ blurb = c("Stopping Ratio model\n\n",
"Links: ",
- namesof(if(reverse) "P[Y=j+1|Y<=j+1]" else "P[Y=j|Y>=j]",
- link, earg=earg),
+ namesof(if (reverse) "P[Y=j+1|Y<=j+1]" else "P[Y=j|Y>=j]",
+ link, earg = earg),
"\n",
"Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .parallel=parallel, .zero=zero ))),
- deviance=Deviance.categorical.data.vgam,
- initialize=eval(substitute(expression({
+ }), list( .parallel = parallel, .zero = zero ))),
+ deviance = Deviance.categorical.data.vgam,
+ initialize = eval(substitute(expression({
delete.zero.colns = TRUE
eval(process.categorical.data.vgam)
M = ncol(y) - 1
mynames = if ( .reverse)
- paste("P[Y=",2:(M+1),"|Y<=",2:(M+1),"]", sep="") else
- paste("P[Y=",1:M,"|Y>=",1:M,"]", sep="")
- predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
+ paste("P[Y=", 2:(M+1),"|Y<=", 2:(M+1),"]", sep="") else
+ paste("P[Y=", 1:M, "|Y>=", 1:M, "]", sep="")
+ predictors.names = namesof(mynames, .link, short=TRUE, earg = .earg)
y.names = paste("mu", 1:(M+1), sep="")
extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- }), list( .earg=earg, .link=link, .reverse=reverse ))),
- inverse=eval(substitute( function(eta, extra=NULL) {
+ }), list( .earg = earg, .link = link, .reverse = reverse ))),
+ inverse = eval(substitute( function(eta, extra = NULL) {
if (!is.matrix(eta))
eta = as.matrix(eta)
fv.matrix =
if ( .reverse ) {
M = ncol(eta)
- djr = eta2theta(eta, .link, earg= .earg )
+ djr = eta2theta(eta, .link, earg = .earg )
temp = tapplymat1(1-djr[,M:1], "cumprod")[,M:1]
cbind(1,djr) * cbind(temp,1)
} else {
- dj = eta2theta(eta, .link, earg= .earg )
+ dj = eta2theta(eta, .link, earg = .earg )
temp = tapplymat1(1-dj, "cumprod")
cbind(dj,1) * cbind(1, temp)
}
if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
- }, list( .earg=earg, .link=link, .reverse=reverse) )),
- last=eval(substitute(expression({
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ last = eval(substitute(expression({
misc$link = rep( .link, length=M)
names(misc$link) = mynames
@@ -209,59 +218,72 @@ Deviance.categorical.data.vgam <-
misc$parameters = mynames
misc$reverse = .reverse
extra = list() # kill what was used
- }), list( .earg=earg, .link=link, .reverse=reverse ))),
- link=eval(substitute( function(mu, extra=NULL) {
+ }), list( .earg = earg, .link = link, .reverse = reverse ))),
+ link = eval(substitute( function(mu, extra = NULL) {
cump = tapplymat1(mu, "cumsum")
if ( .reverse ) {
djr = mu[,-1] / cump[,-1]
- theta2eta(djr, .link, earg= .earg )
+ theta2eta(djr, .link, earg = .earg )
} else {
M = ncol(mu) - 1
dj = if (M==1) mu[,1] else mu[,1:M]/(1-cbind(0,cump[,1:(M-1)]))
- theta2eta(dj, .link, earg= .earg )
+ theta2eta(dj, .link, earg = .earg )
}
- }, list( .earg=earg, .link=link, .reverse=reverse) )),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
},
- vfamily=c("sratio", "vcategorical"),
- deriv=eval(substitute(expression({
+ vfamily = c("sratio", "vcategorical"),
+ deriv = eval(substitute(expression({
if (!length(extra$mymat)) {
extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
}
if ( .reverse ) {
- djr = eta2theta(eta, .link, earg= .earg )
+ djr = eta2theta(eta, .link, earg = .earg )
Mp1 = ncol(extra$mymat)
w * (y[,-1]/djr - extra$mymat[,-Mp1]/(1-djr)) *
- dtheta.deta(djr, .link, earg= .earg )
+ dtheta.deta(djr, .link, earg = .earg )
} else {
- dj = eta2theta(eta, .link, earg= .earg )
+ dj = eta2theta(eta, .link, earg = .earg )
w * (y[,-ncol(y)]/dj - extra$mymat[,-1]/(1-dj)) *
- dtheta.deta(dj, .link, earg= .earg )
+ dtheta.deta(dj, .link, earg = .earg )
}
- }), list( .earg=earg, .link=link, .reverse=reverse) )),
- weight= eval(substitute(expression({
+ }), list( .earg = earg, .link = link, .reverse = reverse) )),
+ weight = eval(substitute(expression({
if ( .reverse ) {
cump = tapplymat1(mu, "cumsum")
- ddjr.deta = dtheta.deta(djr, .link, earg= .earg )
+ ddjr.deta = dtheta.deta(djr, .link, earg = .earg )
wz = w * ddjr.deta^2 * (mu[,-1]/djr^2 + cump[,1:M]/(1-djr)^2)
} else {
ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[,ncol(mu):1]
- ddj.deta = dtheta.deta(dj, .link, earg= .earg )
+ ddj.deta = dtheta.deta(dj, .link, earg = .earg )
wz = w * ddj.deta^2 * (mu[,1:M]/dj^2 + ccump[,-1]/(1-dj)^2)
}
wz
- }), list( .earg=earg, .link=link, .reverse=reverse ))))
+ }), list( .earg = earg, .link = link, .reverse = reverse ))))
}
- cratio = function(link="logit", earg=list(),
- parallel=FALSE, reverse=FALSE, zero=NULL)
+ cratio = function(link = "logit", earg = list(),
+ parallel = FALSE, reverse = FALSE, zero = NULL)
{
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -270,50 +292,50 @@ Deviance.categorical.data.vgam <-
stop("argument 'reverse' must be a single logical")
new("vglmff",
- blurb=c("Continuation Ratio model\n\n",
+ blurb = c("Continuation Ratio model\n\n",
"Links: ",
- namesof(if(reverse) "P[Y<j+1|Y<=j+1]" else "P[Y>j|Y>=j]",
- link, earg=earg),
+ namesof(if (reverse) "P[Y<j+1|Y<=j+1]" else "P[Y>j|Y>=j]",
+ link, earg = earg),
"\n",
"Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .parallel=parallel, .zero=zero ))),
- deviance=Deviance.categorical.data.vgam,
- initialize=eval(substitute(expression({
+ }), list( .parallel = parallel, .zero = zero ))),
+ deviance = Deviance.categorical.data.vgam,
+ initialize = eval(substitute(expression({
delete.zero.colns = TRUE
eval(process.categorical.data.vgam)
M = ncol(y) - 1
mynames = if ( .reverse )
paste("P[Y<",2:(M+1),"|Y<=",2:(M+1),"]", sep="") else
paste("P[Y>",1:M,"|Y>=",1:M,"]", sep="")
- predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
+ predictors.names = namesof(mynames, .link, short=TRUE, earg = .earg)
y.names = paste("mu", 1:(M+1), sep="")
extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- }), list( .earg=earg, .link=link, .reverse=reverse ))),
- inverse=eval(substitute( function(eta, extra=NULL) {
+ }), list( .earg = earg, .link = link, .reverse = reverse ))),
+ inverse = eval(substitute( function(eta, extra = NULL) {
if (!is.matrix(eta))
eta = as.matrix(eta)
fv.matrix =
if ( .reverse ) {
M = ncol(eta)
- djrs = eta2theta(eta, .link, earg= .earg )
+ djrs = eta2theta(eta, .link, earg = .earg )
temp = tapplymat1(djrs[,M:1], "cumprod")[,M:1]
cbind(1,1-djrs) * cbind(temp,1)
} else {
- djs = eta2theta(eta, .link, earg= .earg )
+ djs = eta2theta(eta, .link, earg = .earg )
temp = tapplymat1(djs, "cumprod")
cbind(1-djs,1) * cbind(1, temp)
}
if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
- }, list( .earg=earg, .link=link, .reverse=reverse) )),
- last=eval(substitute(expression({
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ last = eval(substitute(expression({
misc$link = rep( .link, length=M)
names(misc$link) = mynames
misc$earg = vector("list", M)
@@ -322,52 +344,65 @@ Deviance.categorical.data.vgam <-
misc$parameters = mynames
misc$reverse = .reverse
extra = list() # kill what was used
- }), list( .earg=earg, .link=link, .reverse=reverse ))),
- link=eval(substitute( function(mu, extra=NULL) {
+ }), list( .earg = earg, .link = link, .reverse = reverse ))),
+ link = eval(substitute( function(mu, extra = NULL) {
cump = tapplymat1(mu, "cumsum")
if ( .reverse ) {
djrs = 1 - mu[,-1] / cump[,-1]
- theta2eta(djrs, .link, earg= .earg )
+ theta2eta(djrs, .link, earg = .earg )
} else {
M = ncol(mu) - 1
djs = if (M==1) 1-mu[,1] else 1-mu[,1:M]/(1-cbind(0,cump[,1:(M-1)]))
- theta2eta(djs, .link, earg= .earg )
+ theta2eta(djs, .link, earg = .earg )
}
- }, list( .earg=earg, .link=link, .reverse=reverse) )),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(w * y * log(mu))
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
},
- vfamily=c("cratio", "vcategorical"),
- deriv=eval(substitute(expression({
+ vfamily = c("cratio", "vcategorical"),
+ deriv = eval(substitute(expression({
if (!length(extra$mymat)) {
extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
}
if ( .reverse ) {
- djrs = eta2theta(eta, .link, earg= .earg )
+ djrs = eta2theta(eta, .link, earg = .earg )
Mp1 = ncol(extra$mymat)
-w * (y[,-1]/(1-djrs) - extra$mymat[,-Mp1]/djrs) *
- dtheta.deta(djrs, .link, earg= .earg )
+ dtheta.deta(djrs, .link, earg = .earg )
} else {
- djs = eta2theta(eta, .link, earg= .earg )
+ djs = eta2theta(eta, .link, earg = .earg )
-w * (y[,-ncol(y)]/(1-djs) - extra$mymat[,-1]/djs) *
- dtheta.deta(djs, .link, earg= .earg )
+ dtheta.deta(djs, .link, earg = .earg )
}
- }), list( .earg=earg, .link=link, .reverse=reverse) )),
- weight= eval(substitute(expression({
+ }), list( .earg = earg, .link = link, .reverse = reverse) )),
+ weight = eval(substitute(expression({
if ( .reverse ) {
cump = tapplymat1(mu, "cumsum")
- ddjrs.deta = dtheta.deta(djrs, .link, earg= .earg )
+ ddjrs.deta = dtheta.deta(djrs, .link, earg = .earg )
wz = w * ddjrs.deta^2 * (mu[,-1]/(1-djrs)^2 + cump[,1:M]/djrs^2)
} else {
ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[,ncol(mu):1]
- ddjs.deta = dtheta.deta(djs, .link, earg= .earg )
+ ddjs.deta = dtheta.deta(djs, .link, earg = .earg )
wz = w * ddjs.deta^2 * (mu[,1:M]/(1-djs)^2 + ccump[,-1]/djs^2)
}
wz
- }), list( .earg=earg, .link=link, .reverse=reverse ))))
+ }), list( .earg = earg, .link = link, .reverse = reverse ))))
}
@@ -411,24 +446,26 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
- multinomial = function(zero=NULL, parallel=FALSE, nointercept=NULL,
+ multinomial = function(zero = NULL, parallel = FALSE, nointercept=NULL,
refLevel="last")
{
if (length(refLevel) != 1) stop("the length of 'refLevel' must be one")
if (is.character(refLevel)) {
- if (refLevel != "last") stop('if a character, refLevel must be "last"')
+ if (refLevel != "last")
+ stop('if a character, refLevel must be "last"')
refLevel = -1
} else if (is.factor(refLevel)) {
- if (is.ordered(refLevel)) warning("'refLevel' is from an ordered factor")
+ if (is.ordered(refLevel))
+ warning("'refLevel' is from an ordered factor")
refLevel = as.character(refLevel) == levels(refLevel)
refLevel = (1:length(refLevel))[refLevel]
if (!is.Numeric(refLevel, allow=1, integer=TRUE, posit=TRUE))
- stop("could not coerce 'refLevel' into a single positive integer")
+ stop("could not coerce 'refLevel' into a single positive integer")
} else if (!is.Numeric(refLevel, allow=1, integer=TRUE, posit=TRUE))
stop("'refLevel' must be a single positive integer")
new("vglmff",
- blurb=c("Multinomial logit model\n\n",
+ blurb = c("Multinomial logit model\n\n",
if (refLevel < 0)
"Links: log(mu[,j]/mu[,M+1]), j=1:M,\n" else {
if (refLevel==1)
@@ -440,7 +477,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
sep="")
},
"Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
@@ -450,10 +487,10 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
intercept.apply=FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
constraints = cm.nointercept.vgam(constraints, x, .nointercept, M)
- }), list( .parallel=parallel, .zero=zero, .nointercept=nointercept,
- .refLevel=refLevel ))),
- deviance=Deviance.categorical.data.vgam,
- initialize=eval(substitute(expression({
+ }), list( .parallel = parallel, .zero = zero, .nointercept=nointercept,
+ .refLevel = refLevel ))),
+ deviance = Deviance.categorical.data.vgam,
+ initialize = eval(substitute(expression({
delete.zero.colns = TRUE
eval(process.categorical.data.vgam)
M = ncol(y)-1
@@ -465,7 +502,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
"]/mu[,", use.refLevel, "])", sep="")
y.names = paste("mu", 1:(M+1), sep="")
}), list( .refLevel = refLevel ))),
- inverse=eval(substitute( function(eta, extra=NULL) {
+ inverse = eval(substitute( function(eta, extra = NULL) {
if (any(is.na(eta)))
warning("there are NAs in eta in slot inverse")
M = ncol(cbind(eta))
@@ -484,7 +521,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
warning("there are NAs here in slot inverse")
ans
}), list( .refLevel = refLevel )),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$refLevel = if ( .refLevel < 0) M+1 else .refLevel
misc$link = "mlogit"
misc$earg = list(mlogit = list()) # vector("list", M)
@@ -493,7 +530,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
if (!is.null(dy[[2]]))
dimnames(fit$fitted.values) = dy
}), list( .refLevel = refLevel ))),
- link=eval(substitute( function(mu, extra=NULL) {
+ link = eval(substitute( function(mu, extra = NULL) {
if ( .refLevel < 0) {
log(mu[,-ncol(mu)] / mu[,ncol(mu)])
} else {
@@ -501,26 +538,39 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
log(mu[,-( use.refLevel )] / mu[, use.refLevel ])
}
}), list( .refLevel = refLevel )),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
},
- vfamily=c("multinomial", "vcategorical"),
- deriv=eval(substitute(expression({
+ vfamily = c("multinomial", "vcategorical"),
+ deriv = eval(substitute(expression({
if ( .refLevel < 0) {
w * (y[,-ncol(y)] - mu[,-ncol(y)])
} else {
use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
w * (y[,-use.refLevel] - mu[,-use.refLevel])
}
- }), list( .refLevel=refLevel ))),
- weight=eval(substitute(expression({
+ }), list( .refLevel = refLevel ))),
+ weight = eval(substitute(expression({
mytiny = (mu < sqrt(.Machine$double.eps)) |
- (mu > 1 - sqrt(.Machine$double.eps))
+ (mu > 1.0 - sqrt(.Machine$double.eps))
use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
- if (M==1) wz = mu[,3-use.refLevel] * (1-mu[,3-use.refLevel]) else {
+ if (M == 1) wz = mu[,3-use.refLevel] * (1-mu[,3-use.refLevel]) else {
index = iam(NA, NA, M, both=TRUE, diag=TRUE)
myinc = (index$row.index >= use.refLevel)
index$row.index[myinc] = index$row.index[myinc] + 1
@@ -533,10 +583,11 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
atiny = (mytiny %*% rep(1, ncol(mu))) > 0 # apply(mytiny, 1, any)
if (any(atiny)) {
- if (M==1) wz[atiny] = wz[atiny] * (1 + .Machine$double.eps^0.5) +
- .Machine$double.eps else
+ if (M == 1) wz[atiny] = wz[atiny] *
+ (1 + .Machine$double.eps^0.5) +
+ .Machine$double.eps else
wz[atiny,1:M] = wz[atiny,1:M] * (1 + .Machine$double.eps^0.5) +
- .Machine$double.eps
+ .Machine$double.eps
}
w * wz
}), list( .refLevel = refLevel ))))
@@ -544,9 +595,9 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
- cumulative = function(link="logit", earg = list(),
- parallel=FALSE, reverse=FALSE,
- mv=FALSE,
+ cumulative = function(link = "logit", earg = list(),
+ parallel = FALSE, reverse = FALSE,
+ mv = FALSE,
intercept.apply = FALSE)
{
if (mode(link) != "character" && mode(link) != "name")
@@ -558,14 +609,16 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
stop("argument 'reverse' must be a single logical")
new("vglmff",
- blurb=if( mv ) c(paste("Multivariate cumulative", link, "model\n\n"),
+ blurb=if ( mv ) c(paste("Multivariate cumulative", link, "model\n\n"),
"Links: ",
- namesof(if(reverse) "P[Y1>=j+1]" else "P[Y1<=j]", link, earg=earg),
+ namesof(if (reverse) "P[Y1>=j+1]" else "P[Y1<=j]",
+ link, earg = earg),
", ...") else
c(paste("Cumulative", link, "model\n\n"),
"Links: ",
- namesof(if(reverse) "P[Y>=j+1]" else "P[Y<=j]", link, earg=earg)),
- constraints=eval(substitute(expression({
+ namesof(if (reverse) "P[Y>=j+1]" else "P[Y<=j]",
+ link, earg = earg)),
+ constraints = eval(substitute(expression({
if ( .mv ) {
if ( !length(constraints) ) {
Llevels = extra$Llevels
@@ -578,9 +631,10 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints,
intercept.apply = .intercept.apply)
}
- }), list( .parallel=parallel, .mv=mv, .intercept.apply=intercept.apply ))),
+ }), list( .parallel = parallel, .mv=mv, .intercept.apply=intercept.apply ))),
deviance=eval(substitute(
- function(mu, y, w, residuals=FALSE, eta, extra=NULL) {
+ function(mu, y, w, residuals=FALSE, eta, extra = NULL) {
+
answer =
if ( .mv ) {
totdev = 0
@@ -600,8 +654,8 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
eta=eta, extra=extra)
}
answer
- }, list( .earg=earg, .link=link, .mv = mv ) )),
- initialize=eval(substitute(expression({
+ }, list( .earg = earg, .link = link, .mv = mv ) )),
+ initialize = eval(substitute(expression({
if (colnames(x)[1] != "(Intercept)")
stop("there is no intercept term!")
@@ -634,7 +688,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
paste("P[",Y.names,"<=",1:(Llevels-1),"]", sep=""))
y.names = c(y.names, paste(mu.names, 1:Llevels, sep=""))
}
- predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
+ predictors.names = namesof(mynames, .link, short=TRUE, earg = .earg)
extra$NOS = NOS
extra$Llevels = Llevels
} else {
@@ -643,7 +697,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
M = ncol(y)-1
mynames = if ( .reverse ) paste("P[Y>=",2:(1+M),"]", sep="") else
paste("P[Y<=",1:M,"]", sep="")
- predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
+ predictors.names = namesof(mynames, .link, short=TRUE, earg = .earg)
y.names = paste("mu", 1:(M+1), sep="")
if (ncol(cbind(w)) == 1) {
for(iii in 1:ncol(y))
@@ -653,8 +707,8 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
}
- }), list( .link=link, .reverse=reverse, .mv = mv, .earg = earg ))),
- inverse=eval(substitute( function(eta, extra=NULL) {
+ }), list( .link = link, .reverse = reverse, .mv = mv, .earg = earg ))),
+ inverse = eval(substitute( function(eta, extra = NULL) {
answer =
if ( .mv ) {
NOS = extra$NOS
@@ -679,10 +733,10 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
} else {
fv.matrix =
if ( .reverse ) {
- ccump = cbind(1, eta2theta(eta, .link, earg= .earg))
+ ccump = cbind(1, eta2theta(eta, .link, earg = .earg))
cbind(-tapplymat1(ccump, "diff"), ccump[,ncol(ccump)])
} else {
- cump = cbind(eta2theta(eta, .link, earg= .earg), 1)
+ cump = cbind(eta2theta(eta, .link, earg = .earg), 1)
cbind(cump[,1], tapplymat1(cump, "diff"))
}
if (length(extra$dimnamesy2))
@@ -690,8 +744,8 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
fv.matrix
}
answer
- }, list( .link=link, .reverse=reverse, .earg= earg, .mv = mv ))),
- last=eval(substitute(expression({
+ }, list( .link = link, .reverse = reverse, .earg= earg, .mv = mv ))),
+ last = eval(substitute(expression({
if ( .mv ) {
misc$link = .link
misc$earg = list( .earg )
@@ -707,9 +761,9 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
misc$reverse = .reverse
misc$parallel = .parallel
misc$mv = .mv
- }), list( .link=link, .reverse=reverse, .parallel=parallel,
+ }), list( .link = link, .reverse = reverse, .parallel = parallel,
.mv = mv, .earg= earg ))),
- link=eval(substitute( function(mu, extra=NULL) {
+ link = eval(substitute( function(mu, extra = NULL) {
answer =
if ( .mv ) {
NOS = extra$NOS
@@ -720,24 +774,37 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
aindex = (iii-1)*(Llevels) + 1:(Llevels)
cump = tapplymat1(as.matrix(mu[,aindex]), "cumsum")
eta.matrix[,cindex] =
- theta2eta(if( .reverse) 1-cump[,1:(Llevels-1)] else
- cump[,1:(Llevels-1)], .link, earg= .earg)
+ theta2eta(if ( .reverse) 1-cump[,1:(Llevels-1)] else
+ cump[,1:(Llevels-1)], .link, earg = .earg)
}
eta.matrix
} else {
cump = tapplymat1(as.matrix(mu), "cumsum")
M = ncol(as.matrix(mu)) - 1
- theta2eta(if( .reverse ) 1-cump[,1:M] else cump[,1:M], .link,
+ theta2eta(if ( .reverse ) 1-cump[,1:M] else cump[,1:M], .link,
earg= .earg)
}
answer
- }, list( .link=link, .reverse=reverse, .earg=earg, .mv=mv ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
+ }, list( .link = link, .reverse = reverse, .earg = earg, .mv=mv ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
},
- vfamily=c("cumulative", "vcategorical"),
- deriv=eval(substitute(expression({
+ vfamily = c("cumulative", "vcategorical"),
+ deriv = eval(substitute(expression({
mu.use = pmax(mu, .Machine$double.eps * 1.0e-0)
deriv.answer =
if ( .mv ) {
@@ -747,22 +814,22 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
for(iii in 1:NOS) {
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels-1)
- cump = eta2theta(eta[,cindex,drop=FALSE], .link, earg= .earg)
- dcump.deta[,cindex] = dtheta.deta(cump, .link, earg= .earg)
+ cump = eta2theta(eta[,cindex,drop=FALSE], .link, earg = .earg)
+ dcump.deta[,cindex] = dtheta.deta(cump, .link, earg = .earg)
resmat[,cindex] =
(y[,aindex,drop=FALSE]/mu.use[,aindex,drop=FALSE] -
y[,1+aindex,drop=FALSE]/mu.use[,1+aindex,drop=FALSE])
}
- (if( .reverse) -w else w) * dcump.deta * resmat
+ (if ( .reverse) -w else w) * dcump.deta * resmat
} else {
- cump = eta2theta(eta, .link, earg= .earg)
- dcump.deta = dtheta.deta(cump, .link, earg= .earg)
- (if( .reverse) -w else w) * dcump.deta *
+ cump = eta2theta(eta, .link, earg = .earg)
+ dcump.deta = dtheta.deta(cump, .link, earg = .earg)
+ (if ( .reverse) -w else w) * dcump.deta *
(y[,-(M+1)]/mu.use[,-(M+1)] - y[,-1]/mu.use[,-1])
}
deriv.answer
- }), list( .link=link, .reverse=reverse, .earg= earg, .mv=mv ))),
- weight= eval(substitute(expression({
+ }), list( .link = link, .reverse = reverse, .earg= earg, .mv=mv ))),
+ weight = eval(substitute(expression({
if ( .mv ) {
NOS = extra$NOS
Llevels = extra$Llevels
@@ -801,24 +868,24 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
dcump.deta[,2:M] / mu.use[,2:M])
}
wz
- }), list( .earg=earg, .link=link, .mv=mv ))))
+ }), list( .earg = earg, .link = link, .mv=mv ))))
}
- propodds = function(reverse=TRUE) {
+ propodds = function(reverse = TRUE) {
if (!is.logical(reverse) || length(reverse) != 1)
stop("argument 'reverse' must be a single logical")
- cumulative(parallel=TRUE, reverse=reverse)
+ cumulative(parallel = TRUE, reverse = reverse)
}
- acat = function(link="loge", earg = list(),
- parallel=FALSE, reverse=FALSE, zero=NULL)
+ acat = function(link = "loge", earg = list(),
+ parallel = FALSE, reverse = FALSE, zero = NULL)
{
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -827,50 +894,52 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
stop("argument 'reverse' must be a single logical")
new("vglmff",
- blurb=c("Adjacent-categories model\n\n",
- "Links: ",
- namesof(if(reverse) "P[Y=j]/P[Y=j+1]" else "P[Y=j+1]/P[Y=j]",
- link, earg=earg),
+ blurb = c("Adjacent-categories model\n\n",
+ "Links: ",
+ namesof(if (reverse) "P[Y=j]/P[Y=j+1]" else "P[Y=j+1]/P[Y=j]",
+ link, earg = earg),
"\n",
"Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .parallel=parallel, .zero=zero ))),
+ }), list( .parallel = parallel, .zero = zero ))),
- deviance=Deviance.categorical.data.vgam,
- initialize=eval(substitute(expression({
+ deviance = Deviance.categorical.data.vgam,
+ initialize = eval(substitute(expression({
delete.zero.colns = TRUE
eval(process.categorical.data.vgam)
M = ncol(y) - 1
+ print("y 20100607")
+ print( y )
mynames = if ( .reverse )
- paste("P[Y=",1:M,"]/P[Y=",2:(M+1),"]", sep="") else
- paste("P[Y=",2:(M+1),"]/P[Y=",1:M,"]", sep="")
- predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
+ paste("P[Y=", 1:M, "]/P[Y=", 2:(M+1), "]", sep="") else
+ paste("P[Y=", 2:(M+1), "]/P[Y=", 1:M, "]", sep="")
+
+ predictors.names = namesof(mynames, .link, short=TRUE, earg = .earg)
y.names = paste("mu", 1:(M+1), sep="")
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- }), list( .earg=earg, .link=link, .reverse=reverse ))),
- inverse=eval(substitute( function(eta, extra=NULL) {
+ }), list( .earg = earg, .link = link, .reverse = reverse ))),
+ inverse = eval(substitute( function(eta, extra = NULL) {
if (!is.matrix(eta))
eta = as.matrix(eta)
M = ncol(eta)
- fv.matrix =
- if ( .reverse ) {
- zetar = eta2theta(eta, .link, earg= .earg )
+ fv.matrix = if ( .reverse ) {
+ zetar = eta2theta(eta, .link, earg = .earg )
temp = tapplymat1(zetar[,M:1], "cumprod")[,M:1,drop=FALSE]
cbind(temp,1) / drop(1 + temp %*% rep(1,ncol(temp)))
} else {
- zeta = eta2theta(eta, .link, earg= .earg )
+ zeta = eta2theta(eta, .link, earg = .earg )
temp = tapplymat1(zeta, "cumprod")
cbind(1,temp) / drop(1 + temp %*% rep(1,ncol(temp)))
}
if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
- }, list( .earg=earg, .link=link, .reverse=reverse) )),
- last=eval(substitute(expression({
- misc$link = rep( .link, length=M)
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ last = eval(substitute(expression({
+ misc$link = rep( .link, length = M)
names(misc$link) = mynames
misc$earg = vector("list", M)
@@ -879,49 +948,62 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
misc$parameters = mynames
misc$reverse = .reverse
- }), list( .earg=earg, .link=link, .reverse=reverse ))),
- link=eval(substitute( function(mu, extra=NULL) {
+ }), list( .earg = earg, .link = link, .reverse = reverse ))),
+ link = eval(substitute( function(mu, extra = NULL) {
M = ncol(mu) - 1
- theta2eta(if( .reverse ) mu[,1:M]/mu[,-1] else mu[,-1]/mu[,1:M],
- .link, earg= .earg )
- }, list( .earg=earg, .link=link, .reverse=reverse) )),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
+ theta2eta(if ( .reverse ) mu[,1:M] / mu[,-1] else
+ mu[,-1] / mu[,1:M], .link, earg = .earg )
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
},
- vfamily=c("acat", "vcategorical"),
- deriv=eval(substitute(expression({
- zeta = eta2theta(eta, .link, earg= .earg ) # May be zetar
+ vfamily = c("acat", "vcategorical"),
+ deriv = eval(substitute(expression({
+ zeta = eta2theta(eta, .link, earg = .earg ) # May be zetar
d1 = acat.deriv(zeta, M=M, n=n, reverse=.reverse)
score = attr(d1, "gradient") / d1
- dzeta.deta = dtheta.deta(zeta, .link, earg= .earg )
+ dzeta.deta = dtheta.deta(zeta, .link, earg = .earg )
if ( .reverse ) {
cumy = tapplymat1(y, "cumsum")
- w * dzeta.deta * (cumy[,1:M]/zeta - score)
+ w * dzeta.deta * (cumy[,1:M] / zeta - score)
} else {
ccumy = tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
- w * dzeta.deta * (ccumy[,-1]/zeta - score)
+ w * dzeta.deta * (ccumy[,-1] / zeta - score)
}
- }), list( .earg=earg, .link=link, .reverse=reverse) )),
- weight= eval(substitute(expression({
+ }), list( .earg = earg, .link = link, .reverse = reverse) )),
+ weight = eval(substitute(expression({
wz = matrix(as.numeric(NA), n, dimm(M))
hess = attr(d1, "hessian") / d1
- if (M>1)
- for(jay in 1:(M-1))
- for(kay in (jay+1):M)
+ if (M > 1)
+ for(jay in 1:(M-1))
+ for(kay in (jay+1):M)
wz[,iam(jay,kay,M)] = (hess[,jay,kay] - score[,jay] *
score[,kay]) * dzeta.deta[,jay] * dzeta.deta[,kay]
if ( .reverse ) {
cump = tapplymat1(mu, "cumsum")
- wz[,1:M] = (cump[,1:M]/zeta^2 - score^2) * dzeta.deta^2
+ wz[,1:M] = (cump[,1:M] / zeta^2 - score^2) * dzeta.deta^2
} else {
- ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[,ncol(mu):1]
- wz[,1:M] = (ccump[,-1]/zeta^2 - score^2) * dzeta.deta^2
+ ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[, ncol(mu):1]
+ wz[,1:M] = (ccump[,-1] / zeta^2 - score^2) * dzeta.deta^2
}
w * wz
- }), list( .earg=earg, .link=link, .reverse=reverse ))))
+ }), list( .earg = earg, .link = link, .reverse = reverse ))))
}
@@ -931,11 +1013,11 @@ acat.deriv = function(zeta, reverse, M, n)
alltxt = NULL
for(ii in 1:M) {
index = if (reverse) ii:M else 1:ii
- vars = paste("zeta", index, sep="")
- txt = paste(vars, collapse="*")
+ vars = paste("zeta", index, sep = "")
+ txt = paste(vars, collapse = "*")
alltxt = c(alltxt, txt)
}
- alltxt = paste(alltxt, collapse=" + ")
+ alltxt = paste(alltxt, collapse = " + ")
alltxt = paste(" ~ 1 +", alltxt)
txt = as.formula(alltxt)
@@ -966,10 +1048,10 @@ acat.deriv = function(zeta, reverse, M, n)
stop("'refgp' must be a single positive integer")
new("vglmff",
- blurb=c(paste("Bradley-Terry model (without ties)\n\n"),
+ blurb = c(paste("Bradley-Terry model (without ties)\n\n"),
"Links: ",
namesof("alpha's", "loge")),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
are.ties = attr(y, "are.ties") # If Brat() was used
if (is.logical(are.ties) && are.ties)
stop("use bratt(), not brat(), when there are ties")
@@ -978,7 +1060,7 @@ acat.deriv = function(zeta, reverse, M, n)
M = (1:length(try.index))[(try.index+1)*(try.index) == ncol(y)]
if (!is.finite(M)) stop("cannot determine 'M'")
init.alpha = matrix( rep( .init.alpha, len=M), n, M, byrow=TRUE)
- etastart = matrix(theta2eta(init.alpha, "loge", earg=list()), n, M, byrow=TRUE)
+ etastart = matrix(theta2eta(init.alpha, "loge", earg = list()), n, M, byrow=TRUE)
refgp = .refgp
if (!intercept.only)
warning("this function only works with intercept-only models")
@@ -986,12 +1068,12 @@ acat.deriv = function(zeta, reverse, M, n)
uindex = if ( .refgp =="last") 1:M else (1:(M+1))[-( .refgp ) ]
predictors.names=namesof(paste("alpha",uindex,sep=""),"loge",short=TRUE)
- }), list( .refgp=refgp, .init.alpha=init.alpha ))),
- inverse=eval(substitute( function(eta, extra=NULL) {
+ }), list( .refgp = refgp, .init.alpha=init.alpha ))),
+ inverse = eval(substitute( function(eta, extra = NULL) {
probs = NULL
eta = as.matrix(eta) # in case M=1
for(ii in 1:nrow(eta)) {
- alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg=list()),
+ alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg = list()),
.refvalue, .refgp)
alpha1 = alpha[extra$ybrat.indices[,"rindex"]]
alpha2 = alpha[extra$ybrat.indices[,"cindex"]]
@@ -999,24 +1081,37 @@ acat.deriv = function(zeta, reverse, M, n)
}
dimnames(probs) = dimnames(eta)
probs
- }, list( .refgp=refgp, .refvalue=refvalue) )),
- last=eval(substitute(expression({
+ }, list( .refgp = refgp, .refvalue = refvalue) )),
+ last = eval(substitute(expression({
misc$link = rep( "loge", length=M)
names(misc$link) = paste("alpha",uindex,sep="")
misc$refgp = .refgp
misc$refvalue = .refvalue
- }), list( .refgp=refgp, .refvalue=refvalue ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
+ }), list( .refgp = refgp, .refvalue = refvalue ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
},
- vfamily=c("brat"),
- deriv=eval(substitute(expression({
+ vfamily = c("brat"),
+ deriv = eval(substitute(expression({
ans = NULL
uindex = if ( .refgp =="last") 1:M else (1:(M+1))[-( .refgp ) ]
eta = as.matrix(eta) # in case M=1
for(ii in 1:nrow(eta)) {
- alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg=list()),
+ alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg = list()),
.refvalue, .refgp)
ymat = InverseBrat(y[ii,], NCo=M+1, diag=0)
answer = rep(0, len=M)
@@ -1029,11 +1124,11 @@ acat.deriv = function(zeta, reverse, M, n)
}
dimnames(ans) = dimnames(eta)
ans
- }), list( .refvalue=refvalue, .refgp=refgp) )),
- weight= eval(substitute(expression({
+ }), list( .refvalue = refvalue, .refgp = refgp) )),
+ weight = eval(substitute(expression({
wz = matrix(0, n, dimm(M))
for(ii in 1:nrow(eta)) {
- alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg=list()),
+ alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg = list()),
.refvalue, .refgp)
ymat = InverseBrat(y[ii,], NCo=M+1, diag=0)
for(aa in 1:(M+1)) {
@@ -1052,7 +1147,7 @@ acat.deriv = function(zeta, reverse, M, n)
}
wz = wz * w
wz
- }), list( .refvalue=refvalue, .refgp=refgp ))))
+ }), list( .refvalue = refvalue, .refgp = refgp ))))
}
@@ -1073,10 +1168,10 @@ bratt = function(refgp="last",
!is.Numeric(refgp, allow=1, integer=TRUE, positi=TRUE))
stop("'refgp' must be a single positive integer")
new("vglmff",
- blurb=c(paste("Bradley-Terry model (with ties)\n\n"),
+ blurb = c(paste("Bradley-Terry model (with ties)\n\n"),
"Links: ",
namesof("alpha's", "loge"), ", log(alpha0)"),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
try.index = 1:400
M = (1:length(try.index))[(try.index*(try.index-1)) == ncol(y)]
if (!is.Numeric(M, allow=1, integ=TRUE)) stop("cannot determine 'M'")
@@ -1109,10 +1204,10 @@ bratt = function(refgp="last",
predictors.names=c(
namesof(paste("alpha",uindex,sep=""),"loge",short=TRUE),
namesof("alpha0", "loge", short=TRUE))
- }), list( .refgp=refgp,
+ }), list( .refgp = refgp,
.i0 = i0,
.init.alpha=init.alpha ))),
- inverse=eval(substitute( function(eta, extra=NULL) {
+ inverse = eval(substitute( function(eta, extra = NULL) {
probs = qprobs = NULL
M = ncol(eta)
for(ii in 1:nrow(eta)) {
@@ -1127,21 +1222,21 @@ bratt = function(refgp="last",
dimnames(qprobs) = extra$dnties
attr(probs, "probtie") = qprobs
probs
- }, list( .refgp=refgp, .refvalue=refvalue) )),
- last=eval(substitute(expression({
+ }, list( .refgp = refgp, .refvalue = refvalue) )),
+ last = eval(substitute(expression({
misc$link = rep( "loge", length=M)
names(misc$link) = c(paste("alpha",uindex,sep=""), "alpha0")
misc$refgp = .refgp
misc$refvalue = .refvalue
misc$alpha = alpha
misc$alpha0 = alpha0
- }), list( .refgp=refgp, .refvalue=refvalue ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
+ }), list( .refgp = refgp, .refvalue = refvalue ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * (y * log(mu) + 0.5 * extra$ties * log(attr(mu, "probtie"))))
},
- vfamily=c("bratt"),
- deriv=eval(substitute(expression({
+ vfamily = c("bratt"),
+ deriv = eval(substitute(expression({
ans = NULL
ties = extra$ties
NCo = M
@@ -1173,8 +1268,8 @@ bratt = function(refgp="last",
}
dimnames(ans) = dimnames(eta)
ans
- }), list( .refvalue=refvalue, .refgp=refgp) )),
- weight= eval(substitute(expression({
+ }), list( .refvalue = refvalue, .refgp = refgp) )),
+ weight = eval(substitute(expression({
wz = matrix(0, n, dimm(M)) # includes diagonal
for(ii in 1:nrow(eta)) {
alpha = .brat.alpha(eta2theta(eta[ii,-M],"loge"), .refvalue, .refgp)
@@ -1215,7 +1310,7 @@ bratt = function(refgp="last",
}
wz = wz * w
wz
- }), list( .refvalue=refvalue, .refgp=refgp ))))
+ }), list( .refvalue = refvalue, .refgp = refgp ))))
}
@@ -1223,7 +1318,7 @@ bratt = function(refgp="last",
if (is.character(posn))
if (posn!="last")
stop("can only handle \"last\"") else return(c(vec, value))
- c(if(posn==1) NULL else vec[1:(posn-1)], value,
+ c(if (posn==1) NULL else vec[1:(posn-1)], value,
if (posn==length(vec)+1) NULL else vec[posn:length(vec)])
}
@@ -1276,10 +1371,10 @@ Brat = function(mat, ties=0*mat, string=c(" > "," == ")) {
}
-InverseBrat = function(yvec, NCo=
- (1:900)[(1:900)*((1:900)-1)==ncol(rbind(yvec))],
- multiplicity=if(is.matrix(yvec)) nrow(yvec) else 1,
- diag=NA, string=c(" > "," == ")) {
+InverseBrat = function(yvec, NCo =
+ (1:900)[(1:900)*((1:900)-1) == ncol(rbind(yvec))],
+ multiplicity = if (is.matrix(yvec)) nrow(yvec) else 1,
+ diag = NA, string = c(" > "," == ")) {
ans = array(diag, c(NCo, NCo, multiplicity))
yvec.orig = yvec
yvec = c(yvec)
@@ -1341,8 +1436,8 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
ordpoisson = function(cutpoints,
countdata=FALSE, NOS=NULL, Levels=NULL,
- init.mu = NULL, parallel=FALSE, zero=NULL,
- link="loge", earg = list()) {
+ init.mu = NULL, parallel = FALSE, zero = NULL,
+ link = "loge", earg = list()) {
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
if (!is.list(earg)) earg = list()
@@ -1363,14 +1458,14 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
}
new("vglmff",
- blurb=c(paste("Ordinal Poisson model\n\n"),
- "Link: ", namesof("mu", link, earg= earg)),
- constraints=eval(substitute(expression({
+ blurb = c(paste("Ordinal Poisson model\n\n"),
+ "Link: ", namesof("mu", link, earg = earg)),
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints,
intercept.apply=TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .parallel=parallel, .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .parallel = parallel, .zero = zero ))),
+ initialize = eval(substitute(expression({
orig.y = cbind(y) # Convert y into a matrix if necessary
if ( .countdata ) {
extra$NOS = M = NOS = .NOS
@@ -1407,7 +1502,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
cptr = cptr + Levels[iii]
}
mustart = NULL # Overwrite it
- etastart = theta2eta(use.etastart, .link, earg= .earg)
+ etastart = theta2eta(use.etastart, .link, earg = .earg)
y = use.y # n x sum(Levels)
M = NOS
for(iii in 1:NOS) {
@@ -1420,17 +1515,17 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
extra$cutpoints = cp.vector
extra$n = n
mynames = if (M > 1) paste("mu",1:M,sep="") else "mu"
- predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
- }), list( .link=link, .countdata = countdata, .earg = earg,
+ predictors.names = namesof(mynames, .link, short=TRUE, earg = .earg)
+ }), list( .link = link, .countdata = countdata, .earg = earg,
.cutpoints=cutpoints, .NOS=NOS, .Levels=Levels,
.init.mu = init.mu
))),
- inverse=eval(substitute( function(eta, extra=NULL) {
- mu = eta2theta(eta, link= .link, earg= .earg) # Poisson means
+ inverse = eval(substitute( function(eta, extra = NULL) {
+ mu = eta2theta(eta, link= .link, earg = .earg) # Poisson means
mu = cbind(mu)
mu
- }, list( .link=link, .earg= earg, .countdata = countdata ))),
- last=eval(substitute(expression({
+ }, list( .link = link, .earg= earg, .countdata = countdata ))),
+ last = eval(substitute(expression({
if ( .countdata ) {
misc$link = .link
misc$earg = list( .earg )
@@ -1444,8 +1539,8 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
misc$parameters = mynames
misc$countdata = .countdata
misc$true.mu = FALSE # $fitted is not a true mu
- }), list( .link=link, .countdata = countdata, .earg= earg ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ }), list( .link = link, .countdata = countdata, .earg= earg ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (residuals) stop("loglikelihood residuals not implemented yet") else {
probs = ordpoissonProbs(extra, mu)
index0 = y == 0
@@ -1455,8 +1550,8 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
sum(pindex0) * (-1.0e+10) + sum(w * y * log(probs))
}
},
- vfamily=c("ordpoisson", "vcategorical"),
- deriv=eval(substitute(expression({
+ vfamily = c("ordpoisson", "vcategorical"),
+ deriv = eval(substitute(expression({
probs = ordpoissonProbs(extra, mu)
probs.use = pmax(probs, .Machine$double.eps * 1.0e-0)
@@ -1476,8 +1571,8 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
}
resmat = w * resmat * dmu.deta
resmat
- }), list( .link=link, .earg= earg, .countdata=countdata ))),
- weight= eval(substitute(expression({
+ }), list( .link = link, .earg= earg, .countdata=countdata ))),
+ weight = eval(substitute(expression({
d2l.dmu2 = matrix(0, n, M) # Diagonal matrix
cptr = 1
for(iii in 1:NOS) {
@@ -1489,7 +1584,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
}
wz = w * d2l.dmu2 * dmu.deta^2
wz
- }), list( .earg=earg, .link=link, .countdata=countdata ))))
+ }), list( .earg = earg, .link = link, .countdata=countdata ))))
}
ordpoissonProbs = function(extra, mu, deriv=0) {
@@ -1537,9 +1632,9 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
if (FALSE)
- scumulative = function(link="logit", earg = list(),
+ scumulative = function(link = "logit", earg = list(),
lscale="loge", escale = list(),
- parallel=FALSE, sparallel=TRUE, reverse=FALSE,
+ parallel = FALSE, sparallel = TRUE, reverse = FALSE,
iscale = 1)
{
stop("sorry, not working yet")
@@ -1555,12 +1650,13 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
stop("argument 'reverse' must be a single logical")
new("vglmff",
- blurb=c(paste("Scaled cumulative", link, "model\n\n"),
+ blurb = c(paste("Scaled cumulative", link, "model\n\n"),
"Links: ",
- namesof(if(reverse) "P[Y>=j+1]" else "P[Y<=j]", link, earg=earg),
+ namesof(if (reverse) "P[Y>=j+1]" else "P[Y<=j]",
+ link, earg = earg),
", ",
namesof("scale_j", lscale, escale)),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
J = M / 2
constraints = cm.vgam(matrix(1,J,1), x, .parallel, constraints,
intercept.apply = FALSE)
@@ -1579,15 +1675,15 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
for(ii in 1:length(constraints))
constraints[[ii]] =
(constraints[[ii]])[interleave.VGAM(M, M=2),,drop=FALSE]
- }), list( .parallel=parallel, .sparallel=sparallel ))),
+ }), list( .parallel = parallel, .sparallel=sparallel ))),
deviance=eval(substitute(
- function(mu, y, w, residuals=FALSE, eta, extra=NULL) {
+ function(mu, y, w, residuals=FALSE, eta, extra = NULL) {
answer =
Deviance.categorical.data.vgam(mu=mu, y=y, w=w, residuals=residuals,
eta=eta, extra=extra)
answer
- }, list( .earg=earg, .link=link ) )),
- initialize=eval(substitute(expression({
+ }, list( .earg = earg, .link = link ) )),
+ initialize = eval(substitute(expression({
if (intercept.only)
stop("use cumulative() for intercept-only models")
delete.zero.colns = TRUE # Cannot have FALSE since then prob(Y=jay)=0
@@ -1598,9 +1694,9 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
mynames = if ( .reverse ) paste("P[Y>=",2:(1+J),"]", sep="") else
paste("P[Y<=",1:J,"]", sep="")
predictors.names = c(
- namesof(mynames, .link, short=TRUE, earg= .earg),
+ namesof(mynames, .link, short=TRUE, earg = .earg),
namesof(paste("scale_", 1:J, sep=""),
- .lscale, short=TRUE, earg= .escale))
+ .lscale, short=TRUE, earg = .escale))
y.names = paste("mu", 1:(J+1), sep="")
if (length(dimnames(y)))
@@ -1608,28 +1704,28 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
- }), list( .link=link, .lscale=lscale, .reverse=reverse,
+ }), list( .link = link, .lscale=lscale, .reverse = reverse,
.earg= earg, .escale=escale ))),
- inverse=eval(substitute( function(eta, extra=NULL) {
+ inverse = eval(substitute( function(eta, extra = NULL) {
J = extra$J
M = 2*J
etamat1 = eta[,2*(1:J)-1,drop=FALSE]
etamat2 = eta[,2*(1:J), drop=FALSE]
- scalemat = eta2theta(etamat2, .lscale, earg= .escale)
+ scalemat = eta2theta(etamat2, .lscale, earg = .escale)
fv.matrix =
if ( .reverse ) {
ccump = cbind(1, eta2theta(etamat1/scalemat, .link, earg=.earg))
cbind(-tapplymat1(ccump, "diff"), ccump[,ncol(ccump)])
} else {
- cump = cbind(eta2theta(etamat1/scalemat, .link, earg= .earg), 1)
+ cump = cbind(eta2theta(etamat1/scalemat, .link, earg = .earg), 1)
cbind(cump[,1], tapplymat1(cump, "diff"))
}
if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
- }, list( .link=link, .lscale=lscale, .reverse=reverse,
+ }, list( .link = link, .lscale=lscale, .reverse = reverse,
.earg= earg, .escale=escale ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
J = extra$J
misc$link = c(rep( .link, length=J),
rep( .lscale, length=J))[interleave.VGAM(M, M=2)]
@@ -1642,28 +1738,41 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
misc$reverse = .reverse
misc$parallel = .parallel
misc$sparallel = .sparallel
- }), list( .link=link, .lscale=lscale,
- .reverse=reverse, .parallel=parallel, .sparallel=sparallel,
- .earg=earg, .escale=escale ))),
- link=eval(substitute( function(mu, extra=NULL) {
+ }), list( .link = link, .lscale=lscale,
+ .reverse = reverse, .parallel = parallel, .sparallel=sparallel,
+ .earg = earg, .escale=escale ))),
+ link = eval(substitute( function(mu, extra = NULL) {
cump = tapplymat1(as.matrix(mu), "cumsum")
J = ncol(as.matrix(mu)) - 1
M = 2 * J
answer = cbind(
- theta2eta(if( .reverse ) 1-cump[,1:J] else cump[,1:J], .link,
+ theta2eta(if ( .reverse ) 1-cump[,1:J] else cump[,1:J], .link,
earg= .earg),
matrix(theta2eta( .iscale, .lscale, earg = .escale),
nrow(as.matrix(mu)), J, byrow=TRUE))
answer = answer[,interleave.VGAM(M, M=2)]
answer
- }, list( .link=link, .lscale=lscale, .reverse=reverse,
- .iscale=iscale, .earg=earg, .escale=escale ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
- },
- vfamily=c("scumulative", "vcategorical"),
- deriv=eval(substitute(expression({
+ }, list( .link = link, .lscale=lscale, .reverse = reverse,
+ .iscale=iscale, .earg = earg, .escale=escale ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, docheck = FALSE))
+ },
+ vfamily = c("scumulative", "vcategorical"),
+ deriv = eval(substitute(expression({
ooz = iter %% 2
J = extra$J
@@ -1671,12 +1780,12 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
etamat1 = eta[,2*(1:J)-1,drop=FALSE]
etamat2 = eta[,2*(1:J), drop=FALSE]
- scalemat = eta2theta(etamat2, .lscale, earg= .escale)
+ scalemat = eta2theta(etamat2, .lscale, earg = .escale)
- cump = eta2theta(etamat1 / scalemat, .link, earg= .earg)
- dcump.deta = dtheta.deta(cump, .link, earg= .earg)
- dscale.deta = dtheta.deta(scalemat, .lscale, earg= .escale)
- dl.dcump = (if( .reverse) -w else w) *
+ cump = eta2theta(etamat1 / scalemat, .link, earg = .earg)
+ dcump.deta = dtheta.deta(cump, .link, earg = .earg)
+ dscale.deta = dtheta.deta(scalemat, .lscale, earg = .escale)
+ dl.dcump = (if ( .reverse) -w else w) *
(y[,1:J]/mu.use[,1:J] - y[,-1]/mu.use[,-1])
dcump.dscale = -dcump.deta * etamat1 / scalemat^2
ans = cbind(dl.dcump * dcump.deta / scalemat,
@@ -1684,9 +1793,9 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
ans = ans[,interleave.VGAM(M, M=2)]
if (ooz) ans[,c(TRUE,FALSE)] = 0 else ans[,c(FALSE,TRUE)] = 0
ans
- }), list( .link=link, .lscale=lscale, .reverse=reverse,
+ }), list( .link = link, .lscale=lscale, .reverse = reverse,
.earg= earg, .escale=escale ))),
- weight= eval(substitute(expression({
+ weight = eval(substitute(expression({
wz = matrix(0, n, 2*(2*M-3))
@@ -1727,7 +1836,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
wz[,iam(2*ii,2*ii+1,M=M)] = if (ooz) wz0[,ii] else 0
}
wz
- }), list( .link=link, .lscale=lscale, .earg=earg, .escale=escale ))))
+ }), list( .link = link, .lscale=lscale, .earg = earg, .escale=escale ))))
}
@@ -1817,7 +1926,7 @@ margeff = function(object, subset=NULL) {
} else {
if (is.logical(is.multivariateY <- object at misc$mv) && is.multivariateY)
- stop("cannot handle cumulative(mv=TRUE)")
+ stop("cannot handle cumulative(mv = TRUE)")
reverse = object at misc$reverse
linkfunctions = object at misc$link
all.eargs = object at misc$earg
@@ -1906,8 +2015,8 @@ prplot = function(object,
matplot(use.x, use.y, type="l", xlab=myxlab, ylab=myylab,
lty=control$lty, col=control$col, las=control$las,
- xlim=if(is.Numeric(control$xlim)) control$xlim else range(use.x),
- ylim=if(is.Numeric(control$ylim)) control$ylim else range(use.y),
+ xlim=if (is.Numeric(control$xlim)) control$xlim else range(use.x),
+ ylim=if (is.Numeric(control$ylim)) control$ylim else range(use.y),
main=mymain)
if (control$rug.arg)
rug(use.x, col=control$rcol, lwd=control$rlwd)
diff --git a/R/family.exp.R b/R/family.exp.R
new file mode 100644
index 0000000..ba5fe48
--- /dev/null
+++ b/R/family.exp.R
@@ -0,0 +1,369 @@
+# These functions are Copyright (C) 1998-2010 T. W. Yee All rights reserved.
+
+# Families for expectile regression are put in this file
+# 20100324;
+# Last modified: 20100324, 20100326, 20100329, 20100331,
+
+# Yet to do:
+# 1. lms.bcn(expectiles = FALSE). If lms.bcn(expectiles = TRUE) then
+# expectiles, and not quantiles, are the fitted values.
+# This is LMS-BCN expectile regression, a new method.
+# 2. Improve the approximations (initial values) for each of the
+# three distributions. See the zzs below.
+# 3. For peunif(q) etc.: use e or q as first argument??
+# For deunif(x) etc.: use e or x as first argument??
+# For qeunif(x) etc.: rename to eeunif(x)?
+
+# Done:
+# 1. For norm, exp and unif distributions:
+# qenorm(0.25) returns the 0.25-expectile of a standard normal,
+# penorm(1.25) returns the tau (in (0,1)) for an expectile of 1.25.
+# This is based on the paper by M C Jones (1994) in Stat Prob Letters.
+
+# Notes:
+# 1.
+
+# ======================================================================
+# Expectiles for uniform distribution ----------------------------------
+# 20100324
+# The [et]norm() here were adapted from MC Jones paper.
+
+qeunif <- function(p, min = 0, max = 1, Maxit_nr = 10, Tol_nr = 1.0e-6) {
+# Using Newton-Raphson may be a problem at the boundaries.
+# The secant method may be better.
+
+ ppp = p
+ vsmallno = sqrt(.Machine$double.eps)
+ smallno = 0.10
+ if (any(min >= max))
+ stop("argument 'min' has values greater or equal to argument 'max'")
+ if (!is.Numeric( Tol_nr, allow = 1, posit = TRUE) || Tol_nr > 0.10)
+ stop("argument 'Tol_nr' is not a single positive value, or is too large")
+ nrok = ppp >= vsmallno & ppp <= 1.0 - vsmallno & is.finite(ppp)
+
+# A beta function seems to approximate it ok near the middle.
+# This can be improved zz.
+ eee = qbeta(ppp, shape1 = 3, shape2 = 3)
+# A different quadratic fits each boundary well (asymptotic expansion).
+ eee[ppp < smallno] = sqrt(ppp[ppp < smallno])
+ eee[ppp > 1.0 - smallno] = 1.0 - sqrt(1.0 - ppp[ppp > 1.0 - smallno])
+
+#lines(ppp, eee, col="purple", type="b")
+#print("initial eee")
+#isample = sample(length(eee))
+#isample = 1:length(eee)
+#print( head(eee[isample]) )
+#print( (eee[isample]) )
+#cat("\n")
+
+ for(iii in 1:Maxit_nr) {
+ realdiff <- (peunif(eee[nrok]) - ppp[nrok]) / deunif(eee[nrok])
+# #print("max(abs(realdiff))")
+# #print( max(abs(realdiff)) )
+ eee[nrok] = eee[nrok] - realdiff
+# cat("Iteration ", iii, "\n")
+# #print( head(eee[isample]) )
+# #print( (eee[isample]) )
+# cat("\n")
+ if (all(abs(realdiff) / (1.0 + abs(realdiff)) < Tol_nr )) break
+ if (iii == Maxit_nr) warning("did not converge")
+ }
+
+# Check again (on the standard uniform distribution);
+ if (max(abs(peunif(eee[nrok]) - ppp[nrok])) > Tol_nr)
+ warning("did not converge on the second check")
+
+# zz; Needs checking, esp. near the boundary of 1.0:
+ eee[ppp < vsmallno] = sqrt( ppp[ppp < vsmallno])
+ eee[ppp > 1.0 - vsmallno] = 1.0 - sqrt(1.0 - ppp[ppp > 1.0 - vsmallno])
+ eee[ppp == 0] = 0
+ eee[ppp == 1] = 1
+ eee[ppp < 0] = NA
+ eee[ppp > 1] = NA
+ min + eee * (max - min)
+}
+
+
+peunif <- function(q, min = 0, max = 1, log = FALSE) {
+# zz use e or x ??
+# This is G(y).
+ if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ rm(log)
+ if (any(min >= max))
+ stop("argument 'min' has values greater or equal to argument 'max'")
+
+ eee = (q - min) / (max - min)
+ if (log.arg) {
+ logGofy = 2 * log(eee) - log1p(2 * eee * (eee - 1))
+ logGofy[eee < 0] = -Inf
+ logGofy[eee > 1] = 0.0
+ logGofy
+ } else {
+ Gofy = eee^2 / (1 + 2 * eee * (eee - 1))
+ Gofy[eee < 0] = 0.0
+ Gofy[eee > 1] = 1.0
+ Gofy
+ }
+}
+
+
+
+deunif <- function(x, min = 0, max = 1, log = FALSE) {
+# This is g(x).
+ if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ rm(log)
+ if (any(min >= max))
+ stop("argument 'min' has values greater or equal to argument 'max'")
+
+ eee = (x - min) / (max - min)
+
+ if (log.arg) {
+ ans = log(2) + log(eee) + log1p(-eee) -
+ 2.0 * log(2*eee*(1-eee) - 1) - log(max - min)
+ ans[eee <= 0.0] = log(0.0)
+ ans[eee >= 1.0] = log(0.0)
+ } else {
+ gunif <- function(y)
+ as.numeric(y >= 0 & y <= 1) * 2*y*(1-y) / (2*y*(1-y) - 1)^2
+ ans = gunif(eee) / (max - min)
+# ans[eee < 0.0] = 0.0
+# ans[eee > 1.0] = 0.0
+ }
+ ans
+}
+
+
+
+
+reunif <- function(n, min = 0, max = 1) {
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ stop("bad input for argument 'n'") else n
+ qeunif(runif(use.n), min = min, max = max)
+}
+
+
+
+
+# ======================================================================
+# Expectiles for normal distribution -----------------------------------
+# 20100324
+# The [et]norm() here were adapted from MC Jones paper.
+
+qenorm <- function(p, mean = 0, sd = 1, Maxit_nr = 10, Tol_nr = 1.0e-6) {
+ ppp = p
+ if (!is.Numeric( Tol_nr, allow = 1, posit = TRUE) || Tol_nr > 0.10)
+ stop("argument 'Tol_nr' is not a single positive value, or is too large")
+# if (!is.Numeric( sd, posit = TRUE))
+# stop("argument 'sd' must contain positive values")
+ nrok = is.finite(ppp)
+
+# A N(0, sd = 2/3) approximation is good according to the paper.
+ eee = qnorm(ppp, sd = 2/3)
+
+# lines(ppp, eee, col="purple", type="b")
+##print("initial eee")
+#isample = sample(length(eee))
+#isample = 1:length(eee)
+##print( head(eee[isample]) )
+##print( (eee[isample]) )
+# cat("\n")
+
+ gnorm = function(y) dnorm(y) / (y * (1-2*pnorm(y)) - 2*dnorm(y))^2
+
+ for(iii in 1:Maxit_nr) {
+ realdiff <- (penorm(eee[nrok]) - ppp[nrok]) / gnorm(eee[nrok])
+# #print("max(abs(realdiff))")
+# #print( max(abs(realdiff)) )
+ eee[nrok] = eee[nrok] - realdiff
+# cat("Iteration ", iii, "\n")
+# #print( head(eee[isample]) )
+# #print( (eee[isample]) )
+# cat("\n")
+ if (all(abs(realdiff) / (1.0 + abs(realdiff)) < Tol_nr )) break
+ if (iii == Maxit_nr) warning("did not converge")
+ }
+
+# Check again (on the standard normal distribution);
+ if (max(abs(penorm(eee[nrok]) - ppp[nrok])) > Tol_nr)
+ warning("did not converge on the second check")
+
+# zz; Needs checking, esp. near the boundary of 1.0:
+ eee[ppp == 0] = -Inf
+ eee[ppp == 1] = Inf
+ eee[ppp < 0] = NA
+ eee[ppp > 1] = NA
+ eee * ifelse(sd >= 0, sd, NaN) + mean
+}
+
+
+penorm <- function(q, mean = 0, sd = 1, log = FALSE) {
+ if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ rm(log)
+
+ eee = (q - mean) / sd
+ tmp1 = -dnorm(eee) - eee * pnorm(eee)
+ if (log.arg) {
+ logGofy = log(tmp1) - log(2 * tmp1 + eee)
+ logGofy[eee <= -Inf] = -Inf
+ logGofy[eee >= Inf] = 0.0
+ logGofy
+ } else {
+ Gofy = tmp1 / (2 * tmp1 + eee)
+ Gofy[eee <= -Inf] = 0.0
+ Gofy[eee >= Inf] = 1.0
+ Gofy
+ }
+}
+
+
+denorm <- function(x, mean = 0, sd = 1, log = FALSE) {
+# This is g(x).
+ if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ rm(log)
+
+ eee = (x - mean) / sd
+ if (log.arg) {
+ ans = dnorm(eee, log = TRUE) -
+ 2.0 * log(eee * (1-2*pnorm(eee)) - 2*dnorm(eee)) - log(sd)
+ } else {
+ gnorm = function(y) dnorm(y) / (y * (1-2*pnorm(y)) - 2*dnorm(y))^2
+ ans = gnorm(eee) / sd
+ ans[sd <= 0.0] = NaN
+ }
+ ans
+}
+
+
+
+
+renorm <- function(n, mean = 0, sd = 1) {
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ stop("bad input for argument 'n'") else n
+ qenorm(runif(use.n), mean = mean, sd = sd)
+}
+
+
+
+
+
+# ======================================================================
+# Expectiles for exponential distribution ------------------------------
+# 20100324
+# The [et]exp() here were adapted from MC Jones paper.
+
+
+qeexp <- function(p, rate = 1, Maxit_nr = 10, Tol_nr = 1.0e-6) {
+ ppp = p
+ vsmallno = sqrt(.Machine$double.eps)
+ if (!is.Numeric( Tol_nr, allow = 1, posit = TRUE) || Tol_nr > 0.10)
+ stop("argument 'Tol_nr' is not a single positive value, or is too large")
+ nrok = ppp >= vsmallno & is.finite(ppp)
+
+# 20100401; An approximation: (zz improve this!!)
+# eee = qf(0.8 * ppp, df1 = 4.0, df2 = 44) * 1.5
+
+# 20100408; This is a piecewise approximation, and looks ok.
+ eee = qf(1.0 * ppp, df1 = 4.0, df2 = 44)
+ if ( any(rangex <- ppp < 0.8) )
+ eee[rangex] = qrayleigh(ppp[rangex], a = 0.8)
+
+
+# A different quadratic fits each boundary well (asymptotic expansion). zz
+ eee[ppp < vsmallno] = sqrt(ppp[ppp < vsmallno])
+
+#lines(ppp,eee,col="purple",type="b") # See what the initial values were like
+##print("initial eee")
+#isample = sample(length(eee))
+#isample = 1:length(eee)
+##print( head(eee[isample]) )
+##print( (eee[isample]) )
+##cat("\n")
+
+ for(iii in 1:Maxit_nr) {
+ realdiff <- (peexp(eee[nrok]) - ppp[nrok]) / deexp(eee[nrok])
+# #print("max(abs(realdiff))")
+# #print( max(abs(realdiff)) )
+ eee[nrok] = eee[nrok] - realdiff
+# cat("Iteration ", iii, "\n")
+# #print( head(eee[isample]) )
+# #print( (eee[isample]) )
+# cat("\n")
+ if (all(abs(realdiff) / (1.0 + abs(realdiff)) < Tol_nr )) break
+ if (iii == Maxit_nr) warning("did not converge")
+ }
+
+# Check again (on the standard exponential distribution);
+ if (max(abs(peexp(eee[nrok]) - ppp[nrok])) > Tol_nr)
+ warning("did not converge on the second check")
+
+# zz; Needs checking, esp. near the boundary of 1.0:
+ eee[ppp < vsmallno] = sqrt(ppp[ppp < vsmallno])
+ eee[ppp == 0] = 0
+ eee[ppp == 1] = Inf
+ eee[ppp < 0] = NaN
+ eee[ppp > 1] = NaN
+ eee / rate
+}
+
+
+peexp <- function(q, rate = 1, log = FALSE) {
+ if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ rm(log)
+
+ eee = q * rate
+ if (log.arg) {
+ tmp1 = -expm1(-eee) - eee
+# logGofy = log(tmp1) - log(2 * tmp1 + eee - 1.0)
+ logGofy = log1p(- eee - exp(-eee)) - log(2 * tmp1 + eee - 1.0)
+ logGofy[eee < 0] = log(0.0)
+ logGofy[eee >= Inf] = log(1.0)
+ logGofy
+ } else {
+# tmp1 = 1 - eee - exp(-eee)
+ tmp1 = -expm1(-eee) - eee
+ Gofy = tmp1 / (2 * tmp1 + eee - 1.0)
+ Gofy[eee < 0] = 0.0
+ Gofy[eee >= Inf] = 1.0
+ Gofy
+ }
+}
+
+
+
+deexp <- function(x, rate = 1, log = FALSE) {
+# This is g(x).
+ if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ rm(log)
+ if (any(rate <= 0))
+ stop("argument 'rate' must have positive values")
+
+ eee = x * rate
+
+ if (log.arg) {
+ ans = log(eee) - eee + 2.0 * log((1-y) - 2 * exp(-y)) + log(rate)
+ } else {
+ gexp = function(y)
+ as.numeric(y >= 0) * y * exp(-y) / ((1-y) - 2 * exp(-y))^2
+ ans = gexp(eee) * rate
+ ans[rate <= 0.0] = NaN
+ }
+ ans
+}
+
+
+
+reexp <- function(n, rate = 1) {
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ stop("bad input for argument 'n'") else n
+ qeexp(runif(use.n), rate = rate)
+}
+
+
+# ======================================================================
+
+# ======================================================================
+
+
diff --git a/R/family.glmgam.R b/R/family.glmgam.R
index ad7e775..05c51ca 100644
--- a/R/family.glmgam.R
+++ b/R/family.glmgam.R
@@ -9,44 +9,42 @@
- binomialff = function(link="logit", earg=list(),
- dispersion=1, mv=FALSE, onedpar=!mv,
- parallel = FALSE, zero=NULL)
+
+
+
+ binomialff = function(link = "logit", earg = list(),
+ dispersion = 1, mv = FALSE, onedpar = !mv,
+ parallel = FALSE, zero = NULL)
{
- estimated.dispersion <- dispersion==0
+ estimated.dispersion <- dispersion == 0
if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=if(mv) c("Multivariate Binomial model\n\n",
- "Link: ", namesof("mu[,j]", link, earg= earg), "\n",
+ blurb = if (mv) c("Multivariate Binomial model\n\n",
+ "Link: ", namesof("mu[,j]", link, earg = earg), "\n",
"Variance: mu[,j]*(1-mu[,j])") else
c("Binomial model\n\n",
- "Link: ", namesof("mu", link, earg= earg), "\n",
+ "Link: ", namesof("mu", link, earg = earg), "\n",
"Variance: mu*(1-mu)"),
- constraints=eval(substitute(expression({
- constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints)
+ constraints = eval(substitute(expression({
+ constraints <- cm.vgam(matrix(1, M, 1), x, .parallel, constraints)
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .parallel=parallel, .zero=zero ))),
- deviance=function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ }), list( .parallel = parallel, .zero = zero ))),
+ deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
Deviance.categorical.data.vgam(mu=cbind(mu,1-mu), y=cbind(y,1-y),
w=w, residuals = residuals,
eta=eta, extra=extra)
},
- initialize=eval(substitute(expression({
- if (is.R()) {
- assign("CQO.FastAlgorithm", ( .link=="logit" || .link=="cloglog"),
- envir=VGAMenv)
- assign("modelno", if ( .link=="logit") 1 else
- if ( .link=="cloglog") 4 else NULL, envir=VGAMenv)
- } else {
- CQO.FastAlgorithm <<- ( .link == "logit" || .link=="cloglog")
- modelno <<- if ( .link=="logit") 1 else if ( .link=="cloglog") 4 else NULL
- }
+ initialize = eval(substitute(expression({
+ assign("CQO.FastAlgorithm",
+ ( .link == "logit" || .link == "cloglog"), envir = VGAMenv)
+ assign("modelno", if ( .link == "logit") 1 else
+ if ( .link=="cloglog") 4 else NULL, envir = VGAMenv)
if (.mv) {
y = as.matrix(y)
M = ncol(y)
@@ -58,8 +56,8 @@
} else {
paste("mu", 1:M, sep="")
}
- predictors.names = namesof(if(M>1) dn2 else
- "mu", .link, earg= .earg, short=TRUE)
+ predictors.names = namesof(if (M > 1) dn2 else
+ "mu", .link, earg = .earg, short = TRUE)
mustart = (0.5 + w * y) / (1 + w)
} else {
@@ -69,52 +67,54 @@
if (NCOL(y) == 1) {
if (is.factor(y)) y = y != levels(y)[1]
- nn = rep(1, n)
+ nvec = rep(1, n)
+ y[w == 0] <- 0
if (!all(y >= 0 & y <= 1))
- stop("response values must be in [0, 1]")
+ stop("response values 'y' must satisfy 0 <= y <= 1")
mustart = (0.5 + w * y) / (1 + w)
no.successes = w * y
if (any(abs(no.successes - round(no.successes)) > 0.001))
stop("Number of successes must be integer-valued")
} else if (NCOL(y) == 2) {
+ if (!all(w == 1))
+ extra$orig.w = w
+
if (any(abs(y - round(y)) > 0.001))
stop("Count data must be integer-valued")
- nn = y[,1] + y[,2]
- y = ifelse(nn > 0, y[,1]/nn, 0)
- w = w * nn
- mustart = (0.5 + nn * y) / (1 + nn)
- } else
- stop("Response not of the right form")
- predictors.names = namesof("mu", .link, earg= .earg, short=TRUE)
+ nvec = y[,1] + y[,2]
+ y = ifelse(nvec > 0, y[,1] / nvec, 0)
+ w = w * nvec
+ mustart = (0.5 + nvec * y) / (1 + nvec)
+ } else {
+ stop("for the binomial family, 'y' must be a ",
+ "vector of 0 and 1's\n",
+ "or a vector of proportions and 'weight' specified,\n",
+ "or a 2-column matrix where col 1 is the no. of ",
+ "successes and col 2 is the no. of failures")
+ }
+ predictors.names = namesof("mu", .link, earg = .earg, short = TRUE)
}
- }), list( .link=link, .mv=mv, .earg=earg ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- mu = eta2theta(eta, link= .link, earg = .earg)
+ }), list( .link = link, .mv = mv, .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({
- if (is.R()) {
- if (exists("CQO.FastAlgorithm", envir = VGAMenv))
- rm("CQO.FastAlgorithm", envir = VGAMenv)
- if (exists("modelno", envir = VGAMenv))
- rm("modelno", envir = VGAMenv)
- } else {
- while(exists("CQO.FastAlgorithm"))
- remove("CQO.FastAlgorithm")
- while(exists("modelno"))
- remove("modelno")
- }
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
+ if (exists("CQO.FastAlgorithm", envir = VGAMenv))
+ rm("CQO.FastAlgorithm", envir = VGAMenv)
+ if (exists("modelno", envir = VGAMenv))
+ rm("modelno", envir = VGAMenv)
dpar <- .dispersion
if (!dpar) {
- temp87 = (y-mu)^2 * wz /
- (dtheta.deta(mu, link= .link, earg = .earg )^2) # w cancel
+ temp87 = (y-mu)^2 * wz / (dtheta.deta(mu, link = .link,
+ earg = .earg )^2) # w cancel
if (.mv && ! .onedpar) {
dpar = rep(as.numeric(NA), len=M)
temp87 = cbind(temp87)
nrow.mu = if (is.matrix(mu)) nrow(mu) else length(mu)
for(ii in 1:M)
dpar[ii] = sum(temp87[,ii]) / (nrow.mu - ncol(x))
- if (is.matrix(y) && length(dimnames(y)[[2]])==length(dpar))
+ if (is.matrix(y) && length(dimnames(y)[[2]]) == length(dpar))
names(dpar) = dimnames(y)[[2]]
} else
dpar = sum(temp87) / (length(mu) - ncol(x))
@@ -124,77 +124,92 @@
misc$default.dispersion <- 1
misc$estimated.dispersion <- .estimated.dispersion
misc$link = rep( .link, length=M)
- names(misc$link) = if (M>1) dn2 else "mu"
+ names(misc$link) = if (M > 1) dn2 else "mu"
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M) misc$earg[[ii]] = .earg
misc$expected = TRUE
- }), list( .dispersion=dispersion, .estimated.dispersion=estimated.dispersion,
- .onedpar=onedpar, .link=link, .mv=mv, .earg = earg ))),
- link=eval(substitute(function(mu, extra=NULL)
+ }), list( .dispersion = dispersion,
+ .estimated.dispersion = estimated.dispersion,
+ .onedpar = onedpar, .link = link, .mv = mv, .earg = earg ))),
+ link = eval(substitute(function(mu, extra = NULL)
theta2eta(mu, .link, earg = .earg )
- , list( .link=link, .earg = earg ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if (residuals) w*(y/mu - (1-y)/(1-mu)) else {
- sum(dbinom(x=w*y, size=w, prob=mu, log=TRUE))
+ , list( .link = link, .earg = earg ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ if (residuals) w * (y / mu - (1-y) / (1-mu)) else {
+
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dbinom(x = ycounts, size = nvec, prob = mu,
+ log = TRUE))
}
},
- vfamily=c("binomialff", "vcategorical"),
- deriv=eval(substitute(expression({
+ vfamily = c("binomialff", "vcategorical"),
+ deriv = eval(substitute(expression({
if ( .link == "logit") {
w * (y - mu)
} else if ( .link == "cloglog") {
mu.use = mu
smallno = 100 * .Machine$double.eps
- mu.use[mu.use < smallno] = smallno
- mu.use[mu.use > 1 - smallno] = 1 - smallno
+ mu.use[mu.use < smallno] = smallno
+ mu.use[mu.use > 1.0 - smallno] = 1.0 - smallno
-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 ))),
- weight=eval(substitute(expression({
- tmp100 = mu*(1-mu)
+ w * dtheta.deta(mu, link = .link, earg = .earg ) *
+ (y / mu - 1.0) / (1.0 - mu)
+ }), list( .link = link, .earg = earg ))),
+ weight = eval(substitute(expression({
+ tmp100 = mu * (1.0 - mu)
tmp200 = if ( .link == "logit") {
cbind(w * tmp100)
} else if ( .link == "cloglog") {
- cbind(w * (1-mu.use) * (log1p(-mu.use))^2 / mu.use )
+ cbind(w * (1.0 - mu.use) * (log1p(-mu.use))^2 / mu.use)
} else {
- cbind(w * dtheta.deta(mu, link= .link, earg = .earg)^2 / tmp100)
+ cbind(w * dtheta.deta(mu, link = .link, earg = .earg)^2 / tmp100)
}
for(ii in 1:M) {
index200 = !is.finite(tmp200[,ii]) |
(abs(tmp200[,ii]) < .Machine$double.eps)
- if (any(index200)) {
- tmp200[index200,ii] = .Machine$double.eps # Diagonal 0's are bad
+ if (any(index200)) { # Diagonal 0's are bad
+ tmp200[index200,ii] = .Machine$double.eps
}
}
tmp200
- }), list( .link=link, .earg = earg ))))
+ }), list( .link = link, .earg = earg ))))
}
- gammaff = function(link="nreciprocal", earg=list(), dispersion=0)
+ gammaff = function(link="nreciprocal", earg = list(), dispersion=0)
{
- estimated.dispersion <- dispersion==0
+ estimated.dispersion <- dispersion == 0
if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Gamma distribution\n\n",
+ blurb = c("Gamma distribution\n\n",
"Link: ", namesof("mu", link, earg=earg), "\n",
"Variance: mu^2 / k"),
- deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ deviance= function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
devi <- -2 * w * (log(ifelse(y == 0, 1, y/mu)) - (y - mu)/mu)
if (residuals) {
sign(y - mu) * sqrt(abs(devi) * w)
} else sum(w * devi)
},
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
mustart <- y + 0.167 * (y == 0)
M = if (is.matrix(y)) ncol(y) else 1
dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
@@ -203,15 +218,15 @@
} else {
paste("mu", 1:M, sep="")
}
- predictors.names = namesof(if(M>1) dn2 else "mu", .link,
- earg=.earg, short=TRUE)
+ predictors.names = namesof(if (M > 1) dn2 else "mu", .link,
+ earg=.earg, short = TRUE)
if (!length(etastart))
- etastart <- theta2eta(mustart, link= .link, earg=.earg)
- }), list( .link=link, .earg=earg ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, link= .link, earg=.earg)
- }, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ etastart <- theta2eta(mustart, link = .link, earg=.earg)
+ }), list( .link = link, .earg = earg ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta, link = .link, earg=.earg)
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
dpar <- .dispersion
if (!dpar) {
if (M == 1) {
@@ -230,29 +245,29 @@
misc$default.dispersion <- 0
misc$estimated.dispersion <- .estimated.dispersion
misc$link = rep( .link, length=M)
- names(misc$link) = if (M>1) paste("mu", 1:M, sep="") else "mu"
+ names(misc$link) = if (M > 1) paste("mu", 1:M, sep="") else "mu"
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M) misc$earg[[ii]] = .earg
misc$expected = TRUE
- }), list( .dispersion=dispersion, .earg=earg,
- .estimated.dispersion=estimated.dispersion,
- .link=link ))),
- link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, link= .link, earg=.earg)
- }, list( .link=link, .earg=earg ))),
- vfamily="gammaff",
- deriv=eval(substitute(expression({
+ }), list( .dispersion = dispersion, .earg = earg,
+ .estimated.dispersion = estimated.dispersion,
+ .link = link ))),
+ link = eval(substitute(function(mu, extra = NULL) {
+ theta2eta(mu, link = .link, earg=.earg)
+ }, list( .link = link, .earg = earg ))),
+ vfamily = "gammaff",
+ deriv = eval(substitute(expression({
dl.dmu = (y-mu) / mu^2
- dmu.deta = dtheta.deta(theta=mu, link= .link, earg=.earg)
+ dmu.deta = dtheta.deta(theta=mu, link = .link, earg=.earg)
w * dl.dmu * dmu.deta
- }), list( .link=link, .earg=earg ))),
- weight=eval(substitute(expression({
+ }), list( .link = link, .earg = earg ))),
+ weight = eval(substitute(expression({
d2l.dmu2 = 1 / mu^2
w * dmu.deta^2 * d2l.dmu2
- }), list( .link=link, .earg=earg ))))
+ }), list( .link = link, .earg = earg ))))
}
@@ -268,10 +283,10 @@
if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Inverse Gaussian distribution\n\n",
+ blurb = c("Inverse Gaussian distribution\n\n",
"Link: ", namesof("mu", link), "\n",
"Variance: mu^3 /k"),
- deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ deviance= function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
pow <- 3 # Use Quasi()$deviance with pow==3
devy <- y^(2-pow) / (1-pow) - y^(2-pow) / (2-pow)
devmu <- y * mu^(1-pow) / (1-pow) - mu^(2-pow) / (2-pow)
@@ -280,15 +295,15 @@
sign(y - mu) * sqrt(abs(devi) * w)
} else sum(w * devi)
},
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
mu <- y + 0.167 * (y == 0)
if (!length(etastart))
- etastart <- theta2eta(mu, link= .link)
- }), list( .link=link ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, link= .link)
- }, list( .link=link ))),
- last=eval(substitute(expression({
+ etastart <- theta2eta(mu, link = .link)
+ }), list( .link = link ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta, link = .link)
+ }, list( .link = link ))),
+ last = eval(substitute(expression({
dpar <- .dispersion
if (!dpar) {
temp <- w * dmu.deta^2
@@ -298,23 +313,23 @@
misc$default.dispersion <- 0
misc$estimated.dispersion <- .estimated.dispersion
misc$link = rep( .link, length=M)
- names(misc$link) = if (M>1) paste("mu", 1:M, sep="") else "mu"
- }), list( .dispersion=dispersion,
- .estimated.dispersion=estimated.dispersion,
- .link=link ))),
- link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, link= .link)
- }, list( .link=link ))),
- vfamily="inverse.gaussianff",
- deriv=eval(substitute(expression({
+ names(misc$link) = if (M > 1) paste("mu", 1:M, sep="") else "mu"
+ }), list( .dispersion = dispersion,
+ .estimated.dispersion = estimated.dispersion,
+ .link = link ))),
+ link = eval(substitute(function(mu, extra = NULL) {
+ theta2eta(mu, link = .link)
+ }, list( .link = link ))),
+ vfamily = "inverse.gaussianff",
+ deriv = eval(substitute(expression({
dl.dmu <- (y-mu) / mu^3
- dmu.deta <- dtheta.deta(theta=mu, link= .link)
+ dmu.deta <- dtheta.deta(theta=mu, link = .link)
w * dl.dmu * dmu.deta
- }), list( .link=link ))),
- weight=eval(substitute(expression({
+ }), list( .link = link ))),
+ weight = eval(substitute(expression({
d2l.dmu2 <- 1 / mu^3
w * dmu.deta^2 * d2l.dmu2
- }), list( .link=link ))))
+ }), list( .link = link ))))
}
@@ -372,7 +387,7 @@ rinv.gaussian = function(n, mu, lambda) {
inv.gaussianff = function(lmu="loge", llambda="loge",
emu=list(), elambda=list(),
ilambda=1,
- zero=NULL)
+ zero = NULL)
{
if (mode(lmu) != "character" && mode(lmu) != "name")
lmu <- as.character(substitute(lmu))
@@ -382,56 +397,57 @@ rinv.gaussian = function(n, mu, lambda) {
if (!is.list(elambda)) elambda = list()
new("vglmff",
- blurb=c("Inverse Gaussian distribution\n\n",
+ blurb = c("Inverse Gaussian distribution\n\n",
"f(y) = sqrt(lambda/(2*pi*y^3)) * exp(-lambda*(y-mu)^2/(2*mu^2*y)), y&lambda>0",
"Link: ", namesof("mu", lmu, earg= emu), ", ",
namesof("lambda", llambda, earg= elambda), "\n",
"Mean: ", "mu\n",
"Variance: mu^3 / lambda"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
if (any(y <= 0)) stop("Require the response to have positive values")
predictors.names =
- c(namesof("mu", .lmu, earg= .emu, short= TRUE),
- namesof("lambda", .llambda, earg= .elambda, short= TRUE))
+ c(namesof("mu", .lmu, earg = .emu, short= TRUE),
+ namesof("lambda", .llambda, earg = .elambda, short= TRUE))
if (!length(etastart)) {
initmu = y + 1/8
- initlambda = rep(if(length( .ilambda)) .ilambda else 1, len=n)
+ initlambda = rep(if (length( .ilambda)) .ilambda else 1, len=n)
etastart = cbind(
- theta2eta(initmu, link=.lmu, earg= .emu),
- theta2eta(initlambda, link=.llambda, earg= .elambda))
+ theta2eta(initmu, link=.lmu, earg = .emu),
+ theta2eta(initlambda, link=.llambda, earg = .elambda))
}
}), list( .lmu=lmu, .llambda=llambda,
.emu=emu, .elambda=elambda,
.ilambda=ilambda ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], link=.lmu, earg= .emu)
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta[,1], link=.lmu, earg = .emu)
}, list( .lmu=lmu, .emu=emu, .elambda=elambda ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(mu = .lmu, lambda = .llambda)
misc$earg = list(mu = .emu, lambda = .elambda)
}), list( .lmu=lmu, .llambda=llambda, .emu=emu, .elambda=elambda ))),
- loglikelihood=eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- lambda <- eta2theta(eta[,2], link=.llambda, earg= .elambda)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ lambda <- eta2theta(eta[,2], link=.llambda, earg = .elambda)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
sum(w * dinv.gaussian(x=y, mu=mu, lambda=lambda, log=TRUE))
}
}, list( .llambda=llambda, .emu=emu, .elambda=elambda ))),
- vfamily="inv.gaussianff",
- deriv=eval(substitute(expression({
- lambda <- eta2theta(eta[,2], link=.llambda, earg= .elambda)
+ vfamily = "inv.gaussianff",
+ deriv = eval(substitute(expression({
+ lambda <- eta2theta(eta[,2], link=.llambda, earg = .elambda)
dl.dmu = lambda * (y-mu) / mu^3
dl.dlambda <- 0.5 / lambda - (y-mu)^2 / (2 * mu^2 * y)
- dmu.deta <- dtheta.deta(theta=mu, link=.lmu, earg= .emu)
- dlambda.deta <- dtheta.deta(theta=lambda, link=.llambda, earg= .elambda)
+ dmu.deta <- dtheta.deta(theta=mu, link=.lmu, earg = .emu)
+ dlambda.deta <- dtheta.deta(theta=lambda, link=.llambda, earg = .elambda)
w * cbind(dl.dmu * dmu.deta, dl.dlambda * dlambda.deta)
}), list( .lmu=lmu, .llambda=llambda, .emu=emu, .elambda=elambda ))),
- weight=eval(substitute(expression({
+ weight = eval(substitute(expression({
d2l.dmu2 = lambda / mu^3
d2l.dlambda2 = 0.5 / (lambda^2)
w * cbind(dmu.deta^2 * d2l.dmu2, dlambda.deta^2 * d2l.dlambda2)
@@ -440,10 +456,10 @@ rinv.gaussian = function(n, mu, lambda) {
- poissonff = function(link="loge", earg=list(),
- dispersion=1, onedpar=FALSE,
+ poissonff = function(link="loge", earg = list(),
+ dispersion = 1, onedpar=FALSE,
imu=NULL, method.init=1,
- parallel=FALSE, zero=NULL)
+ parallel=FALSE, zero = NULL)
{
estimated.dispersion <- dispersion==0
@@ -457,35 +473,33 @@ rinv.gaussian = function(n, mu, lambda) {
stop("bad input for argument 'imu'")
new("vglmff",
- blurb=c("Poisson distribution\n\n",
- "Link: ", namesof("mu", link, earg= earg), "\n",
+ blurb = c("Poisson distribution\n\n",
+ "Link: ", namesof("mu", link, earg = earg), "\n",
"Variance: mu"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints)
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .parallel=parallel, .zero=zero ))),
- deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ }), list( .parallel = parallel, .zero = zero ))),
+ 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({
+ initialize = eval(substitute(expression({
y = as.matrix(y)
M = ncoly = ncol(y)
- if (is.R()) assign("CQO.FastAlgorithm",
- ( .link == "loge"), envir = VGAMenv) else
- CQO.FastAlgorithm <<- ( .link == "loge")
+ assign("CQO.FastAlgorithm", ( .link == "loge"), envir = VGAMenv)
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)
+ predictors.names = namesof(if (M > 1) dn2 else "mu", .link,
+ earg = .earg, short = TRUE)
if (!length(etastart)) {
mu.init = pmax(y, 1/8)
@@ -498,26 +512,21 @@ rinv.gaussian = function(n, mu, lambda) {
}
if (length(.imu))
mu.init = matrix( .imu, n, ncoly, byrow=TRUE)
- etastart <- theta2eta(mu.init, link= .link, earg= .earg)
+ etastart <- theta2eta(mu.init, link = .link, earg = .earg)
}
- }), list( .link=link, .estimated.dispersion=estimated.dispersion,
- .method.init=method.init, .imu=imu, .earg=earg ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- mu = eta2theta(eta, link= .link, earg= .earg)
+ }), list( .link = link, .estimated.dispersion = estimated.dispersion,
+ .method.init=method.init, .imu=imu, .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({
- if (is.R()) {
- if (exists("CQO.FastAlgorithm", envir = VGAMenv))
- rm("CQO.FastAlgorithm", envir = VGAMenv)
- } else {
- while(exists("CQO.FastAlgorithm"))
- remove("CQO.FastAlgorithm")
- }
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
+ if (exists("CQO.FastAlgorithm", envir = VGAMenv))
+ rm("CQO.FastAlgorithm", envir = VGAMenv)
dpar <- .dispersion
if (!dpar) {
temp87 = (y-mu)^2 *
- wz / (dtheta.deta(mu, link= .link, earg= .earg)^2) # w cancel
+ wz / (dtheta.deta(mu, link = .link, earg = .earg)^2) # w cancel
if (M > 1 && ! .onedpar) {
dpar = rep(as.numeric(NA), len=M)
temp87 = cbind(temp87)
@@ -534,45 +543,45 @@ rinv.gaussian = function(n, mu, lambda) {
misc$estimated.dispersion <- .estimated.dispersion
misc$expected = TRUE
misc$link = rep( .link, length=M)
- names(misc$link) = if (M>1) dn2 else "mu"
+ names(misc$link) = if (M > 1) dn2 else "mu"
misc$method.init = .method.init
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M) misc$earg[[ii]] = .earg
- }), list( .dispersion=dispersion, .method.init=method.init,
- .estimated.dispersion=estimated.dispersion,
- .onedpar=onedpar, .link=link, .earg=earg ))),
- link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, link= .link, earg= .earg)
- }, list( .link=link, .earg=earg ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ }), list( .dispersion = dispersion, .method.init=method.init,
+ .estimated.dispersion = estimated.dispersion,
+ .onedpar = onedpar, .link = link, .earg = earg ))),
+ link = eval(substitute(function(mu, extra = NULL) {
+ theta2eta(mu, link = .link, earg = .earg)
+ }, list( .link = link, .earg = earg ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (residuals) w*(y/mu - 1) else {
sum(w * dpois(x=y, lambda=mu, log=TRUE))
}
},
- vfamily="poissonff",
- deriv=eval(substitute(expression({
+ vfamily = "poissonff",
+ deriv = eval(substitute(expression({
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)
+ dlambda.deta <- dtheta.deta(theta=lambda, link = .link, earg = .earg)
w * dl.dlambda * dlambda.deta
}
- }), list( .link=link, .earg=earg ))),
- weight=eval(substitute(expression({
+ }), list( .link = link, .earg = earg ))),
+ weight = eval(substitute(expression({
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
- d2lambda.deta2=d2theta.deta2(theta=lambda,link= .link,earg= .earg)
+ d2lambda.deta2=d2theta.deta2(theta=lambda,link= .link,earg = .earg)
w * dlambda.deta^2 * d2l.dlambda2
}
- }), list( .link=link, .earg=earg ))))
+ }), list( .link = link, .earg = earg ))))
}
@@ -605,9 +614,9 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}
- poissonqn = function(link="loge", earg=list(),
- dispersion=1, onedpar=FALSE,
- parallel=FALSE, zero=NULL,
+ poissonqn = function(link="loge", earg = list(),
+ dispersion = 1, onedpar=FALSE,
+ parallel=FALSE, zero = NULL,
wwts=c("expected","observed","qn"))
{
estimated.dispersion <- dispersion==0
@@ -619,21 +628,21 @@ poissonqn.control <- function(save.weight=TRUE, ...)
if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Poisson distribution\n\n",
- "Link: ", namesof("mu", link, earg= earg), "\n",
+ blurb = c("Poisson distribution\n\n",
+ "Link: ", namesof("mu", link, earg = earg), "\n",
"Variance: mu"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints)
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .parallel=parallel, .zero=zero ))),
- deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ }), list( .parallel = parallel, .zero = zero ))),
+ 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({
+ initialize = eval(substitute(expression({
M = if (is.matrix(y)) ncol(y) else 1
dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
dn2 = if (length(dn2)) {
@@ -641,21 +650,21 @@ poissonqn.control <- function(save.weight=TRUE, ...)
} else {
paste("mu", 1:M, sep="")
}
- predictors.names = namesof(if(M>1) dn2 else "mu", .link,
- earg= .earg, short=TRUE)
+ predictors.names = namesof(if (M > 1) dn2 else "mu", .link,
+ earg = .earg, short = TRUE)
mu = pmax(y, 0.167) # y + 0.167 * (y == 0)
if (!length(etastart))
- etastart <- theta2eta(mu, link= .link, earg= .earg)
- }), list( .link=link, .estimated.dispersion=estimated.dispersion,
- .earg=earg ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, link= .link, earg= .earg)
- }, list( .link=link,
- .earg=earg ))),
- last=eval(substitute(expression({
+ etastart <- theta2eta(mu, link = .link, earg = .earg)
+ }), list( .link = link, .estimated.dispersion = estimated.dispersion,
+ .earg = earg ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta, link = .link, earg = .earg)
+ }, list( .link = link,
+ .earg = earg ))),
+ last = eval(substitute(expression({
dpar <- .dispersion
if (!dpar) {
- temp87= (y-mu)^2 * wz/(dtheta.deta(mu, link= .link, earg= .earg)^2)
+ temp87= (y-mu)^2 * wz/(dtheta.deta(mu, link = .link, earg = .earg)^2)
if (M > 1 && ! .onedpar) {
dpar = rep(as.numeric(NA), len=M)
temp87 = cbind(temp87)
@@ -673,26 +682,26 @@ poissonqn.control <- function(save.weight=TRUE, ...)
misc$estimated.dispersion <- .estimated.dispersion
misc$expected = FALSE
misc$link = rep( .link, length=M)
- names(misc$link) = if (M>1) dn2 else "mu"
+ names(misc$link) = if (M > 1) dn2 else "mu"
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M) misc$earg[[ii]] = .earg
- }), list( .dispersion=dispersion,
- .earg=earg,
- .estimated.dispersion=estimated.dispersion,
- .onedpar=onedpar, .link=link ))),
- link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, link= .link, earg= .earg)
- }, list( .link=link,
- .earg=earg ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ }), list( .dispersion = dispersion,
+ .earg = earg,
+ .estimated.dispersion = estimated.dispersion,
+ .onedpar = onedpar, .link = link ))),
+ link = eval(substitute(function(mu, extra = NULL) {
+ theta2eta(mu, link = .link, earg = .earg)
+ }, list( .link = link,
+ .earg = earg ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (residuals) w*(y/mu - 1) else {
sum(w * dpois(x=y, lambda=mu, log=TRUE))
}
},
- vfamily="poissonqn",
- deriv=eval(substitute(expression({
+ vfamily = "poissonqn",
+ deriv = eval(substitute(expression({
if (iter == 1) {
etanew = eta
} else {
@@ -707,13 +716,13 @@ poissonqn.control <- function(save.weight=TRUE, ...)
} else {
lambda <- mu
dl.dlambda <- (y-lambda) / lambda
- dlambda.deta <- dtheta.deta(theta=lambda, link= .link, earg= .earg)
+ dlambda.deta <- dtheta.deta(theta=lambda, link = .link, earg = .earg)
w * dl.dlambda * dlambda.deta
}
derivnew
- }), list( .link=link,
- .earg=earg ))),
- weight=eval(substitute(expression({
+ }), list( .link = link,
+ .earg = earg ))),
+ weight = eval(substitute(expression({
if ( .wwts == "qn") {
if (iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
@@ -742,8 +751,8 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}
}
wznew
- }), list( .wwts=wwts, .link=link,
- .earg=earg ))))
+ }), list( .wwts=wwts, .link = link,
+ .earg = earg ))))
}
@@ -752,7 +761,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
dexppoisson = function(lmean="loge", emean=list(),
ldispersion="logit", edispersion=list(),
idispersion=0.8,
- zero=NULL)
+ zero = NULL)
{
if (mode(lmean)!= "character" && mode(lmean)!= "name")
lmean = as.character(substitute(lmean))
@@ -764,16 +773,16 @@ poissonqn.control <- function(save.weight=TRUE, ...)
if (!is.list(edispersion)) edispersion = list()
new("vglmff",
- blurb=c("Double Exponential Poisson distribution\n\n",
+ 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 = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), 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
@@ -784,57 +793,58 @@ poissonqn.control <- function(save.weight=TRUE, ...)
"mu"
}
predictors.names =
- c(namesof(dn2, link= .lmean, earg= .emean, short=TRUE),
- namesof("dispersion", link= .ldispersion,
- earg= .edispersion, short=TRUE))
+ 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),
+ 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({
+ 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 {
+ }), 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)
+ }, 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)
+ 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({
+ }), 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 ))))
+ }), list( .lmean = lmean, .emean = emean,
+ .ldispersion = ldispersion, .edispersion = edispersion ))))
}
@@ -854,15 +864,19 @@ poissonqn.control <- function(save.weight=TRUE, ...)
if (!is.list(edispersion)) edispersion = list()
new("vglmff",
- blurb=c("Double Exponential Binomial distribution\n\n",
+ 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 = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ if (!all(w == 1))
+ extra$orig.w = w
+
+
if (ncol(cbind(w)) != 1)
stop("'weights' must be a vector or a one-column matrix")
@@ -872,7 +886,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
if (NCOL(y) == 1) {
if (is.factor(y)) y = y != levels(y)[1]
- nn = rep(1, n)
+ nvec = 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)
@@ -882,10 +896,10 @@ poissonqn.control <- function(save.weight=TRUE, ...)
} else if (NCOL(y) == 2) {
if (any(abs(y - round(y)) > 0.001))
stop("Count data must be integer-valued")
- nn = y[,1] + y[,2]
- y = ifelse(nn > 0, y[,1]/nn, 0)
- w = w * nn
- init.mu = (0.5 + nn * y) / (1 + nn)
+ nvec = y[,1] + y[,2]
+ y = ifelse(nvec > 0, y[,1] / nvec, 0)
+ w = w * nvec
+ init.mu = (0.5 + nvec * y) / (1 + nvec)
} else
stop("Response not of the right form")
@@ -897,43 +911,44 @@ poissonqn.control <- function(save.weight=TRUE, ...)
"mu"
}
predictors.names =
- c(namesof(dn2, link= .lmean, earg= .emean, short=TRUE),
- namesof("dispersion", link= .ldispersion,
- earg= .edispersion, short=TRUE))
+ 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),
+ 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({
+ 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)
+ 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)
@@ -941,26 +956,26 @@ poissonqn.control <- function(save.weight=TRUE, ...)
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,
+ 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({
+ }), 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 ))))
+ }), list( .lmean = lmean, .emean = emean,
+ .ldispersion = ldispersion, .edispersion = edispersion ))))
}
- mbinomial = function(mvar=NULL, link="logit", earg=list(),
+ mbinomial = function(mvar = NULL, link = "logit", earg = list(),
parallel = TRUE, smallno = .Machine$double.eps^(3/4))
{
if (mode(link )!= "character" && mode(link )!= "name")
@@ -979,9 +994,9 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}
new("vglmff",
- blurb= c("Matched binomial model (intercepts fitted)\n\n",
- "Link: ", namesof("mu[,j]", link, earg= earg)),
- constraints=eval(substitute(expression({
+ blurb = c("Matched binomial model (intercepts fitted)\n\n",
+ "Link: ", namesof("mu[,j]", link, earg = earg)),
+ constraints = eval(substitute(expression({
constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints,
intercept.apply=TRUE)
constraints[[extra$mvar]] <- diag(M)
@@ -991,8 +1006,11 @@ poissonqn.control <- function(save.weight=TRUE, ...)
specialCM[[1]][[ii]] = (constraints[[extra$mvar]])[,1+ii,drop=FALSE]
}
names(specialCM) = extra$mvar
- }), list( .parallel=parallel ))),
- initialize=eval(substitute(expression({
+ }), list( .parallel = parallel ))),
+ initialize = eval(substitute(expression({
+ if (!all(w == 1))
+ extra$orig.w = w
+
mvar = .mvar
NCOL = function (x)
@@ -1001,7 +1019,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
if (NCOL(y) == 1) {
if (is.factor(y)) y = y != levels(y)[1]
- nn = rep(1, n)
+ nvec = rep(1, n)
if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
mustart = (0.5 + w * y) / (1 + w)
@@ -1011,10 +1029,10 @@ poissonqn.control <- function(save.weight=TRUE, ...)
} else if (NCOL(y) == 2) {
if (any(abs(y - round(y)) > 0.001))
stop("Count data must be integer-valued")
- nn = y[,1] + y[,2]
- y = ifelse(nn > 0, y[,1]/nn, 0)
- w = w * nn
- mustart = (0.5 + nn * y) / (1 + nn)
+ nvec = y[,1] + y[,2]
+ y = ifelse(nvec > 0, y[,1] / nvec, 0)
+ w = w * nvec
+ mustart = (0.5 + nvec * y) / (1 + nvec)
} else
stop("Response not of the right form")
@@ -1031,34 +1049,47 @@ poissonqn.control <- function(save.weight=TRUE, ...)
extra$mvar = mvar
extra$index9 = temp9
- predictors.names = namesof("mu", .link, earg= .earg, short=TRUE)
+ predictors.names = namesof("mu", .link, earg = .earg, short = TRUE)
predictors.names = rep(predictors.names, len=M)
- }), list( .link=link, .earg=earg, .mvar=mvar ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- mu = eta2theta(eta, link= .link, earg = .earg)
+ }), list( .link = link, .earg = earg, .mvar = mvar ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ mu = eta2theta(eta, link = .link, earg = .earg)
mu[cbind(1:extra$n, extra$index9)]
- }, list( .link=link, .earg = earg ))),
- last=eval(substitute(expression({
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
misc$link = rep( .link, length=M)
- names(misc$link) = if (M>1) paste("mu(matched set ",
+ names(misc$link) = if (M > 1) paste("mu(matched set ",
1:M, ")", sep="") else "mu"
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M) misc$earg[[ii]] = .earg
misc$expected = TRUE
- }), list( .link=link, .earg = earg ))),
- link=eval(substitute(function(mu, extra=NULL) {
+ }), list( .link = link, .earg = earg ))),
+ link = eval(substitute(function(mu, extra = NULL) {
temp = theta2eta(mu, .link, earg = .earg )
matrix(temp, extra$n, extra$M)
- }, list( .link=link, .earg = earg ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if (residuals) w*(y/mu - (1-y)/(1-mu)) else {
- sum(w*(y*log(mu) + (1-y)*log1p(-mu)))
+ }, 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 {
+
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dbinom(x = ycounts, size = nvec, prob = mu,
+ log = TRUE))
}
},
- vfamily=c("mbinomial", "vcategorical"),
- deriv=eval(substitute(expression({
+ vfamily = c("mbinomial", "vcategorical"),
+ deriv = eval(substitute(expression({
answer =
if ( .link == "logit") {
w * (y - mu)
@@ -1069,25 +1100,25 @@ poissonqn.control <- function(save.weight=TRUE, ...)
mu.use[mu.use > 1 - smallno] = 1 - smallno
-w * (y - mu) * log1p(-mu.use) / mu.use
} else
- w * dtheta.deta(mu, link= .link, earg = .earg )* (y/mu - 1)/(1-mu)
+ w * dtheta.deta(mu, link = .link, earg = .earg )* (y/mu - 1)/(1-mu)
result = matrix(0, n, M)
result[cbind(1:n, extra$index9)] = answer
result
- }), list( .link=link, .earg = earg ))),
- weight=eval(substitute(expression({
+ }), list( .link = link, .earg = earg ))),
+ weight = eval(substitute(expression({
tmp100 = mu*(1-mu)
answer = if ( .link == "logit") {
cbind(w * tmp100)
} else if ( .link == "cloglog") {
cbind(w * (1-mu.use) * (log1p(-mu.use))^2 / mu.use )
} else {
- cbind(w * dtheta.deta(mu, link= .link, earg = .earg)^2 / tmp100)
+ cbind(w * dtheta.deta(mu, link = .link, earg = .earg)^2 / tmp100)
}
result = matrix( .smallno, n, M)
result[cbind(1:n, extra$index9)] = answer
result
- }), list( .link=link, .earg = earg, .smallno=smallno ))))
+ }), list( .link = link, .earg = earg, .smallno = smallno ))))
}
@@ -1119,13 +1150,13 @@ mypool = function(x, index) {
new("vglmff",
- blurb= c("Matched binomial model (intercepts not fitted)\n\n",
- "Link: ", namesof("mu[,j]", link, earg= earg)),
- constraints=eval(substitute(expression({
+ blurb = c("Matched binomial model (intercepts not fitted)\n\n",
+ "Link: ", namesof("mu[,j]", link, earg = earg)),
+ constraints = eval(substitute(expression({
constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints,
intercept.apply=FALSE)
- }), list( .parallel=parallel ))),
- initialize=eval(substitute(expression({
+ }), list( .parallel = parallel ))),
+ initialize = eval(substitute(expression({
if (colnames(x)[1] == "(Intercept)")
stop("the model matrix must not have an intercept")
@@ -1135,7 +1166,7 @@ mypool = function(x, index) {
if (NCOL(y) == 1) {
if (is.factor(y)) y = y != levels(y)[1]
- nn = rep(1, n)
+ nvec = rep(1, n)
if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
mustart = (0.5 + w * y) / (1 + w)
@@ -1145,10 +1176,10 @@ mypool = function(x, index) {
} else if (NCOL(y) == 2) {
if (any(abs(y - round(y)) > 0.001))
stop("Count data must be integer-valued")
- nn = y[,1] + y[,2]
- y = ifelse(nn > 0, y[,1]/nn, 0)
- w = w * nn
- mustart = (0.5 + nn * y) / (1 + nn)
+ nvec = y[,1] + y[,2]
+ y = ifelse(nvec > 0, y[,1] / nvec, 0)
+ w = w * nvec
+ mustart = (0.5 + nvec * y) / (1 + nvec)
} else
stop("Response not of the right form")
@@ -1171,32 +1202,32 @@ mypool = function(x, index) {
extra$M = M
extra$rlex = xrle
extra$index9 = temp9
- predictors.names = namesof("mu", .link, earg= .earg, short=TRUE)
- }), list( .link=link, .earg=earg, .mvar=mvar ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
+ predictors.names = namesof("mu", .link, earg = .earg, short = TRUE)
+ }), list( .link = link, .earg = earg, .mvar = mvar ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
denominator = exp(eta)
numerator = mypool(denominator, extra$mvar)
numerator / denominator
- }, list( .link=link, .earg = earg ))),
- last=eval(substitute(expression({
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
misc$link = c(mu = .link)
misc$earg = list( mu = .earg )
misc$expected = TRUE
- }), list( .link=link, .earg = earg ))),
- loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ }), list( .link = link, .earg = earg ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (residuals) w*(y/mu - (1-y)/(1-mu)) else {
sum(w*(y*log(mu) + (1-y)*log1p(-mu)))
}
},
- vfamily=c("mbin", "vcategorical"),
- deriv=eval(substitute(expression({
+ vfamily = c("mbin", "vcategorical"),
+ deriv = eval(substitute(expression({
answer =
if ( .link == "logit") {
w * (y - mu)
} else stop("can only handle the logit link")
answer
- }), list( .link=link, .earg = earg ))),
- weight=eval(substitute(expression({
+ }), list( .link = link, .earg = earg ))),
+ weight = eval(substitute(expression({
tmp100 = mu*(1-mu)
answer = if ( .link == "logit") {
cbind(w * tmp100)
@@ -1205,7 +1236,7 @@ mypool = function(x, index) {
result = matrix( .smallno, n, M)
result[cbind(1:n, extra$index9)] = answer
result
- }), list( .link=link, .earg = earg, .smallno=smallno ))))
+ }), list( .link = link, .earg = earg, .smallno = smallno ))))
}
diff --git a/R/family.nonlinear.R b/R/family.nonlinear.R
index 0d1d4c5..db3415d 100644
--- a/R/family.nonlinear.R
+++ b/R/family.nonlinear.R
@@ -6,167 +6,164 @@
-vnonlinear.control <- function(save.weight=TRUE, ...)
+vnonlinear.control <- function(save.weight = TRUE, ...)
{
- list(save.weight=as.logical(save.weight)[1])
+ list(save.weight = as.logical(save.weight)[1])
}
-micmen <- function(rpar=0.001, divisor=10,
- init1=NULL, init2=NULL,
- link1="identity",
- link2="identity",
- earg1=list(),
- earg2=list(),
- dispersion=0,
- zero=NULL)
+micmen <- function(rpar = 0.001, divisor = 10,
+ init1 = NULL, init2 = NULL,
+ link1 = "identity", link2 = "identity",
+ earg1 = list(), earg2 = list(),
+ dispersion = 0, zero = NULL)
{
- estimated.dispersion <- dispersion==0
-
- if (mode(link1) != "character" && mode(link1) != "name")
- link1 <- as.character(substitute(link1))
- if (mode(link2) != "character" && mode(link2) != "name")
- link2 <- as.character(substitute(link2))
- if (!is.list(earg1)) earg1 = list()
- if (!is.list(earg2)) earg2 = list()
-
- new("vglmff",
- blurb=c("Michaelis-Menton regression model\n",
- "Y_i = theta1 * u_i / (theta2 + u_i) + e_i\n\n",
- "Links: ",
- namesof("theta1", link1, earg=earg1), ", ",
- namesof("theta2", link2, earg=earg2),
- "\n",
- "Variance: constant"),
- constraints=eval(substitute(expression({
- constraints <- cm.zero.vgam(constraints, x, .zero, M=2)
- }), list(.zero=zero))),
- deviance=function(mu, y, w, residuals=FALSE, eta, extra=NULL) {
- M <- if (is.matrix(y)) ncol(y) else 1
- if (residuals) {
- if (M>1) NULL else (y-mu) * sqrt(w)
- } else
- rss.vgam(y-mu, w, M=M)
- },
- initialize=eval(substitute(expression({
- if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
-
- if (!length(Xm2))
- stop("regressor not found")
- if (ncol(as.matrix(Xm2)) != 1)
- stop("regressor not found or is not a vector. Use the ",
- "'form2' argument without an intercept")
- Xm2 = as.vector(Xm2) # Make sure
- extra$Xm2 = Xm2 # Needed for @inverse
-
- predictors.names <-
- c(namesof("theta1", .link1, earg= .earg1, tag=FALSE),
- namesof("theta2", .link2, earg= .earg2, tag=FALSE))
-
- if (length(mustart) || length(coefstart))
- stop("cannot handle mustart or coefstart")
- if (!length(etastart)) {
- index <- (1:n)[Xm2>quantile(Xm2, prob=.85)]
- init1 <- median(y[index])
- init2 <- median(init1*Xm2/y - Xm2)
-
- if (length(.init1)) init1 = .init1
- if (length(.init2)) init2 = .init2
-
- etastart = cbind(
- rep(theta2eta(init1, .link1, earg= .earg1), len=n),
- rep(theta2eta(init2, .link2, earg= .earg2), len=n))
- } else {
- stop("cannot handle etastart or mustart")
- }
-
- }), list(.init1=init1, .init2=init2,
- .earg1=earg1, .earg2=earg2,
- .link1=link1, .link2=link2))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- theta1 <- eta2theta(eta[,1], .link1, earg= .earg1)
- theta2 <- eta2theta(eta[,2], .link2, earg= .earg2)
- theta1 * extra$Xm2 / (theta2 + extra$Xm2)
- }, list(.link1=link1, .link2=link2,
- .earg1=earg1, .earg2=earg2 ))),
- last=eval(substitute(expression({
- misc$link <- c(theta1= .link1, theta2= .link2)
- misc$earg = list(theta1= .earg1, theta2= .earg2 )
- misc$rpar <- rpar
- fit$df.residual <- n - rank # Not nrow_X_vlm - rank
- fit$df.total <- n # Not nrow_X_vlm
-
- extra$Xm2 = NULL # Regressor is in control$regressor
- dpar <- .dispersion
- if (!dpar) {
- dpar <- sum(w * (y-mu)^2) / (n - ncol_X_vlm)
- }
- misc$dispersion <- dpar
- misc$default.dispersion <- 0
- misc$estimated.dispersion <- .estimated.dispersion
- }), list(.link1=link1, .link2=link2, .dispersion=dispersion,
- .earg1=earg1, .earg2=earg2,
- .estimated.dispersion=estimated.dispersion))),
- summary.dispersion=FALSE,
- vfamily=c("micmen","vnonlinear"),
- deriv=eval(substitute(expression({
- if (iter>1) {
- rpar = max(rpar / .divisor, 1000 * .Machine$double.eps)
- } else {
- rpar = .rpar
- d3 = deriv3(~ theta1 * Xm2 / (theta2 + Xm2),
- c("theta1","theta2"), hessian=FALSE)
- }
-
- theta1 <- eta2theta(eta[,1], .link1, earg= .earg1)
- theta2 <- eta2theta(eta[,2], .link2, earg= .earg2)
-
- if (TRUE) {
- dmus.dthetas = attr(eval(d3), "gradient")
- } else {
- dmu.dtheta1 <- Xm2 / (theta2 + Xm2)
- dmu.dtheta2 <- -theta1 * Xm2 / (Xm2 + theta2)^2
- dmus.dthetas = cbind(dmu.dtheta1, dmu.dtheta2)
- }
-
- dthetas.detas = cbind(dtheta.deta(theta1, .link1, earg= .earg1),
- dtheta.deta(theta2, .link2, earg= .earg2))
-
- if (TRUE) {
- index = iam(NA, NA, M=M, both=TRUE)
- temp200809 = dmus.dthetas * dthetas.detas
- if (M>1)
- temp200809[,2:M] = temp200809[,2:M] + sqrt(rpar)
- w * (y-mu) * temp200809
- } else {
- w * (y-mu) *
- cbind(dmus.dthetas[,1] * dthetas.detas[,1],
- dmus.dthetas[,2] * dthetas.detas[,2] + sqrt(rpar))
- }
- }), list( .link1=link1, .link2=link2, .rpar=rpar,
- .earg1=earg1, .earg2=earg2,
- .divisor=divisor))),
- weight=eval(substitute(expression({
- if (TRUE) {
- wz = dmus.dthetas[,index$row] * dmus.dthetas[,index$col] *
- dthetas.detas[,index$row] * dthetas.detas[,index$col]
- if (M > 1)
- wz[,2:M] = wz[,2:M] + rpar
- } else {
- wz = cbind((dmus.dthetas[,1] * dthetas.detas[,1])^2,
- (dmus.dthetas[,2] * dthetas.detas[,2])^2 + rpar,
- dmus.dthetas[,1] * dmus.dthetas[,2] *
- dthetas.detas[,1] * dthetas.detas[,2])
- }
- w * wz
- }), list( .link1=link1, .link2=link2 ))))
+ estimated.dispersion <- dispersion == 0
+
+ if (mode(link1) != "character" && mode(link1) != "name")
+ link1 <- as.character(substitute(link1))
+ if (mode(link2) != "character" && mode(link2) != "name")
+ link2 <- as.character(substitute(link2))
+ if (!is.list(earg1)) earg1 = list()
+ if (!is.list(earg2)) earg2 = list()
+
+ new("vglmff",
+ blurb = c("Michaelis-Menton regression model\n",
+ "Y_i = theta1 * u_i / (theta2 + u_i) + e_i\n\n",
+ "Links: ",
+ namesof("theta1", link1, earg = earg1), ", ",
+ namesof("theta2", link2, earg = earg2),
+ "\n",
+ "Variance: constant"),
+ constraints = eval(substitute(expression({
+ constraints <- cm.zero.vgam(constraints, x, .zero, M = 2)
+ }), list(.zero = zero))),
+ deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ M <- if (is.matrix(y)) ncol(y) else 1
+ if (residuals) {
+ if (M > 1) NULL else (y-mu) * sqrt(w)
+ } else
+ rss.vgam(y-mu, w, M = M)
+ },
+ initialize = eval(substitute(expression({
+ if (ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+
+ if (!length(Xm2))
+ stop("regressor not found")
+ if (ncol(as.matrix(Xm2)) != 1)
+ stop("regressor not found or is not a vector. Use the ",
+ "'form2' argument without an intercept")
+ Xm2 <- as.vector(Xm2) # Make sure
+ extra$Xm2 <- Xm2 # Needed for @inverse
+
+ predictors.names <-
+ c(namesof("theta1", .link1, earg = .earg1, tag = FALSE),
+ namesof("theta2", .link2, earg = .earg2, tag = FALSE))
+
+ if (length(mustart) || length(coefstart))
+ stop("cannot handle 'mustart' or 'coefstart'")
+ if (!length(etastart)) {
+ index <- (1:n)[Xm2 > quantile(Xm2, prob = 0.85)]
+ init1 <- median(y[index])
+ init2 <- median(init1 * Xm2 / y - Xm2)
+
+ if (length(.init1)) init1 = .init1
+ if (length(.init2)) init2 = .init2
+
+ etastart <- cbind(
+ rep(theta2eta(init1, .link1, earg = .earg1), len = n),
+ rep(theta2eta(init2, .link2, earg = .earg2), len = n))
+ } else {
+ stop("cannot handle 'etastart' or 'mustart'")
+ }
+
+ }), list(.init1 = init1, .init2 = init2,
+ .earg1 = earg1, .earg2 = earg2,
+ .link1 = link1, .link2 = link2))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ theta1 <- eta2theta(eta[,1], .link1, earg = .earg1)
+ theta2 <- eta2theta(eta[,2], .link2, earg = .earg2)
+ theta1 * extra$Xm2 / (theta2 + extra$Xm2)
+ }, list(.link1 = link1, .link2 = link2,
+ .earg1 = earg1, .earg2 = earg2 ))),
+ last = eval(substitute(expression({
+ misc$link <- c(theta1 = .link1, theta2 = .link2)
+ misc$earg <- list(theta1 = .earg1, theta2 = .earg2 )
+ misc$rpar <- rpar
+ fit$df.residual <- n - rank # Not nrow_X_vlm - rank
+ fit$df.total <- n # Not nrow_X_vlm
+
+ extra$Xm2 <- NULL # Regressor is in control$regressor
+ dpar <- .dispersion
+ if (!dpar) {
+ dpar <- sum(w * (y-mu)^2) / (n - ncol_X_vlm)
+ }
+ misc$dispersion <- dpar
+ misc$default.dispersion <- 0
+ misc$estimated.dispersion <- .estimated.dispersion
+ }), list(.link1 = link1, .link2 = link2, .dispersion = dispersion,
+ .earg1 = earg1, .earg2 = earg2,
+ .estimated.dispersion = estimated.dispersion))),
+ summary.dispersion = FALSE,
+ vfamily = c("micmen","vnonlinear"),
+ deriv = eval(substitute(expression({
+ if (iter > 1) {
+ rpar <- max(rpar / .divisor, 1000 * .Machine$double.eps)
+ } else {
+ rpar <- .rpar
+ d3 <- deriv3(~ theta1 * Xm2 / (theta2 + Xm2),
+ c("theta1", "theta2"), hessian = FALSE)
+ }
+
+ theta1 <- eta2theta(eta[,1], .link1, earg = .earg1)
+ theta2 <- eta2theta(eta[,2], .link2, earg = .earg2)
+
+ if (TRUE) {
+ dmus.dthetas <- attr(eval(d3), "gradient")
+ } else {
+ dmu.dtheta1 <- Xm2 / (theta2 + Xm2)
+ dmu.dtheta2 <- -theta1 * Xm2 / (Xm2 + theta2)^2
+ dmus.dthetas <- cbind(dmu.dtheta1, dmu.dtheta2)
+ }
+
+ dthetas.detas <- cbind(dtheta.deta(theta1, .link1, earg = .earg1),
+ dtheta.deta(theta2, .link2, earg = .earg2))
+
+ if (TRUE) {
+ index <- iam(NA, NA, M = M, both = TRUE)
+ temp200809 <- dmus.dthetas * dthetas.detas
+ if (M > 1)
+ temp200809[,2:M] <- temp200809[,2:M] + sqrt(rpar)
+ w * (y-mu) * temp200809
+ } else {
+ w * (y-mu) *
+ cbind(dmus.dthetas[,1] * dthetas.detas[,1],
+ dmus.dthetas[,2] * dthetas.detas[,2] + sqrt(rpar))
+ }
+ }), list( .link1 = link1, .link2 = link2, .rpar = rpar,
+ .earg1 = earg1, .earg2 = earg2,
+ .divisor = divisor))),
+ weight = eval(substitute(expression({
+ if (TRUE) {
+ wz <- dmus.dthetas[,index$row] * dmus.dthetas[,index$col] *
+ dthetas.detas[,index$row] * dthetas.detas[,index$col]
+ if (M > 1)
+ wz[,2:M] <- wz[,2:M] + rpar
+ } else {
+ wz <- cbind(( dmus.dthetas[,1] * dthetas.detas[,1])^2,
+ ( dmus.dthetas[,2] * dthetas.detas[,2])^2 + rpar,
+ dmus.dthetas[,1] * dmus.dthetas[,2] *
+ dthetas.detas[,1] * dthetas.detas[,2])
+ }
+ w * wz
+ }), list( .link1 = link1, .link2 = link2 ))))
}
diff --git a/R/family.positive.R b/R/family.positive.R
index d9d22e2..217b2b8 100644
--- a/R/family.positive.R
+++ b/R/family.positive.R
@@ -44,8 +44,8 @@ pposnegbin = function(q, size, prob=NULL, munb=NULL) {
L = max(length(q), length(prob), length(size))
q = rep(q, len=L); prob = rep(prob, len=L); size = rep(size, len=L);
- ifelse(q<1, 0, (pnbinom(q, size=size, prob=prob) -
- dnbinom(q*0, size=size, prob=prob)) / pnbinom(q*0,
+ ifelse(q < 1, 0, (pnbinom(q, size=size, prob=prob) -
+ dnbinom(q*0, size=size, prob=prob)) / pnbinom(q*0,
size=size, prob=prob, lower.tail = FALSE))
}
@@ -275,9 +275,10 @@ dpospois = function(x, lambda, log=FALSE) {
L = max(length(x), length(lambda))
x = rep(x, len=L); lambda = rep(lambda, len=L);
ans = if (log.arg) {
- ifelse(x==0, log(0.0), dpois(x, lambda, log=TRUE) - log1p(-exp(-lambda)))
+ ifelse(x == 0, log(0.0), dpois(x, lambda, log=TRUE) -
+ log1p(-exp(-lambda)))
} else {
- ifelse(x==0, 0, -dpois(x, lambda) / expm1(-lambda))
+ ifelse(x == 0, 0, -dpois(x, lambda) / expm1(-lambda))
}
ans
}
@@ -288,7 +289,7 @@ ppospois = function(q, lambda) {
stop("bad input for argument 'lambda'")
L = max(length(q), length(lambda))
q = rep(q, len=L); lambda = rep(lambda, len=L);
- ifelse(q<1, 0, (ppois(q, lambda) - exp(-lambda)) / (-expm1(-lambda)))
+ ifelse(q < 1, 0, (ppois(q, lambda) - exp(-lambda)) / (-expm1(-lambda)))
}
qpospois = function(p, lambda) {
@@ -346,7 +347,7 @@ rpospois = function(n, lambda) {
if (any(y != round(y )))
stop("the response must be integer-valued")
- predictors.names = namesof(if(ncol(y)==1) "lambda"
+ predictors.names = namesof(if(ncol(y) == 1) "lambda"
else paste("lambda", 1:ncol(y), sep=""), .link,
earg= .earg, tag=FALSE)
if ( .method.init == 1) {
@@ -359,19 +360,19 @@ rpospois = function(n, lambda) {
lambda.init = -y / expm1(-y)
}
if (length( .ilambda))
- lambda.init = lambda.init*0 + .ilambda
+ lambda.init = lambda.init * 0 + .ilambda
if (!length(etastart))
etastart = theta2eta(lambda.init, .link, earg= .earg)
- }), list( .link=link, .earg= earg,
- .ilambda=ilambda, .method.init=method.init ))),
+ }), list( .link = link, .earg = earg,
+ .ilambda = ilambda, .method.init = method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- lambda = eta2theta(eta, .link, earg= .earg )
+ lambda = eta2theta(eta, .link, earg = .earg )
-lambda / expm1(-lambda)
}, list( .link=link, .earg= earg ))),
last=eval(substitute(expression({
misc$expected = .expected
misc$link = rep( .link, len=M)
- names(misc$link) = if (M==1) "lambda" else paste("lambda", 1:M, sep="")
+ names(misc$link) = if (M == 1) "lambda" else paste("lambda", 1:M, sep="")
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M)
@@ -381,28 +382,28 @@ rpospois = function(n, lambda) {
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 * dpospois(x=y, lambda=lambda, log=TRUE))
+ sum(w * dpospois(x = y, lambda = lambda, log = TRUE))
}
- }, list( .link=link, .earg= earg ))),
+ }, list( .link = link, .earg = earg ))),
vfamily=c("pospoisson"),
deriv=eval(substitute(expression({
lambda = eta2theta(eta, .link, earg= .earg )
- temp = exp(lambda)
- dl.dlambda = y/lambda - 1 - 1/(temp-1)
- dlambda.deta = dtheta.deta(lambda, .link, earg= .earg )
+ temp6 = expm1(lambda)
+ dl.dlambda = y/lambda - 1 - 1 / temp6
+ dlambda.deta = dtheta.deta(lambda, .link, earg = .earg )
w * dl.dlambda * dlambda.deta
- }), list( .link=link, .earg= earg ))),
+ }), list( .link = link, .earg = earg ))),
weight=eval(substitute(expression({
if ( .expected ) {
- ed2l.dlambda2 = temp * (1/lambda - 1/(temp-1)) / (temp-1)
+ ed2l.dlambda2 = (temp6 + 1) * (1/lambda - 1/temp6) / temp6
wz = (dlambda.deta^2) * ed2l.dlambda2
} else {
- d2l.dlambda2 = y/lambda^2 - temp/(temp-1)^2
- d2lambda.deta2 = d2theta.deta2(lambda, .link, earg=.earg)
+ d2l.dlambda2 = y / lambda^2 - (temp6 + 1) / temp6^2
+ d2lambda.deta2 = d2theta.deta2(lambda, .link, earg = .earg)
wz = (dlambda.deta^2) * d2l.dlambda2 - dl.dlambda * d2lambda.deta2
}
w * wz
- }), list( .link=link, .earg= earg, .expected=expected ))))
+ }), list( .link = link, .earg = earg, .expected = expected ))))
}
@@ -442,7 +443,7 @@ rpospois = function(n, lambda) {
}), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
- yint = round(y*w)
+ yint = round(y * w)
mymu = eta2theta(eta, .link, earg= .earg )
if (max(abs(w - round(w))) > 0.0001) {
warning("rounding w to an integer")
@@ -454,10 +455,10 @@ rpospois = function(n, lambda) {
}, list( .link=link, .earg=earg ))),
vfamily=c("posbinomial"),
deriv=eval(substitute(expression({
- yint = round(y*w)
+ yint = round(y * w)
mymu = eta2theta(eta, .link, earg= .earg )
- dl.dmymu = yint/mymu - (w-yint)/(1-mymu) -
- w*(1-mymu)^(w-1) / (1-(1-mymu)^w)
+ dl.dmymu = yint / mymu - (w-yint) / (1-mymu) -
+ w * (1-mymu)^(w-1) / (1-(1-mymu)^w)
dmymu.deta = dtheta.deta(mymu, .link, earg= .earg )
dl.dmymu * dmymu.deta
}), list( .link=link, .earg=earg ))),
@@ -500,7 +501,7 @@ pposbinom = function(q, size, prob, lower.tail = TRUE, log.p = FALSE) {
stop("no zero or non-numeric values allowed for argument 'prob'")
L = max(length(q), length(size), length(prob))
q = rep(q, len=L); size = rep(size, len=L); prob = rep(prob, len=L);
- ifelse(q<1, 0, (pbinom(q=q, size=size, prob=prob, lower.tail=lower.tail,
+ ifelse(q < 1, 0, (pbinom(q=q, size=size, prob=prob, lower.tail=lower.tail,
log.p=log.p) - (1-prob)^size) / (1 - (1-prob)^size))
}
diff --git a/R/family.qreg.R b/R/family.qreg.R
index 7a02894..e4a98ea 100644
--- a/R/family.qreg.R
+++ b/R/family.qreg.R
@@ -11,6 +11,10 @@
+
+
+
+
lms.bcn.control <-
lms.bcg.control <-
lms.yjn.control <- function(trace=TRUE, ...)
@@ -20,7 +24,7 @@ lms.yjn.control <- function(trace=TRUE, ...)
-lms.bcn <- function(percentiles=c(25,50,75),
+ lms.bcn <- function(percentiles=c(25,50,75),
zero=c(1,3),
llambda="identity",
lmu="identity",
@@ -29,7 +33,7 @@ lms.bcn <- function(percentiles=c(25,50,75),
dfmu.init=4,
dfsigma.init=2,
ilambda=1,
- isigma=NULL)
+ isigma=NULL, expectiles = FALSE)
{
if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
@@ -44,14 +48,16 @@ lms.bcn <- function(percentiles=c(25,50,75),
stop("bad input for argument 'ilambda'")
if (length(isigma) && !is.Numeric(isigma, posit=TRUE))
stop("bad input for argument 'isigma'")
+ if (length(expectiles) != 1 || !is.logical(expectiles))
+ stop("bad input for argument 'expectiles'")
new("vglmff",
- blurb=c("LMS Quantile Regression ",
- "(Box-Cox transformation to normality)\n",
+ blurb=c("LMS ", if (expectiles) "Expectile" else "Quantile",
+ " Regression (Box-Cox transformation to normality)\n",
"Links: ",
namesof("lambda", link=llambda, earg= elambda), ", ",
- namesof("mu", link=lmu, earg= emu), ", ",
- namesof("sigma", link=lsigma, earg= esigma)),
+ namesof("mu", link=lmu, earg= emu), ", ",
+ namesof("sigma", link=lsigma, earg= esigma)),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
@@ -95,30 +101,40 @@ lms.bcn <- function(percentiles=c(25,50,75),
eta[,1] = eta2theta(eta[,1], .llambda, earg= .elambda)
eta[,2] = eta2theta(eta[,2], .lmu, earg= .emu)
eta[,3] = eta2theta(eta[,3], .lsigma, earg= .esigma)
- qtplot.lms.bcn(percentiles= .percentiles, eta=eta)
+ if ( .expectiles ) {
+ explot.lms.bcn(percentiles= .percentiles, eta=eta)
+ } else {
+ qtplot.lms.bcn(percentiles= .percentiles, eta=eta)
+ }
}, list( .llambda=llambda, .lmu=lmu, .lsigma=lsigma,
.elambda=elambda, .emu=emu, .esigma=esigma,
- .percentiles=percentiles ))),
+ .percentiles=percentiles, .expectiles = expectiles ))),
last=eval(substitute(expression({
misc$percentiles = .percentiles
misc$links = c(lambda = .llambda, mu = .lmu, sigma = .lsigma)
misc$earg = list(lambda = .elambda, mu = .emu, sigma = .esigma)
misc$true.mu = FALSE # $fitted is not a true mu
+ misc$expectiles = .expectiles
if (control$cdf) {
post$cdf = cdf.lms.bcn(y, eta0=matrix(c(lambda,mymu,sigma),
ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
}
}), list( .llambda=llambda, .lmu=lmu, .lsigma=lsigma,
.elambda=elambda, .emu=emu, .esigma=esigma,
- .percentiles=percentiles ))),
+ .percentiles=percentiles, .expectiles = expectiles ))),
loglikelihood=eval(substitute(
function(mu,y,w, residuals= FALSE, eta, extra=NULL) {
lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
mu = eta2theta(eta[,2], .lmu, earg= .emu)
sigma = eta2theta(eta[,3], .lsigma, earg= .esigma)
- z = ((y/mu)^lambda - 1) / (lambda * sigma)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (lambda * log(y/mu) - log(sigma) - 0.5*z^2))
+ zedd = ((y/mu)^lambda - 1) / (lambda * sigma)
+ if (residuals) stop("loglikelihood residuals not implemented") else {
+ use.this = (lambda * log(y / mu) - log(sigma) - log(y) +
+ dnorm(zedd, log = TRUE))
+ use.this[abs(lambda) < 0.001] = (-log(y / mu) - log(sigma) +
+ dnorm(zedd, log = TRUE))[abs(lambda) < 0.001]
+ sum(w * use.this)
+ }
}, list( .llambda=llambda, .lmu=lmu, .lsigma=lsigma,
.elambda=elambda, .emu=emu, .esigma=esigma ))),
vfamily=c("lms.bcn", "lmscreg"),
@@ -126,10 +142,11 @@ lms.bcn <- function(percentiles=c(25,50,75),
lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
mymu = eta2theta(eta[,2], .lmu, earg= .emu)
sigma = eta2theta(eta[,3], .lsigma, earg= .esigma)
- z = ((y/mymu)^lambda - 1) / (lambda * sigma)
- z2m1 = z * z - 1
- dl.dlambda = z*(z - log(y/mymu) / sigma) / lambda - z2m1 * log(y/mymu)
- dl.dmu = z / (mymu * sigma) + z2m1 * lambda / mymu
+ zedd = ((y/mymu)^lambda - 1) / (lambda * sigma)
+ z2m1 = zedd * zedd - 1
+ dl.dlambda = zedd*(zedd - log(y/mymu) / sigma) / lambda -
+ z2m1 * log(y/mymu)
+ dl.dmu = zedd / (mymu * sigma) + z2m1 * lambda / mymu
dl.dsigma = z2m1 / sigma
dlambda.deta = dtheta.deta(lambda, .llambda, earg= .elambda)
dmu.deta = dtheta.deta(mymu, .lmu, earg= .emu)
@@ -154,7 +171,7 @@ lms.bcn <- function(percentiles=c(25,50,75),
-lms.bcg = function(percentiles=c(25,50,75),
+ lms.bcg = function(percentiles=c(25,50,75),
zero=c(1,3),
llambda="identity",
lmu="identity",
@@ -252,26 +269,27 @@ lms.bcg = function(percentiles=c(25,50,75),
lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
mu = eta2theta(eta[,2], .lmu, earg= .emu)
sigma = eta2theta(eta[,3], .lsigma, earg= .esigma)
- g = (y/mu)^lambda
+ Gee = (y / mu)^lambda
theta = 1 / (sigma * lambda)^2
if (residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (log(abs(lambda)) + theta*(log(theta)+log(g)-g) -
- lgamma(theta) - log(y)))
+ sum(w * (log(abs(lambda)) + theta * (log(theta) +
+ log(Gee)-Gee) - lgamma(theta) - log(y)))
}, list( .llambda=llambda, .lmu=lmu, .lsigma=lsigma,
.elambda=elambda, .emu=emu, .esigma=esigma ))),
vfamily=c("lms.bcg", "lmscreg"),
deriv=eval(substitute(expression({
lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
- mymu = eta2theta(eta[,2], .lmu, earg= .emu)
- sigma = eta2theta(eta[,3], .lsigma, earg= .esigma)
+ mymu = eta2theta(eta[,2], .lmu, earg= .emu)
+ sigma = eta2theta(eta[,3], .lsigma, earg= .esigma)
- g = (y/mymu)^lambda
+ Gee = (y / mymu)^lambda
theta = 1 / (sigma * lambda)^2
dd = digamma(theta)
- dl.dlambda = (1 + 2*theta*(dd+g-1-log(theta)-0.5*(g+1)*log(g)))/lambda
- dl.dmu = lambda * theta * (g-1) / mymu
- dl.dsigma = 2*theta*(dd+g-log(theta * g)-1) / sigma
+ dl.dlambda = (1 + 2 * theta * (dd + Gee -1 -log(theta) -
+ 0.5 * (Gee + 1) * log(Gee))) / lambda
+ dl.dmu = lambda * theta * (Gee-1) / mymu
+ dl.dsigma = 2*theta*(dd + Gee - log(theta * Gee)-1) / sigma
dlambda.deta = dtheta.deta(lambda, link=.llambda, earg= .elambda)
dmu.deta = dtheta.deta(mymu, link=.lmu, earg= .emu)
dsigma.deta = dtheta.deta(sigma, link=.lsigma, earg= .esigma)
@@ -290,20 +308,20 @@ lms.bcg = function(percentiles=c(25,50,75),
wz[,iam(1,1,M)] = ((1 + theta*(tritheta*(1+4*theta) -
4*(1+1/theta) - log(theta)*(2/theta -
log(theta)) + dd*part2)) / lambda^2) *
- dlambda.deta^2
+ dlambda.deta^2
} else {
- temp = mean( g*(log(g))^2 )
- wz[,iam(1,1,M)] = ((4*theta*(theta*tritheta-1) -1 +
- theta*temp)/lambda^2) *
- dlambda.deta^2
+ temp = mean( Gee*(log(Gee))^2 )
+ wz[,iam(1,1,M)] = ((4 * theta * (theta * tritheta-1) - 1 +
+ theta*temp) / lambda^2) * dlambda.deta^2
}
- wz[,iam(2,2,M)] = dmu.deta^2 / (mymu*sigma)^2
- wz[,iam(3,3,M)] = (4*theta*(theta*tritheta-1)/sigma^2) * dsigma.deta^2
- wz[,iam(1,2,M)] = (-theta * (dd + 1/theta - log(theta)) / mymu) *
+ wz[,iam(2,2,M)] = dmu.deta^2 / (mymu * sigma)^2
+ wz[,iam(3,3,M)] = (4 * theta * (theta * tritheta - 1) / sigma^2) *
+ dsigma.deta^2
+ wz[,iam(1,2,M)] = (-theta * (dd + 1 / theta - log(theta)) / mymu) *
dlambda.deta * dmu.deta
wz[,iam(1,3,M)] = 2 * theta^1.5 * (2 * theta * tritheta - 2 -
- 1/theta) * dlambda.deta * dsigma.deta
+ 1 / theta) * dlambda.deta * dsigma.deta
wz * w
}), list( .llambda=llambda, .lmu=lmu, .lsigma=lsigma,
.elambda=elambda, .emu=emu, .esigma=esigma ))))
@@ -324,7 +342,7 @@ dyj.dy.yeojohnson = function(y, lambda) {
ifelse(y>0, (1 + y)^(lambda - 1), (1 - y)^(1 - lambda))
}
-yeo.johnson = function(y, lambda, derivative=0,
+ yeo.johnson = function(y, lambda, derivative=0,
epsilon=sqrt(.Machine$double.eps), inverse= FALSE)
{
@@ -536,7 +554,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
list(save.weight=save.weight)
}
-lms.yjn2 = function(percentiles=c(25,50,75),
+ lms.yjn2 = function(percentiles=c(25,50,75),
zero=c(1,3),
llambda="identity",
lmu="identity",
@@ -722,7 +740,7 @@ lms.yjn2 = function(percentiles=c(25,50,75),
}
-lms.yjn <- function(percentiles=c(25,50,75),
+ lms.yjn <- function(percentiles=c(25,50,75),
zero=c(1,3),
llambda="identity",
lsigma="loge",
@@ -1033,7 +1051,7 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
M <- length(extra$w.aml)
- if (M > 1) y = matrix(y,extra$n,extra$M)
+ if (M > 1) y = matrix(y, extra$n, extra$M)
devi = cbind((y - mu)^2)
if (residuals) {
@@ -1043,8 +1061,9 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
} else {
all.deviances = numeric(M)
myresid = matrix(y,extra$n,extra$M) - cbind(mu)
- for(ii in 1:M) all.deviances[ii] = sum(w * devi[,ii] *
- Wr1(myresid[,ii], w=extra$w.aml[ii]))
+ for(ii in 1:M)
+ all.deviances[ii] = sum(w * devi[,ii] *
+ Wr1(myresid[,ii], w=extra$w.aml[ii]))
}
if (is.logical(extra$individual) && extra$individual)
all.deviances else sum(all.deviances)
@@ -1052,10 +1071,10 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- amlnormal <- function(w.aml=1, parallel=FALSE,
+ amlnormal <- function(w.aml = 1, parallel = FALSE,
lexpectile = "identity", eexpectile = list(),
iexpectile = NULL,
- method.init=1, digw=4)
+ method.init = 1, digw = 4)
{
@@ -1124,14 +1143,18 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
misc$parallel = .parallel
misc$expected = TRUE
extra$percentile = numeric(M)
- for(ii in 1:M)
- extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, w)
+ for(ii in 1:M) {
+ use.w = if (M > 1 && ncol(cbind(w)) == M) w[, ii] else w
+ extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, use.w)
+ }
names(extra$percentile) = names(misc$link)
extra$individual = TRUE
- extra$deviance = amlnormal.deviance(mu=mu, y=y, w=w, residuals=FALSE,
- eta=eta, extra=extra)
- names(extra$deviance) = extra$y.names
+ if (!(M > 1 && ncol(cbind(w)) == M)) {
+ extra$deviance = amlnormal.deviance(mu=mu, y=y, w=w,
+ residuals=FALSE, eta=eta, extra=extra)
+ names(extra$deviance) = extra$y.names
+ }
}), list( .lexpectile=lexpectile, .eexpectile=eexpectile,
.parallel=parallel ))),
vfamily=c("amlnormal"),
@@ -1182,8 +1205,8 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
}
-amlpoisson <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
- link="loge", earg=list())
+ amlpoisson <- function(w.aml = 1, parallel = FALSE, method.init = 1,
+ digw = 4, link = "loge", earg = list())
{
if (!is.Numeric(w.aml, posit=TRUE))
stop("'w.aml' must be a vector of positive values")
@@ -1313,8 +1336,8 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
}
-amlbinomial <- function(w.aml=1, parallel=FALSE, digw=4,
- link="logit", earg=list())
+ amlbinomial <- function(w.aml = 1, parallel= FALSE, digw = 4,
+ link = "logit", earg = list())
{
if (!is.Numeric(w.aml, posit=TRUE))
stop("'w.aml' must be a vector of positive values")
@@ -1451,8 +1474,8 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL)
}
-amlexponential <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
- link="loge", earg=list())
+ amlexponential <- function(w.aml = 1, parallel = FALSE, method.init = 1,
+ digw = 4, link = "loge", earg = list())
{
if (!is.Numeric(w.aml, posit=TRUE))
stop("'w.aml' must be a vector of positive values")
diff --git a/R/family.rrr.R b/R/family.rrr.R
index 2196a74..60b0feb 100644
--- a/R/family.rrr.R
+++ b/R/family.rrr.R
@@ -13,7 +13,7 @@ replace.constraints = function(Blist, cm, index) {
}
-valt.control <- function(
+ valt.control <- function(
Alphavec=c(2, 4, 6, 9, 12, 16, 20, 25, 30, 40, 50,
60, 80, 100, 125, 2^(8:12)),
Criterion = c("rss", "coefficients"),
@@ -55,7 +55,10 @@ qrrvglm.xprod = function(numat, Aoffset, Quadratic, ITolerances) {
}
-valt <- function(x, z, U, Rank=1,
+
+
+
+ valt <- function(x, z, U, Rank=1,
Blist=NULL,
Cinit=NULL,
Alphavec=c(2, 4, 6, 9, 12, 16, 20, 25, 30, 40, 50,
@@ -76,13 +79,15 @@ valt <- function(x, z, U, Rank=1,
+
+
if (mode(Criterion) != "character" && mode(Criterion) != "name")
Criterion <- as.character(substitute(Criterion))
Criterion <- match.arg(Criterion, c("rss", "coefficients"))[1]
if (any(diff(Alphavec) <= 0))
- stop("Alphavec must be an increasing sequence")
+ stop("'Alphavec' must be an increasing sequence")
if (!is.matrix(z))
z <- as.matrix(z)
@@ -91,11 +96,14 @@ valt <- function(x, z, U, Rank=1,
if (!is.matrix(x))
x <- as.matrix(x)
- colx2.index = (1:ncol(x))[-colx1.index]
+ colx2.index = if (is.null(colx1.index)) 1:ncol(x) else
+ (1:ncol(x))[-colx1.index]
+
p1 = length(colx1.index)
p2 = length(colx2.index)
p = p1 + p2
- if (!p2) stop("p2, the dimension of vars for reduced-rank regn, must be > 0")
+ if (!p2) stop("'p2', the number of variables for the ",
+ "reduced-rank regression, must be > 0")
if (!length(Blist)) {
Blist = replace.constraints(vector("list", p), diag(M), 1:p)
@@ -105,17 +113,18 @@ valt <- function(x, z, U, Rank=1,
if (dU[2] != n)
stop("input unconformable")
- cmat2 = replace.constraints(vector("list", Rank+p1),
- if (length(Structural.zero))
- diag(M)[,-Structural.zero,drop=FALSE] else diag(M), 1:Rank)
- if (p1)
+ clist2 = replace.constraints(vector("list", Rank+p1),
+ if (length(Structural.zero))
+ diag(M)[,-Structural.zero,drop=FALSE] else diag(M), 1:Rank)
+ if (p1) {
for(kk in 1:p1)
- cmat2[[Rank+kk]] <- Blist[[colx1.index[kk]]]
+ clist2[[Rank+kk]] <- Blist[[colx1.index[kk]]]
+ }
if (is.null(Cinit))
Cinit <- matrix(rnorm(p2*Rank, sd=SD.Cinit), p2, Rank)
- fit <- list(rss=0) # Only for initial old.crit below
+ fit <- list(rss = 0) # Only for initial old.crit below
C <- Cinit # This is input for the main iter loop
old.crit <- switch(Criterion, coefficients=C, rss=fit$rss)
@@ -124,18 +133,22 @@ valt <- function(x, z, U, Rank=1,
for(iter in 1:Maxit) {
iter.save <- iter
- lv.mat <- x[,colx2.index,drop=FALSE] %*% C
- new.lv.model.matrix = cbind(lv.mat, if (p1) x[,colx1.index] else NULL)
- fit = vlm.wfit(xmat=new.lv.model.matrix, z, Blist=cmat2, U=U,
- matrix.out=TRUE, is.vlmX=FALSE, rss=FALSE, qr=FALSE, xij=xij)
- A <- t(fit$mat.coef[1:Rank,,drop=FALSE])
-
- cmat1 = replace.constraints(Blist, A, colx2.index)
- fit = vlm.wfit(xmat=x, z, Blist=cmat1, U=U,
- matrix.out=TRUE, is.vlmX=FALSE, rss=TRUE, qr=FALSE, xij=xij)
- C = fit$mat.coef[colx2.index,,drop=FALSE] %*% A %*% solve(t(A) %*% A)
-
- numat = x[,colx2.index,drop=FALSE] %*% C
+ lv.mat <- x[, colx2.index, drop=FALSE] %*% C
+ new.lv.model.matrix = cbind(lv.mat,
+ if (p1) x[, colx1.index] else NULL)
+ fit = vlm.wfit(xmat = new.lv.model.matrix, z, Blist = clist2,
+ U = U, matrix.out = TRUE, is.vlmX = FALSE,
+ rss = FALSE, qr = FALSE, xij = xij)
+ A <- t(fit$mat.coef[1:Rank, , drop = FALSE])
+
+ clist1 = replace.constraints(Blist, A, colx2.index)
+ fit = vlm.wfit(xmat = x, z, Blist = clist1, U = U,
+ matrix.out = TRUE, is.vlmX = FALSE,
+ rss = TRUE, qr = FALSE, xij = xij)
+ C = fit$mat.coef[colx2.index, , drop=FALSE] %*% A %*%
+ solve(t(A) %*% A)
+
+ numat = x[, colx2.index, drop=FALSE] %*% C
evnu = eigen(var(numat))
temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
evnu$vector %*% evnu$value^(-0.5)
@@ -146,9 +159,9 @@ valt <- function(x, z, U, Rank=1,
A = temp8$amat
- ratio=switch(Criterion,
- coefficients=max(abs(C - old.crit) / (Tolerance+abs(C))),
- rss=max(abs(fit$rss - old.crit) / (Tolerance+fit$rss)))
+ ratio = switch(Criterion,
+ coefficients = max(abs(C - old.crit) / (Tolerance+abs(C))),
+ rss = max(abs(fit$rss - old.crit) / (Tolerance+fit$rss)))
if (trace) {
cat(" Alternating iteration", iter,
@@ -174,24 +187,25 @@ valt <- function(x, z, U, Rank=1,
for(itter in 1:length(Alphavec)) {
CC <- xold + Alphavec[itter] * direction1
- try.lv.mat <- x[,colx2.index,drop=FALSE] %*% CC
+ try.lv.mat <- x[, colx2.index, drop=FALSE] %*% CC
try.new.lv.model.matrix = cbind(try.lv.mat,
if (p1) x[,colx1.index] else NULL)
- try = vlm.wfit(xmat=try.new.lv.model.matrix, z, Blist=cmat2,
- U=U, matrix.out=TRUE, is.vlmX=FALSE,
- rss=TRUE, qr=FALSE, xij=xij)
+ try = vlm.wfit(xmat = try.new.lv.model.matrix, z,
+ Blist = clist2, U = U, matrix.out = TRUE,
+ is.vlmX = FALSE, rss = TRUE, qr = FALSE,
+ xij = xij)
if (try$rss < ftemp) {
use.alpha <- Alphavec[itter]
fit <- try
ftemp <- try$rss
C <- CC
- A = t(fit$mat.coef[1:Rank,,drop=FALSE])
- lv.mat <- x[,colx2.index,drop=FALSE] %*% C
- recover = iter # Give it some alt'g iterations to recover
+ A = t(fit$mat.coef[1:Rank, , drop=FALSE])
+ lv.mat <- x[, colx2.index, drop=FALSE] %*% C
+ recover = iter # Give it some altg iters to recover
} else {
- if (trace && use.alpha>0) {
- cat(" Finished line search using Alpha =",
+ if (trace && use.alpha > 0) {
+ cat(" Finished line search using Alpha =",
use.alpha, "\n")
flush.console()
}
@@ -201,11 +215,12 @@ valt <- function(x, z, U, Rank=1,
} # End of itter loop
}
- xold <- C # Don't take care of drift
+ xold <- C # Do not take care of drift
old.crit <- switch(Criterion, coefficients=C, rss=fit$rss)
} # End of iter loop
- list(A=A, C=C, fitted=fit$fitted, new.coeffs = fit$coef, rss=fit$rss)
+ list(A = A, C = C, fitted = fit$fitted, new.coeffs = fit$coef,
+ rss = fit$rss)
}
@@ -228,27 +243,27 @@ lm2qrrvlm.model.matrix = function(x, Blist, C, control, assign=TRUE,
Qoffset = if (Quadratic) ifelse(ITolerances, 0, sum(1:Rank)) else 0
NoA = length(combine2) == M # No unknown parameters in A
- cmat2 = if (NoA) {
+ clist2 = if (NoA) {
Aoffset = 0
vector("list", Aoffset+Qoffset+p1)
} else {
Aoffset = Rank
replace.constraints(vector("list", Aoffset+Qoffset+p1),
if (length(combine2)) diag(M)[,-combine2,drop=FALSE] else diag(M),
- 1:Rank) # If Corner then doesn't contain \bI_{Rank}
+ 1:Rank) # If Corner then does not contain \bI_{Rank}
}
if (Quadratic && !ITolerances)
- cmat2 = replace.constraints(cmat2,
+ clist2 = replace.constraints(clist2,
if (control$EqualTolerances)
matrix(1, M, 1) - eij(Dzero, M) else {
if (length(Dzero)) diag(M)[,-Dzero,drop=FALSE] else diag(M)},
Aoffset + (1:Qoffset))
if (p1)
for(kk in 1:p1)
- cmat2[[Aoffset+Qoffset+kk]] <- Blist[[colx1.index[kk]]]
+ clist2[[Aoffset+Qoffset+kk]] <- Blist[[colx1.index[kk]]]
if (!no.thrills) {
i63 = iam(NA, NA, M=Rank, both=TRUE)
- names(cmat2) = c(
+ names(clist2) = c(
if (NoA) NULL else paste("(lv", 1:Rank, ")", sep=""),
if (Quadratic && Rank==1 && !ITolerances)
"(lv^2)" else
@@ -265,12 +280,12 @@ lm2qrrvlm.model.matrix = function(x, Blist, C, control, assign=TRUE,
new.lv.model.matrix = cbind(tmp900$matrix,
if (p1) x[,colx1.index] else NULL)
if (!no.thrills)
- dimnames(new.lv.model.matrix) = list(dimnames(x)[[1]], names(cmat2))
+ dimnames(new.lv.model.matrix) = list(dimnames(x)[[1]], names(clist2))
if (assign) {
asx = attr(x, "assign")
asx = vector("list", ncol(new.lv.model.matrix))
- names(asx) = names(cmat2)
+ names(asx) = names(clist2)
for(ii in 1:length(names(asx))) {
asx[[ii]] = ii
}
@@ -278,23 +293,25 @@ lm2qrrvlm.model.matrix = function(x, Blist, C, control, assign=TRUE,
}
if (no.thrills)
- list(new.lv.model.matrix = new.lv.model.matrix, constraints = cmat2,
+ list(new.lv.model.matrix = new.lv.model.matrix, constraints = clist2,
offset = tmp900$offset) else
- list(new.lv.model.matrix = new.lv.model.matrix, constraints = cmat2,
+ list(new.lv.model.matrix = new.lv.model.matrix, constraints = clist2,
NoA = NoA, Aoffset = Aoffset, lv.mat = lv.mat,
offset = tmp900$offset)
}
+
+
valt.2iter <- function(x, z, U, Blist, A, control) {
- cmat1 = replace.constraints(Blist, A, control$colx2.index)
- fit <- vlm.wfit(xmat=x, z, Blist=cmat1, U=U, matrix.out=TRUE,
+ clist1 = replace.constraints(Blist, A, control$colx2.index)
+ fit <- vlm.wfit(xmat=x, z, Blist=clist1, U=U, matrix.out=TRUE,
is.vlmX=FALSE, rss=TRUE, qr=FALSE, xij=control$xij)
C = fit$mat.coef[control$colx2.index,,drop=FALSE] %*% A %*% solve(t(A) %*% A)
list(A=A, C=C, fitted=fit$fitted, new.coeffs = fit$coef,
- Blist=cmat1, rss=fit$rss)
+ Blist=clist1, rss=fit$rss)
}
@@ -314,7 +331,7 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
Qoffset = if (Quadratic) ifelse(ITolerances, 0, sum(1:Rank)) else 0
tmp833 = lm2qrrvlm.model.matrix(x=x, Blist=Blist, C=C, control=control)
new.lv.model.matrix = tmp833$new.lv.model.matrix
- cmat2.save = cmat2 = tmp833$constraints # Doesn't contain \bI_{Rank}
+ clist2 = clist2 = tmp833$constraints # Does not contain \bI_{Rank}
lv.mat = tmp833$lv.mat
if (Corner)
zedd[,Index.corner] = zedd[,Index.corner] - lv.mat
@@ -322,14 +339,14 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
if (nice31 && MSratio == 1) {
fit = list(mat.coef = NULL, fitted.values = NULL, rss = 0)
- cmat2 = NULL # for vlm.wfit
+ clist2 = NULL # for vlm.wfit
i5 = rep(0, len=MSratio)
for(ii in 1:NOS) {
i5 = i5 + 1:MSratio
tmp100 = vlm.wfit(xmat=new.lv.model.matrix, zedd[,i5,drop=FALSE],
- Blist=cmat2, U=U[i5,,drop=FALSE],
+ Blist=clist2, U=U[i5,,drop=FALSE],
matrix.out=TRUE, is.vlmX=FALSE, rss=TRUE,
qr=FALSE, Eta.range = control$Eta.range,
xij=control$xij, lp.names=lp.names[i5])
@@ -338,7 +355,7 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
fit$fitted.values = cbind(fit$fitted.values, tmp100$fitted.values)
}
} else {
- fit = vlm.wfit(xmat=new.lv.model.matrix, zedd, Blist=cmat2, U=U,
+ fit = vlm.wfit(xmat=new.lv.model.matrix, zedd, Blist=clist2, U=U,
matrix.out=TRUE, is.vlmX=FALSE, rss=TRUE, qr=FALSE,
Eta.range = control$Eta.range,
xij=control$xij, lp.names=lp.names)
@@ -364,7 +381,7 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
NULL
list(Amat=A, B1=B1, Cmat=C, Dmat=Dmat, fitted = if (M == 1) c(fv) else fv,
- new.coeffs = fit$coef, constraints=cmat2, rss=fit$rss,
+ new.coeffs = fit$coef, constraints=clist2, rss=fit$rss,
offset = if (length(tmp833$offset)) tmp833$offset else NULL)
}
@@ -373,9 +390,14 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
rrr.init.expression <- expression({
- if (control$Quadratic)
+ if (length(control$Quadratic) && control$Quadratic)
copy_X_vlm <- TRUE
+
+
+
+ if (function.name %in% c("cqo", "cao")) {
+
modelno = switch(family at vfamily[1], "poissonff"=2,
"quasipoissonff"=2, "quasipoisson"=2,
"binomialff"=1, "quasibinomialff"=1,
@@ -393,7 +415,11 @@ rrr.init.expression <- expression({
control$Dzero =
rrcontrol$Dzero = seq(from=2, to=M, by=2) # Handles D
+
}
+ } else {
+ modelno = 0 # Any value will do as the variable is unused.
+ }
})
@@ -426,6 +452,8 @@ rrr.alternating.expression <- expression({
eval(rrr.end.expression) # Put Amat into Blist, and create new z
})
+
+
adjust.Dmat.expression = expression({
if (length(Dmat)) {
ind0 = iam(NA, NA, both= TRUE, M=Rank)
@@ -441,6 +469,8 @@ rrr.alternating.expression <- expression({
}
}})
+
+
rrr.normalize = function(rrcontrol, A, C, x, Dmat=NULL) {
@@ -609,7 +639,7 @@ rrr.derivative.expression <- expression({
(ncol(X_vlm_save) - p2star)
X_vlm_1save = if (p1star > 0) X_vlm_save[,-(1:p2star)] else NULL
quasi.newton = optim(par=Cmat, fn=callcqof,
- gr = if (control$GradientFunction) calldcqof else NULL,
+ gr = if (control$GradientFunction) calldcqo else NULL,
method=which.optimizer,
control=list(fnscale=1,trace=as.integer(control$trace),
parscale=rep(control$Parscale, len=length(Cmat)),
@@ -703,6 +733,7 @@ rrr.derivative.expression <- expression({
})
+
rrr.derivC.rss = function(theta, U, z, M, xmat, Blist, rrcontrol,
omit.these=NULL) {
@@ -730,7 +761,7 @@ rrr.derivC.rss = function(theta, U, z, M, xmat, Blist, rrcontrol,
tmp700 = lm2qrrvlm.model.matrix(x=xmat, Blist=Blist,
no.thrills = !rrcontrol$Corner,
C=Cmat, control=rrcontrol, assign=FALSE)
- Blist = tmp700$constraints # Doesn't contain \bI_{Rank} \bnu
+ Blist = tmp700$constraints # Does not contain \bI_{Rank} \bnu
if (rrcontrol$Corner) {
z = as.matrix(z) # should actually call this zedd
@@ -821,7 +852,7 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
estITol = if (ConstrainedQO) object at control$ITolerances else FALSE
modelno = object at control$modelno # 1,2,3,4,5,6,7 or 0
combine2 = c(Structural.zero, if (Corner) Index.corner else NULL)
- NoA = length(combine2) == M # A is fully known # doesn't handle !Corner yet
+ NoA = length(combine2) == M # A is fully known.
Qoffset = if (Quadratic) ifelse(estITol, 0, sum(1:Rank)) else 0
@@ -1015,7 +1046,7 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
setClass(Class="Coef.rrvglm", representation(
"A" = "matrix",
- "B1" = "matrix",
+ "B1" = "matrix", # This may be unassigned if p1=0.
"C" = "matrix",
"Rank" = "numeric",
"colx1.index" = "numeric",
@@ -1257,7 +1288,7 @@ coefqrrvglm = function(object, matrix.out = FALSE,
residualsqrrvglm <- function(object,
type = c("deviance", "pearson", "working", "response", "ldot"),
matrix.arg= TRUE) {
- stop("this function hasn't been written yet")
+ stop("this function has not been written yet")
}
@@ -1417,10 +1448,10 @@ summary.rrvglm <- function(object, correlation=FALSE,
-get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
- numerical=TRUE,
- fixA=FALSE, h.step=0.0001,
- trace.arg=FALSE, ...) {
+get.rrvglm.se1 = function(fit, omit13 = FALSE, kill.all = FALSE,
+ numerical = TRUE,
+ fixA = FALSE, h.step = 0.0001,
+ trace.arg = FALSE, ...) {
@@ -1434,25 +1465,25 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
if (!length(fit at x))
stop("fix at x is empty. Run rrvglm(... , x= TRUE)")
- colx1.index = fit at control$colx1.index
+ colx1.index = fit at control$colx1.index # May be NULL
colx2.index = fit at control$colx2.index
Blist <- fit at constraints
ncolBlist <- unlist(lapply(Blist, ncol))
- p1 = length(colx1.index)
+ p1 = length(colx1.index) # May be 0
p2 = length(colx2.index)
Rank <- fit at control$Rank # fit at misc$Nested.Rank
Amat <- fit at constraints[[colx2.index[1]]]
- Bmat <- if (p1) coefvlm(fit, mat= TRUE)[colx1.index,,drop=FALSE] else NULL
+ B1mat =if (p1) coefvlm(fit,mat=TRUE)[colx1.index,,drop=FALSE] else NULL
C.try <- coefvlm(fit, mat= TRUE)[colx2.index,,drop=FALSE]
Cmat <- C.try %*% Amat %*% solve(t(Amat) %*% Amat)
- x1mat <- if (p1) fit at x[,colx1.index,drop=FALSE] else NULL
- x2mat <- fit at x[,colx2.index,drop=FALSE]
+ x1mat <- if (p1) fit at x[, colx1.index, drop=FALSE] else NULL
+ x2mat <- fit at x[, colx2.index, drop=FALSE]
- wz <- weights(fit, type="w") # old: wweights(fit) #fit at weights
+ wz <- weights(fit, type="work") # old: wweights(fit) #fit at weights
if (!length(wz))
stop("cannot get fit at weights")
@@ -1467,18 +1498,17 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
if (numerical) {
delct.da <- num.deriv.rrr(fit, M=M, r=Rank,
- x1mat=x1mat, x2mat=x2mat, p2=p2,
- Index.corner, Aimat=Amat, Bmat=Bmat, Cimat=Cmat,
- h.step=h.step, colx2.index=colx2.index,
- xij=fit at control$xij,
- Structural.zero=Structural.zero)
+ x1mat=x1mat, x2mat=x2mat, p2=p2,
+ Index.corner, Aimat=Amat, B1mat=B1mat, Cimat=Cmat,
+ h.step=h.step, colx2.index=colx2.index,
+ xij=fit at control$xij,
+ Structural.zero=Structural.zero)
} else {
- delct.da <- dctda.fast.only(theta=theta, wz=wz, U=U, zmat, M=M, r=Rank,
- x1mat=x1mat, x2mat=x2mat,
- p2=p2, Index.corner, Aimat=Amat,
- Bmat=Bmat, Cimat=Cmat,
- xij=fit at control$xij,
- Structural.zero=Structural.zero)
+ delct.da <- dctda.fast.only(theta=theta, wz=wz, U=U, zmat,
+ M=M, r=Rank, x1mat=x1mat, x2mat=x2mat, p2=p2,
+ Index.corner, Aimat=Amat, B1mat=B1mat, Cimat=Cmat,
+ xij=fit at control$xij,
+ Structural.zero=Structural.zero)
}
@@ -1623,14 +1653,15 @@ get.rrvglm.se2 <- function(cov.unscaled, dispersion=1, coefficients) {
num.deriv.rrr <- function(fit, M, r, x1mat, x2mat,
- p2, Index.corner, Aimat, Bmat, Cimat,
+ p2, Index.corner, Aimat, B1mat, Cimat,
h.step=0.0001, colx2.index,
xij=NULL, Structural.zero=NULL)
{
+
nn <- nrow(x2mat)
- if (nrow(Cimat)!=p2 || ncol(Cimat)!=r)
- stop("Cimat wrong shape")
+ if (nrow(Cimat) != p2 || ncol(Cimat) != r)
+ stop("'Cimat' wrong shape")
dct.da <- matrix(as.numeric(NA), (M-r-length(Structural.zero))*r, r*p2)
@@ -1648,8 +1679,10 @@ num.deriv.rrr <- function(fit, M, r, x1mat, x2mat,
small.Blist[[ii]] = pAmat
offset = if (length(fit at offset)) fit at offset else 0
- if (all(offset==0)) offset = 0
- neweta = x1mat %*% Bmat + x2mat %*% Cimat %*% t(pAmat)
+ if (all(offset == 0)) offset = 0
+ neweta = x2mat %*% Cimat %*% t(pAmat)
+ if (is.numeric(x1mat))
+ neweta = neweta + x1mat %*% B1mat
fit at predictors = neweta
@@ -1665,12 +1698,14 @@ num.deriv.rrr <- function(fit, M, r, x1mat, x2mat,
U <- vchol(wz, M=M, n=nn, silent= TRUE)
tvfor <- vforsub(U, as.matrix(deriv.mu), M=M, n=nn)
newzmat <- neweta + vbacksub(U, tvfor, M=M, n=nn) - offset
+ if (is.numeric(x1mat))
+ newzmat = newzmat - x1mat %*% B1mat
- newfit = vlm.wfit(xmat=x2mat, zmat=newzmat - x1mat %*% Bmat,
- Blist=small.Blist, U = U,
+ newfit = vlm.wfit(xmat = x2mat, zmat = newzmat,
+ Blist = small.Blist, U = U,
matrix.out = FALSE, is.vlmX = FALSE,
rss = TRUE, qr = FALSE, x.ret = FALSE,
- offset = NULL, xij=xij)
+ offset = NULL, xij = xij)
dct.da[ptr,] <- (newfit$coef - t(Cimat)) / h.step
ptr = ptr + 1
}
@@ -1682,7 +1717,7 @@ num.deriv.rrr <- function(fit, M, r, x1mat, x2mat,
dctda.fast.only = function(theta, wz, U, zmat, M, r, x1mat, x2mat,
- p2, Index.corner, Aimat, Bmat, Cimat,
+ p2, Index.corner, Aimat, B1mat, Cimat,
xij=NULL,
Structural.zero=NULL)
{
@@ -1711,8 +1746,8 @@ dctda.fast.only = function(theta, wz, U, zmat, M, r, x1mat, x2mat,
stop("cannot handle full rank models yet")
cbindex = (1:M)[-Index.corner] # complement of Index.corner
resid2 = if (length(x1mat))
- mux22(t(wz), zmat - x1mat %*% Bmat, M=M, upper=FALSE, as.mat=TRUE) else
- mux22(t(wz), zmat , M=M, upper=FALSE, as.mat=TRUE)
+ mux22(t(wz), zmat - x1mat %*% B1mat, M=M, upp=FALSE, as.mat=TRUE) else
+ mux22(t(wz), zmat , M=M, upp=FALSE, as.mat=TRUE)
for(sss in 1:r)
for(ttt in cbindex) {
@@ -1993,6 +2028,8 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
+
+
vellipse = function(R, ratio=1, orientation=0, center=c(0,0), N=300) {
if (length(center) != 2) stop("center must be of length 2")
theta = 2*pi*(0:N)/N
@@ -2051,9 +2088,9 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
MSratio = M / NOS # First value is g(mean) = quadratic form in lv
n = object at misc$n
colx2.index = object at control$colx2.index
- cx1i = object at control$colx1.index
+ cx1i = object at control$colx1.index # May be NULL
if (check.ok)
- if (!(length(cx1i)==1 && names(cx1i)=="(Intercept)"))
+ if (!(length(cx1i) == 1 && names(cx1i) == "(Intercept)"))
stop("latent variable plots allowable only for Norrr = ~ 1 models")
Coef.list = Coef(object, varlvI = varlvI, reference = reference)
@@ -2235,9 +2272,7 @@ lvplot.rrvglm = function(object,
stop("can only handle rank-2 models")
M = object at misc$M
n = object at misc$n
- colx1.index = object at control$colx1.index
colx2.index = object at control$colx2.index
- p1 = length(colx1.index)
Coef.list = Coef(object)
Amat = Coef.list at A
Cmat = Coef.list at C
@@ -2249,7 +2284,7 @@ lvplot.rrvglm = function(object,
if (!length(object at x)) {
object at x = model.matrixvlm(object, type="lm")
}
- x2mat = object at x[,colx2.index,drop=FALSE]
+ x2mat = object at x[, colx2.index, drop=FALSE]
nuhat = x2mat %*% Cmat
if (!plot.it) return(as.matrix(nuhat))
@@ -2339,18 +2374,18 @@ lvplot.rrvglm = function(object,
-Coef.rrvglm <- function(object, ...) {
+ Coef.rrvglm <- function(object, ...) {
M <- object at misc$M
n <- object at misc$n
colx1.index = object at control$colx1.index
colx2.index = object at control$colx2.index
- p1 = length(colx1.index)
+ p1 = length(colx1.index) # May be 0
Amat <- object at constraints[[colx2.index[1]]]
B1mat = if (p1) coefvlm(object, mat=TRUE)[colx1.index,,drop=FALSE] else NULL
- C.try <- coefvlm(object, mat= TRUE)[colx2.index,,drop=FALSE]
+ C.try <- coefvlm(object, mat = TRUE)[colx2.index, , drop=FALSE]
Cmat <- C.try %*% Amat %*% solve(t(Amat) %*% Amat)
@@ -2363,19 +2398,30 @@ Coef.rrvglm <- function(object, ...) {
ans = new(Class="Coef.rrvglm",
A = Amat,
- B1 = B1mat,
C = Cmat,
Rank = Rank,
- colx1.index = colx1.index,
colx2.index = colx2.index)
+
+ if (!is.null(colx1.index)) {
+ ans at colx1.index = colx1.index
+ ans at B1 = B1mat
+ }
+
if (object at control$Corner)
ans at Atilde = Amat[-c(object at control$Index.corner,
object at control$Structural.zero),,drop=FALSE]
ans
}
+
+
+
setMethod("Coef", "rrvglm", function(object, ...) Coef.rrvglm(object, ...))
+
+
+
+
printCoef.rrvglm = function(x, ...) {
object = x
@@ -2386,8 +2432,11 @@ printCoef.rrvglm = function(x, ...) {
cat("\nC matrix:\n")
print(object at C, ...)
- cat("\nB1 matrix:\n")
- print(object at B1, ...)
+ p1 = length(object at colx1.index)
+ if (p1) {
+ cat("\nB1 matrix:\n")
+ print(object at B1, ...)
+ }
invisible(object)
}
diff --git a/R/family.univariate.R b/R/family.univariate.R
index ee74d79..117b8e9 100644
--- a/R/family.univariate.R
+++ b/R/family.univariate.R
@@ -42,10 +42,10 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
mccullagh89 = function(ltheta="rhobit", lnu="logoff",
- itheta=NULL, inu=NULL,
- etheta=list(),
- enu=if(lnu == "logoff") list(offset=0.5) else list(),
- zero=NULL)
+ itheta=NULL, inu=NULL,
+ etheta=list(),
+ enu=if (lnu == "logoff") list(offset=0.5) else list(),
+ zero=NULL)
{
if (mode(ltheta) != "character" && mode(ltheta) != "name")
ltheta = as.character(substitute(ltheta))
@@ -91,7 +91,7 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
tmp = y / (theta.init-y)
tmp[tmp < -0.4] = -0.4
tmp[tmp > 10.0] = 10.0
- nu.init = rep(if(length(.inu)) .inu else tmp, length=n)
+ 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 ))
@@ -112,7 +112,8 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
Theta = eta2theta(eta[,1], .ltheta, earg= .etheta )
nu = eta2theta(eta[,2], .lnu, earg= .enu )
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * ((nu-0.5)*log1p(-y^2) - nu * log1p(-2*Theta*y + Theta^2) -
lbeta(nu+0.5,0.5 )))
}, list( .ltheta=ltheta, .lnu=lnu, .etheta = etheta, .enu=enu ))),
@@ -196,7 +197,8 @@ hzeta.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
alpha = eta2theta(eta, .link, earg= .earg )
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dhzeta(x=y, alpha=alpha, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -373,7 +375,8 @@ rhzeta = function(n, alpha)
phi = eta2theta(eta[,M], .lphi, earg= .ephi )
n = length(phi)
ycount = as.matrix(y * w)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
ans = rep(0.0, len=n)
omega = extra$n2
for(jay in 1:M) {
@@ -613,7 +616,8 @@ dirmul.old = function(link="loge", earg=list(), init.alpha = 0.01,
shape = eta2theta(eta, .link, earg=.earg)
M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M))
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w*(lgamma(sumshape) - lgamma(extra$n2 + sumshape ))) +
sum(w * (lgamma(y + shape) - lgamma(shape )))
}, list( .link=link, .earg=earg ))),
@@ -714,7 +718,8 @@ rdiric = function(n, shape, dimension=NULL) {
shape = eta2theta(eta, .link, earg= .earg )
M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M))
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * (lgamma(sumshape) - lgamma(shape) + (shape-1)*log(y )))
}, list( .link=link, .earg=earg ))),
vfamily=c("dirichlet"),
@@ -736,20 +741,20 @@ rdiric = function(n, shape, dimension=NULL) {
- zeta = function(x, deriv=0) {
+ zeta = function(x, deriv = 0) {
deriv.arg = deriv
- if (!is.Numeric(deriv.arg, allow=1, integer=TRUE, positi=TRUE) && deriv.arg!=0)
+ rm(deriv)
+ if (!is.Numeric(deriv.arg, allow = 1, integer = TRUE))
stop("'deriv' must be a single non-negative integer")
- if (!(deriv.arg==0 || deriv.arg==1 || deriv.arg==2))
+ if (deriv.arg < 0 || deriv.arg > 2)
stop("'deriv' must be 0, 1, or 2")
-
if (deriv.arg > 0)
- return(zeta.derivative(x, deriv=deriv))
+ return(Zeta.derivative(x, deriv.arg = deriv.arg))
@@ -761,7 +766,7 @@ rdiric = function(n, shape, dimension=NULL) {
ans[special3] <- NA # For 0 < Re(x) < 1
special4 <- (0 < Re(x)) & (Re(x) < 1) & (Im(x) == 0)
- ans[special4] <- zeta.derivative(x[special4], deriv=deriv)
+ ans[special4] <- Zeta.derivative(x[special4], deriv.arg = deriv.arg)
special2 <- Re(x) < 0
@@ -777,7 +782,7 @@ rdiric = function(n, shape, dimension=NULL) {
return(ans)
}
- a=12; k=8 # Markman paper
+ a = 12; k = 8
B = c(1/6, -1/30,1/42,-1/30,5/66,-691/2730,7/6,-3617/510)
ans = 0
for(ii in 1:(a-1))
@@ -788,22 +793,22 @@ rdiric = function(n, shape, dimension=NULL) {
ans = ans + term * B[1]
for(mm in 2:k) {
- term = term * (x+2*mm-2) * (x+2*mm-3) / (a*a* 2*mm * (2*mm-1))
+ term = term * (x+2*mm-2) * (x+2*mm-3) / (a * a * 2 * mm * (2*mm-1))
ans = ans + term * B[mm]
}
ans
}
-zeta.derivative = function(x, deriv=0)
+
+ Zeta.derivative = function(x, deriv.arg = 0)
{
- deriv.arg = deriv
- if (!is.Numeric(deriv.arg, allow=1, integer=TRUE, positi=TRUE) && deriv.arg!=0)
- stop("'deriv' must be a single non-negative integer")
- if (!(deriv.arg==0 || deriv.arg==1 || deriv.arg==2))
- stop("'deriv' must be 0, 1, or 2")
+ if (!is.Numeric(deriv.arg, allow=1, integer=TRUE))
+ stop("'deriv.arg' must be a single non-negative integer")
+ if (deriv.arg < 0 || deriv.arg > 2)
+ stop("'deriv.arg' must be 0, 1, or 2")
if (any(Im(x) != 0))
stop("Sorry, currently can only handle x real, not complex")
@@ -814,18 +819,19 @@ zeta.derivative = function(x, deriv=0)
ans = rep(as.numeric(NA), length(x))
nn = sum(ok) # Effective length (excludes x < 0 and x = 1 values)
if (nn)
- ans[ok] = dotC(name="aaaa_vzetawr", as.double(x[ok]), ans=double(nn),
+ ans[ok] = dotC(name="vzetawr", as.double(x[ok]), ans=double(nn),
as.integer(deriv.arg), as.integer(nn))$ans
- if (deriv==0)
- ans[is.finite(x) & abs(x) < 1.0e-12] = -0.5
+ if (deriv.arg == 0)
+ ans[is.finite(x) & abs(x) < 1.0e-12] = -0.5
ans
}
+
dzeta = function(x, p, log = FALSE)
{
if (!is.logical(log.arg <- log))
@@ -840,7 +846,7 @@ dzeta = function(x, p, log = FALSE)
ox = !is.finite(x)
zero = ox | round(x) != x | x < 1
if (any(zero)) warning("non-integer x and/or x < 1 or NAs")
- ans = rep(if(log.arg) log(0) else 0, len=LLL)
+ ans = rep(if (log.arg) log(0) else 0, len=LLL)
if (any(!zero)) {
if (log.arg) {
ans[!zero] = (-p[!zero]-1)*log(x[!zero]) - log(zeta(p[!zero]+1))
@@ -904,7 +910,8 @@ dzeta = function(x, p, log = FALSE)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
pp = eta2theta(eta, .link, earg=.earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dzeta(x=y, p=pp, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -965,7 +972,7 @@ dzipf = function(x, N, s, log=FALSE)
x = rep(x, len=nn); N = rep(N, len=nn); s = rep(s, len=nn);
ox = !is.finite(x)
zero = ox | round(x) != x | x < 1 | x > N
- ans = (if(log.arg) log(0) else 0) * x
+ ans = (if (log.arg) log(0) else 0) * x
if (any(!zero))
if (log.arg) {
ans[!zero] = (-s[!zero]) * log(x[!zero]) -
@@ -1061,7 +1068,8 @@ pzipf = function(q, N, s) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
ss = eta2theta(eta, .link, earg= .earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dzipf(x=y, N=extra$N, s=ss, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -1188,7 +1196,8 @@ cauchy.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta[,1], .llocation, earg=.elocation)
myscale = eta2theta(eta[,2], .lscale, earg=.escale)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dcauchy(x=y, loc=location, sc=myscale, log=TRUE))
}
}, list( .escale=escale, .lscale=lscale,
@@ -1305,7 +1314,8 @@ cauchy.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta, .llocation, earg=.elocation)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dcauchy(x=y, loc=location, scale= .scale.arg, log=TRUE))
}
}, list( .scale.arg=scale.arg, .elocation=elocation,
@@ -1377,7 +1387,8 @@ cauchy.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta, .llocation, earg= .elocation)
zedd = (y-location)/.scale.arg
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dlogis(x=y, location = location,
scale = .scale.arg, log = TRUE))
}
@@ -1451,7 +1462,8 @@ cauchy.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sc = eta2theta(eta, .link, earg=.earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * ((.shape.arg - 1) * log(y) - y / sc - .shape.arg * log(sc) -
lgamma( .shape.arg )))
}
@@ -1488,7 +1500,7 @@ dbort = function(x, Qsize=1, a=0.5, log=FALSE) {
x = rep(x, len=N); Qsize = rep(Qsize, len=N); a = rep(a, len=N);
xok = (x >= Qsize) & (x == round(x)) & (a > 0) & (a < 1)
- ans = rep(if(log.arg) log(0) else 0, len=N) # loglikelihood
+ ans = rep(if (log.arg) log(0) else 0, len=N) # loglikelihood
ans[xok] = lgamma(1 + Qsize[xok]) - lgamma(x[xok] + 1 - Qsize[xok]) +
(x[xok] - 1 - Qsize[xok]) * log(x[xok]) +
(x[xok] - Qsize[xok]) * log(a[xok]) - a[xok] * x[xok]
@@ -1572,7 +1584,8 @@ rbort = function(n, Qsize=1, a=0.5) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
aa = eta2theta(eta, .link, earg=.earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dbort(x=y, Qsize= .Qsize, a=aa, log=TRUE))
}
}, list( .link=link, .earg=earg, .Qsize=Qsize ))),
@@ -1603,7 +1616,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
x = rep(x, len=N); a = rep(a, len=N);
xok = (x %% 2 == 1) & (x == round(x)) & (x >= 1) & (a > 0) & (a < 0.5)
- ans = rep(if(log.arg) log(0) else 0, len=N) # loglikelihood
+ ans = rep(if (log.arg) log(0) else 0, len=N) # loglikelihood
ans[xok] = ((x[xok]-3)/2) * log(x[xok]) + ((x[xok]-1)/2) * log(a[xok]) -
lgamma(x[xok]/2 + 0.5) - a[xok] * x[xok]
if (!log.arg) {
@@ -1615,8 +1628,8 @@ dfelix = function(x, a=0.25, log = FALSE) {
felix = function(link="elogit",
- earg=if(link=="elogit") list(min=0, max=0.5) else list(),
- method.init=1)
+ earg=if (link == "elogit") list(min=0, max=0.5) else list(),
+ method.init=1)
{
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -1661,7 +1674,8 @@ dfelix = function(x, a=0.25, log = FALSE) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
aa = eta2theta(eta, .link, earg=.earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dfelix(x=y, a=aa, log = TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -1761,7 +1775,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
alpha = eta2theta(eta, .lshape, earg=.earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dsnorm(x=y, location=0, scale=1, shape=alpha, log=TRUE))
}
}, list( .earg=earg, .lshape=lshape ))),
@@ -1805,10 +1820,10 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
betaff = function(A=0, B=1,
- lmu=if(A==0 & B==1) "logit" else "elogit", lphi="loge",
- emu=if(lmu=="elogit") list(min=A,max=B) else list(),
- ephi=list(),
- imu=NULL, iphi=NULL, method.init=1, zero=NULL)
+ lmu = if (A == 0 & B == 1) "logit" else "elogit", lphi="loge",
+ emu = if (lmu == "elogit") list(min=A, max=B) else list(),
+ ephi=list(),
+ imu=NULL, iphi=NULL, method.init=1, zero=NULL)
{
if (!is.Numeric(A, allow=1) || !is.Numeric(B, allow=1) || A >= B)
stop("A must be < B, and both must be of length one")
@@ -1857,8 +1872,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
namesof("phi", .lphi, .ephi, short=TRUE))
if (!length(etastart)) {
mu.init = if (is.Numeric(.imu)) .imu else
- {if(.method.init==1) weighted.mean(y,w) else
- median(rep(y,w))}
+ {if ( .method.init == 1) weighted.mean(y,w) else
+ median(rep(y,w))}
mu1.init = (mu.init - .A) / (.B - .A) # In (0,1)
phi.init = if (is.Numeric(.iphi)) .iphi else
max(0.01, -1 + (.B-.A)^2 * mu1.init*(1-mu1.init)/var(y))
@@ -1884,7 +1899,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
mu = eta2theta(eta[,1], .lmu, .emu )
m1u = if ( .stdbeta ) mu else (mu - .A) / (.B - .A)
phi = eta2theta(eta[,2], .lphi, .ephi )
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
shape1 = phi * m1u
shape2 = (1 - m1u) * phi
zedd = (y - .A) / ( .B - .A)
@@ -2015,7 +2031,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
function(mu, y, w, residuals= FALSE, eta, extra=NULL){
shapes = cbind(eta2theta(eta[,1], .lshape1, earg= .eshape1 ),
eta2theta(eta[,2], .lshape2, earg= .eshape2 ))
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
zedd = (y - .A) / ( .B - .A)
sum(w * (dbeta(x=zedd, shape1=shapes[,1], shape2=shapes[,2],
log=TRUE) - log( abs( .B - .A ))))
@@ -2105,7 +2122,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
.A = eta[,3]
.B = eta[,4]
temp = lbeta(shapes[,1], shapes[,2])
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * ((shapes[,1]-1)*log(y-.A) + (shapes[,2]-1)*log(.B-y) - temp -
(shapes[,1]+shapes[,2]-1)*log(.B-.A )))
}, list( .link=link, .earg=earg ))),
@@ -2304,7 +2322,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
theta2eta(mu, .link, earg=.earg)),
list( .link=link, .earg=earg )),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dgamma(x=y, shape=mu, scale=1, log=TRUE))
},
vfamily=c("gamma1"),
@@ -2388,7 +2407,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
rate = eta2theta(eta[,1], .lrate, earg=.erate)
shape = eta2theta(eta[,2], .lshape, earg=.eshape)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dgamma(x=y, shape=shape, rate=rate, log=TRUE))
}
}, list( .lrate=lrate, .lshape=lshape,
@@ -2511,8 +2531,9 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
if (exists("CQO.FastAlgorithm", envir = VGAMenv))
rm("CQO.FastAlgorithm", envir = VGAMenv)
tmp34 = c(rep( .lmu, length=NOS), rep( .lshape, length=NOS))
- names(tmp34) = c(if(NOS==1) "mu" else paste("mu", 1:NOS, sep=""),
- if (NOS==1) "shape" else paste("shape", 1:NOS, sep=""))
+ names(tmp34) =
+ c(if (NOS == 1) "mu" else paste("mu", 1:NOS, sep=""),
+ if (NOS == 1) "shape" else paste("shape", 1:NOS, sep=""))
tmp34 = tmp34[interleave.VGAM(M, M=2)]
misc$link = tmp34 # Already named
misc$earg = vector("list", M)
@@ -2534,7 +2555,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
NOS = ncol(eta) / 2
mymu = mu # eta2theta(eta[,2*(1:NOS)-1], .lmu, earg=.emu )
shapemat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lshape, earg=.eshape )
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dgamma(x=y, shape=c(shapemat), scale=c(mymu/shapemat),
log=TRUE))
}
@@ -2630,7 +2652,8 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
prob = eta2theta(eta, .link, earg= .earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dgeom(x=y, prob=prob, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -2783,7 +2806,8 @@ rbetageom = function(n, shape1, shape2) {
ell1 = -log(sd[cen0]) - 0.5 * ((y[cen0] - mum[cen0])/sd[cen0])^2
ell2 = log1p(-pnorm((mum[cenL] - .Lower)/sd[cenL]))
ell3 = log1p(-pnorm(( .Upper - mum[cenU])/sd[cenU]))
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w[cen0] * ell1) + sum(w[cenL] * ell2) + sum(w[cenU] * ell3)
}, list( .lmu=lmu, .lsd=lsd,
.emu=emu, .esd=esd,
@@ -2917,7 +2941,8 @@ rbetageom = function(n, shape1, shape2) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sd = eta2theta(eta[,2], .lsd, earg= .esd)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dnorm(y, m=mu, sd=sd, log=TRUE))
}
}, list( .lsd=lsd, .emean=emean, .esd=esd ))),
@@ -2995,7 +3020,8 @@ rbetageom = function(n, shape1, shape2) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
mulog = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dlnorm(y, meanlog=mulog, sdlog=sdlog, log=TRUE))
}
}, list( .lmeanlog = lmeanlog, .lsdlog=lsdlog,
@@ -3107,7 +3133,8 @@ rbetageom = function(n, shape1, shape2) {
lambda = eta2theta(eta[,3], "identity", earg=list())
if (any(y < lambda))
warning("bad 'y'")
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w*dlnorm(y-lambda, meanlog=mymu, sdlog=sdlog, log=TRUE))
}
}, list( .lmeanlog=lmeanlog, .lsdlog=lsdlog,
@@ -3157,14 +3184,18 @@ negbinomial.control <- function(save.weight=TRUE, ...)
negbinomial = function(lmu = "loge", lk = "loge",
emu =list(), ek=list(),
- ik = NULL, nsimEIM=100, cutoff = 0.995, Maxiter=5000,
- deviance.arg=FALSE, method.init=1, shrinkage.init=0.95,
- zero = -2)
+ imu = NULL, ik = NULL,
+ quantile.probs = 0.75,
+ nsimEIM=100, cutoff = 0.995, Maxiter=5000,
+ deviance.arg=FALSE, method.init=1,
+ shrinkage.init=0.95, zero = -2)
{
+ if (length(imu) && !is.Numeric(imu, posit=TRUE))
+ stop("bad input for argument 'imu'")
if (length(ik) && !is.Numeric(ik, posit=TRUE))
stop("bad input for argument 'ik'")
if (!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
@@ -3210,16 +3241,16 @@ negbinomial.control <- function(save.weight=TRUE, ...)
is.Numeric( .zero, allow=1) && .zero != -2)
stop("argument zero=-2 is required")
- if (any(y<0))
+ if (any(y < 0))
stop("negative values not allowed for the negbinomial family")
if (any(round(y) != y))
stop("integer-values only allowed for the negbinomial family")
y = as.matrix(y)
M = 2 * ncol(y)
NOS = ncoly = ncol(y) # Number of species
- predictors.names = c(namesof(if(NOS==1) "mu" else
+ predictors.names = c(namesof(if (NOS == 1) "mu" else
paste("mu", 1:NOS, sep=""), .lmu, earg=.emu, tag=FALSE),
- namesof(if(NOS==1) "k" else paste("k",1:NOS,sep=""), .lk, earg=.ek,
+ namesof(if (NOS == 1) "k" else paste("k",1:NOS,sep=""), .lk, earg=.ek,
tag=FALSE))
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
@@ -3233,14 +3264,20 @@ negbinomial.control <- function(save.weight=TRUE, ...)
use.this = if ( .method.init == 1) {
weighted.mean(y[,iii], w) + 1/16
} else if ( .method.init == 3) {
- c(quantile(y[,iii], probs = 0.75) + 1/16)
+ c(quantile(y[,iii], probs = .quantile.probs) + 1/16)
} else {
median(y[,iii]) + 1/16
}
+ if (is.numeric( .mu.init ))
+ use.this = .mu.init
medabsres = median(abs(y[,iii] - use.this)) + 1/32
allowfun = function(z, maxtol=1) sign(z) * pmin(abs(z), maxtol)
mu.init[,iii] = use.this +
- (1- .sinit)*allowfun(y[,iii] - use.this, maxtol=medabsres)
+ (1- .sinit)*allowfun(y[,iii] - use.this, maxtol=medabsres)
+
+ mu.init[,iii] = abs(mu.init[,iii]) + 1 / 1024
+
+
}
if ( is.Numeric( .k.init )) {
@@ -3250,7 +3287,8 @@ negbinomial.control <- function(save.weight=TRUE, ...)
mu = extraargs
sum(w * dnbinom(x=y, mu=mu, size=kmat, log=TRUE))
}
- k.grid = 2^((-6):6)
+ k.grid = 2^((-7):7)
+ k.grid = 2^(seq(-8, 8, length = 40))
kay.init = matrix(0, nr=n, nc=NOS)
for(spp. in 1:NOS) {
kay.init[,spp.] = getMaxMin(k.grid,
@@ -3263,9 +3301,10 @@ negbinomial.control <- function(save.weight=TRUE, ...)
theta2eta(kay.init, .lk, earg= .ek))
etastart = etastart[,interleave.VGAM(M, M=2),drop=FALSE]
}
- }), list( .lmu=lmu, .lk=lk, .k.init=ik, .zero=zero,
- .emu=emu, .ek=ek,
- .sinit=shrinkage.init, .nsimEIM=nsimEIM,
+ }), list( .lmu=lmu, .lk=lk,
+ .emu=emu, .ek=ek, .mu.init = imu,
+ .k.init = ik, .quantile.probs = quantile.probs,
+ .sinit=shrinkage.init, .nsimEIM=nsimEIM, .zero=zero,
.method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = ncol(eta) / 2
@@ -3275,7 +3314,7 @@ negbinomial.control <- function(save.weight=TRUE, ...)
if (exists("CQO.FastAlgorithm", envir = VGAMenv))
rm("CQO.FastAlgorithm", envir = VGAMenv)
temp0303 = c(rep( .lmu, length=NOS), rep( .lk, length=NOS))
- names(temp0303) = c(if(NOS==1) "mu" else paste("mu", 1:NOS, sep=""),
+ names(temp0303) = c(if (NOS==1) "mu" else paste("mu", 1:NOS, sep=""),
if (NOS==1) "k" else paste("k", 1:NOS, sep=""))
temp0303 = temp0303[interleave.VGAM(M, M=2)]
misc$link = temp0303 # Already named
@@ -3295,7 +3334,7 @@ negbinomial.control <- function(save.weight=TRUE, ...)
link=eval(substitute(function(mu, extra=NULL) {
temp = theta2eta(mu, .lmu, earg= .emu)
temp = cbind(temp, NA * temp)
- temp[,interleave.VGAM(ncol(temp), M=2),drop=FALSE]
+ temp[, interleave.VGAM(ncol(temp), M=2), drop=FALSE]
}, list( .lmu=lmu, .emu=emu, .ek=ek ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
@@ -3308,7 +3347,8 @@ negbinomial.control <- function(save.weight=TRUE, ...)
}
kmat = eta2theta(temp300, .lk, earg= .ek)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * dnbinom(x=y, mu=mu, size=kmat, log=TRUE))
}, list( .lk=lk, .emu=emu, .ek=ek ))),
vfamily=c("negbinomial"),
@@ -3374,7 +3414,7 @@ negbinomial.control <- function(save.weight=TRUE, ...)
temp300[temp300 < -bigval] = -bigval
} else stop("can only handle the 'loge' link")
k = eta2theta(temp300, .lk, earg= .ek)
- devi = 2 * (y*log(ifelse(y<1, 1, y)/mu) + (y+k)*log((mu+k)/(k+y )))
+ devi = 2 * (y*log(ifelse(y < 1, 1, y)/mu) + (y+k)*log((mu+k)/(k+y)))
if (residuals)
sign(y - mu) * sqrt(abs(devi) * w) else
sum(w * devi)
@@ -3446,7 +3486,8 @@ negbinomial.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
kvec = eta2theta(eta[,2], .link.k, earg= .ek)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dnbinom(x=y, mu=kvec*alpha, size=kvec, log=TRUE))
}
}, list( .link.alpha=link.alpha, .link.k=link.k,
@@ -3600,7 +3641,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
prob = eta2theta(eta[,1], .link.p, earg= .ep)
k = eta2theta(eta[,2], .link.k, earg= .ek)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * (y * log1p(-prob) + k * log(prob) + lgamma(y+k) -
lgamma(k) - lgamma(y+1 )))
}, list( .link.p=link.p, .link.k=link.k,
@@ -3697,7 +3739,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
prob = eta2theta(eta, .link, earg= .earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * (y * log1p(-prob) + .k * log(prob) + lgamma(y+ .k) -
lgamma( .k ) - lgamma(y+1 )))
}, list( .link=link, .earg=earg, .k=k ))),
@@ -3810,7 +3853,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
df = eta2theta(eta, .link.df, earg= .earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dt(x=y, df=df, log=TRUE))
}
}, list( .link.df=link.df, .earg=earg ))),
@@ -3874,7 +3918,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
loglikelihood =eval(substitute(
function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
df = eta2theta(eta, .link, earg= .earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * dchisq(x=y, df=df, ncp = 0, log = TRUE))
}, list( .link = link, .earg=earg ))),
vfamily="chisq",
@@ -3897,115 +3942,202 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
- simplex = function(lmu="logit", lsigma="loge",
- emu=list(), esigma=list(), imu=NULL, isigma=NULL)
-{
+dsimplex = function(x, mu = 0.5, dispersion = 1, log = FALSE) {
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
+ rm(log)
+ sigma = dispersion
- if (mode(lmu) != "character" && mode(lmu) != "name")
- lmu = as.character(substitute(lmu))
- if (mode(lsigma) != "character" && mode(lsigma) != "name")
- lsigma = as.character(substitute(lsigma))
- if (!is.list(emu)) emu = list()
- if (!is.list(esigma)) esigma = list()
+ deeFun = function(y, mu)
+ (((y - mu) / (mu * (1 - mu)))^2) / (y * (1 - y))
+ logpdf = (-0.5 * log(2 * pi) - log(sigma) - 1.5 * log(x) -
+ 1.5 * log1p(-x) - 0.5 * deeFun(x, mu) / sigma^2)
+ logpdf[x <= 0.0] = -Inf # log(0.0)
+ logpdf[x >= 1.0] = -Inf # log(0.0)
+ logpdf[mu <= 0.0] = NaN
+ logpdf[mu >= 1.0] = NaN
+ logpdf[sigma <= 0.0] = NaN
+ if (log.arg) logpdf else exp(logpdf)
+}
- new("vglmff",
- blurb = c("Univariate Simplex distribution \n",
- "f(y) = [2*pi*sigma^2*(y*(1-y))^3]^(-0.5) * \n",
- " exp[-0.5*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2)/sigma^2], ",
- " 0 < y < 1,\n",
- "Links: ",
- namesof("mu", lmu, earg=emu), ", ",
- namesof("sigma", lsigma, earg=esigma), "\n\n",
- "Mean: mu\n",
- "Variance: sigma^2"),
- initialize=eval(substitute(expression({
- y = as.numeric(y)
- if (any(y <= 0 | y >= 1))
- stop("all y values must be in (0,1)")
- predictors.names = c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
- namesof("sigma", .lsigma, earg=.esigma, tag=FALSE))
+rsimplex = function(n, mu = 0.5, dispersion = 1) {
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ stop("bad input for argument 'n'") else n
- if (!length(etastart)) {
- mu.init = rep(if(length( .imu)) .imu else
- median(y), length=n)
- sigma.init = rep(if(length( .isigma)) .isigma else
- sqrt(var(y)), length=n)
- etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
- theta2eta(sigma.init, .lsigma, earg= .esigma))
- }
- }), list( .lmu=lmu, .lsigma=lsigma,
- .emu=emu, .esigma=esigma,
- .imu=imu, .isigma=isigma ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .lmu, earg= .emu)
- }, list( .lmu=lmu,
- .emu=emu, .esigma=esigma ))),
- last = eval(substitute(expression({
- misc$d3 = d3 # because save.weights=F
- misc$link = c(mu= .lmu, sigma= .lsigma)
- misc$earg = list(mu= .emu, sigma= .esigma)
- misc$pooled.weight = pooled.weight
- }), list( .lmu=lmu, .lsigma=lsigma,
- .emu=emu, .esigma=esigma ))),
- loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- sigma = eta2theta(eta[,2], .lsigma, earg= .esigma)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (-0.5*log(2*pi*sigma^2*(y*(1-y))^3) -
- (0.5/sigma^2)*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2 )))
- }, list( .lsigma=lsigma,
- .emu=emu, .esigma=esigma ))),
- vfamily=c("simplex"),
- deriv=eval(substitute(expression({
- if (iter==1) {
- d3 = deriv3(~ w * (-0.5*log(2*pi*sigma^2*(y*(1-y))^3) -
- (0.5/sigma^2)*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2)),
- c("mu", "sigma"), hessian= TRUE)
- }
+ oneval <- (length(mu) == 1 && length(dispersion) == 1)
+ answer = rep(0.0, len = use.n)
+ mu = rep(mu, len = use.n); dispersion = rep(dispersion, len = use.n)
+ Kay1 = 3 * (dispersion * mu * (1-mu))^2
- sigma = eta2theta(eta[,2], .lsigma, earg= .esigma)
+ if (oneval) {
+ Kay1 = Kay1[1] # Since oneval means there is only one unique value
+ mymu = mu[1]
+ myroots = polyroot(c(-mymu^2, Kay1+2*mymu^2, -3*Kay1+1-2*mymu, 2*Kay1))
+ myroots = myroots[abs(Im(myroots)) < 0.00001]
+ myroots = Re(myroots)
+ myroots = myroots[myroots >= 0.0]
+ myroots = myroots[myroots <= 1.0]
+ pdfmax = dsimplex(myroots, mymu, dispersion[1])
+ pdfmax = rep(max(pdfmax), len = use.n) # For multiple peaks
+ } else {
+ pdfmax = numeric(use.n)
+ for (ii in 1:use.n) {
+ myroots = polyroot(c(-mu[ii]^2, Kay1[ii]+2*mu[ii]^2,
+ -3*Kay1[ii]+1-2*mu[ii], 2*Kay1[ii]))
+ myroots = myroots[abs(Im(myroots)) < 0.00001]
+ myroots = Re(myroots)
+ myroots = myroots[myroots >= 0.0]
+ myroots = myroots[myroots <= 1.0]
+ pdfmax[ii] = max(dsimplex(myroots, mu[ii], dispersion[ii]))
+ }
+ }
+
+ index = 1:use.n
+ nleft = length(index)
+ while (nleft > 0) {
+ xx = runif(nleft) # , 0, 1
+ yy = runif(nleft, max = pdfmax[index])
+ newindex = (1:nleft)[yy < dsimplex(xx, mu[index], dispersion[index])]
+ if (length(newindex)) {
+ answer[index[newindex]] = xx[newindex]
+ index = setdiff(index, index[newindex])
+ nleft = nleft - length(newindex)
+ }
+ }
+ answer
+}
- eval.d3 = eval(d3)
- dl.dthetas = attr(eval.d3, "gradient")
- dmu.deta = dtheta.deta(mu, .lmu, earg= .emu)
- dsigma.deta = dtheta.deta(sigma, .lsigma, earg= .esigma)
- dtheta.detas = cbind(dmu.deta, dsigma.deta)
- dl.dthetas * dtheta.detas
- }), list( .lmu=lmu, .lsigma=lsigma,
- .emu=emu, .esigma=esigma ))),
- weight=eval(substitute(expression({
- d2l.dthetas2 = attr(eval.d3, "hessian")
- wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(M)
- wz[,iam(1,1,M)] = -d2l.dthetas2[,1,1] * dtheta.detas[,1]^2
- wz[,iam(2,2,M)] = -d2l.dthetas2[,2,2] * dtheta.detas[,2]^2
- wz[,iam(1,2,M)] = -d2l.dthetas2[,1,2] * dtheta.detas[,1] *
- dtheta.detas[,2]
- if (!.expected) {
- d2mudeta2 = d2theta.deta2(mu, .lmu, earg= .emu)
- d2sigmadeta2 = d2theta.deta2(sigma, .lsigma, earg= .esigma)
- wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dthetas[,1] * d2mudeta2
- wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dthetas[,2] * d2sigmadeta2
- }
- if (intercept.only) {
- sumw = sum(w)
- for(ii in 1:ncol(wz))
- wz[,ii] = sum(wz[,ii]) / sumw
- pooled.weight = TRUE
- wz = w * wz # Put back the weights
- } else
- pooled.weight = FALSE
- wz
- }), list( .lmu=lmu, .lsigma=lsigma, .expected=FALSE,
- .emu=emu, .esigma=esigma ))))
+ simplex = function(lmu = "logit", lsigma = "loge",
+ emu = list(), esigma = list(),
+ imu = NULL, isigma = NULL,
+ method.init = 1, shrinkage.init = 0.95,
+ zero = 2) {
+
+
+ if (mode(lmu) != "character" && mode(lmu) != "name")
+ lmu = as.character(substitute(lmu))
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
+ lsigma = as.character(substitute(lsigma))
+ if (!is.list(emu)) emu = list()
+ if (!is.list(esigma)) esigma = list()
+ if (!is.Numeric(method.init, allow = 1, integ = TRUE, posit = TRUE) ||
+ method.init > 3)
+ stop("'method.init' must be 1 or 2 or 3")
+ if (!is.Numeric(shrinkage.init, allow = 1) || shrinkage.init < 0 ||
+ shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ stop("bad input for argument 'zero'")
+
+ new("vglmff",
+ blurb = c("Univariate Simplex distribution \n",
+ "f(y) = [2*pi*sigma^2*(y*(1-y))^3]^(-0.5) * \n",
+ " exp[-0.5*(y-mu)^2 / (sigma^2 * y*(1-y)*mu^2*(1-mu)^2)],\n",
+ " 0 < y < 1, 0 < mu < 1, sigma > 0\n",
+ "Links: ",
+ namesof("mu", lmu, earg = emu), ", ",
+ namesof("sigma", lsigma, earg = esigma), "\n\n",
+ "Mean: mu\n",
+ "Variance function: V(mu) = mu^3 * (1-mu)^3"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ y = as.numeric(y)
+ if (ncol(y <- cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ if (any(y <= 0.0 | y >= 1.0))
+ stop("all 'y' values must be in (0,1)")
+
+ predictors.names = c(
+ namesof("mu", .lmu, earg = .emu, tag = FALSE),
+ namesof("sigma", .lsigma, earg = .esigma, tag = FALSE))
+
+ deeFun = function(y, mu)
+ (((y - mu) / (mu * (1 - mu)))^2) / (y * (1 - y))
+
+ if (!length(etastart)) {
+ use.this = if ( .method.init == 3) weighted.mean(y, w) else
+ if ( .method.init == 1) median(y) else
+ mean(y, trim = 0.1)
+ init.mu = (1 - .sinit) * y + .sinit * use.this
+ mu.init = rep(if (length( .imu )) .imu else init.mu, length = n)
+ sigma.init = if (length( .isigma )) rep( .isigma, leng = n) else {
+ use.this = deeFun(y, mu=init.mu)
+ rep(sqrt( if ( .method.init == 3) weighted.mean(use.this, w) else
+ if ( .method.init == 1) median(use.this) else
+ mean(use.this, trim = 0.1)),
+ length = n)
+ }
+ etastart = cbind(theta2eta(mu.init, .lmu, earg = .emu),
+ theta2eta(sigma.init, .lsigma, earg = .esigma))
+ }
+ }), list( .lmu = lmu, .lsigma = lsigma,
+ .emu = emu, .esigma = esigma,
+ .imu = imu, .isigma = isigma,
+ .sinit = shrinkage.init, .method.init = method.init ))),
+ inverse = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta[,1], .lmu, earg = .emu)
+ }, list( .lmu = lmu, .emu = emu ))),
+ last = eval(substitute(expression({
+ misc$link = c(mu = .lmu, sigma = .lsigma)
+ misc$earg = list(mu = .emu, sigma = .esigma)
+ misc$imu = .imu
+ misc$isigma = .isigma
+ misc$method.init = .method.init
+ misc$shrinkage.init = .sinit
+ }), list( .lmu = lmu, .lsigma = lsigma,
+ .imu = imu, .isigma = isigma,
+ .emu = emu, .esigma = esigma,
+ .sinit = shrinkage.init, .method.init = method.init ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ sigma = eta2theta(eta[,2], .lsigma, earg = .esigma)
+ if (residuals)
+ stop("loglikelihood residuals not ",
+ "implemented yet") else {
+ sum(w * dsimplex(y, mu, sigma, log = TRUE))
+ }
+ }, list( .lsigma = lsigma, .emu = emu,
+ .esigma = esigma ))),
+ vfamily = c("simplex"),
+ deriv = eval(substitute(expression({
+ deeFun = function(y, mu)
+ (((y - mu) / (mu * (1 - mu)))^2) / (y * (1 - y))
+ sigma = eta2theta(eta[,2], .lsigma, earg = .esigma)
+ dmu.deta = dtheta.deta(mu, .lmu, earg = .emu)
+ dsigma.deta = dtheta.deta(sigma, .lsigma, earg = .esigma)
+
+ dl.dmu = (y - mu) * (deeFun(y, mu) +
+ 1 / (mu * (1 - mu))^2) / (mu * (1 - mu) * sigma^2)
+
+ dl.dsigma = (deeFun(y, mu) / sigma^2 - 1) / sigma
+ cbind(dl.dmu * dmu.deta, dl.dsigma * dsigma.deta)
+ }), list( .lmu = lmu, .lsigma = lsigma,
+ .emu = emu, .esigma = esigma ))),
+ weight = eval(substitute(expression({
+ wz = matrix(0.0, n, M) # Diagonal!!
+ eim11 = 3 / (mu * (1 - mu)) + 1 / (sigma^2 * (mu * (1 - mu))^3)
+ wz[, iam(1, 1, M)] = eim11 * dmu.deta^2
+ wz[, iam(2, 2, M)] = (2 / sigma^2) * dsigma.deta^2
+ w * wz
+ }), list( .lmu = lmu, .lsigma = lsigma,
+ .emu = emu, .esigma = esigma ))))
}
+
+
+
+
+
rig = function(lmu="identity", llambda="loge",
emu=list(), elambda=list(), imu=NULL, ilambda=1)
{
@@ -4038,9 +4170,9 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
if (!length(etastart)) {
- mu.init = rep(if(length( .imu)) .imu else
+ mu.init = rep(if (length( .imu)) .imu else
median(y), length=n)
- lambda.init = rep(if(length( .ilambda )) .ilambda else
+ lambda.init = rep(if (length( .ilambda )) .ilambda else
sqrt(var(y)), length=n)
etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
theta2eta(lambda.init, .llambda, earg= .elambda))
@@ -4062,7 +4194,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * (-0.5*log(y) + 0.5*log(lambda) - (0.5*lambda/y) * (y-mu)^2))
}, list( .llambda=llambda,
.emu=emu, .elambda=elambda ))),
@@ -4118,7 +4251,7 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
hypersecant = function(link.theta="elogit",
- earg=if(link.theta=="elogit") list(min=-pi/2, max=pi/2) else list(),
+ earg = if (link.theta=="elogit") list(min=-pi/2, max=pi/2) else list(),
init.theta=NULL)
{
@@ -4138,7 +4271,7 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("theta", .link.theta, earg=.earg, tag=FALSE)
if (!length(etastart)) {
- theta.init = rep(if(length( .init.theta)) .init.theta else
+ theta.init = rep(if (length( .init.theta)) .init.theta else
median(y), length=n)
etastart = theta2eta(theta.init, .link.theta, earg= .earg)
}
@@ -4155,7 +4288,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
}), list( .link.theta=link.theta, .earg=earg ))),
loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
theta = eta2theta(eta, .link.theta, earg= .earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * (theta*y + log(cos(theta)) - log(cosh(pi*y/2 ))))
}, list( .link.theta=link.theta, .earg=earg ))),
vfamily=c("hypersecant"),
@@ -4175,7 +4309,7 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
hypersecant.1 = function(link.theta="elogit",
- earg=if(link.theta=="elogit") list(min=-pi/2, max=pi/2) else list(),
+ earg=if (link.theta == "elogit") list(min=-pi/2, max=pi/2) else list(),
init.theta=NULL)
{
@@ -4200,7 +4334,7 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
stop("all y values must be in (0,1)")
predictors.names = namesof("theta", .link.theta, earg=.earg, tag=FALSE)
if (!length(etastart)) {
- theta.init = rep(if(length( .init.theta)) .init.theta else
+ theta.init = rep(if (length( .init.theta)) .init.theta else
median(y), length=n)
etastart = theta2eta(theta.init, .link.theta, earg= .earg)
@@ -4218,7 +4352,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
}), list( .link.theta=link.theta, .earg=earg ))),
loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
theta = eta2theta(eta, .link.theta, earg= .earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * (log(cos(theta)) + (-0.5+theta/pi)*log(y) +
(-0.5-theta/pi)*log1p(-y )))
}, list( .link.theta=link.theta, .earg=earg ))),
@@ -4272,9 +4407,9 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
if (!length(etastart)) {
- mu.init = rep(if(length( .imu)) .imu else
+ mu.init = rep(if (length( .imu)) .imu else
(y), length=n)
- lambda.init = rep(if(length( .ilambda)) .ilambda else
+ lambda.init = rep(if (length( .ilambda)) .ilambda else
1/var(y), length=n)
etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
theta2eta(lambda.init, .llambda, earg= .elambda))
@@ -4295,7 +4430,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w * (-0.5*log(y*(1-y)) - 0.5 * lambda *
log1p((y-mu)^2 / (y*(1-y ))) - lgamma((lambda+1)/2) +
lgamma(1+ lambda/2 )))
@@ -4358,11 +4494,11 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
invbinomial = function(lrho="elogit", llambda="loge",
- erho=if(lrho=="elogit") list(min = 0.5, max = 1) else list(),
- elambda=list(),
- irho=NULL,
- ilambda=NULL,
- zero=NULL)
+ erho=if (lrho == "elogit") list(min = 0.5, max = 1) else list(),
+ elambda=list(),
+ irho=NULL,
+ ilambda=NULL,
+ zero=NULL)
{
if (mode(lrho) != "character" && mode(lrho) != "name")
@@ -4394,10 +4530,10 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
covarn = sd(y)^2 / weighted.mean(y, w)
temp1 = 0.5 + (1 + sqrt(1+8*covarn)) / (8*covarn)
temp2 = 0.5 + (1 - sqrt(1+8*covarn)) / (8*covarn)
- init.rho = rep(if(length( .irho)) .irho else {
+ init.rho = rep(if (length( .irho)) .irho else {
ifelse(temp1 > 0.5 && temp1 < 1, temp1, temp2)
}, length=n)
- init.lambda = rep(if(length( .ilambda)) .ilambda else {
+ init.lambda = rep(if (length( .ilambda)) .ilambda else {
(2*init.rho-1) * weighted.mean(y, w) / (1-init.rho)
}, length=n)
etastart = cbind(theta2eta(init.rho, .lrho, earg= .erho),
@@ -4422,7 +4558,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
rho = eta2theta(eta[,1], .lrho, earg= .erho)
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w*(log(lambda) - lgamma(2*y+lambda) - lgamma(y+1) -
lgamma(y+lambda+1) + y*log(rho) + y*log1p(-rho) +
lambda*log(rho)))
@@ -4469,7 +4606,7 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
genpoisson = function(llambda="elogit", ltheta="loge",
- elambda=if(llambda=="elogit") list(min=-1,max=1) else list(),
+ elambda=if (llambda=="elogit") list(min=-1,max=1) else list(),
etheta=list(),
ilambda=NULL, itheta=NULL,
use.approx=TRUE,
@@ -4523,9 +4660,9 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
if (init.lambda >= 1)
init.lambda = 0.9
if (!length(etastart)) {
- lambda = rep(if(length( .ilambda)) .ilambda else
+ lambda = rep(if (length( .ilambda)) .ilambda else
init.lambda, length=n)
- theta = rep(if(length( .itheta)) .itheta else init.theta, length=n)
+ theta = rep(if (length( .itheta)) .itheta else init.theta, length=n)
etastart = cbind(theta2eta(lambda, .llambda, earg= .elambda),
theta2eta(theta, .ltheta, earg= .etheta))
}
@@ -4552,7 +4689,8 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
theta = eta2theta(eta[,2], .ltheta, earg= .etheta)
index = (y == 0)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w[index]*(-theta[index])) +
sum(w[!index] * (-y[!index]*lambda[!index]-theta[!index] +
(y[!index]-1)*log(theta[!index]+y[!index]*lambda[!index]) +
@@ -4687,7 +4825,8 @@ rlgamma = function(n, location=0, scale=1, k=1) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
kk = eta2theta(eta, .link, earg= .earg)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dlgamma(x=y, location=0, scale=1, k=kk, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -4776,7 +4915,8 @@ rlgamma = function(n, location=0, scale=1, k=1) {
aa = eta2theta(eta[,1], .llocation, earg= .elocation)
bb = eta2theta(eta[,2], .lscale, earg= .escale)
kk = eta2theta(eta[,3], .lshape, earg= .eshape)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
sum(w * dlgamma(x=y, location=aa, scale=bb, k=kk, log=TRUE))
}
}, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
@@ -4818,7 +4958,7 @@ rlgamma = function(n, location=0, scale=1, k=1) {
prentice74 = function(llocation="identity", lscale="loge", lshape="identity",
elocation=list(), escale=list(), eshape=list(),
- ilocation=NULL, iscale=NULL, ishape=NULL, zero=NULL)
+ ilocation=NULL, iscale=NULL, ishape=NULL, zero=2:3)
{
if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
@@ -4888,7 +5028,8 @@ rlgamma = function(n, location=0, scale=1, k=1) {
k = eta2theta(eta[,3], .lshape, earg= .eshape)
tmp55 = k^(-2)
doubw = (y-a)*k/b + digamma(tmp55)
- if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else
sum(w*(log(abs(k)) -log(b) -lgamma(tmp55) + doubw*tmp55 -exp(doubw )))
}, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
.elocation=elocation, .escale=escale, .eshape=eshape ))),
@@ -4934,14 +5075,17 @@ rlgamma = function(n, location=0, scale=1, k=1) {
-dggamma = function(x, scale=1, d=1, k=1, log = FALSE) {
+dgengamma = function(x, scale=1, d=1, k=1, log = FALSE) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if (!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
- if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+ if (!is.Numeric(scale, posit=TRUE))
+ stop("bad input for argument 'scale'")
+ if (!is.Numeric(d, posit=TRUE))
+ stop("bad input for argument 'd'")
+ if (!is.Numeric(k, posit=TRUE))
+ stop("bad input for argument 'k'")
N = max(length(x), length(scale), length(d), length(k))
x = rep(x, len=N); scale = rep(scale, len=N);
d = rep(d, len=N); k = rep(k, len=N);
@@ -4963,31 +5107,46 @@ dggamma = function(x, scale=1, d=1, k=1, log = FALSE) {
-pggamma = function(q, scale=1, d=1, k=1) {
- if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if (!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
- if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+pgengamma = function(q, scale=1, d=1, k=1) {
+ if (!is.Numeric(scale, posit=TRUE))
+ stop("bad input for argument 'scale'")
+ if (!is.Numeric(d, posit=TRUE))
+ stop("bad input for argument 'd'")
+ if (!is.Numeric(k, posit=TRUE))
+ stop("bad input for argument 'k'")
z = (q/scale)^d
pgamma(z, k)
}
-qggamma = function(p, scale=1, d=1, k=1) {
- if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if (!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
- if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+
+
+qgengamma = function(p, scale=1, d=1, k=1) {
+ if (!is.Numeric(scale, posit=TRUE))
+ stop("bad input for argument 'scale'")
+ if (!is.Numeric(d, posit=TRUE))
+ stop("bad input for argument 'd'")
+ if (!is.Numeric(k, posit=TRUE))
+ stop("bad input for argument 'k'")
q = qgamma(p, k)
scale * q^(1/d)
}
-rggamma = function(n, scale=1, d=1, k=1) {
+
+
+rgengamma = function(n, scale=1, d=1, k=1) {
if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for 'n'")
- if (!is.Numeric(scale, posit=TRUE)) stop("bad input for 'scale'")
- if (!is.Numeric(d, posit=TRUE)) stop("bad input for 'd'")
- if (!is.Numeric(k, posit=TRUE)) stop("bad input for 'k'")
+ if (!is.Numeric(scale, posit=TRUE))
+ stop("bad input for 'scale'")
+ if (!is.Numeric(d, posit=TRUE))
+ stop("bad input for 'd'")
+ if (!is.Numeric(k, posit=TRUE))
+ stop("bad input for 'k'")
y = rgamma(n, k)
scale * y^(1/d)
}
- ggamma = function(lscale="loge", ld="loge", lk="loge",
+
+
+ gengamma = function(lscale="loge", ld="loge", lk="loge",
escale=list(), ed=list(), ek=list(),
iscale=NULL, id=NULL, ik=NULL, zero=NULL)
{
@@ -5007,13 +5166,13 @@ rggamma = function(n, scale=1, d=1, k=1) {
new("vglmff",
blurb = c("Generalized gamma distribution",
- " f(y) = d * b^(-d*k) * y^(d*k-1) * exp(-(y/b)^d) / gamma(k),\n",
- "scale=b>0, d>0, k>0, y>0\n\n",
- "Links: ",
- namesof("scale", lscale, earg=escale), ", ",
- namesof("d", ld, earg=ed), ", ",
- namesof("k", lk, earg=ek), "\n", "\n",
- "Mean: b*k", "\n"),
+ " f(y) = d * b^(-d*k) * y^(d*k-1) * exp(-(y/b)^d) / gamma(k),\n",
+ "scale=b>0, d>0, k>0, y>0\n\n",
+ "Links: ",
+ namesof("scale", lscale, earg=escale), ", ",
+ namesof("d", ld, earg=ed), ", ",
+ namesof("k", lk, earg=ek), "\n", "\n",
+ "Mean: b*k", "\n"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
@@ -5058,12 +5217,13 @@ rggamma = function(n, scale=1, d=1, k=1) {
b = eta2theta(eta[,1], .lscale, earg= .escale)
d = eta2theta(eta[,2], .ld, earg= .ed)
k = eta2theta(eta[,3], .lk, earg= .ek)
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(w * dggamma(x=y, scale=b, d=d, k=k, log = TRUE))
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
+ sum(w * dgengamma(x=y, scale=b, d=d, k=k, log = TRUE))
}
}, list( .lscale=lscale, .ld=ld, .lk=lk,
.escale=escale, .ed=ed, .ek=ek ))),
- vfamily=c("ggamma"),
+ vfamily=c("gengamma"),
deriv=eval(substitute(expression({
b = eta2theta(eta[,1], .lscale, earg= .escale)
d = eta2theta(eta[,2], .ld, earg= .ed)
@@ -5156,10 +5316,10 @@ plog = function(q, prob, log.p=FALSE) {
seqq = sequence(floorq)
seqp = rep(prob, floorq)
onevector = (seqp^seqq / seqq) / (-log1p(-seqp))
- rlist = dotFortran(name="cum8sum",
- x=as.double(onevector), answer=double(N),
- as.integer(N), as.double(seqq),
- as.integer(length(onevector)), notok=integer(1))
+ rlist = dotC(name="tyee_C_cum8sum",
+ as.double(onevector), answer=double(N),
+ as.integer(N), as.double(seqq),
+ as.integer(length(onevector)), notok=integer(1))
if (rlist$notok != 0) stop("error in 'cum8sum'")
ans = if (log.p) log(rlist$answer) else rlist$answer
if (specialCase)
@@ -5470,8 +5630,9 @@ rlog = function(n, prob, Smallno=1.0e-6) {
extra$y0 = y0
if (!length(etastart)) {
- alpha = rep(if(length( .ialpha)) .ialpha else -1/fit0$coef[1], length=n)
- theta = rep(if(length( .itheta)) .itheta else 1.0, length=n)
+ alpha = rep(if (length( .ialpha)) .ialpha else
+ -1/fit0$coef[1], length=n)
+ theta = rep(if (length( .itheta)) .itheta else 1.0, length=n)
etastart = cbind(theta2eta(alpha, .link.alpha, earg= .ealpha),
theta2eta(theta, .link.theta, earg= .etheta))
}
@@ -5616,9 +5777,12 @@ rlino = function(n, shape1, shape2, lambda=1) {
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
if (!length(etastart)) {
- lambda.init = rep(if(length( .ilambda )) .ilambda else 1, length=n)
- sh1.init = if (length( .ishape1 )) rep( .ishape1, length=n) else NULL
- sh2.init = if (length( .ishape2 )) rep( .ishape2, length=n) else NULL
+ lambda.init = rep(if (length( .ilambda )) .ilambda else 1,
+ length=n)
+ sh1.init = if (length( .ishape1 ))
+ rep( .ishape1, length=n) else NULL
+ sh2.init = if (length( .ishape2 ))
+ rep( .ishape2, length=n) else NULL
txY.init = lambda.init * y / (1+lambda.init*y - y)
mean1 = mean(txY.init)
mean2 = mean(1/txY.init)
@@ -5749,11 +5913,12 @@ rlino = function(n, shape1, shape2, lambda=1) {
}
if (!length(etastart)) {
- aa = rep(if(length(.init.a)) .init.a else 1/fit0$coef[2], length=n)
- scale = rep(if(length(.init.scale)) .init.scale else
+ aa = rep(if (length(.init.a)) .init.a else 1/fit0$coef[2],
+ length=n)
+ scale = rep(if (length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
- qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
- parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
+ qq = rep(if (length(.init.q)) .init.q else 1.0, length=n)
+ parg = rep(if (length(.init.p)) .init.p else 1.0, length=n)
etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
theta2eta(scale, .link.scale, earg= .earg.scale),
theta2eta(parg, .link.p, earg= .earg.p),
@@ -6074,10 +6239,11 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
}
if (!length(etastart)) {
- aa = rep(if(length(.init.a)) .init.a else 1/fit0$coef[2], length=n)
- scale = rep(if(length(.init.scale)) .init.scale else
+ aa = rep(if (length(.init.a)) .init.a else 1/fit0$coef[2],
+ length=n)
+ scale = rep(if (length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
- qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
+ qq = rep(if (length(.init.q)) .init.q else 1.0, length=n)
etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
theta2eta(scale, .link.scale, earg= .earg.scale),
theta2eta(qq, .link.q, earg= .earg.q))
@@ -6213,9 +6379,10 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
}
if (!length(etastart)) {
- parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
- aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
- scale = rep(if(length(.init.scale)) .init.scale else
+ parg = rep(if (length(.init.p)) .init.p else 1.0, length=n)
+ aa = rep(if (length(.init.a)) .init.a else -1/fit0$coef[2],
+ length=n)
+ scale = rep(if (length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
theta2eta(scale, .link.scale, earg= .earg.scale),
@@ -6349,13 +6516,13 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
}
if (!length(etastart)) {
- scale = rep(if(length(.init.scale)) .init.scale else
- exp(fit0$coef[1]), length=n)
- qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
- parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
- etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
- theta2eta(parg, .link.p, earg= .earg.p),
- theta2eta(qq, .link.q, earg= .earg.q))
+ scale = rep(if (length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
+ qq = rep(if (length(.init.q)) .init.q else 1.0, length=n)
+ parg = rep(if (length(.init.p)) .init.p else 1.0, length=n)
+ etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(parg, .link.p, earg= .earg.p),
+ theta2eta(qq, .link.q, earg= .earg.q))
}
}), list( .link.scale=link.scale,
.link.p=link.p, .link.q=link.q,
@@ -6486,11 +6653,11 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
}
if (!length(etastart)) {
- qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
- scale = rep(if(length(.init.scale)) .init.scale else
- exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
- theta2eta(qq, .link.q, earg= .earg.q))
+ qq = rep(if (length(.init.q)) .init.q else 1.0, length=n)
+ scale = rep(if (length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
+ etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(qq, .link.q, earg= .earg.q))
}
}), list( .link.scale=link.scale, .link.q=link.q,
.earg.scale=earg.scale, .earg.q=earg.q,
@@ -6587,11 +6754,12 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
}
if (!length(etastart)) {
- aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
- scale = rep(if(length(.init.scale)) .init.scale else
- exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
- theta2eta(scale, .link.scale, earg= .earg.scale))
+ aa = rep(if (length(.init.a)) .init.a else -1/fit0$coef[2],
+ length=n)
+ scale = rep(if (length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale))
}
}), list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale,
@@ -6696,11 +6864,11 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
if (!length(etastart)) {
- scale = rep(if(length(.init.scale)) .init.scale else
- exp(fit0$coef[1]), length=n)
- parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
- etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
- theta2eta(parg, .link.p, earg= .earg.p))
+ scale = rep(if (length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
+ parg = rep(if (length(.init.p)) .init.p else 1.0, length=n)
+ etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(parg, .link.p, earg= .earg.p))
}
}), list( .link.scale=link.scale,
.link.p=link.p,
@@ -6805,11 +6973,12 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
}
if (!length(etastart)) {
- aa = rep(if(length(.init.a)) .init.a else 1/fit0$coef[2], length=n)
- scale = rep(if(length(.init.scale)) .init.scale else
- exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
- theta2eta(scale, .link.scale, earg= .earg.scale))
+ aa = rep(if (length(.init.a)) .init.a else 1/fit0$coef[2],
+ length=n)
+ scale = rep(if (length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale))
}
}), list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale,
@@ -6917,11 +7086,12 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
qq = 1
if (!length(etastart)) {
- aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
- scale = rep(if(length(.init.scale)) .init.scale else
- exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
- theta2eta(scale, .link.scale, earg= .earg.scale))
+ aa = rep(if (length(.init.a)) .init.a else -1/fit0$coef[2],
+ length=n)
+ scale = rep(if (length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale))
}
}), list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale,
@@ -7031,7 +7201,8 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
if (any(y <= 0)) stop("y must be positive")
if (!length(etastart)) {
- sigma.init = rep(if(length( .init.sigma)) .init.sigma else sigma.init, len=n)
+ sigma.init = rep(if (length( .init.sigma)) .init.sigma else
+ sigma.init, len=n)
r.init = if (length( .init.r)) .init.r else init.r
etastart = cbind(mu=rep(log(median(y)), len=n),
sigma=sigma.init,
@@ -8846,7 +9017,8 @@ betaffqn.control <- function(save.weight=TRUE, ...)
predictors.names =
c(namesof(paste("quantile(", y.names, ")", sep=""),
.llocation, earg=.elocation, tag=FALSE),
- namesof(if(M==2) "scale" else paste("scale", 1:(M/2), sep=""),
+ namesof(if (M == 2) "scale" else
+ paste("scale", 1:(M/2), sep=""),
.lscale, earg=.escale, tag=FALSE))
if (!length(etastart)) {
@@ -9920,7 +10092,7 @@ ptriangle = function(q, theta, lower=0, upper=1) {
triangle = function(lower=0, upper=1,
- link="elogit", earg=if(link=="elogit")
+ 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'")
@@ -10322,7 +10494,7 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
predictors.names =
c(namesof(paste("quantile(", y.names, ")", sep=""),
.llocation, earg=.elocation, tag=FALSE),
- namesof(if(M==2) "scale" else paste("scale", 1:(M/2), sep=""),
+ namesof(if (M == 2) "scale" else paste("scale", 1:(M/2), sep=""),
.lscale, earg=.escale, tag=FALSE))
if (weighted.mean(1*(y < 0.001), w) >= min(extra$tau))
stop("sample proportion of 0s > minimum 'tau' value. ",
diff --git a/R/family.zeroinf.R b/R/family.zeroinf.R
index 358279b..7cd3f6b 100644
--- a/R/family.zeroinf.R
+++ b/R/family.zeroinf.R
@@ -338,9 +338,7 @@ rzipois = function(n, lambda, phi=0) {
zapoisson = function(lp0="logit", llambda="loge",
- ep0=list(), elambda=list(),
- zero=NULL)
-{
+ ep0=list(), elambda=list(), zero=NULL) {
if (mode(lp0) != "character" && mode(lp0) != "name")
lp0 = as.character(substitute(lp0))
if (mode(llambda) != "character" && mode(llambda) != "name")
@@ -349,8 +347,8 @@ rzipois = function(n, lambda, phi=0) {
if (!is.list(elambda)) elambda = list()
new("vglmff",
- blurb=c(
- "Zero-altered Poisson (binomial and positive-Poisson conditional model)\n\n",
+ blurb=c("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),
@@ -368,95 +366,101 @@ rzipois = function(n, lambda, phi=0) {
if (any(y < 0))
stop("the response must not have negative values")
- extra$y0 = y0 = ifelse(y==0, 1, 0)
+ extra$y0 = y0 = ifelse(y == 0, 1, 0)
extra$NOS = NOS = ncoly = ncol(y) # Number of species
extra$skip.these = skip.these = matrix(as.logical(y0), n, NOS)
- mynames1 = if (ncoly==1) "p0" else paste("p0", 1:ncoly, sep="")
- mynames2 = if (ncoly==1) "lambda" else paste("lambda", 1:ncoly, sep="")
+ mynames1 = if (ncoly == 1) "p0" else paste("p0", 1:ncoly, sep = "")
+ mynames2 = if (ncoly == 1) "lambda" else
+ paste("lambda", 1:ncoly, sep = "")
predictors.names =
- c(namesof(mynames1, .lp0, earg= .ep0, tag=FALSE),
- namesof(mynames2, .llambda, earg= .elambda, tag=FALSE))
+ c(namesof(mynames1, .lp0, earg = .ep0, tag = FALSE),
+ namesof(mynames2, .llambda, earg = .elambda, tag = FALSE))
if (!length(etastart)) {
etastart = cbind(theta2eta((0.5+w*y0)/(1+w), .lp0, earg= .ep0 ),
matrix(1, n, NOS)) # 1 here is any old value
- for(spp. in 1:NOS)
- etastart[!skip.these[,spp.],NOS+spp.] =
- theta2eta(y[!skip.these[,spp.],spp.] /
- (1-exp(-y[!skip.these[,spp.],spp.])), .llambda,
- earg= .elambda )
+ for(spp. in 1:NOS) {
+ sthese = skip.these[, spp.]
+ etastart[!sthese, NOS+spp.] = theta2eta(
+ y[!sthese, spp.] / (-expm1(-y[!sthese, spp.])),
+ .llambda, earg = .elambda )
+ }
}
- }), list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
+ }), list( .lp0 = lp0, .llambda = llambda,
+ .ep0 = ep0, .elambda = elambda ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = extra$NOS
- p0 = eta2theta(eta[,1:NOS], .lp0, earg= .ep0)
- lambda = eta2theta(eta[,NOS+(1:NOS)], .llambda, earg= .elambda)
- (1-p0) * (lambda / (1-exp(-lambda)))
+ p0 = eta2theta(eta[, 1:NOS], .lp0, earg = .ep0)
+ lambda = eta2theta(eta[, NOS+(1:NOS)], .llambda, earg= .elambda)
+ (1-p0) * lambda / (-expm1(-lambda))
}, list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
last=eval(substitute(expression({
- misc$link = c(rep( .lp0, len=NOS), rep( .llambda, len=NOS))
+ misc$link = c(rep( .lp0, len = NOS), rep( .llambda, len = NOS))
names(misc$link) = c(mynames1, mynames2)
- misc$earg = vector("list", 2*NOS)
+ misc$earg = vector("list", 2 * NOS)
names(misc$earg) = c(mynames1, mynames2)
for(ii in 1:NOS) {
misc$earg[[ ii]] = .ep0
misc$earg[[NOS + ii]] = .elambda
}
- }), list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
+ }), list( .lp0 = lp0, .llambda = llambda,
+ .ep0 = ep0, .elambda = elambda ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta,extra=NULL) {
NOS = extra$NOS
- p0 = cbind(eta2theta(eta[,1:NOS], .lp0, earg= .ep0))
- lambda = cbind(eta2theta(eta[,NOS+(1:NOS)], .llambda, earg= .elambda ))
- if (residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(w * dzapois(x=y, p0=p0, lambda=lambda, log=TRUE))
+ p0 = cbind(eta2theta(eta[, 1:NOS], .lp0, earg = .ep0))
+ lambda = cbind(eta2theta(eta[, NOS+(1:NOS)], .llambda, earg = .elambda ))
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+ sum(w * dzapois(x = y, p0 = p0, lambda = lambda, log = TRUE))
}
- }, list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
+ }, list( .lp0 = lp0, .llambda = llambda,
+ .ep0 = ep0, .elambda = elambda ))),
vfamily=c("zapoisson"),
deriv=eval(substitute(expression({
NOS = extra$NOS
y0 = extra$y0
skip = extra$skip.these
- p0 = cbind(eta2theta(eta[,1:NOS], .lp0, earg= .ep0))
- lambda = cbind(eta2theta(eta[,NOS+(1:NOS)], .llambda, earg= .ep0))
- dl.dlambda = y/lambda - 1 - 1/(exp(lambda)-1)
+ p0 = cbind(eta2theta(eta[, 1:NOS], .lp0, earg = .ep0))
+ lambda = cbind(eta2theta(eta[, NOS+(1:NOS)], .llambda, earg = .elambda))
+ dl.dlambda = y/lambda - 1 - 1 / expm1(lambda)
for(spp. in 1:NOS)
- dl.dlambda[skip[,spp.],spp.] = 0
- dlambda.deta = dtheta.deta(lambda, .llambda, earg= .ep0)
+ dl.dlambda[skip[, spp.], spp.] = 0
+ dlambda.deta = dtheta.deta(lambda, .llambda, earg = .elambda)
mup0 = p0
temp3 = if (.lp0 == "logit") {
w * (y0 - mup0)
} else
- w * dtheta.deta(mup0, link=.lp0, earg= .ep0) * (y0/mup0 - 1) / (1-mup0)
- ans = cbind(temp3, w * dl.dlambda * dlambda.deta)
- ans
- }), list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
+ w * dtheta.deta(mup0, link = .lp0, earg = .ep0) *
+ (y0 / mup0 - 1) / (1 - mup0)
+ cbind(temp3, w * dl.dlambda * dlambda.deta)
+ }), list( .lp0 = lp0, .llambda = llambda, .ep0 = ep0, .elambda = elambda ))),
weight=eval(substitute(expression({
wz = matrix( 10 * .Machine$double.eps^(3/4), n, 2*NOS)
for(spp. in 1:NOS) {
- temp4 = exp(lambda[!skip[,spp.], spp.])
- ed2l.dlambda2 = -temp4 * (1/lambda[!skip[,spp.],spp.] -
- 1/(temp4-1)) / (temp4-1)
- wz[!skip[,spp.],NOS+spp.] = -w[!skip[,spp.]] *
- (dlambda.deta[!skip[,spp.],spp.]^2) *
- ed2l.dlambda2
+ sthese = skip[, spp.]
+ temp5 = expm1(lambda[!sthese, spp.])
+ ed2l.dlambda2 = -(temp5 + 1) * (1 / lambda[!sthese, spp.] -
+ 1 / temp5) / temp5
+ wz[!sthese, NOS+spp.] = -w[!sthese] * ed2l.dlambda2 *
+ (dlambda.deta[!sthese, spp.]^2)
}
- tmp100 = mup0*(1-mup0)
+ tmp100 = mup0 * (1.0 - mup0)
tmp200 = if ( .lp0 == "logit") {
cbind(w * tmp100)
} else {
cbind(w * dtheta.deta(mup0, link= .lp0, earg= .ep0)^2 / tmp100)
}
for(ii in 1:NOS) {
- index200 = abs(tmp200[,ii]) < .Machine$double.eps
+ index200 = abs(tmp200[, ii]) < .Machine$double.eps
if (any(index200)) {
- tmp200[index200,ii] = 10.0 * .Machine$double.eps^(3/4)
+ tmp200[index200, ii] = 10.0 * .Machine$double.eps^(3/4)
}
}
- wz[,1:NOS] = tmp200
+ wz[, 1:NOS] = tmp200
wz
- }), list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))))
+ }), list( .lp0 = lp0, .ep0 = ep0 ))))
}
@@ -792,41 +796,40 @@ dposnegbin = function(x, munb, k, log=FALSE) {
namesof("lambda", .llambda, earg= .ephi, tag=FALSE))
if (!length(etastart)) {
phi.init = if (length( .iphi)) .iphi else {
- sum(w[y==0]) / sum(w)
+ sum(w[y == 0]) / sum(w)
}
phi.init[phi.init <= 0.02] = 0.02 # Last resort
phi.init[phi.init >= 0.98] = 0.98 # Last resort
if ( .method.init == 2) {
mymean = weighted.mean(y[y>0], w[y>0]) + 1/16
- lambda.init = (1- .sinit) * (y+1/8) + .sinit * mymean
+ lambda.init = (1 - .sinit) * (y + 1/8) + .sinit * mymean
} else {
- use.this = median(y[y>0]) + 1/16
- lambda.init = (1- .sinit) * (y+1/8) + .sinit * use.this
+ use.this = median(y[y > 0]) + 1 / 16
+ lambda.init = (1 - .sinit) * (y + 1/8) + .sinit * use.this
}
- etastart = cbind(theta2eta(rep(phi.init, len=n), .lphi, earg= .ephi ),
- theta2eta(lambda.init, .llambda, earg= .ephi ))
+ etastart = cbind(theta2eta(rep(phi.init, len=n), .lphi, .ephi ),
+ theta2eta(lambda.init, .llambda, .ephi ))
}
- }), list( .lphi=lphi, .llambda=llambda,
- .ephi=ephi, .elambda=elambda,
- .iphi=iphi,
- .method.init=method.init,
- .sinit=shrinkage.init ))),
+ }), list( .lphi = lphi, .llambda = llambda,
+ .ephi = ephi, .elambda = elambda,
+ .iphi = iphi,
+ .method.init = method.init, .sinit = shrinkage.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
phi = eta2theta(eta[,1], .lphi, earg= .ephi )
lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
(1-phi) * lambda
- }, list( .lphi=lphi, .llambda=llambda,
- .ephi=ephi, .elambda=elambda ))),
+ }, list( .lphi = lphi, .llambda = llambda,
+ .ephi = ephi, .elambda = elambda ))),
last=eval(substitute(expression({
- misc$link <- c("phi" = .lphi, "lambda" = .llambda)
+ misc$link <- c("phi" = .lphi, "lambda" = .llambda)
misc$earg <- list("phi" = .ephi, "lambda" = .elambda)
if (intercept.only) {
- phi = eta2theta(eta[1,1], .lphi, earg= .ephi )
+ phi = eta2theta(eta[1,1], .lphi, earg= .ephi )
lambda = eta2theta(eta[1,2], .llambda, earg= .elambda )
misc$prob0 = phi + (1-phi) * exp(-lambda) # P(Y=0)
}
- }), list( .lphi=lphi, .llambda=llambda,
- .ephi=ephi, .elambda=elambda ))),
+ }), list( .lphi = lphi, .llambda = llambda,
+ .ephi = ephi, .elambda = elambda ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
smallno = 100 * .Machine$double.eps
@@ -847,8 +850,8 @@ dposnegbin = function(x, munb, k, log=FALSE) {
phi = pmin(phi, 1.0-smallno)
lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
tmp8 = phi + (1-phi)*exp(-lambda)
- index0 = (y==0)
- dl.dphi = (1-exp(-lambda)) / tmp8
+ index0 = (y == 0)
+ dl.dphi = -expm1(-lambda) / tmp8
dl.dphi[!index0] = -1 / (1-phi[!index0])
dl.dlambda = -(1-phi) * exp(-lambda) / tmp8
dl.dlambda[!index0] = (y[!index0] - lambda[!index0]) / lambda[!index0]
@@ -863,20 +866,19 @@ dposnegbin = function(x, munb, k, log=FALSE) {
.ephi=ephi, .elambda=elambda ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), nrow=n, ncol=dimm(M))
- d2l.dphi2 = (1-exp(-lambda)) / ((1-phi)*tmp8)
+ d2l.dphi2 = -expm1(-lambda) / ((1-phi)*tmp8)
d2l.dlambda2 = (1-phi)/lambda - phi*(1-phi)*exp(-lambda) / tmp8
d2l.dphilambda = -exp(-lambda) / tmp8
- wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2
- wz[,iam(2,2,M)] = d2l.dlambda2 * dlambda.deta^2
- wz[,iam(1,2,M)] = d2l.dphilambda * dphi.deta * dlambda.deta
+ wz[, iam(1,1,M)] = d2l.dphi2 * dphi.deta^2
+ wz[, iam(2,2,M)] = d2l.dlambda2 * dlambda.deta^2
+ wz[, iam(1,2,M)] = d2l.dphilambda * dphi.deta * dlambda.deta
if (.llambda == "loge" && (any(lambda[!index0] < .Machine$double.eps))) {
ind5 = !index0 & (lambda < .Machine$double.eps)
if (any(ind5))
wz[ind5,iam(2,2,M)] = (1-phi[ind5]) * .Machine$double.eps
}
w * wz
- }), list( .lphi=lphi, .llambda=llambda,
- .ephi=ephi, .elambda=elambda ))))
+ }), list( .llambda = llambda ))))
}
@@ -1263,8 +1265,8 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
kay.init
}
- etastart = cbind(theta2eta(phi.init, .lphi, earg= .ephi),
- theta2eta(mu.init, .lmunb, earg= .emunb),
+ etastart = cbind(theta2eta(phi.init, .lphi, earg= .ephi),
+ theta2eta(mu.init, .lmunb, earg= .emunb),
theta2eta(kay.init, .lk, earg= .ek))
etastart = etastart[,interleave.VGAM(ncol(etastart),M=3)]
}
diff --git a/R/links.q b/R/links.q
index 86b3738..6b53fcf 100644
--- a/R/links.q
+++ b/R/links.q
@@ -147,7 +147,7 @@ loglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
if (!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 1.0] <- earg$bval
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(exp(theta))
@@ -182,7 +182,7 @@ cloglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
theta[theta >= 1.0] <- 1.0 - earg$bval
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(theta)
@@ -218,7 +218,7 @@ probit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
theta[theta >= 1.0] <- 1-earg$bval
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
ans <- pnorm(theta)
@@ -227,7 +227,7 @@ probit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
ans
}
} else {
- switch(deriv+1,{
+ switch(deriv+1, {
ans <- qnorm(theta)
if (is.matrix(theta))
dim(ans) <- dim(theta)
@@ -276,7 +276,7 @@ loge <- function(theta, earg=list(), inverse=FALSE, deriv=0,
if (!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 0.0] <- earg$bval
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(theta)
@@ -302,7 +302,7 @@ identity <- function(theta, earg=list(), inverse=FALSE, deriv=0,
return(string)
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
theta
@@ -325,7 +325,7 @@ nidentity <- function(theta, earg=list(), inverse=FALSE, deriv=0,
return(string)
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
-theta
@@ -351,13 +351,13 @@ reciprocal <- function(theta, earg=list(), inverse.arg=FALSE, deriv=0,
if (!inverse.arg && is.list(earg) && length(earg$bval))
theta[theta == 0.0] <- earg$bval
if (inverse.arg) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse.arg=FALSE, deriv=deriv)
} else {
1/theta
}
} else {
- switch(deriv+1,{
+ switch(deriv+1, {
1/theta},
-theta^2,
2*theta^3)
@@ -379,7 +379,7 @@ nloge <- function(theta, earg=list(), inverse=FALSE, deriv=0,
if (!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 0.0] <- earg$bval
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(-theta)
@@ -406,7 +406,7 @@ nreciprocal <- function(theta, earg=list(), inverse.arg=FALSE, deriv=0,
if (!inverse.arg && is.list(earg) && length(earg$bval))
theta[theta == 0.0] <- earg$bval
if (inverse.arg) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / nreciprocal(theta, earg=earg, inverse.arg=FALSE, deriv)
} else {
-1/theta
@@ -431,7 +431,7 @@ natural.ig <- function(theta, earg=list(), inverse=FALSE, deriv=0,
return(string)
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / nreciprocal(theta, earg=earg, inverse=FALSE, deriv)
} else {
1/ sqrt(-2*theta)
@@ -468,14 +468,14 @@ rhobit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(theta)
expm1(theta) / (junk+1.0)
}
} else {
- switch(deriv+1,{
+ switch(deriv+1, {
log1p(theta) - log1p(-theta)},
(1 - theta^2) / 2,
(1 - theta^2)^2 / (4*theta))
@@ -504,7 +504,7 @@ fisherz <- function(theta, earg=list(), inverse=FALSE, deriv=0,
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(2*theta)
@@ -548,7 +548,7 @@ fsqrt <- function(theta, earg=list(min=0, max=1, mux=sqrt(2)),
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
mid = (min + max) / 2
@@ -595,7 +595,7 @@ powl <- function(theta, earg=list(power=1), inverse=FALSE, deriv=0,
return(string)
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
theta^(1/exponent)
@@ -641,7 +641,7 @@ elogit <- function(theta, earg=list(min=0, max=1), inverse=FALSE, deriv=0,
return(string)
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- if (is.R()) care.exp(theta) else care.exp(theta)
@@ -675,7 +675,7 @@ elogit <- function(theta, earg=list(min=0, max=1), inverse=FALSE, deriv=0,
theta[theta >= 1.0] <- 1.0 - earg$bval;
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
eta <- care.exp(theta)
@@ -711,13 +711,13 @@ logc <- function(theta, earg=list(), inverse=FALSE, deriv=0,
theta[theta >= 1.0] <- earg$bval;
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
-expm1(theta)
}
} else {
- switch(deriv+1,{
+ switch(deriv+1, {
log1p(-theta)},
-(1.0 - theta),
-(1.0 - theta)^2)
@@ -748,7 +748,7 @@ logoff <- function(theta, earg=list(offset=0), inverse=FALSE, deriv=0,
return(string)
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(theta) - offset
@@ -778,7 +778,7 @@ nlogoff <- function(theta, earg=0, inverse=FALSE, deriv=0,
return(string)
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
offset - exp(theta)
@@ -810,7 +810,7 @@ cauchit <- function(theta, earg=list(bvalue= .Machine$double.eps),
theta[theta >= 1.0] <- 1.0 - earg$bval
}
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
0.5 + atan(theta)/pi
@@ -887,7 +887,7 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
answer =
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
if (is.Numeric(cutpoint)) {
@@ -905,7 +905,7 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
switch(deriv+1, {
temp = Ql / (3*sqrt(lambda))
temp = pmin(temp, 1.0 - smallno) # 100 / .Machine$double.eps
- -3*log(1-temp) + if (is.Numeric(cutpoint)) log(cutpoint) else 0},
+ -3*log1p(-temp) + if (is.Numeric(cutpoint)) log(cutpoint) else 0},
(1 - Ql / (3*sqrt(lambda))) * sqrt(lambda) * dnorm(Ql),
{ stop('cannot handle deriv=2') },
stop("'deriv' unmatched"))
@@ -955,7 +955,7 @@ polf <- function(theta, earg=stop("'earg' must be given"),
answer =
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
if (cutpoint == 0) {
@@ -1039,7 +1039,7 @@ nbolf <- function(theta, earg=stop("'earg' must be given"),
answer =
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
if (cutpoint == 0) {
@@ -1133,7 +1133,7 @@ nbolf2 <- function(theta, earg=stop("'earg' must be given"),
answer =
if (inverse) {
- if (deriv>0) {
+ if (deriv > 0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
if (cutpoint == 0) {
diff --git a/R/mux.q b/R/mux.q
index b92aafd..abe54e6 100644
--- a/R/mux.q
+++ b/R/mux.q
@@ -7,6 +7,25 @@
mux34 <- function(xmat, cc, symmetric=FALSE)
{
+
+ if (!is.matrix(xmat))
+ xmat <- as.matrix(xmat)
+ d <- dim(xmat)
+ nnn <- d[1]
+ RRR <- d[2]
+ if (length(cc) == 1) cc = matrix(cc, 1, 1)
+ if (!is.matrix(cc)) stop("'cc' is not a matrix")
+ c(dotC(name="VGAM_C_mux34", as.double(xmat), as.double(cc),
+ as.integer(nnn), as.integer(RRR),
+ as.integer(symmetric), ans=as.double(rep(0.0, nnn)),
+ NAOK=TRUE)$ans)
+}
+
+
+if(FALSE)
+mux34 <- function(xmat, cc, symmetric=FALSE)
+{
+
if (!is.matrix(xmat))
xmat <- as.matrix(xmat)
d <- dim(xmat)
@@ -21,6 +40,9 @@ mux34 <- function(xmat, cc, symmetric=FALSE)
}
+
+
+
mux2 <- function(cc, xmat)
{
diff --git a/R/plot.vglm.q b/R/plot.vglm.q
index def6e94..f2342e6 100644
--- a/R/plot.vglm.q
+++ b/R/plot.vglm.q
@@ -45,7 +45,7 @@ plotvgam = function(x, newdata=NULL, y=NULL, residuals=NULL, rugplot=TRUE,
if (!is.Numeric(deriv.arg, integ=TRUE, allow=1) || deriv.arg<0)
stop("bad input for the 'deriv' argument")
- if (se && deriv.arg>0) {
+ if (se && deriv.arg > 0) {
warning("standard errors not available with derivatives. ",
"Setting 'se=FALSE'")
se = FALSE
diff --git a/R/predict.vgam.q b/R/predict.vgam.q
index 4c7792b..ffca04d 100644
--- a/R/predict.vgam.q
+++ b/R/predict.vgam.q
@@ -16,7 +16,7 @@ predict.vgam <- function(object, newdata=NULL,
} else {
newdata <- as.data.frame(newdata)
}
- no.newdata = length(newdata)==0
+ no.newdata = length(newdata) == 0
na.act = object at na.action
object at na.action = list()
@@ -26,18 +26,19 @@ predict.vgam <- function(object, newdata=NULL,
type <- match.arg(type, c("link", "response", "terms"))[1]
- if (untransform && (type!="link" || se.fit || deriv.arg != 0 || offset != 0))
+ if (untransform &&
+ (type != "link" || se.fit || deriv.arg != 0 || offset != 0))
stop("argument 'untransform=TRUE' only if type='link', ",
- "se.fit=FALSE, deriv=0")
+ "se.fit = FALSE, deriv = 0")
if (raw && type!="terms")
- stop("'raw=TRUE' only works when 'type=\"terms\"'")
+ stop("'raw = TRUE' only works when 'type = \"terms\"'")
- if (!is.numeric(deriv.arg) || deriv.arg<0 ||
- deriv.arg!=round(deriv.arg) || length(deriv.arg)>1)
+ if (!is.numeric(deriv.arg) || deriv.arg < 0 ||
+ deriv.arg != round(deriv.arg) || length(deriv.arg) > 1)
stop("bad input for the 'deriv' argument")
- if (deriv.arg>0 && type!="terms")
+ if (deriv.arg > 0 && type!="terms")
stop("'deriv>0' can only be specified if 'type=\"terms\"'")
if (deriv.arg != 0 && !(type!="response" && !se.fit))
@@ -117,7 +118,7 @@ predict.vgam <- function(object, newdata=NULL,
}
- if (deriv.arg>0)
+ if (deriv.arg > 0)
if (se.fit) {
predictor$fitted.values <- predictor$fitted.values * 0
predictor$se.fit <- predictor$se.fit * NA
@@ -153,48 +154,48 @@ predict.vgam <- function(object, newdata=NULL,
cs <- if (raw) cumsum(c(1, ncolBlist)) else
cumsum(c(1, M + 0*ncolBlist))
tmp6 <- vector("list", length(ncolBlist))
- for(i in 1:length(tmp6))
- tmp6[[i]] <- cs[i]:(cs[i+1]-1)
+ for(ii in 1:length(tmp6))
+ tmp6[[ii]] <- cs[ii]:(cs[ii+1]-1)
names(tmp6) <- names(ncolBlist)
}
n.s.xargument <- names(s.xargument) # e.g., c("s(x)", "s(x2)")
- for(i in n.s.xargument) {
+ for(ii in n.s.xargument) {
- fred <- s.xargument[i]
+ fred <- s.xargument[ii]
if (!any(dimnames(newdata)[[2]] == fred))
- fred <- i
+ fred <- ii
- xx <- newdata[,fred] # [,s.xargument[i]] # [,nindex[i]]
+ xx <- newdata[,fred] # [,s.xargument[ii]] # [,nindex[ii]]
ox <- order(xx)
rawMat <- predictvsmooth.spline.fit(
- object at Bspline[[i]],
+ object at Bspline[[ii]],
x=xx,
deriv=deriv.arg)$y
- eta.mat <- if (raw) rawMat else (rawMat %*% t(Blist[[i]]))
+ eta.mat <- if (raw) rawMat else (rawMat %*% t(Blist[[ii]]))
if (type=="terms") {
- ii <- tmp6[[i]]
+ hhh <- tmp6[[ii]]
if (se.fit) {
- predictor$fitted.values[,ii] =
- predictor$fitted.values[,ii] + eta.mat
+ predictor$fitted.values[,hhh] =
+ predictor$fitted.values[,hhh] + eta.mat
TS <- predictor$sigma^2
temp.var <- if (raw) {
- iii <- object at misc$varassign
- iii <- iii[[i]]
- object at var[,iii,drop=FALSE]
+ tmp7 <- object at misc$varassign
+ tmp7 <- tmp7[[ii]]
+ object at var[, tmp7, drop=FALSE]
} else
- stop("cannot handle se's with raw=FALSE")
+ stop("cannot handle se's with raw = FALSE")
- predictor$se.fit[,ii] <- (predictor$se.fit[,ii]^2 +
+ predictor$se.fit[,hhh] <- (predictor$se.fit[,hhh]^2 +
TS * temp.var)^0.5
} else {
- predictor[,ii] <- predictor[,ii] + eta.mat
+ predictor[,hhh] <- predictor[,hhh] + eta.mat
}
} else {
if (se.fit) {
@@ -256,12 +257,12 @@ predict.vgam <- function(object, newdata=NULL,
is.lin <- is.linear.term(names(v))
coefmat <- coefvlm(object, matrix=TRUE)
ord <- 0
- for(i in names(v)) {
+ for(ii in names(v)) {
ord <- ord + 1
- index <- v[[i]]
+ index <- v[[ii]]
lindex <- length(index)
- if (is.lin[i]) {
- if (tto[ord]>1 || (length(ttf) && ttf[i,i])) {
+ if (is.lin[ii]) {
+ if (tto[ord] > 1 || (length(ttf) && ttf[ii,ii])) {
if (se.fit) {
predictor$fitted.values[,index] =
if (tto[ord]>1) NA else NA
@@ -269,7 +270,7 @@ predict.vgam <- function(object, newdata=NULL,
predictor[,index] <- if (tto[ord]>1) NA else NA
}
} else {
- ans <- coefmat[i, 1:lindex]
+ ans <- coefmat[ii, 1:lindex]
if (se.fit) {
predictor$fitted.values[,index] = if (deriv.arg==1)
matrix(ans, ncol=lindex, byrow=TRUE) else 0
@@ -279,17 +280,17 @@ predict.vgam <- function(object, newdata=NULL,
}
}
} else
- if (length(s.xargument) && any(n.s.xargument == i)) {
- ans <- coefmat[i, 1:lindex]
+ if (length(s.xargument) && any(n.s.xargument == ii)) {
+ ans <- coefmat[ii, 1:lindex]
if (se.fit) {
predictor$fitted.values[,index] =
predictor$fitted.values[,index] +
- (if(deriv.arg==1)
+ (if(deriv.arg == 1)
matrix(ans, nrow=nrow(predictor$fitted.values),
ncol=lindex, byrow=TRUE) else 0)
} else {
- predictor[,index] <- predictor[,index] +
- (if(deriv.arg==1)
+ predictor[, index] <- predictor[, index] +
+ (if(deriv.arg == 1)
matrix(ans, nrow=nrow(predictor),
ncol=lindex, byrow=TRUE) else 0)
}
@@ -342,9 +343,9 @@ varassign <- function(constraints, n.s.xargument) {
names(ans) <- n.s.xargument
ptr <- 1
- for(i in n.s.xargument) {
- temp <- ncolBlist[[i]]
- ans[[i]] <- ptr:(ptr+temp-1)
+ for(ii in n.s.xargument) {
+ temp <- ncolBlist[[ii]]
+ ans[[ii]] <- ptr:(ptr + temp - 1)
ptr <- ptr + temp
}
ans
diff --git a/R/qrrvglm.control.q b/R/qrrvglm.control.q
index 4648fcb..6315c48 100644
--- a/R/qrrvglm.control.q
+++ b/R/qrrvglm.control.q
@@ -8,7 +8,7 @@ qrrvglm.control = function(Rank=1,
Cinit = NULL,
Crow1positive=TRUE,
epsilon = 1.0e-06,
- EqualTolerances = ITolerances,
+ EqualTolerances = TRUE,
Etamat.colmax = 10,
FastAlgorithm = TRUE,
GradientFunction=TRUE,
@@ -16,7 +16,7 @@ qrrvglm.control = function(Rank=1,
isdlv = rep(c(2, 1, rep(0.5, len=Rank)), len=Rank),
iKvector = 0.1,
iShape = 0.1,
- ITolerances = TRUE,
+ ITolerances = FALSE,
maxitl = 40,
method.init = 1,
Maxit.optim = 250,
@@ -64,7 +64,7 @@ qrrvglm.control = function(Rank=1,
if (!is.Numeric(SD.Cinit, posit=TRUE, allow=1))
stop("bad input for 'SD.Cinit'")
if (ITolerances && !EqualTolerances)
- stop("EqualTolerances must be TRUE if ITolerances is TRUE")
+ stop("'EqualTolerances' must be TRUE if 'ITolerances' is TRUE")
if (!is.Numeric(Bestof, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'Bestof'")
diff --git a/R/qtplot.q b/R/qtplot.q
index dd58a3b..dad53ac 100644
--- a/R/qtplot.q
+++ b/R/qtplot.q
@@ -17,11 +17,12 @@ qtplot.lms.bcn <- function(percentiles=c(25,50,75),
{
lp = length(percentiles)
- answer <- matrix(as.numeric(NA), nrow(eta), lp, dimnames=list(dimnames(eta)[[1]],
+ answer <- matrix(as.numeric(NA), nrow(eta), lp,
+ dimnames=list(dimnames(eta)[[1]],
paste(as.character(percentiles), "%", sep="")))
- for(i in 1:lp) {
- answer[,i] <- eta[,2] * (1+eta[,1] * eta[,3] *
- qnorm(percentiles[i]/100))^(1/eta[,1])
+ for(ii in 1:lp) {
+ answer[,ii] <- eta[,2] * (1+eta[,1] * eta[,3] *
+ qnorm(percentiles[ii]/100))^(1/eta[,1])
}
answer
}
@@ -32,15 +33,16 @@ qtplot.lms.bcg <- function(percentiles=c(25,50,75),
cc <- percentiles
lp = length(percentiles)
- answer <- matrix(as.numeric(NA), nrow(eta), lp, dimnames=list(dimnames(eta)[[1]],
+ answer <- matrix(as.numeric(NA), nrow(eta), lp,
+ dimnames=list(dimnames(eta)[[1]],
paste(as.character(percentiles), "%", sep="")))
lambda <- eta[,1]
sigma <- eta[,3]
shape <- 1 / (lambda * sigma)^2
- for(i in 1:lp) {
- ccc <- rep(cc[i]/100, len=nrow(eta))
- ccc <- ifelse(lambda>0, ccc, 1-ccc)
- answer[,i] <- eta[,2] * (qgamma(ccc, sh=shape)/shape)^(1/lambda)
+ for(ii in 1:lp) {
+ ccc <- rep(cc[ii]/100, len=nrow(eta))
+ ccc <- ifelse(lambda > 0, ccc, 1-ccc)
+ answer[,ii] <- eta[,2] * (qgamma(ccc, sh=shape)/shape)^(1/lambda)
}
answer
}
@@ -52,14 +54,15 @@ qtplot.lms.yjn <- function(percentiles=c(25,50,75),
cc <- percentiles
lp = length(percentiles)
- answer <- matrix(as.numeric(NA), nrow(eta), lp, dimnames=list(dimnames(eta)[[1]],
+ answer <- matrix(as.numeric(NA), nrow(eta), lp,
+ dimnames=list(dimnames(eta)[[1]],
paste(as.character(percentiles), "%", sep="")))
lambda <- eta[,1]
mu <- eta[,2]
sigma <- eta[,3] # Link function already taken care of above
- for(i in 1:lp) {
- ccc <- mu + sigma * qnorm(cc[i]/100)
- answer[,i] <- yeo.johnson(ccc, lambda, inverse= TRUE) - yoffset
+ for(ii in 1:lp) {
+ ccc <- mu + sigma * qnorm(cc[ii]/100)
+ answer[,ii] <- yeo.johnson(ccc, lambda, inverse= TRUE) - yoffset
}
answer
}
@@ -88,9 +91,9 @@ qtplot.default <- function(object, ...) {
qtplot.lmscreg <- function(object,
- newdata=NULL,
- percentiles=object at misc$percentiles,
- plot.it= TRUE, ...) {
+ newdata=NULL,
+ percentiles=object at misc$percentiles,
+ plot.it= TRUE, ...) {
same <- length(percentiles) == length(object at misc$percentiles) &&
all(percentiles==object at misc$percentiles)
@@ -109,8 +112,13 @@ qtplot.lmscreg <- function(object,
object at predictors
eta <- eta2theta(eta, object at misc$link) # Now lambda, mu, sigma
- newcall = paste("qtplot.", object at family@vfamily[1],
- "(percentiles=percentiles, eta=eta, yoffset=object at misc$yoffset)", sep="")
+ if (!is.logical(expectiles <- object at misc$expectiles)) {
+ expectiles <- FALSE
+ }
+
+ newcall = paste(if (expectiles) "explot." else "qtplot.",
+ object at family@vfamily[1], "(percentiles=percentiles",
+ ", eta=eta, yoffset=object at misc$yoffset)", sep="")
newcall = parse(text=newcall)[[1]]
fitted.values = as.matrix( eval(newcall) )
dimnames(fitted.values) <- list(dimnames(eta)[[1]],
@@ -119,9 +127,9 @@ qtplot.lmscreg <- function(object,
if (plot.it) {
plotqtplot.lmscreg(fit=fitted.values, obj=object,
- newdata=newdata,
- lp=lp,
- percentiles=percentiles, ...)
+ newdata=newdata,
+ lp=lp,
+ percentiles=percentiles, ...)
}
list(fitted.values = fitted.values, percentiles = percentiles)
@@ -130,21 +138,21 @@ qtplot.lmscreg <- function(object,
plotqtplot.lmscreg <- function(fitted.values, object,
- newdata=NULL,
- percentiles=object at misc$percentiles,
- lp=NULL,
- add.arg=FALSE,
- y = if (length(newdata)) FALSE else TRUE,
- spline.fit=FALSE,
- label=TRUE,
- size.label=0.06,
- xlab=NULL, ylab="",
- pch=par()$pch, pcex=par()$cex, pcol.arg=par()$col,
- xlim=NULL, ylim=NULL,
- llty.arg=par()$lty,
- lcol.arg=par()$col, llwd.arg=par()$lwd,
- tcol.arg=par()$col,
- tadj=1, ...)
+ newdata=NULL,
+ percentiles=object at misc$percentiles,
+ lp=NULL,
+ add.arg=FALSE,
+ y = if (length(newdata)) FALSE else TRUE,
+ spline.fit=FALSE,
+ label=TRUE,
+ size.label=0.06,
+ xlab=NULL, ylab="",
+ pch=par()$pch, pcex=par()$cex, pcol.arg=par()$col,
+ xlim=NULL, ylim=NULL,
+ llty.arg=par()$lty,
+ lcol.arg=par()$col, llwd.arg=par()$lwd,
+ tcol.arg=par()$col,
+ tadj=1, ...)
{
@@ -217,21 +225,21 @@ plotqtplot.lmscreg <- function(fitted.values, object,
lcol.arg = rep(lcol.arg, length=lp)
llwd.arg = rep(llwd.arg, length=lp)
llty.arg = rep(llty.arg, length=lp)
- for(i in 1:lp) {
- temp <- cbind(xx, fitted.values[,i])
+ for(ii in 1:lp) {
+ temp <- cbind(xx, fitted.values[,ii])
temp <- temp[sort.list(temp[,1]),]
index <- !duplicated(temp[,1])
if (spline.fit) {
lines(spline(temp[index,1], temp[index,2]),
- lty=llty.arg[i], col=lcol.arg[i], err=-1, lwd=llwd.arg[i])
+ lty=llty.arg[ii], col=lcol.arg[ii], err=-1, lwd=llwd.arg[ii])
} else {
lines(temp[index,1], temp[index,2],
- lty=llty.arg[i], col=lcol.arg[i], err=-1, lwd=llwd.arg[i])
+ lty=llty.arg[ii], col=lcol.arg[ii], err=-1, lwd=llwd.arg[ii])
}
if (label)
text(par()$usr[2], temp[nrow(temp),2],
- paste( percentiles[i], "%", sep=""),
- adj=tadj, col=tcol.arg[i], err=-1)
+ paste( percentiles[ii], "%", sep=""),
+ adj=tadj, col=tcol.arg[ii], err=-1)
}
invisible(fitted.values)
@@ -335,22 +343,22 @@ qtplot.gumbel <-
return(answer)
}
- for(i in 1:(lp+mpv))
+ for(ii in 1:(lp+mpv))
{
- temp <- cbind(xx, fitted.values[,i])
+ temp <- cbind(xx, fitted.values[,ii])
temp <- temp[sort.list(temp[,1]),]
index <- !duplicated(temp[,1])
if (spline.fit) {
lines(spline(temp[index,1], temp[index,2]),
- lty=llty.arg[i], col=lcol.arg[i], lwd=llwd.arg[i])
+ lty=llty.arg[ii], col=lcol.arg[ii], lwd=llwd.arg[ii])
} else {
lines(temp[index,1], temp[index,2],
- lty=llty.arg[i], col=lcol.arg[i], lwd=llwd.arg[i])
+ lty=llty.arg[ii], col=lcol.arg[ii], lwd=llwd.arg[ii])
}
if (label) {
- mylabel = (dimnames(answer$fitted)[[2]])[i]
+ mylabel = (dimnames(answer$fitted)[[2]])[ii]
text(par()$usr[2], temp[nrow(temp),2],
- mylabel, adj=tadj, col=tcol.arg[i], err=-1)
+ mylabel, adj=tadj, col=tcol.arg[ii], err=-1)
}
}
@@ -767,3 +775,21 @@ setMethod("rlplot", "vglm", function(object, ...)
+explot.lms.bcn <- function(percentiles=c(25,50,75),
+ eta=NULL, yoffset=0)
+{
+
+ lp = length(percentiles)
+ answer <- matrix(as.numeric(NA), nrow(eta), lp, dimnames=list(dimnames(eta)[[1]],
+ paste(as.character(percentiles), "%", sep="")))
+ for(ii in 1:lp) {
+ answer[,ii] <- eta[,2] * (1+eta[,1] * eta[,3] *
+ qenorm(percentiles[ii]/100))^(1/eta[,1])
+ }
+ answer
+}
+
+
+
+
+
diff --git a/R/rrvglm.control.q b/R/rrvglm.control.q
index 5de4d87..f6081b2 100644
--- a/R/rrvglm.control.q
+++ b/R/rrvglm.control.q
@@ -4,18 +4,20 @@
-rrvglm.control = function(Rank=1,
- Algorithm=c("alternating", "derivative"),
+rrvglm.control = function(Rank = 1,
+ Algorithm = c("alternating", "derivative"),
Corner=TRUE,
Uncorrelated.lv=FALSE,
Wmat=NULL,
Svd.arg=FALSE,
Index.corner = if (length(Structural.zero))
head((1:1000)[-Structural.zero], Rank) else 1:Rank,
+ Ainit=NULL,
Alpha=0.5,
Bestof = 1,
Cinit=NULL,
Etamat.colmax = 10,
+ SD.Ainit = 0.02,
SD.Cinit = 0.02,
Structural.zero = NULL,
Norrr = ~ 1,
@@ -41,6 +43,8 @@ rrvglm.control = function(Rank=1,
stop("bad input for 'Alpha'")
if (!is.Numeric(Bestof, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'Bestof'")
+ if (!is.Numeric(SD.Ainit, posit=TRUE, allow=1))
+ stop("bad input for 'SD.Ainit'")
if (!is.Numeric(SD.Cinit, posit=TRUE, allow=1))
stop("bad input for 'SD.Cinit'")
if (!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
@@ -76,6 +80,9 @@ rrvglm.control = function(Rank=1,
if (!is.Numeric(wzepsilon, allow=1, positive=TRUE))
stop("bad input for 'wzepsilon'")
+ if (class(Norrr) != "formula" && !is.null(Norrr))
+ stop("argument 'Norrr' should be a formula or a NULL")
+
ans =
c(vglm.control(trace = trace, ...),
switch(Algorithm,
@@ -83,6 +90,7 @@ rrvglm.control = function(Rank=1,
"derivative" = if (is.R()) rrvglm.optim.control(...) else
nlminbcontrol(...)),
list(Rank=Rank,
+ Ainit=Ainit,
Algorithm=Algorithm,
Alpha=Alpha,
Bestof = Bestof,
@@ -92,6 +100,7 @@ rrvglm.control = function(Rank=1,
Corner=Corner, Uncorrelated.lv=Uncorrelated.lv, Wmat=Wmat,
OptimizeWrtC = TRUE, # OptimizeWrtC,
Quadratic = FALSE, # A constant now, here.
+ SD.Ainit = SD.Ainit,
SD.Cinit = SD.Cinit,
Etamat.colmax = Etamat.colmax,
Structural.zero = Structural.zero,
diff --git a/R/rrvglm.fit.q b/R/rrvglm.fit.q
index a338bd6..1860081 100644
--- a/R/rrvglm.fit.q
+++ b/R/rrvglm.fit.q
@@ -6,6 +6,7 @@
+
rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
etastart=NULL, mustart=NULL, coefstart=NULL,
offset=0, family,
@@ -54,7 +55,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
- if (trace && orig.stepsize==1) {
+ if (trace && orig.stepsize == 1) {
cat(if(control$Quadratic) "QRR-VGLM" else "RR-VGLM",
" linear loop ", iter, ": ", criterion, "= ")
uuuu = switch(criterion, coefficients=
@@ -111,7 +112,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
coefficients=new.coeffs,
tfun(mu=mu,y=y,w=w,res=FALSE,eta=eta,extra))
- if ((criterion=="coefficients") ||
+ if ((criterion == "coefficients") ||
( minimize.criterion && new.crit < old.crit) ||
(!minimize.criterion && new.crit > old.crit))
break
@@ -232,17 +233,19 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
special.matrix = matrix(-34956.125, M, M) # An unlikely used matrix
just.testing <- cm.vgam(special.matrix, x, rrcontrol$Norrr, constraints)
+
findex = trivial.constraints(just.testing, special.matrix)
+ if (is.null(just.testing)) findex = NULL # 20100617
tc1 = trivial.constraints(constraints)
- if (!control$Quadratic && sum(!tc1)) {
+ if (!is.null(findex) && !control$Quadratic && sum(!tc1)) {
for(ii in names(tc1))
- if (!tc1[ii] && !any(ii == names(findex)[findex==1]))
+ if (!tc1[ii] && !any(ii == names(findex)[findex == 1]))
warning("'", ii, "' is a non-trivial constraint that ",
"will be overwritten by reduced-rank regression")
}
- if (all(findex == 1))
+ if (!is.null(findex) && all(findex == 1))
stop("use vglm(), not rrvglm()!")
colx1.index = names.colx1.index = NULL
dx2 = dimnames(x)[[2]]
@@ -255,34 +258,38 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
names(colx1.index) = names.colx1.index
}
- rrcontrol$colx1.index=control$colx1.index=colx1.index #Save it on the object
+ rrcontrol$colx1.index = control$colx1.index =
+ colx1.index # Save it on the object
colx2.index = 1:ncol(x)
names(colx2.index) = dx2
- colx2.index = colx2.index[-colx1.index]
+ if (length(colx1.index))
+ colx2.index = colx2.index[-colx1.index]
+
p1 = length(colx1.index); p2 = length(colx2.index)
- rrcontrol$colx2.index=control$colx2.index=colx2.index #Save it on the object
+ rrcontrol$colx2.index = control$colx2.index =
+ colx2.index # Save it on the object
Index.corner = control$Index.corner
Amat <- if (length(rrcontrol$Ainit)) rrcontrol$Ainit else
- matrix(rnorm(M * Rank, sd=rrcontrol$SD.Cinit), M, Rank)
+ matrix(rnorm(M * Rank, sd = rrcontrol$SD.Cinit), M, Rank)
Cmat <- if (length(rrcontrol$Cinit)) rrcontrol$Cinit else {
if (!rrcontrol$Use.Init.Poisson.QO) {
matrix(rnorm(p2 * Rank, sd=rrcontrol$SD.Cinit), p2, Rank)
} else
.Init.Poisson.QO(ymat=as.matrix(y),
- X1=x[,colx1.index,drop=FALSE],
- X2=x[,colx2.index,drop=FALSE],
- Rank=rrcontrol$Rank, trace=rrcontrol$trace,
- max.ncol.etamat = rrcontrol$Etamat.colmax,
- Crow1positive=rrcontrol$Crow1positive,
- isdlv=rrcontrol$isdlv)
+ X1=if (length(colx1.index)) x[, colx1.index, drop=FALSE] else NULL,
+ X2=x[, colx2.index, drop=FALSE],
+ Rank=rrcontrol$Rank, trace=rrcontrol$trace,
+ max.ncol.etamat = rrcontrol$Etamat.colmax,
+ Crow1positive=rrcontrol$Crow1positive,
+ isdlv=rrcontrol$isdlv)
}
- if (modelno==3)
- Amat[c(FALSE,TRUE),] <- 0 # Intercept only for log(k)
+ if (modelno == 3)
+ Amat[c(FALSE, TRUE),] <- 0 # Intercept only for log(k)
if (control$Corner)
@@ -310,7 +317,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
C=Cmat, control=control)
xsmall.qrr = tmp500$new.lv.model.matrix
B.list = tmp500$constraints # Doesn't change or contain \bI_{Rank} \bnu
- if (modelno==3 && FALSE) {
+ if (modelno == 3 && FALSE) {
B.list[[1]] = (B.list[[1]])[,c(TRUE,FALSE),drop=FALSE] # Amat
B.list[[2]] = (B.list[[2]])[,c(TRUE,FALSE),drop=FALSE] # D
}
@@ -415,7 +422,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
}
- if (maxit>1 && iter>=maxit)
+ if (maxit > 1 && iter >= maxit)
warning("convergence not obtained in ", maxit, " iterations")
@@ -426,7 +433,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (length(family at fini))
eval(family at fini)
- if (M>1 && !nice31)
+ if (M > 1 && !nice31)
tfit$predictors <- matrix(tfit$predictors, n, M)
asgn <- attr(X_vlm_save, "assign")
@@ -469,7 +476,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (nice31) {
residuals <- z - fv
- if (M==1) {
+ if (M == 1) {
residuals <- as.vector(residuals)
names(residuals) <- yn
} else {
@@ -477,7 +484,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
} else {
residuals <- z - tfit$predictors
- if (M==1) {
+ if (M == 1) {
tfit$predictors <- as.vector(tfit$predictors)
residuals <- as.vector(residuals)
names(residuals) <- names(tfit$predictors) <- yn
@@ -519,7 +526,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
dimnames(fit$qr$qr) <- dnrow_X_vlm
}
- if (M==1) {
+ if (M == 1) {
wz <- as.vector(wz) # Convert wz into a vector
} # else
fit$weights <- if (save.weight) wz else NULL
@@ -566,7 +573,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
eval(family at last)
- structure(c(fit, list(predictors = if (nice31) matrix(eta,n,M) else
+ structure(c(fit, list(predictors = if (nice31) matrix(eta, n, M) else
tfit$predictors,
contrasts=attr(x, "contrasts"),
control=control,
diff --git a/R/s.vam.q b/R/s.vam.q
index 1b45925..ad6378e 100644
--- a/R/s.vam.q
+++ b/R/s.vam.q
@@ -5,9 +5,9 @@
-s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
- bf.epsilon=0.001, trace=FALSE, se.fit=TRUE,
- X_vlm_save, Blist, ncolBlist, M, qbig, U,
+s.vam <- function(x, zedd, wz, smomat, which, smooth.frame, bf.maxit = 10,
+ bf.epsilon=0.001, trace=FALSE, se.fit = TRUE,
+ X_vlm_save, Blist, ncolBlist, M, qbig, Umat,
all.knots=FALSE, nk=NULL,
sf.only=FALSE)
{
@@ -24,175 +24,192 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
smooth.frame$first <- FALSE # No longer first for next time
dx <- as.integer(dim(x))
- smooth.frame$n <- dx[1]
- smooth.frame$p <- dx[2]
+ smooth.frame$n_lm <- dx[1]
+ smooth.frame$p_lm <- dx[2]
attr(data, "class") <- NULL
- spar <- lapply(data, attr, "spar")
- df <- lapply(data, attr, "df")
+ sparv <- lapply(data, attr, "spar")
+ dfvec <- lapply(data, attr, "df")
s.xargument <- lapply(data, attr, "s.xargument")
- for(k in 1:length(nwhich)) {
- i <- nwhich[k]
+ for(kk in 1:length(nwhich)) {
+ ii <- nwhich[kk]
- temp <- spar[[i]]
- if (!is.numeric(temp) || any(temp<0))
+ temp <- sparv[[ii]]
+ if (!is.numeric(temp) || any(temp < 0)) {
stop("spar cannot be negative or non-numeric")
- if (length(temp) > ncolBlist[i])
- warning("only the first ", ncolBlist[i], " values of 'spar' ",
- " are used for variable '", s.xargument, "'")
- spar[[i]] <- rep(temp, length=ncolBlist[i]) # recycle
+ }
+ if (length(temp) > ncolBlist[ii]) {
+ warning("only the first ", ncolBlist[ii], " values of ",
+ "'spar' are used for variable '", s.xargument, "'")
+ }
+ sparv[[ii]] <- rep(temp, length=ncolBlist[ii]) # recycle
- temp <- df[[i]]
- if (!is.numeric(temp) || any(temp<1))
+ temp <- dfvec[[ii]]
+ if (!is.numeric(temp) || any(temp < 1)) {
stop("df is non-numeric or less than 1")
- if (length(temp) > ncolBlist[i])
- warning("only the first", ncolBlist[i], "values of 'df' ",
+ }
+ if (length(temp) > ncolBlist[ii]) {
+ warning("only the first", ncolBlist[ii], "values of 'df' ",
"are used for variable '", s.xargument, "'")
- df[[i]] <- rep(temp, length=ncolBlist[i]) # recycle
- if (max(temp) > smooth.frame$nef[k]-1)
+ }
+ dfvec[[ii]] <- rep(temp, length=ncolBlist[ii]) # recycle
+ if (max(temp) > smooth.frame$nef[kk]-1) {
stop("'df' value too high for variable '", s.xargument, "'")
+ }
- if (any(spar[[i]]!=0) && any(df[[i]]!=4))
+ if (any(sparv[[ii]] != 0) && any(dfvec[[ii]] != 4)) {
stop("cannot specify both 'spar' and 'df'")
- }
+ }
+ } # End of kk loop
- spar <- unlist(spar)
- df <- unlist(df)
- smooth.frame$spar <- spar # original
- smooth.frame$df <- df # original
+ sparv <- unlist(sparv)
+ dfvec <- unlist(dfvec)
+ smooth.frame$sparv <- sparv # original
+ smooth.frame$dfvec <- dfvec # original
- if (sum(smooth.frame$df[smooth.frame$spar==0]) + pbig >
- smooth.frame$n * sum(ncolBlist[nwhich]))
+ if (sum(smooth.frame$dfvec[smooth.frame$sparv == 0]) + pbig >
+ smooth.frame$n_lm * sum(ncolBlist[nwhich])) {
stop("too many parameters/dof for data on hand")
+ }
xnrow_X_vlm <- labels(X_vlm_save)[[2]]
asgn <- attr(X_vlm_save, "assign")
aa <- NULL
- for(i in nwhich) {
- aa <- c(aa, xnrow_X_vlm[asgn[[i]]])
+ for(ii in nwhich) {
+ aa <- c(aa, xnrow_X_vlm[asgn[[ii]]])
}
- smooth.frame$ndfspar <- aa # Stored here
- smooth.frame$xnrow_X_vlm <- xnrow_X_vlm # Stored here
+ smooth.frame$ndfsparv <- aa # Stored here
+ smooth.frame$xnrow_X_vlm <- xnrow_X_vlm # Stored here
smooth.frame$s.xargument <- s.xargument # Stored here
smooth.frame$smap=as.vector(cumsum(
- c(1,ncolBlist[nwhich]))[1:length(nwhich)])
+ c(1, ncolBlist[nwhich]))[1:length(nwhich)])
- smooth.frame$try.spar <- spar
- smooth.frame$prev.dof <- df
+ smooth.frame$try.sparv <- sparv
+ smooth.frame$prev.dof <- dfvec
smooth.frame$bindex <- as.integer(cumsum(c(1,
smooth.frame$nknots*ncolBlist[nwhich])))
- smooth.frame$kindex = as.integer(cumsum(c(1, 4+smooth.frame$nknots)))
- }
- if (sf.only)
+ smooth.frame$kindex = as.integer(
+ cumsum(c(1, 4 + smooth.frame$nknots)))
+ } # End of first
+ if (sf.only) {
return(smooth.frame)
+ }
- ldk <- 4 * max(ncolBlist[nwhich]) # was M; # Prior to 11/7/02
ldk <- 3 * max(ncolBlist[nwhich]) + 1 # 11/7/02
which <- unlist(which)
- p <- smooth.frame$p
- n <- smooth.frame$n
- dimw <- if (is.matrix(wz)) ncol(wz) else 1
+ p_lm <- smooth.frame$p_lm
+ n_lm <- smooth.frame$n_lm
+ dim2wz <- if (is.matrix(wz)) ncol(wz) else 1
- dimu <- if (is.matrix(U)) nrow(U) else 1
-
- index <- iam(NA, NA, M, both=TRUE)
+ dim1U <- if (is.matrix(Umat)) nrow(Umat) else 1
nBlist <- names(Blist)
- for(i in length(nBlist):1) {
- if (!any(nBlist[i] == nwhich))
- Blist[[i]] <- NULL
+ for(ii in length(nBlist):1) {
+ if (!any(nBlist[ii] == nwhich)) {
+ Blist[[ii]] <- NULL
+ }
}
trivc <- trivial.constraints(Blist)
ncbvec <- ncolBlist[nwhich]
- ncolb <- max(ncbvec)
-
- pmax.mwk <- rep(dimw, length(trivc))
- pmax.mwk <- pmax(ncbvec*(ncbvec+1)/2, dimw)
-
- size.twk <- max((4+4*smooth.frame$nef)*ncbvec + dimu*smooth.frame$nef)
-
- size.twk <- max(size.twk, M*smooth.frame$n)
-
- fit <- dotFortran(name="vbfa",
- n = as.integer(n), M = as.integer(M),
- npetc = as.integer(c(n, p, length(which), se.fit, 0,
- bf.maxit, 0, M, n*M, pbig,
- qbig, dimw, dimu, ier=0, ldk=ldk)),
- as.double(x),
- y = as.double(z), w = as.double(wz),
- spar = as.double(smooth.frame$try.spar),
- df = as.double(smooth.frame$df),
- as.integer(smooth.frame$o),as.integer(smooth.frame$nef),as.integer(which),
- etal = double(M*n), smooth = as.double(s), eta = double(M*n),
- s0 = double((2*M)*(2*M)*2),
- beta = double(pbig), var = if (se.fit) as.double(s) else double(1),
- as.double(bf.epsilon),
- qr = as.double(X_vlm_save), qraux = double(pbig),
- qpivot = as.integer(1:pbig),
- X_vlm = double(1),
- U = as.double(U),
- as.double(unlist(Blist)),
- as.integer(ncbvec), as.integer(smooth.frame$smap),
- rcind = integer(M*(M+1)), trivc = as.integer(trivc),
- work1 = double(3*qbig + (9+2*4+max(smooth.frame$nknots))*
- max(smooth.frame$nknots)),
- wk2 = double(n*M*3),
- wkmm = double(M*M*16 + M*pbig),
- work3 = double(max(max(2 * smooth.frame$nef * ncbvec^2),
- max(smooth.frame$nknots * ncbvec * (4*ncbvec+1)))),
- sgdub = double(max(smooth.frame$nknots) * max(4,ncolb)),
- bmb = double(M*M),
- lev = double(max(smooth.frame$nef * ncbvec)),
- mwk = double(max(smooth.frame$nef * (1 + 2*M + pmax.mwk)) ),
- twk = double(size.twk),
- bcoefficients = double(sum(smooth.frame$nknots*ncbvec)),
- knots = as.double(unlist(smooth.frame$knots)),
- resss = double(1),
- bindex = as.integer(smooth.frame$bindex),
- nknots = as.integer(smooth.frame$nknots),
- itwk = integer(2*M),
- kindex = as.integer(smooth.frame$kindex))
+ ncolbmax <- max(ncbvec)
+
+
+
+
+ contr.sp <- list(low = -1.5,## low = 0. was default till R 1.3.x
+ high = 1.5,
+ tol = 1e-4,## tol = 0.001 was default till R 1.3.x
+ eps = 2e-8,## eps = 0.00244 was default till R 1.3.x
+ maxit = 500 )
+
+ if (FALSE)
+ contr.sp <- list(low = -1.5,## low = 0. was default till R 1.3.x
+ high = 1.5,
+ tol = 0.001, # was default till R 1.3.x
+ eps = 0.00244, # was default till R 1.3.x
+ maxit = 500 )
+
+ fit <- dotC(name="Yee_vbfa", # ---------------------------------
+ npetc = as.integer(c(n_lm, p_lm, length(which), se.fit, 0,
+ bf.maxit, qrank = 0, M, nbig = n_lm * M, pbig,
+ qbig, dim2wz, dim1U, ier=0, ldk=ldk, # ldk may be unused
+ contr.sp$maxit, iinfo = 0
+ )),
+ doubvec = as.double(c(bf.epsilon, resSS=0, unlist(contr.sp[1:4]))),
+ as.double(x),
+ y = as.double(zedd), wz = as.double(wz),
+ dfvec = as.double(smooth.frame$dfvec),
+ lamvec = as.double(smooth.frame$try.sparv),
+ sparv = as.double(smooth.frame$try.sparv),
+ as.integer(smooth.frame$o), as.integer(smooth.frame$nef),
+ as.integer(which),
+ smomat = as.double(smomat), etamat = double(M * n_lm),
+ beta = double(pbig),
+ varmat = if (se.fit) as.double(smomat) else double(1),
+ qr = as.double(X_vlm_save), qraux = double(pbig),
+ qpivot = as.integer(1:pbig),
+ as.double(Umat),
+ as.double(unlist(Blist)),
+ as.integer(ncbvec), as.integer(smooth.frame$smap),
+ trivc = as.integer(trivc),
+
+ levmat = if (se.fit) as.double(smomat) else double(1), # 20100227
+
+ bcoefficients = double(sum(smooth.frame$nknots * ncbvec)),
+ knots = as.double(unlist(smooth.frame$knots)),
+ bindex = as.integer(smooth.frame$bindex),
+ nknots = as.integer(smooth.frame$nknots),
+ kindex = as.integer(smooth.frame$kindex)) # End of dotC
dim(fit$qr) = dim(X_vlm_save)
dimnames(fit$qr) = dimnames(X_vlm_save)
- dim(fit$y) = dim(z)
- dimnames(fit$y) = dimnames(z)
- dim(fit$smooth) = dim(s)
- dimnames(fit$smooth) = dimnames(s) # Needed for vgam.nlchisq
+ dim(fit$y) = dim(zedd)
+ dimnames(fit$y) = dimnames(zedd)
+ dim(fit$smomat) = dim(smomat)
+ dimnames(fit$smomat) = dimnames(smomat) # Needed for vgam.nlchisq
if (se.fit) {
- dim(fit$var) = dim(s)
- dimnames(fit$var) = dimnames(s)
- }
+ dim(fit$varmat) = dim(smomat)
+ dimnames(fit$varmat) = dimnames(smomat)
+ dim(fit$levmat) = dim(smomat)
+ dimnames(fit$levmat) = dimnames(smomat)
+ }
- if (fit$npetc[14] != 0)
- stop("something went wrong in the Fortran subroutine vbfa()")
- fit$eta <- if (M>1) matrix(fit$eta,n,M,byrow=TRUE) else c(fit$eta)
+ if (fit$npetc[14] != 0 || fit$npetc[17] != 0) {
+ stop("something went wrong in the C function 'vbfa'")
+ }
- nit <- fit$npetc[5]
+ fit$etamat = if (M > 1) matrix(fit$etamat, n_lm, M, byrow=TRUE) else
+ c(fit$etamat) # May no longer be a matrix
+ nits <- fit$npetc[5]
qrank <- fit$npetc[7]
- smooth.frame$try.spar <- fit$spar
- change <- abs(smooth.frame$prev.dof-fit$df)/fit$df > 0.05 &
- smooth.frame$spar==0
- smooth.frame$try.spar[change] <- 0 # For next time
- smooth.frame$prev.dof <- fit$df
+ smooth.frame$try.sparv <- fit$sparv
+
+ change <- abs(smooth.frame$prev.dof - fit$dfvec)/(1+fit$dfvec) > 0.00 &
+ smooth.frame$sparv == 0
- if ((nit == bf.maxit) & bf.maxit > 1)
- warning("'s.vam' convergence not obtained in ", bf.maxit, " iterations")
+
+ smooth.frame$try.sparv[change] <- 0 # For next time
+ smooth.frame$prev.dof <- fit$dfvec
+
+ if ((nits == bf.maxit) & bf.maxit > 1) {
+ warning("'s.vam' convergence not obtained in ", bf.maxit,
+ " iterations")
+ }
R <- fit$qr[1:pbig, 1:pbig]
R[lower.tri(R)] <- 0
@@ -201,40 +218,43 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
Bspline <- vector("list", length(nwhich))
names(Bspline) <- nwhich
- for(i in 1:length(nwhich)) {
- ans = fit$bcoeff[(smooth.frame$bindex[i]):(smooth.frame$bindex[i+1]-1)]
- ans = matrix(ans, ncol=ncolBlist[nwhich[i]])
- Bspline[[i]] = new("vsmooth.spline.fit",
- "Bcoefficients" = ans,
- "xmax" = smooth.frame$xmax[i],
- "xmin" = smooth.frame$xmin[i],
- "knots" = as.vector(smooth.frame$knots[[i]]))
+ for(ii in 1:length(nwhich)) {
+ ans = fit$bcoeff[(smooth.frame$bindex[ii]):
+ (smooth.frame$bindex[ii+1]-1)]
+ ans = matrix(ans, ncol=ncolBlist[nwhich[ii]])
+ Bspline[[ii]] =
+ new("vsmooth.spline.fit",
+ "Bcoefficients" = ans,
+ "xmax" = smooth.frame$xmax[ii],
+ "xmin" = smooth.frame$xmin[ii],
+ "knots" = as.vector(smooth.frame$knots[[ii]]))
}
rl <- list(
- Bspline = Bspline,
- coefficients = fit$beta,
- df.residual = n*M - qrank - sum(fit$df - 1),
- fitted.values = fit$eta,
- nl.df = fit$df - 1,
- qr = list(qr=fit$qr, rank=qrank, qraux=fit$qraux, pivot=fit$qpivot),
- R = R,
- rank = qrank,
- residuals = fit$y - fit$eta,
- rss = fit$resss,
- smooth = fit$smooth,
- spar = fit$spar,
- s.xargument = unlist(smooth.frame$s.xargument))
+ Bspline = Bspline,
+ coefficients = fit$beta,
+ df.residual = n_lm * M - qrank - sum(fit$dfvec - 1),
+ fitted.values = fit$etamat,
+ nl.df = fit$dfvec - 1,
+ qr = list(qr=fit$qr, rank=qrank, qraux=fit$qraux, pivot=fit$qpivot),
+ R = R,
+ rank = qrank,
+ residuals = fit$y - fit$etamat,
+ rss = fit$doubvec[2],
+ smomat = fit$smomat,
+ sparv = fit$sparv,
+ s.xargument = unlist(smooth.frame$s.xargument))
names(rl$coefficients) <- smooth.frame$xnrow_X_vlm
- names(rl$spar) <- smooth.frame$ndfspar
+ names(rl$sparv) <- smooth.frame$ndfspar
names(rl$nl.df) <- smooth.frame$ndfspar
- if (se.fit)
- rl <- c(rl, list(var=fit$var))
- c(list(smooth.frame=smooth.frame), rl)
+ if (se.fit) {
+ rl <- c(rl, list(varmat = fit$varmat))
+ }
+ c(list(smooth.frame = smooth.frame), rl)
}
diff --git a/R/vgam.R b/R/vgam.R
index bb057fd..75fd774 100644
--- a/R/vgam.R
+++ b/R/vgam.R
@@ -68,11 +68,11 @@ vgam <- function(formula,
spars2 = lapply(mf2, attr, "spar")
dfs2 = lapply(mf2, attr, "df")
sx2 = lapply(mf2, attr, "s.xargument")
- for(i in 1:length(mf)) {
- if (length(sx2[[i]])) {
- attr(mf[[i]], "spar") = spars2[[i]]
- attr(mf[[i]], "dfs2") = dfs2[[i]]
- attr(mf[[i]], "s.xargument") = sx2[[i]]
+ for (ii in 1:length(mf)) {
+ if (length(sx2[[ii]])) {
+ attr(mf[[ii]], "spar") = spars2[[ii]]
+ attr(mf[[ii]], "dfs2") = dfs2[[ii]]
+ attr(mf[[ii]], "s.xargument") = sx2[[ii]]
}
}
rm(mf2)
@@ -105,8 +105,8 @@ vgam <- function(formula,
family at inverse <- eval(family at inverse)
family at link <- eval(family at link)
- for(i in names(.min.criterion.VGAM))
- if (length(family[[i]])) family[[i]] <- eval(family[[i]])
+ for (ii in names(.min.criterion.VGAM))
+ if (length(family[[ii]])) family[[ii]] <- eval(family[[ii]])
}
if (length(slot(family, "first")))
@@ -126,8 +126,8 @@ vgam <- function(formula,
if (nonparametric) {
ff <- apply(aa$factors[smoothers[["s"]],,drop=FALSE], 2, any)
- smoothers[["s"]] <- if (any(ff)) seq(along=ff)[aa$order==1 & ff] else
- NULL
+ smoothers[["s"]] <- if (any(ff))
+ seq(along=ff)[aa$order==1 & ff] else NULL
smooth.labels <- aa$term.labels[unlist(smoothers)]
} else
@@ -156,7 +156,7 @@ vgam <- function(formula,
} else {
}
- fit$smooth <- NULL # Not needed
+ fit$smomat <- NULL # Not needed
fit$call <- ocall
if (model)
@@ -244,8 +244,8 @@ vgam <- function(formula,
slot(answer, "nl.df") = fit$nl.df
slot(answer, "spar") = fit$spar
slot(answer, "s.xargument") = fit$s.xargument
- if (length(fit$var)) {
- slot(answer, "var") = fit$var
+ if (length(fit$varmat)) {
+ slot(answer, "var") = fit$varmat
}
@@ -266,8 +266,8 @@ attr(vgam, "smart") <- TRUE
care.exp <- function(x, thresh = -log(.Machine$double.eps)) {
- x[x > thresh] <- thresh
- x[x < (-thresh)] <- -thresh
+ x[x > thresh] <- thresh
+ x[x < (-thresh)] <- -thresh
exp(x)
}
diff --git a/R/vgam.control.q b/R/vgam.control.q
index 3282ef5..71a0dde 100644
--- a/R/vgam.control.q
+++ b/R/vgam.control.q
@@ -16,8 +16,7 @@ vgam.control <- function(all.knots=FALSE,
se.fit=TRUE,
trace=FALSE,
wzepsilon = .Machine$double.eps^0.75,
- ...)
-{
+ ...) {
@@ -76,30 +75,28 @@ vgam.control <- function(all.knots=FALSE,
}
-vgam.nlchisq <- function(qr, resid, wz, s, deriv, U, smooth.labels,
- assign, M, n, constraints)
-{
-
+vgam.nlchisq <- function(qr, resid, wz, smomat, deriv, U, smooth.labels,
+ assign, M, n, constraints) {
attr(qr, "class") = "qr"
class(qr) <- "qr"
- if (!is.matrix(s)) s <- as.matrix(s)
+ if (!is.matrix(smomat)) smomat <- as.matrix(smomat)
if (!is.matrix(wz)) wz <- as.matrix(wz)
if (!is.matrix(deriv)) deriv <- as.matrix(deriv)
if (!is.matrix(resid)) resid <- as.matrix(resid)
trivc <- trivial.constraints(constraints)
- ans <- rep(as.numeric(NA), length=ncol(s))
- Uderiv <- vbacksub(U, t(deriv), M=M, n=n) # \bU_i^{-1} \biu_i
+ ans <- rep(as.numeric(NA), length = ncol(smomat))
+ Uderiv <- vbacksub(U, t(deriv), M = M, n = n) # \bU_i^{-1} \biu_i
ptr <- 0
- for(i in 1:length(smooth.labels)) {
- cmat <- constraints[[ smooth.labels[i] ]]
+ for(ii in 1:length(smooth.labels)) {
+ cmat <- constraints[[ smooth.labels[ii] ]]
index <- (ptr+1):(ptr+ncol(cmat))
- for(j in index) {
- yy <- t(cmat[,j-ptr,drop=FALSE])
- yy <- kronecker(s[,j,drop=FALSE], yy) # n x M
+ for(jay in index) {
+ yy <- t(cmat[,jay-ptr,drop=FALSE])
+ yy <- kronecker(smomat[,jay,drop=FALSE], yy) # n x M
Us <- mux22(U, yy, M=M, upper=TRUE, as.matrix=TRUE) # n * M
Uss <- matrix(c(t(Us)), nrow=n*M, ncol=1)
@@ -109,13 +106,13 @@ vgam.nlchisq <- function(qr, resid, wz, s, deriv, U, smooth.labels,
vRsw <- matrix(Rsw, nrow=n, ncol=M, byrow=TRUE)
newans <- vbacksub(U, t(vRsw), M=M, n=n)
- ans[j] <- sum(vRsw^2 + 2 * newans * deriv)
+ ans[jay] <- sum(vRsw^2 + 2 * newans * deriv)
}
ptr <- ptr + ncol(cmat)
}
- names(ans) <- dimnames(s)[[2]]
+ names(ans) <- dimnames(smomat)[[2]]
ans
}
diff --git a/R/vgam.fit.q b/R/vgam.fit.q
index df32fb0..2e72295 100644
--- a/R/vgam.fit.q
+++ b/R/vgam.fit.q
@@ -48,7 +48,7 @@ vgam.fit <- function(x, y, w, mf,
new.crit <- switch(criterion,
coefficients=new.coeffs,
- tfun(mu=mu, y=y, w=w, res=FALSE, eta=eta, extra))
+ tfun(mu=mu, y=y, w=w, res=FALSE, eta=eta, extra))
if (trace) {
cat("VGAM ", bf, " loop ", iter, ": ", criterion, "= ")
@@ -66,13 +66,14 @@ vgam.fit <- function(x, y, w, mf,
flush.console()
- if (!is.finite(one.more) || !is.logical(one.more)) one.more = FALSE
+ if (!is.finite(one.more) ||
+ !is.logical(one.more)) one.more = FALSE
if (one.more) {
iter <- iter + 1
deriv.mu <- eval(family at deriv)
wz <- eval(family at weight)
if (control$checkwz)
- wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
+ wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
tvfor <- vforsub(U, as.matrix(deriv.mu), M=M, n=n)
@@ -83,9 +84,9 @@ vgam.fit <- function(x, y, w, mf,
c.list$U <- U
}
- c.list$one.more <- one.more
- c.list$coeff <- runif(length(new.coeffs)) # 12/3/03; twist needed!
- old.coeffs <- new.coeffs
+ c.list$one.more <- one.more
+ c.list$coeff = runif(length(new.coeffs)) # 12/3/03; twist needed!
+ old.coeffs <- new.coeffs
}
c.list
})
@@ -97,11 +98,11 @@ vgam.fit <- function(x, y, w, mf,
old.coeffs <- coefstart
intercept.only <- ncol(x) == 1 && dimnames(x)[[2]] == "(Intercept)"
- y.names <- predictors.names <- NULL # May be overwritten in @initialize
+ y.names <- predictors.names <- NULL # May be overwritten in @initialize
n.save <- n
if (length(slot(family, "initialize")))
- eval(slot(family, "initialize")) # Initialize mu & M (and optionally w)
+ eval(slot(family, "initialize")) # Initialize mu & M (& optionally w)
if (length(etastart)) {
eta <- etastart
@@ -134,26 +135,26 @@ vgam.fit <- function(x, y, w, mf,
bf <- "s.vam"
bf.call <- parse(text=paste(
- "s.vam(x, z, wz, tfit$smooth, which, tfit$smooth.frame,",
+ "s.vam(x, z, wz, tfit$smomat, which, tfit$smooth.frame,",
"bf.maxit, bf.epsilon, trace, se=se.fit, X_vlm_save, ",
- "Blist, ncolBlist, M, qbig, U, ",
+ "Blist, ncolBlist, M=M, qbig=qbig, Umat=U, ",
"all.knots=control$all.knots, nk=control$nk)",
sep=""))[[1]]
qbig <- sum(ncolBlist[smooth.labels]) # Number of component funs
- s <- matrix(0, n, qbig)
+ smomat <- matrix(0, n, qbig)
dy <- if (is.matrix(y)) dimnames(y)[[1]] else names(y)
d2 <- if (is.null(predictors.names))
paste("(Additive predictor ",1:M,")", sep="") else
predictors.names
- dimnames(s) <- list(dy, vlabel(smooth.labels,
+ dimnames(smomat) <- list(dy, vlabel(smooth.labels,
ncolBlist[smooth.labels], M))
- tfit <- list(smooth=s, smooth.frame=smooth.frame)
+ tfit <- list(smomat = smomat, smooth.frame = smooth.frame)
} else {
bf.call <- expression(vlm.wfit(xmat=X_vlm_save, z, Blist=NULL, U=U,
- matrix.out=FALSE, is.vlmX=TRUE,
- qr=qr.arg, xij=NULL))
+ matrix.out = FALSE, is.vlmX = TRUE,
+ qr = qr.arg, xij = NULL))
bf <- "vlm.wfit"
}
@@ -161,7 +162,7 @@ vgam.fit <- function(x, y, w, mf,
if (length(coefstart)) {
- eta <- if (ncol(X_vlm_save)>1) X_vlm_save %*% coefstart +
+ eta <- if (ncol(X_vlm_save) > 1) X_vlm_save %*% coefstart +
offset else X_vlm_save * coefstart + offset
eta <- if (M > 1) matrix(eta, ncol=M, byrow=TRUE) else c(eta)
mu <- family at inverse(eta, extra)
@@ -169,13 +170,13 @@ vgam.fit <- function(x, y, w, mf,
if (criterion != "coefficients") {
- tfun <- slot(family, criterion) # Needed for R, so have to follow suit
+ tfun <- slot(family, criterion) # Needed 4 R so have to follow suit
}
iter <- 1
new.crit <- switch(criterion,
- coefficients=1,
- tfun(mu=mu, y=y, w=w, res=FALSE, eta=eta, extra))
+ coefficients=1,
+ tfun(mu=mu, y=y, w=w, res=FALSE, eta=eta, extra))
old.crit <- if (minimize.criterion) 10*new.crit+10 else -10*new.crit-10
deriv.mu <- eval(family at deriv)
@@ -197,9 +198,9 @@ vgam.fit <- function(x, y, w, mf,
nrow_X_vlm <- dX_vlm[[1]]
ncol_X_vlm <- dX_vlm[[2]]
if (nrow_X_vlm < ncol_X_vlm)
- stop(ncol_X_vlm, " parameters but only ", nrow_X_vlm, " observations")
+ stop(ncol_X_vlm, " parameters but only ", nrow_X_vlm, " observations")
- while(c.list$one.more) {
+ while (c.list$one.more) {
tfit <- eval(bf.call) # fit$smooth.frame is new
c.list$coeff <- tfit$coefficients
@@ -211,7 +212,7 @@ vgam.fit <- function(x, y, w, mf,
NULL
}
- if (maxit>1 && iter>=maxit)
+ if (maxit > 1 && iter >= maxit)
warning("convergence not obtained in ", maxit, " iterations")
@@ -274,17 +275,17 @@ vgam.fit <- function(x, y, w, mf,
df.residual <- nrow_X_vlm - rank
if (!se.fit) {
- fit$var <- NULL
+ fit$varmat <- NULL
}
- if (M==1) {
+ if (M == 1) {
wz <- as.vector(wz) # Convert wz into a vector
} # else
fit$weights <- if (save.weight) wz else NULL
- if (M==1) {
+ if (M == 1) {
fit$predictors <- as.vector(fit$predictors)
fit$residuals <- as.vector(fit$residuals)
names(fit$residuals) <- names(fit$predictors) <- yn
@@ -333,19 +334,19 @@ vgam.fit <- function(x, y, w, mf,
crit.list <- list()
if (criterion != "coefficients")
crit.list[[criterion]] <- fit[[criterion]] <- new.crit
- for(ii in names(.min.criterion.VGAM)) {
+ for (ii in names(.min.criterion.VGAM)) {
if (ii != criterion &&
- any(slotNames(family) == ii) && length(body(slot(family, ii)))) {
- fit[[ii]] <- crit.list[[ii]] <-
- (slot(family, ii))(mu=mu, y=y, w=w, res=FALSE, eta=eta, extra)
+ any(slotNames(family) == ii) &&
+ length(body(slot(family, ii)))) {
+ fit[[ii]] <- crit.list[[ii]] <- (slot(family, ii))(mu=mu,
+ y=y, w=w, res=FALSE, eta=eta, extra)
}
}
-
- if (M==1) {
+ if (M == 1) {
fit$predictors <- as.vector(fit$predictors)
fit$residuals <- as.vector(fit$residuals)
names(fit$residuals) <- names(fit$predictors) <- yn
@@ -363,9 +364,9 @@ vgam.fit <- function(x, y, w, mf,
eval(family at last)
- if (!is.null(fit$smooth)) {
+ if (!is.null(fit$smomat)) {
fit$nl.chisq <- vgam.nlchisq(fit$qr, fit$resid, wz=wz,
- s=fit$smooth, deriv=deriv.mu, U=U,
+ smomat=fit$smomat, deriv=deriv.mu, U=U,
smooth.labels, attr(x, "assign"),
M=M, n=n, constraints=Blist)
}
@@ -415,15 +416,15 @@ new.assign <- function(X, Blist)
L <- length(temp2)
newasgn <- vector("list", L)
- k <- 0
+ kk <- 0
low <- 1
- for(i in 1:length(asgn)) {
- len <- low:(low+ncolBlist[i]*lasgn[i]-1)
- temp <- matrix(len, ncolBlist[i], lasgn[i])
- for(m in 1:ncolBlist[i])
- newasgn[[k+m]] <- temp[m,]
- low <- low + ncolBlist[i]*lasgn[i]
- k <- k + ncolBlist[i]
+ for (ii in 1:length(asgn)) {
+ len <- low:(low + ncolBlist[ii] * lasgn[ii] -1)
+ temp <- matrix(len, ncolBlist[ii], lasgn[ii])
+ for (mm in 1:ncolBlist[ii])
+ newasgn[[kk+mm]] <- temp[mm,]
+ low <- low + ncolBlist[ii] * lasgn[ii]
+ kk <- kk + ncolBlist[ii]
}
names(newasgn) <- temp2
diff --git a/R/vgam.match.q b/R/vgam.match.q
index a351282..db3bb7c 100644
--- a/R/vgam.match.q
+++ b/R/vgam.match.q
@@ -5,80 +5,80 @@
vgam.match <- function(x, all.knots=FALSE, nk=NULL) {
- if (is.list(x)) {
- nvar <- length(x)
- if (length(nk))
- nk = rep(nk, length=nvar)
- temp <- vgam.match(x[[1]], all.knots=all.knots, nk=nk[1])
-
- o <- matrix(temp$o, length(temp$o), nvar)
- nef <- rep(temp$nef, nvar)
- xmin <- rep(temp$xmin, nvar)
- xmax <- rep(temp$xmax, nvar)
- nknots <- rep(temp$nknots, nvar)
- knots <- vector("list", nvar)
- knots[[1]] <- temp$knots
-
- if (nvar > 1)
- for(i in 2:nvar) {
- temp = vgam.match(x[[i]], all.knots=all.knots, nk=nk[i])
- o[, i] <- temp$o
- nef[i] <- temp$nef
- nknots[i] <- temp$nknots
- knots[[i]] <- temp$knots
- xmin[i] <- temp$xmin
- xmax[i] <- temp$xmax
- }
- names(nknots) <- names(knots) <-
- names(nef) <- names(xmin) <- names(xmax) <- names(x)
- dimnames(o) <- list(NULL, names(x))
-
- return(list(o=o, nef=nef, nknots=nknots, knots=knots,
- xmin=xmin, xmax=xmax))
- }
-
- if (!is.null(attributes(x)$NAs) || any(is.na(x)))
- stop("cannot smooth on variables with NAs")
-
- sx <- unique(sort(as.vector(x))) # "as.vector()" strips off attributes
- o <- match(x, sx) # as.integer(match(x, sx)) # sx[o]==x
- nef <- length(sx) # as.integer(length(sx))
-
- if (nef < 7)
- stop("smoothing variables must have at least 7 unique values")
-
- xmin <- sx[1] # Don't use rounded value
- xmax <- sx[nef]
- xbar <- (sx - xmin) / (xmax - xmin)
+ if (is.list(x)) {
+ nvar <- length(x)
+ if (length(nk))
+ nk = rep(nk, length=nvar)
+ temp <- vgam.match(x[[1]], all.knots=all.knots, nk=nk[1])
+
+ ooo <- matrix(temp$o, length(temp$o), nvar)
+ nef <- rep(temp$nef, nvar)
+ xmin <- rep(temp$xmin, nvar)
+ xmax <- rep(temp$xmax, nvar)
+ nknots <- rep(temp$nknots, nvar)
+ knots <- vector("list", nvar)
+ knots[[1]] <- temp$knots
+
+ if (nvar > 1)
+ for (ii in 2:nvar) {
+ temp = vgam.match(x[[ii]], all.knots = all.knots, nk = nk[ii])
+ ooo[, ii] <- temp$o
+ nef[ii] <- temp$nef
+ nknots[ii] <- temp$nknots
+ knots[[ii]] <- temp$knots
+ xmin[ii] <- temp$xmin
+ xmax[ii] <- temp$xmax
+ }
+ names(nknots) <- names(knots) <-
+ names(nef) <- names(xmin) <- names(xmax) <- names(x)
+ dimnames(ooo) <- list(NULL, names(x))
+
+ return(list(o=ooo, nef=nef, nknots=nknots, knots=knots,
+ xmin=xmin, xmax=xmax))
+ }
+
+ if (!is.null(attributes(x)$NAs) || any(is.na(x)))
+ stop("cannot smooth on variables with NAs")
+
+ sx <- unique(sort(as.vector(x))) # "as.vector()" strips off attributes
+ ooo <- match(x, sx) # as.integer(match(x, sx)) # sx[o]==x
+ nef <- length(sx) # as.integer(length(sx))
+
+ if (nef < 7)
+ stop("smoothing variables must have at least 7 unique values")
+
+ xmin <- sx[1] # Don't use rounded value
+ xmax <- sx[nef]
+ xbar <- (sx - xmin) / (xmax - xmin)
noround = TRUE # Improvement 3/8/02
- if (all.knots) {
- if (noround) {
- knot = valid.vknotl2(c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3)))
- } else {
- knot <- c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3))
- }
- if (length(nk)) warning("overriding nk by all.knots=T")
- nk <- length(knot) - 4 # No longer: nef + 2
- } else {
- chosen = length(nk)
- if (chosen && (nk > nef+2 || nk <= 5))
- stop("bad value for nk")
- if (!chosen) nk = 0
- knot.list <- dotFortran(name="vknotl2", as.double(xbar), as.integer(nef),
- knot=double(nef+6), k=as.integer(nk+4),
- chosen=as.integer(chosen))
- if (noround) {
- knot = valid.vknotl2(knot.list$knot[1:(knot.list$k)])
- knot.list$k = length(knot)
- } else {
- knot <- knot.list$knot[1:(knot$k)]
- }
- nk <- knot.list$k - 4
- }
- if (nk <= 5) stop("not enough distinct knots found")
-
- return(list(o=o, nef=nef, nknots=nk, knots=knot, xmin=xmin, xmax=xmax))
+ if (all.knots) {
+ if (noround) {
+ knot = valid.vknotl2(c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3)))
+ } else {
+ knot <- c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3))
+ }
+ if (length(nk)) warning("overriding nk by all.knots = TRUE")
+ nk <- length(knot) - 4 # No longer: nef + 2
+ } else {
+ chosen = length(nk)
+ if (chosen && (nk > nef+2 || nk <= 5))
+ stop("bad value for 'nk'")
+ if (!chosen) nk = 0
+ knot.list <- dotC(name="vknootl2", as.double(xbar),
+ as.integer(nef), knot=double(nef+6),
+ k=as.integer(nk+4), chosen=as.integer(chosen))
+ if (noround) {
+ knot = valid.vknotl2(knot.list$knot[1:(knot.list$k)])
+ knot.list$k = length(knot)
+ } else {
+ knot <- knot.list$knot[1:(knot$k)]
+ }
+ nk <- knot.list$k - 4
+ }
+ if (nk <= 5) stop("not enough distinct knots found")
+
+ return(list(o=ooo, nef=nef, nknots=nk, knots=knot, xmin=xmin, xmax=xmax))
}
diff --git a/R/vglm.R b/R/vglm.R
index 9ba5fdd..4473df7 100644
--- a/R/vglm.R
+++ b/R/vglm.R
@@ -54,7 +54,7 @@ vglm <- function(formula,
if (!is.null(form2)) {
if (!is.null(subset))
- stop("argument 'subset' cannot be used when argument 'form2' is used")
+ stop("argument 'subset' cannot be used when argument 'form2' is used")
retlist = shadowvglm(formula=
form2,
family=family, data=data,
@@ -71,11 +71,11 @@ if (!is.null(form2)) {
if (length(Ym2)) {
if (nrow(as.matrix(Ym2)) != nrow(as.matrix(y)))
- stop("number of rows of y and Ym2 are unequal")
+ stop("number of rows of 'y' and 'Ym2' are unequal")
}
if (length(Xm2)) {
if (nrow(as.matrix(Xm2)) != nrow(as.matrix(x)))
- stop("number of rows of y and Ym2 are unequal")
+ stop("number of rows of 'y' and 'Ym2' are unequal")
}
} else {
Xm2 = Ym2 = NULL
@@ -96,7 +96,7 @@ if (!is.null(form2)) {
if (is.function(family))
family <- family()
if (!inherits(family, "vglmff")) {
- stop("'family=", family, "' is not a VGAM family function")
+ stop("'family = ", family, "' is not a VGAM family function")
}
eval(vcontrol.expression)
@@ -108,15 +108,15 @@ if (!is.null(form2)) {
vglm.fitter <- get(method)
fit <- vglm.fitter(x=x, y=y, w=w, offset=offset,
- Xm2=Xm2, Ym2=Ym2,
- etastart=etastart, mustart=mustart, coefstart=coefstart,
- family=family,
- control=control,
- constraints=constraints,
- criterion=control$criterion,
- extra=extra,
- qr.arg = qr.arg,
- Terms=mt, function.name=function.name, ...)
+ Xm2=Xm2, Ym2=Ym2,
+ etastart=etastart, mustart=mustart, coefstart=coefstart,
+ family=family,
+ control=control,
+ constraints=constraints,
+ criterion=control$criterion,
+ extra=extra,
+ qr.arg = qr.arg,
+ Terms=mt, function.name=function.name, ...)
fit$misc$dataname <- dataname
@@ -184,7 +184,8 @@ if (!is.null(form2)) {
slot(answer, "control") = fit$control
slot(answer, "extra") = if (length(fit$extra)) {
if (is.list(fit$extra)) fit$extra else {
- warning("\"extra\" is not a list, therefore placing \"extra\" into a list")
+ warning("'extra' is not a list, therefore placing ",
+ "'extra' into a list")
list(fit$extra)
}
} else list() # R-1.5.0
diff --git a/R/vglm.fit.q b/R/vglm.fit.q
index fb2b6ed..9e80486 100644
--- a/R/vglm.fit.q
+++ b/R/vglm.fit.q
@@ -53,9 +53,9 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (trace && orig.stepsize==1) {
cat("VGLM linear loop ", iter, ": ", criterion, "= ")
uuuu =
- switch(criterion,
- coefficients=format(new.crit, dig=round(2-log10(epsilon))),
- format(round(new.crit, 4)))
+ switch(criterion,
+ coefficients=format(new.crit, dig=round(2-log10(epsilon))),
+ format(round(new.crit, 4)))
switch(criterion,
coefficients={if(length(new.crit) > 2) cat("\n");
@@ -65,10 +65,11 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
{
- take.half.step=(control$half.stepsizing && length(old.coeffs))&&
+ take.half.step=(control$half.stepsizing &&
+ length(old.coeffs)) &&
((orig.stepsize!=1) ||
(criterion!="coefficients" &&
- (if(minimize.criterion) new.crit > old.crit else
+ (if(minimize.criterion) new.crit > old.crit else
new.crit < old.crit)))
if (!is.logical(take.half.step))
take.half.step = TRUE
@@ -125,11 +126,13 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
iter, ": ", criterion, "= ")
uuuu = switch(criterion,
- coefficients=format(new.crit, dig=round(2-log10(epsilon))),
+ coefficients = format(new.crit,
+ dig=round(2-log10(epsilon))),
format(round(new.crit, 4)))
switch(criterion,
- coefficients={if(length(new.crit) > 2) cat("\n");
+ coefficients={
+ if(length(new.crit) > 2) cat("\n");
cat(uuuu, fill=TRUE, sep=", ")},
cat(uuuu, fill=TRUE, sep=", "))
}
@@ -148,7 +151,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
deriv.mu <- eval(slot(family, "deriv"))
wz <- eval(slot(family, "weight"))
if (control$checkwz)
- wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
+ wz= checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
tvfor <- vforsub(U, as.matrix(deriv.mu), M=M, n=n)
@@ -159,9 +162,9 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (copy_X_vlm) c.list$X_vlm <- X_vlm_save
}
- c.list$one.more <- one.more
- c.list$coeff <- runif(length(new.coeffs)) # 12/3/03; twist needed!
- old.coeffs <- new.coeffs
+ c.list$one.more <- one.more
+ c.list$coeff = runif(length(new.coeffs)) # 12/3/03; twist needed!
+ old.coeffs <- new.coeffs
}
c.list
})
@@ -175,13 +178,13 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
old.coeffs <- coefstart
intercept.only <- ncol(x) == 1 && dimnames(x)[[2]] == "(Intercept)"
- y.names <- predictors.names <- NULL # May be overwritten in @initialize
+ y.names <- predictors.names <- NULL # May be overwritten in @initialize
n.save <- n
if (length(slot(family, "initialize")))
- eval(slot(family, "initialize")) # Initialize mu & M (and optionally w)
+ eval(slot(family, "initialize")) # Initialize mu & M (& optionally w)
if (length(etastart)) {
@@ -243,7 +246,8 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
c.list <- list(z=as.double(z), fit=as.double(t(eta)), one.more=TRUE,
coeff=as.double(rep(1,ncol(X_vlm_save))), U=as.double(U),
copy_X_vlm=copy_X_vlm,
- X_vlm = if (copy_X_vlm) as.double(X_vlm_save) else double(3))
+ X_vlm = if (copy_X_vlm) as.double(X_vlm_save) else
+ double(3))
dX_vlm <- as.integer(dim(X_vlm_save))
@@ -251,7 +255,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
ncol_X_vlm <- dX_vlm[[2]]
if (nrow_X_vlm < ncol_X_vlm)
- stop(ncol_X_vlm, "parameters but only ", nrow_X_vlm, " observations")
+ stop(ncol_X_vlm, "parameters but only ", nrow_X_vlm, " observations")
@@ -384,9 +388,10 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
for(ii in names(.min.criterion.VGAM)) {
if (ii != criterion &&
- any(slotNames(family) == ii) && length(body(slot(family, ii)))) {
- fit[[ii]] <- crit.list[[ii]] <-
- (slot(family, ii))(mu=mu, y=y, w=w, res=FALSE, eta=eta, extra)
+ any(slotNames(family) == ii) &&
+ length(body(slot(family, ii)))) {
+ fit[[ii]] <- crit.list[[ii]] <- (slot(family, ii))(mu=mu,
+ y=y, w=w, res=FALSE, eta=eta, extra)
}
}
diff --git a/R/vlm.R b/R/vlm.R
index 06d9716..6da229e 100644
--- a/R/vlm.R
+++ b/R/vlm.R
@@ -6,7 +6,7 @@
vlm <- function(formula,
data=list(),
- weights=NULL, subset, na.action,
+ weights=NULL, subset = NULL, na.action=na.fail,
prior.weights=NULL,
control=vlm.control(...),
method="qr",
@@ -24,35 +24,36 @@ vlm <- function(formula,
if (smart)
setup.smart("write")
- mt <- terms(formula, data = data) # attr(m, "terms")
if (missing(data))
- data <- sys.frame(sys.parent())
+ data <- environment(formula)
- mf <- match.call(expand=FALSE)
- mf$method <- mf$model <- mf$x.arg <- mf$y.arg <- mf$control <-
- mf$contrasts <- mf$constraints <- mf$extra <-
- mf$qr.arg <- mf$smart <- mf$... <- NULL
+
+ 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[[1]] <- as.name("model.frame")
- mf <- eval(mf, parent.frame())
- if (method == "model.frame")
- return(mf)
+ mf <- eval(mf, parent.frame())
+ switch(method, model.frame = return(mf), qr = 1,
+ stop("invalid 'method': ", method))
+ mt <- attr(mf, "terms")
+
+
+
+
if (method != "qr")
- stop("only method=\"qr\" is implemented")
+ stop("only method = 'qr' is implemented")
- na.act <- attr(mf, "na.action")
- xvars <- as.character(attr(mt, "variables"))[-1]
- if ((yvar <- attr(mt, "response")) > 0)
- xvars <- xvars[-yvar]
- xlev <- if (length(xvars) > 0) {
- xlev <- lapply(mf[xvars], levels)
- xlev[!sapply(xlev, is.null)]
- }
- y <- model.response(mf, "numeric") # model.extract(mf, "response")
- x <- model.matrix(mt, mf, contrasts)
- attr(x, "assign") <- attrassigndefault(x, mt) # So as to make it like Splus
+ xlev = .getXlevels(mt, mf)
+ y <- model.response(mf, "any") # model.extract(mf, "response")
+ x <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts) else
+ matrix(, NROW(y), 0)
+ attr(x, "assign") = attrassigndefault(x, mt)
+
+
offset <- model.offset(mf)
if (is.null(offset))
offset <- 0 # yyy ???
@@ -165,7 +166,9 @@ vlm <- function(formula,
if (length(attr(x, "contrasts")))
slot(answer, "contrasts") = attr(x, "contrasts")
- slot(answer, "na.action") = if (length(na.act)) list(na.act) else list()
+ slot(answer, "na.action") = if (length(aaa <- attr(mf, "na.action")))
+ list(aaa) else list()
+
if (length(offset))
slot(answer, "offset") = as.matrix(offset)
if (qr.arg) {
diff --git a/R/vlm.wfit.q b/R/vlm.wfit.q
index 952ee41..ea87269 100644
--- a/R/vlm.wfit.q
+++ b/R/vlm.wfit.q
@@ -10,8 +10,11 @@ vlm.wfit <- function(xmat, zmat, Blist, wz=NULL, U=NULL,
matrix.out=FALSE, is.vlmX=FALSE, rss=TRUE, qr=FALSE, x.ret=FALSE,
offset=NULL,
omit.these=NULL, only.rss=FALSE,
- ncolx = if (matrix.out && is.vlmX) stop("need argument 'ncolx'") else
- ncol(xmat),
+ ncolx = if (matrix.out && is.vlmX) {
+ stop("need argument 'ncolx'")
+ } else {
+ ncol(xmat)
+ },
xij=NULL,
lp.names=NULL, Eta.range=NULL, Xm2=NULL, ...) {
missing.Blist <- missing(Blist)
@@ -23,22 +26,26 @@ vlm.wfit <- function(xmat, zmat, Blist, wz=NULL, U=NULL,
znames <- dimnames(zmat)[[2]]
}
- if (length(offset))
+ if (length(offset)) {
zmat <- zmat - offset
+ }
if (missing(U) || !length(U)) {
U <- vchol(wz, M=M, n=n, silent=FALSE)
}
dU <- dim(U)
- if (dU[2] != n)
+ if (dU[2] != n) {
stop("input unconformable")
+ }
X_vlm_save <- if (is.vlmX) {
xmat
} else {
- if (missing.Blist || !length(Blist))
- Blist = replace.constraints(vector("list", ncol(xmat)),
+ if (missing.Blist || !length(Blist)) {
+ Blist = replace.constraints(vector("list", ncol(xmat)),
diag(M), 1:ncol(xmat)) # NULL
- lm2vlm.model.matrix(x=xmat, Blist=Blist, M=M, assign.attributes=FALSE,
+ }
+ lm2vlm.model.matrix(x=xmat, Blist=Blist, M=M,
+ assign.attributes=FALSE,
xij = xij,
Xm2=Xm2)
}
@@ -58,8 +65,9 @@ vlm.wfit <- function(xmat, zmat, Blist, wz=NULL, U=NULL,
if (only.rss) return(list(rss=ans$rss))
}
- if (length(omit.these) && any(omit.these))
+ if (length(omit.these) && any(omit.these)) {
stop("code beyond here cannot handle omitted observations")
+ }
fv <- ans$fitted.values
@@ -68,38 +76,44 @@ vlm.wfit <- function(xmat, zmat, Blist, wz=NULL, U=NULL,
if (length(Eta.range)) {
- if (length(Eta.range) != 2)
+ if (length(Eta.range) != 2) {
stop("length(Eta.range) must equal 2")
+ }
fv = ifelse(fv < Eta.range[1], Eta.range[1], fv)
fv = ifelse(fv > Eta.range[2], Eta.range[2], fv)
}
ans$fitted.values <- if (M==1) c(fv) else fv
- if (M > 1)
+ if (M > 1) {
dimnames(ans$fitted.values) <- list(dimnames(zmat)[[1]], znames)
+ }
ans$residuals <- if (M==1) c(zmat-fv) else zmat-fv
- if (M > 1)
+ if (M > 1) {
dimnames(ans$residuals) <- list(dimnames(ans$residuals)[[1]], znames)
+ }
ans$misc <- list(M=M, n=n)
ans$call <- match.call()
ans$constraints <- Blist
ans$contrasts <- contrast.save
- if (x.ret)
+ if (x.ret) {
ans$X_vlm <- X_vlm_save
+ }
- if (!is.null(offset))
+ if (!is.null(offset)) {
ans$fitted.values <- ans$fitted.values + offset
+ }
- if (!matrix.out)
+ if (!matrix.out) {
return(ans)
+ }
dx2 = if (is.vlmX) NULL else dimnames(xmat)[[2]]
- B <- matrix(as.numeric(NA), nrow=M, ncol=ncolx, dimnames=list(lp.names, dx2))
+ B = matrix(as.numeric(NA), nr=M, nc=ncolx, dimnames=list(lp.names, dx2))
if (is.null(Blist)) {
Blist = replace.constraints(vector("list", ncolx), diag(M), 1:ncolx)
}
@@ -126,17 +140,20 @@ print.vlm.wfit <- function(x, ...) {
print(coef, ...)
rank <- x$rank
- if (is.null(rank))
+ if (is.null(rank)) {
rank <- sum(!is.na(coef))
+ }
n <- x$misc$n
M <- x$misc$M
rdf <- x$df.resid
- if (is.null(rdf))
+ if (is.null(rdf)) {
rdf <- (n - rank) * M
+ }
cat("\nDegrees of Freedom:", n*M, "Total;", rdf, "Residual\n")
- if (!is.null(x$rss))
+ if (!is.null(x$rss)) {
cat("Residual Sum of Squares:", format(x$rss), "\n")
+ }
invisible(x)
}
diff --git a/R/vsmooth.spline.q b/R/vsmooth.spline.q
index 1d91157..cefd53e 100644
--- a/R/vsmooth.spline.q
+++ b/R/vsmooth.spline.q
@@ -5,28 +5,29 @@
-if (!exists("is.R")) is.R <- function()
- exists("version") && !is.null(version$language) && version$language=="R"
setClass("vsmooth.spline.fit", representation(
- "Bcoefficients"= "matrix",
- "knots" = "numeric",
- "xmin" = "numeric",
- "xmax" = "numeric"))
+ "Bcoefficients" = "matrix",
+ "knots" = "numeric",
+ "xmin" = "numeric",
+ "xmax" = "numeric"))
+
+
setClass("vsmooth.spline", representation(
- "call" = "call",
- "constraints" = "list",
- "df" = "numeric",
- "nlfit" = "vsmooth.spline.fit", # is the nonlinear component
- "lev" = "matrix",
- "lfit" = "vlm", # 6/6/02: was "vlm.wfit"; is the linear component
- "spar" = "numeric",
- "var" = "matrix",
- "w" = "matrix",
- "x" = "numeric",
- "y" = "matrix",
- "yin" = "matrix"))
+ "call" = "call",
+ "constraints" = "list",
+ "df" = "numeric",
+ "nlfit" = "vsmooth.spline.fit", # is the nonlinear component
+ "lev" = "matrix",
+ "lfit" = "vlm", # 20020606 was "vlm.wfit"; is the linear component
+ "spar" = "numeric",
+ "lambda" = "numeric",
+ "var" = "matrix",
+ "w" = "matrix",
+ "x" = "numeric",
+ "y" = "matrix",
+ "yin" = "matrix"))
setMethod("coefficients", signature(object="vsmooth.spline"),
@@ -75,15 +76,16 @@ setMethod("predict", "vsmooth.spline.fit",
predictvsmooth.spline.fit(object, ...))
-vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
- all.knots=FALSE,
- iconstraint=diag(M),
- xconstraint=diag(M),
- constraints=list("(Intercepts)"=diag(M), x=diag(M)),
- tol.nl=0.01, var.arg=FALSE,
+vsmooth.spline <- function(x, y, w = NULL, df = rep(5, M),
+ spar = NULL, #rep(0,M),
+ all.knots = FALSE,
+ iconstraint = diag(M),
+ xconstraint = diag(M),
+ constraints = list("(Intercepts)"=diag(M), x=diag(M)),
+ var.arg = FALSE,
scale.w=TRUE,
- nk=NULL) {
-
+ nk=NULL,
+ control.spar = list()) {
if (var.arg) {
warning("@var will be returned, but no use will be made of it")
@@ -91,9 +93,28 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
missing.constraints <- missing(constraints)
-
- if (!(missing.spar <- missing(spar)) && !missing(df))
+ if (!(missing.spar <- missing(spar)) && !missing(df)) {
stop("cannot specify both 'spar' and 'df'")
+ }
+
+
+
+ contr.sp <- list(low = -1.5,## low = 0. was default till R 1.3.x
+ high = 1.5,
+ tol = 1e-4,## tol = 0.001 was default till R 1.3.x
+ eps = 2e-8,## eps = 0.00244 was default till R 1.3.x
+ maxit = 500 )
+
+ if(FALSE)
+ contr.sp <- list(low = -1.5,## low = 0. was default till R 1.3.x
+ high = 1.5,
+ tol = 0.001, # was default till R 1.3.x
+ eps = 0.00244, # was default till R 1.3.x
+ maxit = 500 )
+ contr.sp[(names(control.spar))] <- control.spar
+ if(!all(sapply(contr.sp[1:4], is.numeric)) ||
+ contr.sp$tol < 0 || contr.sp$eps <= 0 || contr.sp$maxit <= 0)
+ stop("invalid 'control.spar'")
my.call <- match.call()
@@ -115,270 +136,286 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
}
}
- n <- length(x)
- y <- as.matrix(y)
- ny2 <- dimnames(y)[[2]] # NULL if vector
- M <- ncol(y)
- if (n != nrow(y))
+ xvector <- x
+ n_lm <- length(xvector)
+ ymat <- as.matrix(y)
+ ny2 <- dimnames(ymat)[[2]] # NULL if vector
+ M <- ncol(ymat)
+ if (n_lm != nrow(ymat)) {
stop("lengths of 'x' and 'y' must match")
+ }
- if (any(is.na(x)) || any(is.na(y)))
+ if (any(is.na(xvector)) || any(is.na(ymat))) {
stop("NAs not allowed in 'x' or 'y'")
+ }
- if (missing(w)) {
- w <- matrix(1, n, M)
+ if (is.null(w)) {
+ wzmat <- matrix(1, n_lm, M)
} else {
- if (any(is.na(w)))
+ if (any(is.na(w))) {
stop("NAs not allowed in 'w'")
+ }
+ wzmat <- as.matrix(w)
- w <- as.matrix(w)
-
- if (nrow(y) != nrow(w) || ncol(w)>M*(M+1)/2)
+ if (nrow(ymat) != nrow(wzmat) || ncol(wzmat) > M * (M+1) / 2) {
stop("'w' and 'y' don't match")
+ }
- if (scale.w)
- w <- w / mean(w[,1:M]) # 'Average' value is 1
+ if (scale.w) {
+ wzmat <- wzmat / mean(wzmat[,1:M]) # 'Average' value is 1
+ }
}
- dimw <- ncol(w)
+ dim2wz <- ncol(wzmat)
- if (missing.constraints)
- constraints <- list("(Intercepts)"=eval(iconstraint),
- x=eval(xconstraint))
+ if (missing.constraints) {
+ constraints <- list("(Intercepts)" = eval(iconstraint),
+ "x" = eval(xconstraint))
+ }
constraints <- eval(constraints)
- if (is.matrix(constraints))
- constraints <- list("(Intercepts)"=constraints, x=constraints)
- if (!is.list(constraints) || length(constraints)!=2)
+ if (is.matrix(constraints)) {
+ constraints <- list("(Intercepts)" = constraints, x = constraints)
+ }
+ if (!is.list(constraints) || length(constraints) != 2) {
stop("'constraints' must equal a list (of length 2) or a matrix")
- for(i in 1:2)
- if (!is.numeric(constraints[[i]]) || !is.matrix(constraints[[i]]) ||
- nrow(constraints[[i]])!=M || ncol(constraints[[i]])>M)
+ }
+ for (ii in 1:2)
+ if (!is.numeric(constraints[[ii]]) ||
+ !is.matrix (constraints[[ii]]) ||
+ nrow(constraints[[ii]]) != M ||
+ ncol(constraints[[ii]]) > M)
stop("something wrong with 'constraints'")
names(constraints) <- c("(Intercepts)", "x")
- sx <- unique(sort(as.vector(x)))
- o <- match(x, sx) # sx[o]==x
- nef <- length(sx)
- if (nef < 7)
+ usortx <- unique(sort(as.vector(xvector)))
+ ooo <- match(xvector, usortx) # usortx[ooo] == x
+ neff <- length(usortx)
+ if (neff < 7) {
stop("not enough unique 'x' values (need 7 or more)")
+ }
-
- index <- iam(NA, NA, M, both=TRUE, diagonal=TRUE)
- template1 <- template2 <- matrix(0, nef, M) # Must have M columns
- ncb <- M
- dimu <- dimw # 10/1/00; was M*(M+1)/2
-
- collaps <- dotFortran(name="vsuff9",
- as.integer(n), as.integer(nef), as.integer(o),
- as.double(x), as.double(y), as.double(w),
- xbar=double(nef), ybar=as.double(template1), wbar=double(nef*dimu),
- uwbar=as.double(0), wz=as.double(template2),
- as.integer(M), dimw=as.integer(dimw), dimu=as.integer(dimu),
- as.integer(index$row), as.integer(index$col),
- double(M*(M+1)), double(ncb*(ncb+1)),
- as.double(diag(M)), as.integer(M),
- triv=as.integer(1), wuwbar=as.integer(0), ok=as.integer(0))
-
-
- if (collaps$ok != 1)
- stop("some non-positive-definite weight matrices detected in 'vsuff9'")
- dim(collaps$ybar) <- dim(collaps$wz) <- c(nef, M)
+ dim1U <- dim2wz # 10/1/00; was M * (M+1) / 2
+
+ collaps <- dotC(name="vsuff9",
+ as.integer(n_lm), as.integer(neff), as.integer(ooo),
+ as.double(xvector), as.double(ymat), as.double(wzmat),
+ xbar=double(neff), ybar=double(neff * M),
+ wzbar=double(neff * dim2wz),
+ uwzbar=double(1), wzybar=double(neff * M), okint=as.integer(0),
+ as.integer(M), dim2wz=as.integer(dim2wz), dim1U=as.integer(dim1U),
+ blist=as.double(diag(M)), ncolb=as.integer(M),
+ trivc=as.integer(1), wuwzbar=as.integer(0),
+ dim1Uwzbar = as.integer(dim1U), dim2wzbar = as.integer(dim2wz))
+
+ if (collaps$okint != 1) {
+ stop("some non-positive-definite weight matrices ",
+ "detected in 'vsuff9'")
+ }
+ dim(collaps$ybar) <- c(neff, M)
if (FALSE) {
} else {
- yin = collaps$ybar # Includes both linear and nonlinear parts
- junk.frame = data.frame(x=collaps$xbar, yin = yin)
- x = collaps$xbar # Warning: From now on "x" is no longer the original x
+ yinyin = collaps$ybar # Includes both linear and nonlinear parts
+ x = collaps$xbar # Could call this xxx for location finder
- lfit = vlm(yin ~ 1 + x,
+ lfit = vlm(yinyin ~ 1 + x, # xxx
constraints = constraints,
- save.weight=FALSE, qr=FALSE, x=FALSE, y=FALSE,
+ save.weight = FALSE, qr = FALSE, x = FALSE, y = FALSE,
smart = FALSE,
- weight=matrix(collaps$wbar, nrow=nrow(yin), byrow=FALSE))
+ weight = matrix(collaps$wzbar, neff, dim2wz))
}
- ncb <- ncol(constraints[[2]]) # Of x and not of the intercept
- spar <- if (length(spar)) rep(spar, length=ncb) else rep(0, length=ncb)
- df <- rep(df, length=ncb)
+ ncb0 <- ncol(constraints[[2]]) # Of xxx and not of the intercept
+ spar <- rep(if (length(spar)) spar else 0, length = ncb0)
+ dfvec <- rep(df, length = ncb0)
if (!missing.spar) {
ispar <- 1
- if (any(spar <= 0) || !is.numeric(spar))
- stop("not allowed non-positive or non-numeric smoothing parameters")
-
-
+ if (any(spar <= 0) || !is.numeric(spar)) {
+ stop("not allowed non-positive or non-numeric ",
+ "smoothing parameters")
+ }
nonlin <- (spar != Inf)
} else {
ispar <- 0
- if (!is.numeric(df) || any(df < 2 | df > nef))
- stop("you must supply '2 <= df <= ", nef, "'")
- if (tol.nl <= 0) stop("bad value for 'tol.nl'")
- nonlin <- abs(df-2) > tol.nl
+ if (!is.numeric(dfvec) || any(dfvec < 2 | dfvec > neff)) {
+ stop("you must supply '2 <= df <= ", neff, "'")
+ }
+ nonlin <- (abs(dfvec - 2) > contr.sp$tol)
}
if (all(!nonlin)) {
junk.fill = new("vsmooth.spline.fit",
- "Bcoefficients"= matrix(as.numeric(NA), 1, 1),
- "knots" = numeric(0),
- "xmin" = numeric(0),
- "xmax" = numeric(0)) # 8/11/03
+ "Bcoefficients" = matrix(as.numeric(NA), 1, 1),
+ "knots" = numeric(0),
+ "xmin" = numeric(0),
+ "xmax" = numeric(0)) # 8/11/03
+
+ ratio = as.numeric(NA)
+
object =
new("vsmooth.spline",
- "call" = my.call,
- "constraints" = constraints,
- "df" = if (ispar==0) df else rep(2, length(spar)),
- "lfit" = lfit,
- "nlfit" = junk.fill,
- "spar" = if (ispar==1) spar else rep(Inf, length(df)),
- "w" = as.matrix(collaps$wbar),
- "x" = sx,
- "y" = lfit at fitted.values,
- "yin" = yin)
+ "call" = my.call,
+ "constraints" = constraints,
+ "df" = if (ispar == 0) dfvec else rep(2, length(spar)),
+ "lfit" = lfit,
+ "nlfit" = junk.fill,
+ "spar" = if (ispar == 1) spar else rep(Inf, length(dfvec)),
+ "lambda" = if (ispar == 1) ratio * 16.0^(spar * 6.0 - 2.0) else
+ rep(Inf, length(dfvec)),
+ "w" = matrix(collaps$wzbar, neff, dim2wz),
+ "x" = usortx,
+ "y" = lfit at fitted.values,
+ "yin" = yinyin)
return(object)
}
-
- xbar <- (sx - sx[1]) / (sx[nef] - sx[1])
+ xbar <- (usortx - usortx[1]) / (usortx[neff] - usortx[1])
noround = TRUE # Improvement 3/8/02
+ nknots <- nk
if (all.knots) {
- if (noround) {
- knot = valid.vknotl2(c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3)))
- } else {
- knot <- c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3))
+ knot <- if (noround) {
+ valid.vknotl2(c(rep(xbar[1],3), xbar, rep(xbar[neff],3)))
+ } else {
+ c(rep(xbar[1], 3), xbar, rep(xbar[neff], 3))
+ }
+ if (length(nknots)) {
+ warning("overriding 'nk' by 'all.knots = TRUE'")
}
- if (length(nk)) warning("overriding 'nk' by 'all.knots=TRUE'")
- nk <- length(knot) - 4 # No longer nef + 2
+ nknots <- length(knot) - 4 # No longer neff + 2
} else {
- chosen = length(nk)
- if (chosen && (nk > nef+2 || nk <= 5))
+ chosen = length(nknots)
+ if (chosen && (nknots > neff+2 || nknots <= 5)) {
stop("bad value for 'nk'")
- if (!chosen) nk = 0
- knot.list <- dotFortran(name="vknotl2", as.double(xbar), as.integer(nef),
- knot=double(nef+6), k=as.integer(nk+4),
- chosen=as.integer(chosen))
+ }
+ if (!chosen) {
+ nknots = 0
+ }
+ knot.list <- dotC(name="vknootl2", as.double(xbar),
+ as.integer(neff), knot=double(neff+6),
+ k=as.integer(nknots+4), chosen=as.integer(chosen))
if (noround) {
knot = valid.vknotl2(knot.list$knot[1:(knot.list$k)])
knot.list$k = length(knot)
} else {
knot <- knot.list$knot[1:(knot.list$k)]
}
- nk <- knot.list$k - 4
+ nknots <- knot.list$k - 4
+ }
+ if (nknots <= 5) {
+ stop("not enough distinct knots found")
}
- if (nk <= 5) stop("not enough distinct knots found")
- conmat <- (constraints[[2]])[,nonlin,drop=FALSE]
+ conmat <- (constraints[[2]])[, nonlin, drop=FALSE]
ncb <- sum(nonlin)
trivc <- trivial.constraints(conmat)
- resmat <- collaps$ybar - lfit at fitted.values # nef by M
- spar.nl <- spar[nonlin]
- df.nl <- df[nonlin]
-
- edimu <- if (trivc != 0) dimw else max(ncb*(ncb+1)/2, dimw) # for wbar's size
- dimu <- if (trivc != 0) dimw else ncb*(ncb+1)/2
- o <- 1:nef # Already sorted
-
- collaps <- dotFortran(name="vsuff9",
- as.integer(nef), as.integer(nef), as.integer(o),
- as.double(collaps$xbar), as.double(resmat), as.double(collaps$wbar),
- xbar=double(nef), ybar=as.double(template1),
- wbar=double(nef*edimu), uwbar=as.double(0), wz=as.double(template2),
- M=as.integer(M), dimw=as.integer(dimw), dimu=as.integer(dimu),
- as.integer(index$row), as.integer(index$col),
- double(M*(M+1)), double(ncb*(ncb+1)),
- as.double(conmat), as.integer(ncb),
- as.integer(trivc), wuwbar=as.integer(0), ok=as.integer(0))
- if (collaps$ok != 1)
- stop("some non-positive-definite weight matrices detected in 'vsuff9'")
-
- dim(collaps$ybar) <- dim(collaps$wz) <- c(nef, M)
- collaps$ybar = collaps$ybar[,1:ncb,drop=FALSE]
- collaps$wz = collaps$wz[,1:ncb,drop=FALSE]
- dim(collaps$wbar) <- c(nef, edimu)
+ resmat <- collaps$ybar - lfit at fitted.values # neff by M
+ spar.nl <- spar[nonlin]
+ dofr.nl <- dfvec[nonlin]
+
+ dim1Uwzbar = if (trivc) dim1U else ncb * (ncb+1) / 2
+ dim2wzbar = if (trivc) dim2wz else ncb * (ncb+1) / 2
+ ooo <- 1:neff # Already sorted
+
+
+ collaps <- dotC(name="vsuff9",
+ as.integer(neff), as.integer(neff), as.integer(ooo),
+ as.double(collaps$xbar), as.double(resmat), as.double(collaps$wzbar),
+ xbar=double(neff), ybar=double(neff * ncb),
+ wzbar=double(neff * dim2wzbar),
+ uwzbar=double(1), wzybar=double(neff * ncb), okint=as.integer(0),
+ as.integer(M), as.integer(dim2wz), as.integer(dim1U),
+ blist=as.double(conmat), ncolb=as.integer(ncb),
+ as.integer(trivc), wuwzbar=as.integer(0),
+ as.integer(dim1Uwzbar), as.integer(dim2wzbar))
+
+ if (collaps$okint != 1) {
+ stop("some non-positive-definite weight matrices ",
+ "detected in 'vsuff9' during the second call.")
+ }
+
+ dim(collaps$ybar) <- dim(collaps$wzybar) <- c(neff, ncb)
+ dim(collaps$wzbar) <- c(neff, dim2wzbar)
ldk = 3 * ncb + 1 # 10/7/02; Previously 4 * ncb
- lev <- if (ncb > 1) matrix(0, nef, ncb) else rep(0, nef)
- varmat <- if (var.arg) {if(ncb > 1) matrix(0, nef, ncb) else
- rep(0, nef)} else double(1)
- index <- iam(NA, NA, ncb, both=TRUE, diagonal=TRUE)
- dimwbar <- if (trivc != 0) dimw else ncb*(ncb+1)/2
-
- vsplin <- dotFortran(name="vsplin",
- xs=as.double(xbar), wz=as.double(collaps$wz),
- w=as.double(collaps$wbar), n=as.integer(nef),
- xknot=as.double(knot),
- nk=as.integer(nk), as.integer(ldk),
- M=as.integer(ncb), dimw=as.integer(dimwbar),
- as.integer(index$row), as.integer(index$col),
- wkmm=double(ncb*ncb*16), spar.nl=as.double(spar.nl),
- info=integer(1), fv=double(nef*ncb), Bcoef=double(nk*ncb),
- hs=double(ldk*nk*ncb), btwy=double(ncb*nk),
- sgdub=double(nk * max(4,ncb)),
- var=as.double(varmat), ifvar=as.integer(var.arg),
- bmb=double(ncb*ncb),
- lev=as.double(lev),
- as.double(df.nl),
- scrtch=double(min((17+nk)*nk, nk*17+1)),
- ier=as.integer(0),
- truen=as.integer(nef))
-
-
- if (vsplin$ier != 0) {
- stop("vsplin$ier == ", vsplin$ier, ". Something gone wrong in 'vsplin'")
+ varmat <- if (var.arg) matrix(0, neff, ncb) else double(1)
+ vsplin <- dotC(name="Yee_spline",
+ xs=as.double(xbar), as.double(collaps$wzybar),
+ as.double(collaps$wzbar), xknot=as.double(knot),
+ n=as.integer(neff), nknots=as.integer(nknots), as.integer(ldk),
+ M=as.integer(ncb), dim2wz=as.integer(dim2wzbar),
+ spar.nl=as.double(spar.nl), lamvec=as.double(spar.nl),
+ iinfo=integer(1), fv=double(neff * ncb),
+ Bcoef=double(nknots * ncb), varmat=as.double(varmat),
+ levmat=double(neff * ncb), as.double(dofr.nl),
+ ifvar=as.integer(var.arg), ierror=as.integer(0),
+ n_lm=as.integer(neff),
+ double(nknots), double(nknots), double(nknots), double(nknots),
+ double(1), as.integer(0),
+ icontrsp = as.integer(contr.sp$maxit),
+ contrsp = as.double(unlist(contr.sp[1:4])))
+
+ if (vsplin$ierror != 0) {
+ stop("vsplin$ierror == ", vsplin$ierror,
+ ". Something gone wrong in 'vsplin'")
+ }
+ if (vsplin$iinfo != 0) {
+ stop("leading minor of order ", vsplin$iinfo,
+ " is not positive-definite")
}
- if (vsplin$info != 0)
- stop("leading minor of order ", vsplin$info,
- " is not positive-definite")
- dim(vsplin$lev) <- c(nef, ncb) # A matrix even when ncb==1
+ dim(vsplin$levmat) <- c(neff, ncb) # A matrix even when ncb == 1
if (ncb > 1) {
- dim(vsplin$fv) <- c(nef, ncb)
+ dim(vsplin$fv) <- c(neff, ncb)
if (var.arg)
- dim(vsplin$var) <- c(nef, ncb)
+ dim(vsplin$varmat) <- c(neff, ncb)
}
- df.nl <- colSums(vsplin$lev) # Actual EDF used
+ dofr.nl <- colSums(vsplin$levmat) # Actual EDF used
fv <- lfit at fitted.values + vsplin$fv %*% t(conmat)
- if (M > 1)
+ if (M > 1) {
dimnames(fv) <- list(NULL, ny2)
+ }
- df[!nonlin] = 2
- df[ nonlin] = df.nl
- if (ispar==0) {
+ dfvec[!nonlin] = 2.0
+ dfvec[ nonlin] = dofr.nl
+ if (ispar == 0) {
spar[!nonlin] = Inf
spar[ nonlin] = vsplin$spar.nl # Actually used
}
fit.object = new("vsmooth.spline.fit",
- "Bcoefficients" = matrix(vsplin$Bcoef, nrow=nk, ncol=ncb),
- "knots" = knot,
- "xmax" = sx[nef],
- "xmin" = sx[1])
+ "Bcoefficients" = matrix(vsplin$Bcoef, nknots, ncb),
+ "knots" = knot,
+ "xmax" = usortx[neff],
+ "xmin" = usortx[1])
object =
new("vsmooth.spline",
"call" = my.call,
"constraints" = constraints,
- "df" = df,
+ "df" = dfvec,
"nlfit" = fit.object,
- "lev" = vsplin$lev,
+ "lev" = vsplin$levmat,
"lfit" = lfit,
- "spar" = spar, # if (ispar==1) spar else vsplin$spar,
- "w" = collaps$wbar,
- "x" = sx,
- "y" = fv,
- "yin" = yin)
+ "spar" = spar, # if (ispar == 1) spar else vsplin$spar,
+ "lambda" = vsplin$lamvec, #
+ "w" = collaps$wzbar,
+ "x" = usortx,
+ "y" = fv,
+ "yin" = yinyin)
- if (var.arg)
- object at var = vsplin$var
+ if (var.arg)
+ object at var = vsplin$varmat
object
}
@@ -392,11 +429,11 @@ printvsmooth.spline <- function(x, ...) {
ncb <- if (length(x at nlfit)) ncol(x at nlfit@Bcoefficients) else NULL
cat("\nSmoothing Parameter (Spar):",
- if (length(ncb) && ncb==1) format(x at spar) else
+ if (length(ncb) && ncb == 1) format(x at spar) else
paste(format(x at spar), collapse=", "), "\n")
cat("\nEquivalent Degrees of Freedom (Df):",
- if (length(ncb) && ncb==1) format(x at df) else
+ if (length(ncb) && ncb == 1) format(x at df) else
paste(format(x at df), collapse=", "), "\n")
if (!all(trivial.constraints(x at constraints) == 1)) {
@@ -430,41 +467,42 @@ residvsmooth.spline = function(object, ...) {
-plotvsmooth.spline <- function(x, xlab="x", ylab="", points=TRUE,
- pcol=par()$col, pcex=par()$cex,
- pch=par()$pch,
- lcol=par()$col, lwd=par()$lwd, lty=par()$lty,
- add=FALSE, ...) {
+plotvsmooth.spline <- function(x, xlab="x", ylab="", points=TRUE,
+ pcol=par()$col, pcex=par()$cex,
+ pch=par()$pch, lcol=par()$col,
+ lwd=par()$lwd, lty=par()$lty,
+ add=FALSE, ...) {
+ points.arg = points; rm(points)
M = ncol(x at y)
- pcol = rep(pcol, length=M)
- pcex = rep(pcex, length=M)
- pch = rep(pch, length=M)
- lcol = rep(lcol, length=M)
- lwd = rep(lwd, length=M)
- lty = rep(lty, length=M)
+ pcol = rep(pcol, length = M)
+ pcex = rep(pcex, length = M)
+ pch = rep(pch, length = M)
+ lcol = rep(lcol, length = M)
+ lwd = rep(lwd, length = M)
+ lty = rep(lty, length = M)
if (!add)
matplot(x at x, x at yin, type="n", xlab=xlab, ylab=ylab, ...)
- for(i in 1:ncol(x at y)) {
- if (points)
- points(x at x, x at yin[,i], col=pcol[i], pch=pch[i], cex=pcex[i])
- lines(x at x, x at y[,i], col=lcol[i], lwd=lwd[i], lty=lty[i])
+ for (ii in 1:ncol(x at y)) {
+ if (points.arg)
+ points(x at x, x at yin[,ii], col=pcol[ii], pch=pch[ii], cex=pcex[ii])
+ lines(x at x, x at y[,ii], col=lcol[ii], lwd=lwd[ii], lty=lty[ii])
}
invisible(x)
}
-predictvsmooth.spline <- function(object, x, deriv=0, se.fit=FALSE) {
+predictvsmooth.spline <- function(object, x, deriv = 0, se.fit = FALSE) {
if (se.fit)
warning("'se.fit=TRUE' is not currently implemented. ",
"Using 'se.fit=FALSE'")
- lfit <- object at lfit # Linear part of the vector spline
+ lfit <- object at lfit # Linear part of the vector spline
nlfit <- object at nlfit # Nonlinear part of the vector spline
if (missing(x)) {
- if (deriv==0) {
- return(list(x=object at x, y=object at y))
+ if (deriv == 0) {
+ return(list(x = object at x, y = object at y))
} else {
x <- object at x
return(Recall(object, x, deriv))
@@ -474,49 +512,48 @@ predictvsmooth.spline <- function(object, x, deriv=0, se.fit=FALSE) {
mat.coef = coefvlm(lfit, matrix=TRUE)
coeflfit <- t(mat.coef) # M x p now
- M <- nrow(coeflfit) # if (is.matrix(object at y)) ncol(object at y) else 1
-
- pred <- if (deriv==0) predict(lfit, data.frame(x=x)) else
- if (deriv==1) matrix(coeflfit[,2], length(x), M, byrow=TRUE) else
- matrix(0, length(x), M)
- if (!length(nlfit at knots))
- return(list(x=x, y=pred))
+ M <- nrow(coeflfit) # if (is.matrix(object at y)) ncol(object at y) else 1
+ pred = if (deriv == 0) predict(lfit, data.frame(x = x)) else
+ if (deriv == 1) matrix(coeflfit[,2], length(x), M, byr=TRUE) else
+ matrix(0, length(x), M)
+ if (!length(nlfit at knots)) {
+ return(list(x = x, y = pred))
+ }
nonlin <- (object at spar != Inf)
- conmat <- if (!length(lfit at constraints)) diag(M) else lfit at constraints[[2]]
- conmat <- conmat[,nonlin,drop=FALSE] # Of nonlinear functions
+ conmat = if (!length(lfit at constraints)) diag(M) else
+ lfit at constraints[[2]]
+ conmat = conmat[, nonlin, drop=FALSE] # Of nonlinear functions
- list(x=x, y=pred + predict(nlfit, x, deriv)$y %*% t(conmat))
+ list(x = x, y=pred + predict(nlfit, x, deriv)$y %*% t(conmat))
}
predictvsmooth.spline.fit <- function(object, x, deriv=0) {
- nk = nrow(object at Bcoefficients)
+ nknots = nrow(object at Bcoefficients)
drangex <- object at xmax - object at xmin
if (missing(x))
- x <- seq(from=object at xmin, to=object at xmax, length=nk-4)
+ x <- seq(from=object at xmin, to=object at xmax, length=nknots-4)
- xs <- as.double((x - object at xmin)/drangex)
+ xs <- as.double((x - object at xmin) / drangex)
- bad.left <- xs < 0
- bad.right <- xs > 1
+ bad.left <- (xs < 0)
+ bad.right <- (xs > 1)
good <- !(bad.left | bad.right)
ncb <- ncol(object at Bcoefficients)
y <- matrix(as.numeric(NA), length(xs), ncb)
- if (any(good)) {
- ngood <- sum(good)
- junk <- dotFortran(name="vbvs", as.integer(ngood),
+ if (ngood <- sum(good)) {
+ junk <- dotC(name="Yee_vbvs", as.integer(ngood),
as.double(object at knots), as.double(object at Bcoefficients),
- as.integer(nk),
- as.double(xs[good]), s=double(ngood*ncb),
- as.integer(deriv), as.integer(ncb))
- y[good,] <- junk$s
+ as.double(xs[good]), smomat=double(ngood * ncb),
+ as.integer(nknots), as.integer(deriv), as.integer(ncb))
+ y[good,] <- junk$smomat
if (TRUE && deriv > 1) {
- edges <- xs <= 0 | xs >= 1 # Zero the edges & beyond explicitly
+ edges <- xs <= 0 | xs >= 1 # Zero the edges & beyond explicitly
y[edges,] <- 0
}
}
@@ -526,39 +563,40 @@ predictvsmooth.spline.fit <- function(object, x, deriv=0) {
end.object <- Recall(object, xrange)$y
end.slopes <- Recall(object, xrange, 1)$y * drangex
- if (any(bad.left))
- y[bad.left,] = rep(end.object[1,], rep(sum(bad.left), ncb)) +
- rep(end.slopes[1,], rep(sum(bad.left), ncb)) *
- xs[bad.left]
- if (any(bad.right))
- y[bad.right,] = rep(end.object[2,], rep(sum(bad.right), ncb)) +
- rep(end.slopes[2,], rep(sum(bad.right), ncb)) *
- (xs[bad.right] - 1)
+ if (any(bad.left)) {
+ y[bad.left,] = rep(end.object[1,], rep(sum(bad.left), ncb)) +
+ rep(end.slopes[1,], rep(sum(bad.left), ncb)) *
+ xs[bad.left]
+ }
+ if (any(bad.right)) {
+ y[bad.right,]= rep(end.object[2,], rep(sum(bad.right), ncb)) +
+ rep(end.slopes[2,], rep(sum(bad.right), ncb)) *
+ (xs[bad.right] - 1)
+ }
} else if (deriv == 1) {
end.slopes <- Recall(object, xrange, 1)$y * drangex
- y[bad.left,] <- rep(end.slopes[1,], rep(sum(bad.left), ncb))
+ y[bad.left,] <- rep(end.slopes[1,], rep(sum(bad.left), ncb))
y[bad.right,] <- rep(end.slopes[2,], rep(sum(bad.right), ncb))
} else
y[!good,] <- 0
}
if (deriv > 0)
y <- y / (drangex^deriv)
- list(x=x, y=y)
+ list(x = x, y = y)
}
-valid.vknotl2 = function(knot, tol=1/1000) {
+valid.vknotl2 = function(knot, tol = 1/1024) {
- junk = dotFortran(name="pknotl2", knot=as.double(knot), as.integer(length(knot)),
- keep=integer(length(knot)), as.double(tol))
+ junk = dotC(name="Yee_pknootl2", knot=as.double(knot),
+ as.integer(length(knot)),
+ keep=integer(length(knot)), as.double(tol))
keep = as.logical(junk$keep)
knot = junk$knot[keep]
- if (length(knot) <= 11)
+ if (length(knot) <= 11) {
stop("too few (distinct) knots")
+ }
knot
}
-
-
-
diff --git a/inst/doc/categoricalVGAM.Rnw b/inst/doc/categoricalVGAM.Rnw
index 84df1f5..9d63d50 100644
--- a/inst/doc/categoricalVGAM.Rnw
+++ b/inst/doc/categoricalVGAM.Rnw
@@ -935,7 +935,8 @@ and reference value.
Other \R{}~packages for the Bradley-Terry model
-include \pkg{BradleyTerry}
+include \pkg{BradleyTerry2}
+by H.~Turner and D.~Firth
\citep[with and without ties;][]{firth:2005,firth:2008}
and \pkg{prefmod} \citep{Hatzinger:2009}.
diff --git a/inst/doc/categoricalVGAM.pdf b/inst/doc/categoricalVGAM.pdf
index bd4b46e..859a3f7 100644
Binary files a/inst/doc/categoricalVGAM.pdf and b/inst/doc/categoricalVGAM.pdf differ
diff --git a/man/CommonVGAMffArguments.Rd b/man/CommonVGAMffArguments.Rd
index e330c5f..ab1adab 100644
--- a/man/CommonVGAMffArguments.Rd
+++ b/man/CommonVGAMffArguments.Rd
@@ -122,9 +122,9 @@ TypicalVGAMfamilyFunction(lsigma = "loge", esigma = list(), isigma = NULL,
\eqn{s \mu + (1-s) y}{s*mu + (1-s)*y}
where \eqn{\mu}{mu} is a measure of central tendency such as a weighted
mean or median, and \eqn{y} is the response vector.
- The the initial values are slight perturbations of the mean towards the
- actual data.
- For many type of models this method seems to work well and is often
+ For example, the initial values are slight perturbations of
+ the mean towards the actual data.
+ For many types of models this method seems to work well and is often
reasonably robust to outliers in the response.
Often this argument is only used if
the argument \code{method.init} is assigned a certain value.
diff --git a/man/RayleighUC.Rd b/man/RayleighUC.Rd
index ec69856..8e37836 100644
--- a/man/RayleighUC.Rd
+++ b/man/RayleighUC.Rd
@@ -55,18 +55,16 @@ New York: Wiley-Interscience, Third edition.
\seealso{
\code{\link{rayleigh}},
\code{\link{maxwell}}.
+
}
\examples{
-\dontrun{
-a = 2
-x = seq(-1, 8, by=0.1)
+\dontrun{ a = 2; x = seq(-1, 8, by=0.1)
plot(x, drayleigh(x, a=a), type="l", ylim=c(0,1), las=1, ylab="",
main="Rayleigh density divided into 10 equal areas; red=cdf")
abline(h=0, col="blue", lty=2)
qq = qrayleigh(seq(0.1,0.9,by=0.1),a=a)
lines(qq, drayleigh(qq, a=a), col="purple", lty=3, type="h")
-lines(x, prayleigh(x, a=a), col="red")
-}
+lines(x, prayleigh(x, a=a), col="red") }
}
\keyword{distribution}
diff --git a/man/SinmadUC.Rd b/man/SinmadUC.Rd
index 317b2f3..5c53216 100644
--- a/man/SinmadUC.Rd
+++ b/man/SinmadUC.Rd
@@ -9,12 +9,13 @@
Density, distribution function, quantile function and random
generation for the Singh-Maddala distribution with shape parameters \code{a}
and \code{q}, and scale parameter \code{scale}.
+
}
\usage{
-dsinmad(x, a, scale=1, q.arg, log=FALSE)
-psinmad(q, a, scale=1, q.arg)
-qsinmad(p, a, scale=1, q.arg)
-rsinmad(n, a, scale=1, q.arg)
+dsinmad(x, a, scale = 1, q.arg, log = FALSE)
+psinmad(q, a, scale = 1, q.arg)
+qsinmad(p, a, scale = 1, q.arg)
+rsinmad(n, a, scale = 1, q.arg)
}
\arguments{
\item{x, q}{vector of quantiles.}
@@ -25,7 +26,7 @@ rsinmad(n, a, scale=1, q.arg)
\item{scale}{scale parameter.}
\item{log}{
Logical.
- If \code{log=TRUE} then the logarithm of the density is returned.
+ If \code{log = TRUE} then the logarithm of the density is returned.
}
@@ -35,30 +36,34 @@ rsinmad(n, a, scale=1, q.arg)
\code{psinmad} gives the distribution function,
\code{qsinmad} gives the quantile function, and
\code{rsinmad} generates random deviates.
+
}
\references{
Kleiber, C. and Kotz, S. (2003)
\emph{Statistical Size Distributions in Economics and
Actuarial Sciences},
Hoboken, NJ: Wiley-Interscience.
+
}
\author{ T. W. Yee }
\details{
See \code{\link{sinmad}}, which is the \pkg{VGAM} family function
for estimating the parameters by maximum likelihood estimation.
+
}
\note{
The Singh-Maddala distribution is a special case of the 4-parameter
generalized beta II distribution.
+
}
\seealso{
\code{\link{sinmad}},
\code{\link{genbetaII}}.
}
\examples{
-y = rsinmad(n=3000, 4, 6, 2)
-fit = vglm(y ~ 1, sinmad(init.a=2.1), trace=TRUE, crit="c")
-coef(fit, mat=TRUE)
+y = rsinmad(n = 3000, 4, 6, 2)
+fit = vglm(y ~ 1, sinmad(init.a = 2.1), trace = TRUE, crit = "c")
+coef(fit, matrix = TRUE)
Coef(fit)
}
\keyword{distribution}
diff --git a/man/VGAM-package.Rd b/man/VGAM-package.Rd
index 24bfdf7..ef2b958 100644
--- a/man/VGAM-package.Rd
+++ b/man/VGAM-package.Rd
@@ -18,7 +18,7 @@ quadratic ordination (CQO).
}
\details{
-This package centers on the iteratively reweighted least squares (IRLS)
+This package centers on the \emph{iteratively reweighted least squares} (IRLS)
algorithm.
Other key words include Fisher scoring, additive models, penalized
likelihood, reduced-rank regression and constrained ordination.
@@ -33,6 +33,7 @@ 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
@@ -46,12 +47,14 @@ 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")}.
+
+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
@@ -134,28 +137,27 @@ 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)
+zipdat = data.frame(x = runif(nn <- 2000))
+zipdat = transform(zipdat, phi = logit(-0.5 + 1*x, inverse=TRUE),
+ lambda = loge( 0.5 + 2*x, inverse=TRUE))
+zipdat = transform(zipdat, y = rzipois(nn, lambda, phi))
+with(zipdat, table(y))
+fit = vglm(y ~ x, zipoisson, zipdat, trace=TRUE)
coef(fit, matrix=TRUE) # These should agree with the above values
# Example 3; fit a two species GAM simultaneously
-fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude, df=c(2,3)),
- 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)
+plot(fit2, se = TRUE, overlay = TRUE, lcol = 1:2, scol = 1:2)
ooo = with(hunua, order(altitude))
-with(hunua, matplot(altitude[ooo], fitted(fit2)[ooo,], type="l", lwd=2,
- xlab="Altitude (m)", ylab="Probability of presence", las=1,
- main="Two plant species' response curves", ylim=c(0,.8)))
-with(hunua, rug(altitude))
-}
+with(hunua, matplot(altitude[ooo], fitted(fit2)[ooo,], type = "l", lwd = 2,
+ xlab = "Altitude (m)", ylab = "Probability of presence", las = 1,
+ main = "Two plant species' response curves", ylim = c(0,.8)))
+with(hunua, rug(altitude)) }
# Example 4; LMS quantile regression
@@ -166,20 +168,18 @@ head(bminz) # Person 1 is near the lower quartile among people his age
head(cdf(fit))
\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)
+ xlim=c(15,90), las=1, ylab="BMI", lwd=2, lcol=4) # Quantile plot
-# 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",
+par(mfrow=c(1,1), lwd=2) # Density plot
+aa = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)")
-a
-a = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
-a = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
-a at post$deplot # Contains density function values
+aa
+aa = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
+aa = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
+aa at post$deplot # Contains density function values
}
diff --git a/man/acat.Rd b/man/acat.Rd
index a711d5a..4b89a36 100644
--- a/man/acat.Rd
+++ b/man/acat.Rd
@@ -117,7 +117,7 @@ contains further information and examples.
\code{\link{pneumo}}.
}
\examples{
-pneumo = transform(pneumo, let=log(exposure.time))
+pneumo <- transform(pneumo, let=log(exposure.time))
(fit <- vglm(cbind(normal,mild,severe) ~ let, acat, pneumo))
coef(fit, matrix=TRUE)
constraints(fit)
@@ -126,4 +126,4 @@ model.matrix(fit)
\keyword{models}
\keyword{regression}
-%pneumo$let = log(pneumo$exposure.time)
+%pneumo$let <- log(pneumo$exposure.time)
diff --git a/man/alaplaceUC.Rd b/man/alaplaceUC.Rd
index 63e902e..f9e221c 100644
--- a/man/alaplaceUC.Rd
+++ b/man/alaplaceUC.Rd
@@ -84,8 +84,8 @@ Boston: Birkhauser.
}
\examples{
-x = seq(-5, 5, by=0.01)
-loc = 0; sigma = 1.5; kappa = 2
+x <- seq(-5, 5, by=0.01)
+loc <- 0; sigma <- 1.5; kappa <- 2
\dontrun{
plot(x, dalap(x, loc, sigma, kappa=kappa), type="l", col="blue",
main="Blue is density, red is cumulative distribution function",
diff --git a/man/amh.Rd b/man/amh.Rd
index 45d917e..aac83c3 100644
--- a/man/amh.Rd
+++ b/man/amh.Rd
@@ -91,8 +91,8 @@ Adelaide, South Australia: Rumsby Scientific Publishing.
}
\examples{
-ymat = ramh(1000, alpha=rhobit(2, inverse=TRUE))
-fit = vglm(ymat ~ 1, amh, trace = TRUE)
+ymat <- ramh(1000, alpha=rhobit(2, inverse=TRUE))
+fit <- vglm(ymat ~ 1, amh, trace = TRUE)
coef(fit, mat=TRUE)
Coef(fit)
}
diff --git a/man/amlbinomial.Rd b/man/amlbinomial.Rd
index ac26422..766544c 100644
--- a/man/amlbinomial.Rd
+++ b/man/amlbinomial.Rd
@@ -105,7 +105,8 @@ amlbinomial(w.aml = 1, parallel = FALSE, digw = 4, link = "logit", earg = list()
\code{\link{amlpoisson}},
\code{\link{amlexponential}},
\code{\link{amlnormal}},
- \code{\link{alaplace1}}.
+ \code{\link{alaplace1}},
+ \code{\link{denorm}}.
}
diff --git a/man/amlexponential.Rd b/man/amlexponential.Rd
index ce3ebbf..5db82c6 100644
--- a/man/amlexponential.Rd
+++ b/man/amlexponential.Rd
@@ -116,7 +116,9 @@ amlexponential(w.aml = 1, parallel = FALSE, method.init = 1, digw = 4,
\code{\link{amlbinomial}},
\code{\link{amlpoisson}},
\code{\link{amlnormal}},
- \code{\link{alaplace1}}.
+ \code{\link{alaplace1}},
+ \code{\link{lms.bcg}},
+ \code{\link{deexp}}.
}
diff --git a/man/amlnormal.Rd b/man/amlnormal.Rd
index f525122..ccf65c8 100644
--- a/man/amlnormal.Rd
+++ b/man/amlnormal.Rd
@@ -131,6 +131,7 @@ amlnormal(w.aml = 1, parallel = FALSE, lexpectile = "identity",
\code{\link{amlexponential}},
\code{\link{bminz}},
\code{\link{alaplace1}},
+ \code{\link{denorm}},
\code{\link{lms.bcn}} and similar variants are alternative
methods for quantile regression.
diff --git a/man/benfUC.Rd b/man/benfUC.Rd
index 9448b5e..afd56bf 100644
--- a/man/benfUC.Rd
+++ b/man/benfUC.Rd
@@ -13,10 +13,10 @@
}
\usage{
-dbenf(x, ndigits=1, log=FALSE)
-pbenf(q, ndigits=1, log.p=FALSE)
-qbenf(p, ndigits=1)
-rbenf(n, ndigits=1)
+dbenf(x, ndigits = 1, log = FALSE)
+pbenf(q, ndigits = 1, log.p = FALSE)
+qbenf(p, ndigits = 1)
+rbenf(n, ndigits = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -59,6 +59,7 @@ This means
the probability the first\ significant\ digit is 1 is
approximately \eqn{0.301}, etc.
+
Benford's Law was apparently first discovered in 1881
by astronomer/mathematician
S. Newcombe. It started by the observation
@@ -71,10 +72,12 @@ as different as atomic weights, baseball statistics,
numerical data from \emph{Reader's Digest},
and drainage areas of rivers.
+
Applications of Benford's Law has been as diverse as
to the area of
fraud detection in accounting and the design computers.
+
}
\value{
\code{dbenf} gives the density,
diff --git a/man/benini.Rd b/man/benini.Rd
index 9cce164..cb6b2f3 100644
--- a/man/benini.Rd
+++ b/man/benini.Rd
@@ -8,8 +8,8 @@
}
\usage{
-benini(y0=stop("argument 'y0' must be specified"),
- lshape="loge", earg=list(), ishape=NULL, method.init=1)
+benini(y0 = stop("argument 'y0' must be specified"),
+ lshape = "loge", earg = list(), ishape = NULL, method.init = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -52,6 +52,7 @@ benini(y0=stop("argument 'y0' must be specified"),
F(y) = 1 - exp(-b * [(log(y/y0))^2]). }
Here, Newton-Raphson and Fisher scoring coincide.
+
On fitting, the \code{extra} slot has a component called \code{y0} which
contains the value of the \code{y0} argument.
@@ -64,13 +65,12 @@ benini(y0=stop("argument 'y0' must be specified"),
\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{
Kleiber, C. and Kotz, S. (2003)
-\emph{Statistical Size Distributions in Economics and
- Actuarial Sciences},
+\emph{Statistical Size Distributions in Economics and Actuarial Sciences},
Hoboken, NJ: Wiley-Interscience.
}
@@ -83,15 +83,15 @@ Hoboken, NJ: Wiley-Interscience.
}
\seealso{
\code{\link{Benini}}.
+
}
\examples{
y0 = 1
-bdata = data.frame(y = rbenini(n=3000, y0=y0, shape=exp(2)))
-fit = vglm(y ~ 1, benini(y0=y0), bdata, trace=TRUE, crit="c")
-coef(fit, matrix=TRUE)
+bdata = data.frame(y = rbenini(n = 3000, y0 = y0, shape = exp(2)))
+fit = vglm(y ~ 1, benini(y0 = y0), bdata, trace = TRUE, crit = "coef")
+coef(fit, matrix = TRUE)
Coef(fit)
fit at extra$y0
-
head(fitted(fit), 1) # Apparent discrepancy:
with(bdata, mean(y))
}
diff --git a/man/beniniUC.Rd b/man/beniniUC.Rd
index 3a17a43..8d4659a 100644
--- a/man/beniniUC.Rd
+++ b/man/beniniUC.Rd
@@ -35,6 +35,7 @@ rbenini(n, shape, y0)
\code{pbenini} gives the distribution function,
\code{qbenini} gives the quantile function, and
\code{rbenini} generates random deviates.
+
}
\references{
Kleiber, C. and Kotz, S. (2003)
@@ -48,12 +49,14 @@ Hoboken, NJ: Wiley-Interscience.
See \code{\link{benini}}, the \pkg{VGAM} family function
for estimating the parameter \eqn{b} by maximum likelihood estimation,
for the formula of the probability density function and other details.
+
}
%\note{
%
%}
\seealso{
\code{\link{benini}}.
+
}
\examples{
\dontrun{
diff --git a/man/binomialff.Rd b/man/binomialff.Rd
index aed765f..1f9394b 100644
--- a/man/binomialff.Rd
+++ b/man/binomialff.Rd
@@ -70,18 +70,22 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
is not fully a maximum likelihood estimate (see pp.124--8 of McCullagh
and Nelder, 1989).
+
A dispersion parameter that is less/greater than unity corresponds to
under-/over-dispersion relative to the binomial model. Over-dispersion
is more common in practice.
- Setting \code{mv=TRUE} is necessary when fitting a Quadratic RR-VGLM
+
+ Setting \code{mv = TRUE} is necessary when fitting a Quadratic RR-VGLM
(see \code{\link{cqo}}) because the response is a matrix of \eqn{M}
columns (e.g., one column per species). Then there will be \eqn{M}
dispersion parameters (one per column of the response matrix).
+
When used with \code{\link{cqo}} and \code{\link{cao}}, it may be
preferable to use the \code{\link{cloglog}} link.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -109,35 +113,47 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
\author{ Thomas W. Yee }
\note{
- If \code{mv} is \code{FALSE} (default), then the response can be of one
+ If \code{mv} is \code{FALSE} (default) then the response can be of one
of three formats: a factor (first level taken as success), a vector of
proportions of success, or a 2-column matrix (first column = successes)
of counts. The argument \code{weights} in the modelling function can
also be specified. In particular, for a general vector of proportions,
you will need to specify \code{weights} because the number of trials
is needed.
+ In general, 1 means success and 0 means failure
+ (to check, see the \code{y} slot of the fitted object).
+ To input general positive values into the \code{weights} argument of
+ \code{\link{vglm}}/\code{\link{vgam}} one needs to input a 2-column
+ response.
+
The notation \eqn{M} is used to denote the number of linear/additive
predictors.
+
If \code{mv} is \code{TRUE}, then the matrix response can only be of
- one format: a matrix of 1's and 0's (1=success).
+ one format: a matrix of 1's and 0's (1 = success).
+
The call \code{binomialff(dispersion=0, ...)} is equivalent to
\code{quasibinomialff(...)}. The latter was written so that R users
of \code{quasibinomial()} would only need to add a ``\code{ff}''
to the end of the family function name.
+
Regardless of whether the dispersion parameter is to be estimated or
not, its value can be seen from the output from the \code{summary()}
of the object.
+
% With the introduction of name spaces for the \pkg{VGAM} package,
% \code{"ff"} can be dropped for this family function.
+
Fisher scoring is used. This can sometimes fail to converge by oscillating between
successive iterations (Ridout, 1990). See the example below.
+
}
\seealso{
\code{\link{quasibinomialff}},
@@ -151,6 +167,7 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
\code{\link{mbinomial}},
\code{\link{seq2binomial}},
\code{\link{amlbinomial}},
+ \code{\link{simplex}},
\code{\link[stats:Binomial]{binomial}},
\pkg{safeBinaryRegression}.
diff --git a/man/bivgamma.mckay.Rd b/man/bivgamma.mckay.Rd
new file mode 100644
index 0000000..5226254
--- /dev/null
+++ b/man/bivgamma.mckay.Rd
@@ -0,0 +1,132 @@
+\name{bivgamma.mckay}
+\alias{bivgamma.mckay}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Bivariate Gamma: McKay's Distribution }
+\description{
+ Estimate the three parameters of McKay's bivariate gamma distribution
+ by maximum likelihood estimation.
+
+}
+\usage{
+bivgamma.mckay(lscale = "loge", lshape1 = "loge", lshape2 = "loge",
+ iscale = NULL, ishape1 = NULL, ishape2 = NULL,
+ method.init=1, zero = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lscale, lshape1, lshape2}{
+ Link functions applied to the (positive)
+ parameters \eqn{a}, \eqn{p} and \eqn{q} respectively.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{iscale, ishape1, ishape2}{
+ Optional initial values for \eqn{a}, \eqn{p} and \eqn{q} respectively.
+ The default is to compute them internally.
+
+ }
+ \item{method.init, zero}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
+}
+\details{
+ One of the earliest forms of the bivariate gamma distribution has
+ a joint probability density function given by
+ \deqn{f(y_1,y_2;a,p,q) = (1/a)^{p+q} y_1^{p-1} (y_2-y_1)^{q-1}
+ \exp(-y_2 / a) / [\Gamma(p) \Gamma(q)]}{%
+ f(y1,y2;a,p,q) = (1/a)^(p+q) y1^(p-1) (y2-y1)^(q-1)
+ exp(-y2/a) / [gamma(p) gamma(q)] }
+ for \eqn{a > 0}, \eqn{p > 0}, \eqn{q > 0} and
+ \eqn{0 < y_1 < y_2}{0<y1<y2}
+ (Mckay, 1934).
+ Here, \eqn{\Gamma}{gamma} is the gamma
+ function, as in \code{\link[base:Special]{gamma}}.
+ By default, the linear/additive predictors are
+ \eqn{\eta_1=\log(a)}{eta1=log(a)},
+ \eqn{\eta_2=\log(p)}{eta2=log(p)},
+ \eqn{\eta_3=\log(q)}{eta3=log(q)}.
+
+
+ The marginal distributions are gamma, with shape parameters \eqn{p} and
+ \eqn{p+q} respectively, but they have a common scale parameter \eqn{a}.
+ Pearson's product-moment correlation coefficient of
+ \eqn{y_1}{y1} and \eqn{y_2}{y2} is
+ \eqn{\sqrt{p/(p+q)}}{sqrt(p/(p+q))}.
+ This distribution is also known as the bivariate Pearson type III
+ distribution.
+ Also, \eqn{Y_2 - y_1}{Y2 - y1}, conditional on \eqn{Y_1=y_1}{Y1=y1},
+ has a gamma distribution with shape parameter \eqn{q}.
+
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+
+%% improve the references
+\references{
+
+
+McKay, A. T. (1934)
+Sampling from batches.
+\emph{Journal of the Royal Statistical Society---Supplement},
+\bold{1}, 207--216.
+
+
+Kotz, S. and Balakrishnan, N. and Johnson, N. L. (2000)
+\emph{Continuous Multivariate Distributions Volume 1: Models and Applications},
+2nd edition,
+New York: Wiley.
+
+
+Balakrishnan, N. and Lai, C.-D. (2009)
+\emph{Continuous Bivariate Distributions},
+2nd edition.
+New York: Springer.
+
+}
+\author{ T. W. Yee }
+\note{
+ The response must be a two column matrix where the first column is
+ \eqn{y_1}{y1} and the second \eqn{y_2}{y2}.
+ It is necessary that each element of the vectors \eqn{y_1}{y1}
+ and
+ \eqn{y_2-y_1}{y2-y1} be positive.
+ Currently, the fitted value is a matrix with two columns;
+ the first column has values \eqn{ap} for the marginal mean of
+ \eqn{y_1}{y1},
+ while the second column
+ has values \eqn{a(p+q)} for the marginal mean of
+ \eqn{y_2}{y2} (all evaluated at the final iteration).
+
+
+% The data are sorted internally and the user need not input the
+% data presorted.
+
+
+}
+
+\seealso{
+ \code{\link{gamma2}}.
+
+}
+\examples{
+shape1 = exp(1); shape2 = exp(2); scalepar = exp(3)
+mdata = data.frame(y1 = rgamma(nn <- 1000, shape=shape1, scale=scalepar))
+mdata = transform(mdata, zedd = rgamma(nn, shape=shape2, scale=scalepar))
+mdata = transform(mdata, y2 = y1 + zedd) # Z is defined as Y2-y1|Y1=y1
+fit = vglm(cbind(y1, y2) ~ 1, bivgamma.mckay, mdata, trace = TRUE)
+coef(fit, matrix = TRUE)
+Coef(fit)
+vcov(fit)
+
+colMeans(fit at y) # Check moments
+head(fitted(fit), 1)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/borel.tanner.Rd b/man/borel.tanner.Rd
index 9d13672..a29faaa 100644
--- a/man/borel.tanner.Rd
+++ b/man/borel.tanner.Rd
@@ -55,6 +55,7 @@ borel.tanner(Qsize=1, link="logit", earg=list(), method.init=1)
The Borel-Tanner distribution is an \eqn{Q}-fold convolution of the
Borel distribution.
+
The mean is \eqn{Q/(1-a)} (returned as the fitted values) and the
variance is \eqn{Q a / (1-a)^3}{Q*a/(1-a)^3}.
The distribution has a very long tail unless \eqn{a} is small.
diff --git a/man/brat.Rd b/man/brat.Rd
index 02813bc..769d7dc 100644
--- a/man/brat.Rd
+++ b/man/brat.Rd
@@ -52,6 +52,7 @@ brat(refgp = "last", refvalue = 1, init.alpha = 1)
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}.
+
}
\references{
Agresti, A. (2002)
@@ -63,8 +64,10 @@ Citation patterns in the journals of statistics and probability.
\emph{Statistical Science},
\bold{9}, 94--108.
-The \pkg{BradleyTerry} package has more comprehensive capabilities
+The \pkg{BradleyTerry2} package has more comprehensive capabilities
than this function.
+
+
}
\author{ T. W. Yee }
\note{
diff --git a/man/cao.control.Rd b/man/cao.control.Rd
index 2871fb9..f548026 100644
--- a/man/cao.control.Rd
+++ b/man/cao.control.Rd
@@ -14,8 +14,8 @@ cao.control(Rank=1, all.knots = FALSE, criterion="deviance", Cinit=NULL,
Crow1positive=TRUE, epsilon = 1.0e-05, Etamat.colmax = 10,
GradientFunction=FALSE, iKvector = 0.1, iShape = 0.1,
Norrr = ~ 1, SmallNo = 5.0e-13, Use.Init.Poisson.QO=TRUE,
- Bestof = if (length(Cinit)) 1 else 10, maxitl = 40,
- method.init = 1, bf.epsilon = 1.0e-7, bf.maxit = 40,
+ Bestof = if (length(Cinit)) 1 else 10, maxitl = 10,
+ method.init = 1, bf.epsilon = 1.0e-7, bf.maxit = 10,
Maxit.optim = 250, optim.maxit = 20, SD.sitescores = 1.0,
SD.Cinit = 0.02, trace = TRUE, df1.nl = 2.5, df2.nl = 2.5,
spar1 = 0, spar2 = 0, ...)
diff --git a/man/cardioid.Rd b/man/cardioid.Rd
index 881d3c7..aeb05af 100644
--- a/man/cardioid.Rd
+++ b/man/cardioid.Rd
@@ -7,10 +7,10 @@
cardioid distribution by maximum likelihood estimation.
}
\usage{
-cardioid(lmu="elogit", lrho="elogit",
- emu =if(lmu=="elogit") list(min=0, max=2*pi) else list(),
- erho=if(lmu=="elogit") list(min=-0.5, max=0.5) else list(),
- imu=NULL, irho=0.3, nsimEIM=100, zero=NULL)
+cardioid(lmu = "elogit", lrho = "elogit",
+ emu = if(lmu == "elogit") list(min = 0, max = 2*pi) else list(),
+ erho = if(lmu == "elogit") list(min = -0.5, max = 0.5) else list(),
+ imu = NULL, irho = 0.3, nsimEIM = 100, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -49,6 +49,7 @@ cardioid(lmu="elogit", lrho="elogit",
The default link functions enforce the range constraints
of the parameters.
+
For positive \eqn{\rho} the distribution is unimodal and symmetric about
\eqn{\mu}{mu}.
The mean of \eqn{Y} (which make up the fitted values) is
@@ -95,11 +96,11 @@ Singapore: World Scientific.
}
\examples{
-carddata = data.frame(y = rcard(n=1000, mu=4, rho=0.45))
-fit = vglm(y ~ 1, cardioid, carddata, trace=TRUE)
+cdata = data.frame(y = rcard(n = 1000, mu = 4, rho = 0.45))
+fit = vglm(y ~ 1, cardioid, cdata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
-c(with(carddata, mean(y)), head(fitted(fit),1))
+c(with(cdata, mean(y)), head(fitted(fit), 1))
summary(fit)
}
\keyword{models}
diff --git a/man/cqo.Rd b/man/cqo.Rd
index e70c210..428b031 100644
--- a/man/cqo.Rd
+++ b/man/cqo.Rd
@@ -40,12 +40,12 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
\code{\link{gamma2}},
\code{\link{gaussianff}}.
Sometimes special arguments are required for \code{cqo()}, e.g.,
- \code{binomialff(mv=TRUE)}.
+ \code{binomialff(mv = TRUE)}.
Also, \code{\link{quasipoissonff}} and \code{\link{quasibinomialff}}
may or may not work.
-% \code{negbinomial(deviance=TRUE)},
-% \code{gamma2(deviance=TRUE)}.
+% \code{negbinomial(deviance = TRUE)},
+% \code{gamma2(deviance = TRUE)}.
}
\item{data}{
@@ -99,7 +99,7 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
\item{offset}{
This argument must not be used.
-% especially when \code{ITolerances=TRUE}.
+% especially when \code{ITolerances = TRUE}.
% a vector or \eqn{M}-column matrix of offset values.
% These are \emph{a priori} known and are
% added to the linear predictors during fitting.
@@ -224,8 +224,10 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
tolerances. It can be quite good on binary data too. Otherwise the
\code{Cinit} argument in \code{\link{qrrvglm.control}} can be used.
+
%(and negative binomial)
+
It is possible to relax the quadratic form to an additive model. The
result is a data-driven approach rather than a model-driven approach,
so that CQO is extended to \emph{constrained additive ordination}
@@ -237,7 +239,6 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
\eqn{M=S} for Poisson and binomial species data,
and \eqn{M=2S} for negative binomial and gamma distributed species data.
-
}
\value{
An object of class \code{"qrrvglm"}.
@@ -254,16 +255,19 @@ canonical Gaussian ordination.
\emph{Ecological Monographs},
\bold{74}, 685--701.
+
ter Braak, C. J. F. and Prentice, I. C. (1988)
A theory of gradient analysis.
\emph{Advances in Ecological Research},
\bold{18}, 271--317.
+
%Yee, T. W. (2005)
%On constrained and unconstrained
%quadratic ordination.
%\emph{Manuscript in preparation}.
+
Yee, T. W. (2006)
Constrained additive ordination.
\emph{Ecology}, \bold{87}, 203--213.
@@ -272,6 +276,7 @@ Constrained additive ordination.
\author{Thomas W. Yee}
\note{
+
By default, a rank-1 equal-tolerances QRR-VGLM model is fitted
(see \code{\link{qrrvglm.control}} for the default control
parameters).
@@ -280,7 +285,8 @@ Constrained additive ordination.
By default, the argument \code{trace} is \code{TRUE} meaning a running
log is printed out while the computations are taking place. This is
because the algorithm is computationally expensive, therefore users
- might think that their computers have frozen if \code{trace=FALSE}!
+ might think that their computers have frozen if \code{trace = FALSE}!
+
The argument \code{Bestof} in \code{\link{qrrvglm.control}} controls
the number of models fitted (each uses different starting values) to
@@ -292,16 +298,18 @@ Constrained additive ordination.
arise because the optimization problem is highly nonlinear, and this is
particularly true for CAO.
+
%Convergence of QRR-VGLMs can be difficult, especially for binary
- %data. If this is so, then setting \code{ITolerances=TRUE} or
- %\code{EqualTolerances=TRUE} may help, especially when the number of sites,
+ %data. If this is so, then setting \code{ITolerances = TRUE} or
+ %\code{EqualTolerances = TRUE} may help, especially when the number of sites,
%\eqn{n}, is small.
%If the negative binomial family function \code{\link{negbinomial}} is
- %used for \code{cqo} then set \code{negbinomial(deviance=TRUE)}
+ %used for \code{cqo} then set \code{negbinomial(deviance = TRUE)}
%is necessary. This means to minimize the deviance, which the fast
%algorithm can handle.
+
Many of the arguments applicable to \code{cqo} are common to
\code{\link{vglm}} and \code{\link{rrvglm.control}}.
The most important arguments are
@@ -313,31 +321,36 @@ Constrained additive ordination.
\code{isdlv}, and
\code{MUXfactor}.
+
When fitting a 2-parameter model such as the negative binomial
- or gamma, it pays to set \code{EqualTolerances=TRUE} and
- \code{ITolerances=FALSE}. This is because numerical problems can
+ or gamma, it pays to have \code{EqualTolerances = TRUE} and
+ \code{ITolerances = FALSE}. This is because numerical problems can
occur when fitting the model far away from the global solution when
- \code{ITolerances=TRUE}. Setting the two arguments as described will
+ \code{ITolerances = TRUE}. Setting the two arguments as described will
slow down the computation considerably, however it is numerically
more stable.
+
In Example 1 below, an unequal-tolerances rank-1 QRR-VGLM is fitted to the
- hunting spiders dataset.
- In Example 2 below, an equal-tolerances rank-2 QRR-VGLM is fitted to the
+ hunting spiders dataset, and
+ Example 2 is the equal-tolerances version. The latter is less likely to
+ have convergence problems compared to the unequal-tolerances model.
+ In Example 3 below, an equal-tolerances rank-2 QRR-VGLM is fitted to the
hunting spiders dataset.
The numerical difficulties encountered in fitting the rank-2 model
suggests a rank-1 model is probably preferable.
- In Example 3 below, constrained binary quadratic ordination (in old
+ In Example 4 below, constrained binary quadratic ordination (in old
nomenclature, constrained Gaussian logit ordination) is fitted to some
simulated data coming from a species packing model.
- With multivariate binary responses, one must use \code{mv=TRUE} to
+ With multivariate binary responses, one must use \code{mv = TRUE} to
indicate that the response (matrix) is multivariate. Otherwise, it is
interpreted as a single binary response variable.
- In Example 4 below, the deviance residuals are plotted for each species.
+ In Example 5 below, the deviance residuals are plotted for each species.
This is useful as a diagnostic plot.
This is done by (re)regressing each species separately against the latent
variable.
+
Sometime in the future, this function might handle input of the form
\code{cqo(x, y)}, where \code{x} and \code{y} are matrices containing
the environmental and species data respectively.
@@ -351,11 +364,12 @@ Constrained additive ordination.
random number seed before calling \code{cqo} (the function
\code{\link[base:Random]{set.seed}} does this). The function \code{cqo}
chooses initial values for \bold{C} using \code{.Init.Poisson.QO()}
- if \code{Use.Init.Poisson.QO=TRUE}, else random numbers.
+ if \code{Use.Init.Poisson.QO = TRUE}, else random numbers.
- Unless \code{ITolerances=TRUE} or \code{EqualTolerances=FALSE},
+
+ Unless \code{ITolerances = TRUE} or \code{EqualTolerances = FALSE},
CQO is computationally expensive. It pays to keep the rank down to 1
- or 2. If \code{EqualTolerances=TRUE} and \code{ITolerances=FALSE} then
+ or 2. If \code{EqualTolerances = TRUE} and \code{ITolerances = FALSE} then
the cost grows quickly with the number of species and sites (in terms of
memory requirements and time). The data needs to conform quite closely
to the statistical model, and the environmental range of the data should
@@ -364,6 +378,7 @@ Constrained additive ordination.
the response is linear on the transformed scale (e.g., log or logit)
and the ordination is called \emph{constrained linear ordination} or CLO.
+
Like many regression models, CQO is sensitive to outliers (in the
environmental and species data), sparse data, high leverage points,
multicollinearity etc. For these reasons, it is necessary to examine
@@ -374,15 +389,17 @@ Constrained additive ordination.
be trusted. Fitting a CAO is recommended first, then upon transformations
etc., possibly a CQO can be fitted.
+
For binary data, it is necessary to have `enough' data. In general,
the number of sites \eqn{n} ought to be much larger than the number of
species \emph{S}, e.g., at least 100 sites for two species. Compared
to count (Poisson) data, numerical problems occur more frequently
- with presence/absence (binary) data. For example, if \code{Rank=1}
+ with presence/absence (binary) data. For example, if \code{Rank = 1}
and if the response data for each species is a string of all absences,
then all presences, then all absences (when enumerated along the latent
variable) then infinite parameter estimates will occur. In general,
- setting \code{ITolerances=TRUE} may help.
+ setting \code{ITolerances = TRUE} may help.
+
This function was formerly called \code{cgo}. It has been renamed to
reinforce a new nomenclature described in Yee (2006).
@@ -410,6 +427,7 @@ Constrained additive ordination.
\code{\link[base:Random]{set.seed}},
\code{\link{hspider}}.
+
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
contains further information and examples.
@@ -418,10 +436,127 @@ contains further information and examples.
\examples{
# Example 1; Fit an unequal tolerances model to the hunting spiders data
hspider[,1:6]=scale(hspider[,1:6]) # Standardize the environmental variables
+set.seed(1234) # For reproducibility of the results
+p1ut = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
+ Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
+ Trocterr, Zoraspin) ~
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ fam = poissonff, data = hspider, Crow1positive = FALSE,
+ EqualTol = FALSE)
+sort(p1ut at misc$deviance.Bestof) # A history of all the iterations
+if(deviance(p1ut) > 1177) stop("suboptimal fit obtained")
+
+\dontrun{
+S = ncol(p1ut at y) # Number of species
+clr = (1:(S+1))[-7] # Omits yellow
+lvplot(p1ut, y = TRUE, lcol=clr, pch=1:S, pcol=clr, las=1) # ordination diagram
+legend("topright", leg=colnames(p1ut at y), col=clr,
+ pch=1:S, merge = TRUE, bty="n", lty=1:S, lwd=2) }
+(cp = Coef(p1ut))
+
+(a = cp at lv[cp at lvOrder]) # The ordered site scores along the gradient
+# Names of the ordered sites along the gradient:
+rownames(cp at lv)[cp at lvOrder]
+(a = (cp at Optimum)[,cp at OptimumOrder]) # The ordered optima along the gradient
+a = a[!is.na(a)] # Delete the species that is not unimodal
+names(a) # Names of the ordered optima along the gradient
+
+\dontrun{
+trplot(p1ut, whichSpecies=1:3, log="xy", type="b", lty=1, lwd=2,
+ col=c("blue","red","green"), label = TRUE) -> ii # trajectory plot
+legend(0.00005, 0.3, paste(ii$species[,1], ii$species[,2], sep=" and "),
+ lwd=2, lty=1, col=c("blue","red","green"))
+abline(a=0, b=1, lty="dashed")
+
+S = ncol(p1ut at y) # Number of species
+clr = (1:(S+1))[-7] # Omits yellow
+persp(p1ut, col=clr, label = TRUE, las=1) # perspective plot
+}
+
+
+# Example 2; Fit an equal tolerances model. Less numerically fraught.
+set.seed(1234)
+p1et = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
+ Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
+ Trocterr, Zoraspin) ~
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ fam = poissonff, data = hspider, Crow1positive = FALSE)
+sort(p1et at misc$deviance.Bestof) # A history of all the iterations
+if(deviance(p1et) > 1586) stop("suboptimal fit obtained")
+\dontrun{
+S = ncol(p1et at y) # Number of species
+clr = (1:(S+1))[-7] # Omits yellow
+persp(p1et, col=clr, label = TRUE, las=1) }
+
+
+# Example 3: A rank-2 equal tolerances CQO model with Poisson data
+# This example is numerically fraught... need IToler = TRUE too.
+set.seed(555)
+p2 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
+ Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
+ Trocterr, Zoraspin) ~
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ fam = poissonff, data = hspider, Crow1positive = FALSE,
+ IToler = TRUE, Rank = 2, Bestof = 1, isdlv = c(2.1, 0.9))
+sort(p2 at misc$deviance.Bestof) # A history of all the iterations
+if(deviance(p2) > 1127) stop("suboptimal fit obtained")
+\dontrun{
+lvplot(p2, ellips = FALSE, label = TRUE, xlim=c(-3,4),
+ C = TRUE, Ccol="brown", sites = TRUE, scol="grey",
+ pcol="blue", pch="+", chull = TRUE, ccol="grey") }
+
+
+# Example 4: species packing model with presence/absence data
+set.seed(2345)
+n = 200; p = 5; S = 5
+mydata = rcqo(n, p, S, fam="binomial", hiabundance=4,
+ EqualTol = TRUE, ESOpt = TRUE, EqualMax = TRUE)
+myform = attr(mydata, "formula")
set.seed(1234)
+b1et = cqo(myform, binomialff(mv = TRUE, link="cloglog"), data = mydata)
+sort(b1et at misc$deviance.Bestof) # A history of all the iterations
+\dontrun{ lvplot(b1et, y = TRUE, lcol=1:S, pch=1:S, pcol=1:S, las=1) }
+Coef(b1et)
+
+# Compare the fitted model with the 'truth'
+cbind(truth=attr(mydata, "ccoefficients"), fitted=ccoef(b1et))
+
+
+# Example 5: Plot the deviance residuals for diagnostic purposes
+set.seed(1234)
+p1et = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
+ Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
+ Trocterr, Zoraspin) ~
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ fam=poissonff, data=hspider, EqualTol = TRUE, trace = FALSE)
+sort(p1et at misc$deviance.Bestof) # A history of all the iterations
+if(deviance(p1et) > 1586) stop("suboptimal fit obtained")
+S = ncol(p1et at y)
+par(mfrow=c(3,4))
+for(ii in 1:S) {
+ tempdata = data.frame(lv1 = c(lv(p1et)), sppCounts = p1et at y[,ii])
+ tempdata = transform(tempdata, myOffset = -0.5 * lv1^2)
+
+# For species ii, refit the model to get the deviance residuals
+ fit1 = vglm(sppCounts ~ offset(myOffset) + lv1, fam=poissonff,
+ data=tempdata, trace = FALSE)
+
+# For checking: this should be 0
+ print("max(abs(c(Coef(p1et)@B1[1,ii], Coef(p1et)@A[ii,1]) - coef(fit1)))")
+ print( max(abs(c(Coef(p1et)@B1[1,ii], Coef(p1et)@A[ii,1]) - coef(fit1))) )
+
+# # Plot the deviance residuals
+ devresid = resid(fit1, type = "deviance")
+ predvalues = predict(fit1) + fit1 at offset
+ ooo = with(tempdata, order(lv1))
+\dontrun{
+ with(tempdata, plot(lv1, predvalues + devresid, col="darkgreen",
+ xlab="lv1", ylab="", main=colnames(p1et at y)[ii]))
+ with(tempdata, lines(lv1[ooo], predvalues[ooo], col="blue")) }
+}
}
\keyword{models}
\keyword{regression}
%legend("topright", x=1, y=135, leg=colnames(p1ut at y), col=clr,
-% pch=1:S, merge=TRUE, bty="n", lty=1:S, lwd=2)
+% pch=1:S, merge = TRUE, bty="n", lty=1:S, lwd=2)
diff --git a/man/dirichlet.Rd b/man/dirichlet.Rd
index 423337e..bffd608 100644
--- a/man/dirichlet.Rd
+++ b/man/dirichlet.Rd
@@ -108,7 +108,8 @@ New York: Wiley-Interscience, Third edition.
\seealso{
\code{\link{rdiric}},
\code{\link{dirmultinomial}},
- \code{\link{multinomial}}.
+ \code{\link{multinomial}},
+ \code{\link{simplex}}.
}
\examples{
diff --git a/man/eexpUC.Rd b/man/eexpUC.Rd
new file mode 100644
index 0000000..87caae2
--- /dev/null
+++ b/man/eexpUC.Rd
@@ -0,0 +1,133 @@
+\name{Expectiles-Exponential}
+\alias{Expectiles-Exponential}
+\alias{eexp}
+\alias{deexp}
+\alias{peexp}
+\alias{qeexp}
+\alias{reexp}
+\title{ Expectiles of the Exponential Distribution }
+\description{
+ Density function, distribution function, and
+ expectile function and random generation for the distribution
+ associated with the expectiles of an exponential distribution.
+
+}
+\usage{
+deexp(x, rate = 1, log = FALSE)
+peexp(q, rate = 1, log = FALSE)
+qeexp(p, rate = 1, Maxit_nr = 10, Tol_nr = 1.0e-6)
+reexp(n, rate = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, p, q}{
+ See \code{\link{deunif}}.
+ }
+ \item{n, rate, log}{See \code{\link[stats:Exponential]{rexp}}.}
+ \item{Maxit_nr, Tol_nr}{
+ See \code{\link{deunif}}.
+ }
+}
+\details{
+
+General details are given in \code{\link{deunif}}
+including
+a note regarding the terminology used.
+Here,
+\code{exp} corresponds to the distribution of interest, \eqn{F}, and
+\code{eexp} corresponds to \eqn{G}.
+The addition of ``\code{e}'' is for the `other'
+distribution associated with the parent distribution.
+Thus
+\code{deexp} is for \eqn{g},
+\code{peexp} is for \eqn{G},
+\code{qeexp} is for the inverse of \eqn{G},
+\code{reexp} generates random variates from \eqn{g}.
+
+
+For \code{qeexp} the Newton-Raphson algorithm is used to solve for
+\eqn{y} satisfying \eqn{p = G(y)}.
+Numerical problems may occur when values of \code{p} are
+very close to 0 or 1.
+
+}
+\value{
+ \code{deexp(x)} gives the density function \eqn{g(x)}.
+ \code{peexp(q)} gives the distribution function \eqn{G(q)}.
+ \code{qeexp(p)} gives the expectile function:
+ the value \eqn{y} such that \eqn{G(y)=p}.
+ \code{reexp(n)} gives \eqn{n} random variates from \eqn{G}.
+
+}
+
+%\references{
+%
+%Jones, M. C. (1994)
+%Expectiles and M-quantiles are quantiles.
+%\emph{Statistics and Probability Letters},
+%\bold{20}, 149--153.
+%
+%}
+\author{ T. W. Yee }
+
+%\note{
+%The ``\code{q}'', as the first character of ``\code{qeunif}'',
+%may be changed to ``\code{e}'' in the future,
+%the reason being to emphasize that the expectiles are returned.
+%Ditto for the argument ``\code{q}'' in \code{peunif}.
+%
+%}
+
+\seealso{
+ \code{\link{deunif}},
+ \code{\link{denorm}},
+ \code{\link{dexp}}.
+
+}
+
+\examples{
+my_p = 0.25; y = rexp(nn <- 1000)
+(myexp = qeexp(my_p))
+sum(myexp - y[y <= myexp]) / sum(abs(myexp - y)) # Should be my_p
+
+\dontrun{ par(mfrow=c(2,1))
+yy = seq(-0, 4, len = nn)
+plot(yy, deexp(yy), col = "blue", ylim = 0:1, xlab = "y", ylab = "g(y)",
+ type = "l", main = "g(y) for Exp(1); dotted green is f(y) = dexp(y)")
+lines(yy, dexp(yy), col="darkgreen", lty="dotted", lwd=2) # 'original'
+
+plot(yy, peexp(yy), type = "l", col = "blue", ylim = 0:1,
+ xlab = "y", ylab = "G(y)", main = "G(y) for Exp(1)")
+abline(v = 1, h = 0.5, col = "red", lty = "dashed")
+lines(yy, pexp(yy), col = "darkgreen", lty = "dotted", lwd = 2) }
+}
+\keyword{distribution}
+
+%# Equivalently:
+%I1 = mean(y <= myexp) * mean( myexp - y[y <= myexp])
+%I2 = mean(y > myexp) * mean(-myexp + y[y > myexp])
+%I1 / (I1 + I2) # Should be my_p
+%# Or:
+%I1 = sum( myexp - y[y <= myexp])
+%I2 = sum(-myexp + y[y > myexp])
+
+
+%# Non-standard exponential
+%myrate = 8
+%yy = rexp(nn, rate=myrate)
+%(myexp = qeexp(my_p, rate=myrate))
+%sum(myexp - yy[yy <= myexp]) / sum(abs(myexp - yy)) # Should be my_p
+%peexp(-Inf, rate=myrate) # Should be 0
+%peexp( Inf, rate=myrate) # Should be 1
+%peexp(mean(yy), rate=myrate) # Should be 0.5
+%abs(qeexp(0.5, rate=myrate) - mean(yy)) # Should be 0
+%abs(peexp(myexp, rate=myrate) - my_p) # Should be 0
+%integrate(f = deexp, lower=-1, upper = Inf, rate=myrate) # Should be 1
+
+
+
+
+
+
+
+
diff --git a/man/enormUC.Rd b/man/enormUC.Rd
new file mode 100644
index 0000000..3283d27
--- /dev/null
+++ b/man/enormUC.Rd
@@ -0,0 +1,133 @@
+\name{Expectiles-Normal}
+\alias{Expectiles-Normal}
+\alias{enorm}
+\alias{denorm}
+\alias{penorm}
+\alias{qenorm}
+\alias{renorm}
+\title{ Expectiles of the Normal Distribution }
+\description{
+ Density function, distribution function, and
+ expectile function and random generation for the distribution
+ associated with the expectiles of a normal distribution.
+
+}
+\usage{
+denorm(x, mean = 0, sd = 1, log = FALSE)
+penorm(q, mean = 0, sd = 1, log = FALSE)
+qenorm(p, mean = 0, sd = 1, Maxit_nr = 10, Tol_nr = 1.0e-6)
+renorm(n, mean = 0, sd = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, p, q}{
+ See \code{\link{deunif}}.
+ }
+ \item{n, mean, sd, log}{See \code{\link[stats:Normal]{rnorm}}.}
+ \item{Maxit_nr, Tol_nr}{
+ See \code{\link{deunif}}.
+ }
+}
+\details{
+
+General details are given in \code{\link{deunif}}
+including
+a note regarding the terminology used.
+Here,
+\code{norm} corresponds to the distribution of interest, \eqn{F}, and
+\code{enorm} corresponds to \eqn{G}.
+The addition of ``\code{e}'' is for the `other'
+distribution associated with the parent distribution.
+Thus
+\code{denorm} is for \eqn{g},
+\code{penorm} is for \eqn{G},
+\code{qenorm} is for the inverse of \eqn{G},
+\code{renorm} generates random variates from \eqn{g}.
+
+
+For \code{qenorm} the Newton-Raphson algorithm is used to solve for
+\eqn{y} satisfying \eqn{p = G(y)}.
+Numerical problems may occur when values of \code{p} are
+very close to 0 or 1.
+
+}
+\value{
+ \code{denorm(x)} gives the density function \eqn{g(x)}.
+ \code{penorm(q)} gives the distribution function \eqn{G(q)}.
+ \code{qenorm(p)} gives the expectile function:
+ the value \eqn{y} such that \eqn{G(y)=p}.
+ \code{renorm(n)} gives \eqn{n} random variates from \eqn{G}.
+
+}
+
+%\references{
+%
+%Jones, M. C. (1994)
+%Expectiles and M-quantiles are quantiles.
+%\emph{Statistics and Probability Letters},
+%\bold{20}, 149--153.
+%
+%}
+\author{ T. W. Yee }
+
+%\note{
+%The ``\code{q}'', as the first character of ``\code{qeunif}'',
+%may be changed to ``\code{e}'' in the future,
+%the reason being to emphasize that the expectiles are returned.
+%Ditto for the argument ``\code{q}'' in \code{peunif}.
+%
+%}
+
+\seealso{
+ \code{\link{deunif}},
+ \code{\link{deexp}},
+ \code{\link{dnorm}},
+ \code{\link{amlnormal}},
+ \code{\link{lms.bcn}}.
+
+}
+
+\examples{
+my_p = 0.25; y = rnorm(nn <- 1000)
+(myexp = qenorm(my_p))
+sum(myexp - y[y <= myexp]) / sum(abs(myexp - y)) # Should be my_p
+
+# Non-standard normal
+mymean = 1; mysd = 2
+yy = rnorm(nn, mymean, mysd)
+(myexp = qenorm(my_p, mymean, mysd))
+sum(myexp - yy[yy <= myexp]) / sum(abs(myexp - yy)) # Should be my_p
+penorm(-Inf, mymean, mysd) # Should be 0
+penorm( Inf, mymean, mysd) # Should be 1
+penorm(mean(yy), mymean, mysd) # Should be 0.5
+abs(qenorm(0.5, mymean, mysd) - mean(yy)) # Should be 0
+abs(penorm(myexp, mymean, mysd) - my_p) # Should be 0
+integrate(f = denorm, lower=-Inf, upper = Inf,
+ mymean, mysd) # Should be 1
+
+\dontrun{
+par(mfrow = c(2, 1))
+yy = seq(-3, 3, len = nn)
+plot(yy, denorm(yy), type = "l", col="blue", xlab = "y", ylab = "g(y)",
+ main = "g(y) for N(0,1); dotted green is f(y) = dnorm(y)")
+lines(yy, dnorm(yy), col="darkgreen", lty="dotted", lwd=2) # 'original'
+
+plot(yy, penorm(yy), type = "l", col = "blue", ylim = 0:1,
+ xlab = "y", ylab = "G(y)", main = "G(y) for N(0,1)")
+abline(v = 0, h = 0.5, col = "red", lty = "dashed")
+lines(yy, pnorm(yy), col = "darkgreen", lty = "dotted", lwd = 2) }
+}
+\keyword{distribution}
+
+%# Equivalently:
+%I1 = mean(y <= myexp) * mean( myexp - y[y <= myexp])
+%I2 = mean(y > myexp) * mean(-myexp + y[y > myexp])
+%I1 / (I1 + I2) # Should be my_p
+%# Or:
+%I1 = sum( myexp - y[y <= myexp])
+%I2 = sum(-myexp + y[y > myexp])
+
+
+
+
+
diff --git a/man/erlang.Rd b/man/erlang.Rd
index 20ced3e..2b4a859 100644
--- a/man/erlang.Rd
+++ b/man/erlang.Rd
@@ -89,9 +89,9 @@ New York: Wiley-Interscience, Third edition.
rate = exp(2); myshape = 3
edata = data.frame(y = rep(0, nn <- 1000))
for(ii in 1:myshape)
- edata = transform(edata, y = y + rexp(nn, rate=rate))
-fit = vglm(y ~ 1, erlang(shape=myshape), edata, trace=TRUE)
-coef(fit, matrix=TRUE)
+ edata = transform(edata, y = y + rexp(nn, rate = rate))
+fit = vglm(y ~ 1, erlang(shape = myshape), edata, trace = TRUE)
+coef(fit, matrix = TRUE)
Coef(fit) # Answer = 1/rate
1/rate
summary(fit)
diff --git a/man/eunifUC.Rd b/man/eunifUC.Rd
new file mode 100644
index 0000000..ddc23e6
--- /dev/null
+++ b/man/eunifUC.Rd
@@ -0,0 +1,174 @@
+\name{Expectiles-Uniform}
+\alias{Expectiles-Uniform}
+\alias{eunif}
+\alias{deunif}
+\alias{peunif}
+\alias{qeunif}
+\alias{reunif}
+\title{ Expectiles of the Uniform Distribution }
+\description{
+ Density function, distribution function, and
+ expectile function and random generation for the distribution
+ associated with the expectiles of a uniform distribution.
+
+}
+\usage{
+deunif(x, min = 0, max = 1, log = FALSE)
+peunif(q, min = 0, max = 1, log = FALSE)
+qeunif(p, min = 0, max = 1, Maxit_nr = 10, Tol_nr = 1.0e-6)
+reunif(n, min = 0, max = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, q}{
+ Vector of expectiles.
+ See the terminology note below.
+ }
+ \item{p}{
+ Vector of probabilities. % (tau or \eqn{\tau}).
+ These should lie in \eqn{(0,1)}.
+ }
+ \item{n, min, max, log}{See \code{\link[stats:Uniform]{runif}}.}
+ \item{Maxit_nr}{
+ Numeric.
+ Maximum number of Newton-Raphson iterations allowed.
+ A warning is issued if convergence is not obtained for all \code{p}
+ values.
+ }
+ \item{Tol_nr}{
+ Numeric.
+ Small positive value specifying the tolerance or precision to which
+ the expectiles are computed.
+ }
+}
+\details{
+
+Jones (1994) elucidated on the property that the expectiles
+of a random variable \eqn{X} with distribution function \eqn{F(x)}
+correspond to the
+quantiles of a distribution \eqn{G(x)} where
+\eqn{G} is related by an explicit formula to \eqn{F}.
+In particular, let \eqn{y} be the \eqn{p}-expectile of \eqn{F}.
+Then \eqn{y} is the \eqn{p}-quantile of \eqn{G}
+where
+\deqn{p = G(y) = (P(y) - y F(y)) / (2[P(y) - y F(y)] + y - \mu),}{
+ p = G(y) = (P(y) - y F(y)) / (2[P(y) - y F(y)] + y - mu),}
+and
+\eqn{\mu}{mu} is the mean of \eqn{X}.
+The derivative of \eqn{G} is
+\deqn{g(y) = (\mu F(y) - P(y)) / (2[P(y) - y F(y)] + y - \mu)^2 .}{
+ g(y) = ( mu F(y) - P(y)) / (2[P(y) - y F(y)] + y - mu)^2 .}
+Here, \eqn{P(y)} is the partial moment
+\eqn{\int_{-\infty}^{y} x f(x) \, dx}{int^{y} x f(x) dx}
+and
+\eqn{0 < p < 1}.
+The 0.5-expectile is the mean \eqn{\mu}{mu} and
+the 0.5-quantile is the median.
+
+
+A note about the terminology used here.
+Recall in the \emph{S} language there are the \code{dpqr}-type functions
+associated with a distribution, e.g.,
+\code{\link[stats:Uniform]{dunif}},
+\code{\link[stats:Uniform]{punif}},
+\code{\link[stats:Uniform]{qunif}},
+\code{\link[stats:Uniform]{runif}},
+for the uniform distribution.
+Here,
+\code{unif} corresponds to \eqn{F} and
+\code{eunif} corresponds to \eqn{G}.
+The addition of ``\code{e}'' (for \emph{expectile}) is for the `other'
+distribution associated with the parent distribution.
+Thus
+\code{deunif} is for \eqn{g},
+\code{peunif} is for \eqn{G},
+\code{qeunif} is for the inverse of \eqn{G},
+\code{reunif} generates random variates from \eqn{g}.
+
+
+For \code{qeunif} the Newton-Raphson algorithm is used to solve for
+\eqn{y} satisfying \eqn{p = G(y)}.
+Numerical problems may occur when values of \code{p} are
+very close to 0 or 1.
+
+}
+\value{
+ \code{deunif(x)} gives the density function \eqn{g(x)}.
+ \code{peunif(q)} gives the distribution function \eqn{G(q)}.
+ \code{qeunif(p)} gives the expectile function:
+ the expectile \eqn{y} such that \eqn{G(y) = p}.
+ \code{reunif(n)} gives \eqn{n} random variates from \eqn{G}.
+
+}
+\references{
+
+Jones, M. C. (1994)
+Expectiles and M-quantiles are quantiles.
+\emph{Statistics and Probability Letters},
+\bold{20}, 149--153.
+
+
+Yee, T. W. (2010)
+Vector generalized linear and additive
+quantile and expectile regression.
+\emph{In preparation}.
+
+
+
+}
+\author{ T. W. Yee }
+
+%\note{
+%The ``\code{q}'', as the first character of ``\code{qeunif}'',
+%may be changed to ``\code{e}'' in the future,
+%the reason being to emphasize that the expectiles are returned.
+%Ditto for the argument ``\code{q}'' in \code{peunif}.
+%
+%}
+
+\seealso{
+ \code{\link{deexp}},
+ \code{\link{denorm}},
+ \code{\link{dunif}}.
+
+}
+
+\examples{
+my_p = 0.25; y = runif(nn <- 1000)
+(myexp = qeunif(my_p))
+sum(myexp - y[y <= myexp]) / sum(abs(myexp - y)) # Should be my_p
+# Equivalently:
+I1 = mean(y <= myexp) * mean( myexp - y[y <= myexp])
+I2 = mean(y > myexp) * mean(-myexp + y[y > myexp])
+I1 / (I1 + I2) # Should be my_p
+# Or:
+I1 = sum( myexp - y[y <= myexp])
+I2 = sum(-myexp + y[y > myexp])
+
+# Non-standard uniform
+mymin = 1; mymax = 8
+yy = runif(nn, mymin, mymax)
+(myexp = qeunif(my_p, mymin, mymax))
+sum(myexp - yy[yy <= myexp]) / sum(abs(myexp - yy)) # Should be my_p
+peunif(mymin, mymin, mymax) # Should be 0
+peunif(mymax, mymin, mymax) # Should be 1
+peunif(mean(yy), mymin, mymax) # Should be 0.5
+abs(qeunif(0.5, mymin, mymax) - mean(yy)) # Should be 0
+abs(qeunif(0.5, mymin, mymax) - (mymin+mymax)/2) # Should be 0
+abs(peunif(myexp, mymin, mymax) - my_p) # Should be 0
+integrate(f = deunif, lower=mymin - 3, upper = mymax + 3,
+ min=mymin, max=mymax) # Should be 1
+
+\dontrun{
+par(mfrow=c(2,1))
+yy = seq(0.0, 1.0, len=nn)
+plot(yy, deunif(yy), type="l", col="blue", ylim = c(0, 2),
+ xlab = "y", ylab = "g(y)", main = "g(y) for Uniform(0,1)")
+lines(yy, dunif(yy), col="darkgreen", lty="dotted", lwd=2) # 'original'
+
+plot(yy, peunif(yy), type="l", col="blue", ylim = 0:1,
+ xlab = "y", ylab = "G(y)", main = "G(y) for Uniform(0,1)")
+abline(a=0.0, b=1.0, col="darkgreen", lty="dotted", lwd=2)
+abline(v=0.5, h=0.5, col="red", lty="dashed") }
+}
+\keyword{distribution}
diff --git a/man/expexp.Rd b/man/expexp.Rd
index f11fe48..4aac939 100644
--- a/man/expexp.Rd
+++ b/man/expexp.Rd
@@ -8,7 +8,7 @@
}
\usage{
-expexp(lshape = "loge", lscale = "loge", eshape=list(), escale=list(),
+expexp(lshape = "loge", lscale = "loge", eshape = list(), escale = list(),
ishape = 1.1, iscale = NULL, tolerance = 1.0e-6, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -125,12 +125,14 @@ expexp(lshape = "loge", lscale = "loge", eshape=list(), escale=list(),
\seealso{
\code{\link{expexp1}},
\code{\link{gamma2.ab}},
- \code{\link{weibull}}.
+ \code{\link{weibull}},
+ \code{\link{CommonVGAMffArguments}}.
+
}
\examples{
# A special case: exponential data
y = rexp(n <- 1000)
-fit = vglm(y ~ 1, fam=expexp, trace=TRUE, maxit=99)
+fit = vglm(y ~ 1, fam = expexp, trace = TRUE, maxit = 99)
coef(fit, matrix=TRUE)
Coef(fit)
@@ -140,9 +142,9 @@ bbearings = c(17.88, 28.92, 33.00, 41.52, 42.12, 45.60,
48.80, 51.84, 51.96, 54.12, 55.56, 67.80, 68.64, 68.64,
68.88, 84.12, 93.12, 98.64, 105.12, 105.84, 127.92,
128.04, 173.40)
-fit = vglm(bbearings ~ 1, fam=expexp(iscale=0.05, ish=5),
- trace=TRUE, maxit=300)
-coef(fit, matrix=TRUE)
+fit = vglm(bbearings ~ 1, fam = expexp(iscale = 0.05, ish = 5),
+ trace = TRUE, maxit = 300)
+coef(fit, matrix = TRUE)
Coef(fit) # Authors get c(shape=5.2589, scale=0.0314)
logLik(fit) # Authors get -112.9763
@@ -151,9 +153,9 @@ logLik(fit) # Authors get -112.9763
acplane = c(23, 261, 87, 7, 120, 14, 62, 47,
225, 71, 246, 21, 42, 20, 5, 12, 120, 11, 3, 14,
71, 11, 14, 11, 16, 90, 1, 16, 52, 95)
-fit = vglm(acplane ~ 1, fam=expexp(ishape=0.8, isc=0.15),
- trace=TRUE, maxit=99)
-coef(fit, matrix=TRUE)
+fit = vglm(acplane ~ 1, fam = expexp(ishape = 0.8, isc = 0.15),
+ trace = TRUE, maxit = 99)
+coef(fit, matrix = TRUE)
Coef(fit) # Authors get c(shape=0.8130, scale=0.0145)
logLik(fit) # Authors get log-lik -152.264
}
diff --git a/man/expexp1.Rd b/man/expexp1.Rd
index 0bf7692..6efb6ad 100644
--- a/man/expexp1.Rd
+++ b/man/expexp1.Rd
@@ -8,7 +8,7 @@
}
\usage{
-expexp1(lscale = "loge", escale=list(), iscale = NULL, ishape = 1)
+expexp1(lscale = "loge", escale = list(), iscale = NULL, ishape = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -83,7 +83,9 @@ expexp1(lscale = "loge", escale=list(), iscale = NULL, ishape = 1)
}
\seealso{
- \code{\link{expexp}}.
+ \code{\link{expexp}},
+ \code{\link{CommonVGAMffArguments}}.
+
}
\examples{
# Ball bearings data (number of million revolutions before failure)
@@ -91,9 +93,9 @@ bbearings = data.frame(y = c(17.88, 28.92, 33.00, 41.52, 42.12, 45.60,
48.80, 51.84, 51.96, 54.12, 55.56, 67.80, 68.64, 68.64,
68.88, 84.12, 93.12, 98.64, 105.12, 105.84, 127.92,
128.04, 173.40))
-fit = vglm(y ~ 1, expexp1(ishape=4), bbearings, trace=TRUE,
- maxit=50, checkwz=FALSE)
-coef(fit, matrix=TRUE)
+fit = vglm(y ~ 1, expexp1(ishape = 4), bbearings, trace = TRUE,
+ maxit = 50, checkwz = FALSE)
+coef(fit, matrix = TRUE)
Coef(fit) # Authors get c(0.0314, 5.2589) with log-lik -112.9763
fit at misc$shape # Estimate of shape
logLik(fit)
@@ -103,9 +105,9 @@ logLik(fit)
acplane = data.frame(y = c(23, 261, 87, 7, 120, 14, 62, 47,
225, 71, 246, 21, 42, 20, 5, 12, 120, 11, 3, 14,
71, 11, 14, 11, 16, 90, 1, 16, 52, 95))
-fit = vglm(y ~ 1, expexp1(ishape=0.8), acplane, trace=TRUE,
- maxit=50, checkwz=FALSE)
-coef(fit, matrix=TRUE)
+fit = vglm(y ~ 1, expexp1(ishape = 0.8), acplane, trace = TRUE,
+ maxit = 50, checkwz = FALSE)
+coef(fit, matrix = TRUE)
Coef(fit) # Authors get c(0.0145, 0.8130) with log-lik -152.264
fit at misc$shape # Estimate of shape
logLik(fit)
diff --git a/man/fisk.Rd b/man/fisk.Rd
index 5bd85a9..43ab98d 100644
--- a/man/fisk.Rd
+++ b/man/fisk.Rd
@@ -5,6 +5,7 @@
\description{
Maximum likelihood estimation of the 2-parameter
Fisk distribution.
+
}
\usage{
fisk(link.a = "loge", link.scale = "loge", earg.a=list(),
@@ -43,6 +44,7 @@ fisk(link.a = "loge", link.scale = "loge", earg.a=list(),
Dagum distribution with \eqn{p=1}.
More details can be found in Kleiber and Kotz (2003).
+
The Fisk distribution has density
\deqn{f(y) = a y^{a-1} / [b^a \{1 + (y/b)^a\}^2]}{%
f(y) = a y^(a-1) / [b^a (1 + (y/b)^a)^2]}
@@ -57,11 +59,13 @@ The mean is
E(Y) = b gamma(1 + 1/a) gamma(1 - 1/a)}
provided \eqn{a > 1}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
Kleiber, C. and Kotz, S. (2003)
@@ -89,6 +93,7 @@ Hoboken, NJ: Wiley-Interscience.
\code{\link{lomax}},
\code{\link{paralogistic}},
\code{\link{invparalogistic}}.
+
}
\examples{
diff --git a/man/fitted.vlm.Rd b/man/fitted.vlm.Rd
index cc480e2..6580da6 100644
--- a/man/fitted.vlm.Rd
+++ b/man/fitted.vlm.Rd
@@ -59,20 +59,16 @@ Chambers, J. M. and T. J. Hastie (eds) (1992)
}
\examples{
# Categorical regression example 1
-pneumo = transform(pneumo, let=log(exposure.time))
-fit = vglm(cbind(normal, mild, severe) ~ let,
- cumulative(parallel=TRUE, reverse=TRUE), pneumo)
-fit
+pneumo = transform(pneumo, let = log(exposure.time))
+(fit = vglm(cbind(normal, mild, severe) ~ let, propodds, pneumo))
fitted(fit)
-
# LMS quantile regression example 2
-fit = vgam(BMI ~ s(age, df=c(4,2)),
- fam=lms.bcn(zero=1), data=bminz, trace=TRUE)
-# The following are equal
-head(predict(fit, type="r"))
+fit = vgam(BMI ~ s(age, df = c(4,2)),
+ fam = lms.bcn(zero = 1), data = bminz, trace = TRUE)
+head(predict(fit, type = "r")) # The following three are equal
head(fitted(fit))
-predict(fit, type="r", newdata=head(bminz))
+predict(fit, type = "r", newdata = head(bminz))
}
\keyword{models}
\keyword{regression}
diff --git a/man/frechet.Rd b/man/frechet.Rd
index 99570d5..ded3741 100644
--- a/man/frechet.Rd
+++ b/man/frechet.Rd
@@ -93,6 +93,7 @@ frechet3(anchor=NULL, ldifference="loge", lscale="loge", lshape="loglog",
\eqn{b^2 [ \Gamma(1-2/s) - \Gamma^2(1-1/s)]}{b^2 * [gamma(1-2/s) - gamma(1-1/s)^2]}
for \eqn{s>2}.
+
\code{frechet2} has \eqn{a} known whereas \code{frechet3}
estimates it. Estimating \eqn{a} well requires a lot of data and
a good choice of \code{ilocation} will help speed up convergence.
@@ -109,6 +110,7 @@ frechet3(anchor=NULL, ldifference="loge", lscale="loge", lshape="loglog",
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
\references{
Castillo, E., Hadi, A. S., Balakrishnan, N. Sarabia, J. S. (2005)
@@ -131,13 +133,16 @@ Hoboken, N.J.: Wiley-Interscience.
therefore treated with caution; these are computed in functions such
as \code{vcov()} and \code{summary()}.
+
If \code{fit} is a \code{frechet3} fit then \code{fit at extra$location}
is the final estimate of the location parameter, and
\code{fit at extra$LHSanchor} is the anchor point.
+
}
\seealso{
\code{\link{rfrechet}}.
+
}
\examples{
y = rfrechet(n <- 1000, shape=exp(exp(0)))
diff --git a/man/freund61.Rd b/man/freund61.Rd
index dd90243..b2b862b 100644
--- a/man/freund61.Rd
+++ b/man/freund61.Rd
@@ -60,6 +60,7 @@ freund61(la="loge", lap="loge", lb="loge", lbp="loge", ia=NULL, iap=NULL,
of the \eqn{B} component from \eqn{\beta}{beta} to
\eqn{\beta'}{beta'}.
+
The joint probability density function is given by
\deqn{f(y_1,y_2) = \alpha \beta' \exp(-\beta' y_2 -
(\alpha+\beta-\beta')y_1) }{%
@@ -87,6 +88,7 @@ freund61(la="loge", lap="loge", lb="loge", lbp="loge", ia=NULL, iap=NULL,
and \eqn{\alpha/(\alpha+\beta)}{alpha/(alpha+beta)}
respectively.
+
The marginal distributions are, in general, not exponential.
By default, the linear/additive predictors are
\eqn{\eta_1=\log(\alpha)}{eta1=log(alpha)},
@@ -94,6 +96,7 @@ freund61(la="loge", lap="loge", lb="loge", lbp="loge", ia=NULL, iap=NULL,
\eqn{\eta_3=\log(\beta)}{eta3=log(beta)},
\eqn{\eta_4=\log(\beta')}{eta4=log(beta')}.
+
A special case is when \eqn{\alpha=\alpha'}{alpha=alpha'}
and \eqn{\beta=\beta'}{beta'=beta'}, which means that
\eqn{y_1}{y1} and \eqn{y_2}{y2} are independent, and
@@ -101,6 +104,7 @@ freund61(la="loge", lap="loge", lb="loge", lbp="loge", ia=NULL, iap=NULL,
\eqn{1 / \alpha}{1/alpha} and \eqn{1 / \beta}{1/beta}
respectively.
+
Fisher scoring is used,
and the initial values correspond to the MLEs of an intercept model.
Consequently, convergence may take only one iteration.
diff --git a/man/gamma2.Rd b/man/gamma2.Rd
index 4d37ed6..7d125bd 100644
--- a/man/gamma2.Rd
+++ b/man/gamma2.Rd
@@ -139,7 +139,7 @@ McCullagh, P. and Nelder, J. A. (1989)
\code{\link{gamma1}} for the 1-parameter gamma distribution,
\code{\link{gamma2.ab}} for another parameterization of
the 2-parameter gamma distribution,
- \code{\link{mckaygamma2}} for \emph{a} bivariate gamma distribution,
+ \code{\link{bivgamma.mckay}} for \emph{a} bivariate gamma distribution,
\code{\link{expexp}},
\code{\link[stats]{GammaDist}},
\code{\link{golf}}.
diff --git a/man/gamma2.ab.Rd b/man/gamma2.ab.Rd
index 98f095c..a06b22a 100644
--- a/man/gamma2.ab.Rd
+++ b/man/gamma2.ab.Rd
@@ -96,7 +96,7 @@ gamma2.ab(lrate = "loge", lshape = "loge", erate=list(), eshape=list(),
\code{\link{gamma1}} for the 1-parameter gamma distribution,
\code{\link{gamma2}} for another parameterization of
the 2-parameter gamma distribution,
- \code{\link{mckaygamma2}} for \emph{a} bivariate gamma distribution,
+ \code{\link{bivgamma.mckay}} for \emph{a} bivariate gamma distribution,
\code{\link{expexp}}.
}
diff --git a/man/ggamma.Rd b/man/gengamma.Rd
similarity index 87%
rename from man/ggamma.Rd
rename to man/gengamma.Rd
index 8518ee0..16d4a6f 100644
--- a/man/ggamma.Rd
+++ b/man/gengamma.Rd
@@ -1,5 +1,5 @@
-\name{ggamma}
-\alias{ggamma}
+\name{gengamma}
+\alias{gengamma}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Generalized Gamma distribution family function }
\description{
@@ -8,7 +8,7 @@
}
\usage{
-ggamma(lscale="loge", ld="loge", lk="loge",
+gengamma(lscale="loge", ld="loge", lk="loge",
escale=list(), ed=list(), ek=list(),
iscale=NULL, id=NULL, ik=NULL, zero=NULL)
}
@@ -46,6 +46,7 @@ ggamma(lscale="loge", ld="loge", lk="loge",
and \eqn{y > 0}.
The mean of \eqn{Y} is \eqn{bk}{b*k} (returned as the fitted values).
+
There are many special cases, as given in Table 1 of Stacey and Mihram (1965).
In the following, the parameters are in the order \eqn{b,d,k}.
The special cases are:
@@ -59,6 +60,7 @@ Circular normal \eqn{f(y;\sqrt{2},2,1)}{f(y;sqrt(2),2,1)},
Spherical normal \eqn{f(y;\sqrt{2},2,3/2)}{f(y;sqrt(2),2,3/2)},
Rayleigh \eqn{f(y;c\sqrt{2},2,1)}{f(y;c sqrt(2),2,1)} where \eqn{c>0}.
+
}
\value{
@@ -72,14 +74,17 @@ Rayleigh \eqn{f(y;c\sqrt{2},2,1)}{f(y;c sqrt(2),2,1)} where \eqn{c>0}.
A generalization of the gamma distribution.
\emph{Annals of Mathematical Statistics}, \bold{33}, 1187--1192.
+
Stacy, E. W. and Mihram, G. A. (1965)
Parameter estimation for a generalized gamma distribution.
\emph{Technometrics}, \bold{7}, 349--358.
+
Prentice, R. L. (1974)
A log gamma model and its maximum likelihood estimation.
\emph{Biometrika}, \bold{61}, 539--544.
+
}
\section{Warning }{
Several authors have considered maximum likelihood estimation for the
@@ -95,6 +100,7 @@ Rayleigh \eqn{f(y;c\sqrt{2},2,1)}{f(y;c sqrt(2),2,1)} where \eqn{c>0}.
With covariates, even more observations are needed to increase the
chances of convergence.
+
}
\author{ T. W. Yee }
\note{
@@ -104,9 +110,10 @@ Rayleigh \eqn{f(y;c\sqrt{2},2,1)}{f(y;c sqrt(2),2,1)} where \eqn{c>0}.
try using the \code{zero} argument (e.g., \code{zero=2:3})
or the \code{ik} argument.
+
}
\seealso{
- \code{\link{rggamma}},
+ \code{\link{rgengamma}},
\code{\link{gamma1}},
\code{\link{gamma2}},
\code{\link{prentice74}}.
@@ -114,17 +121,18 @@ Rayleigh \eqn{f(y;c\sqrt{2},2,1)}{f(y;c sqrt(2),2,1)} where \eqn{c>0}.
}
\examples{
k = exp(-1); Scale = exp(1)
-gdata = data.frame(y = rgamma(n=1000, shape=k, scale=Scale))
-fit = vglm(y ~ 1, ggamma, gdata, trace=TRUE)
-coef(fit, matrix=TRUE)
+gdata = data.frame(y = rgamma(1000, shape = k, scale = Scale))
+fit = vglm(y ~ 1, gengamma, gdata, trace = TRUE)
+coef(fit, matrix = TRUE)
# Another example
gdata = data.frame(x = runif(nn <- 5000))
-gdata = transform(gdata, Scale = exp(1), d = exp(0 + 1.2*x), k = exp(-1 + 2*x))
-gdata = transform(gdata, y = rggamma(nn, scale=Scale, d=d, k=k))
-fit = vglm(y ~ x, ggamma(zero=1, iscal=6), gdata, trace=TRUE)
-fit = vglm(y ~ x, ggamma(zero=1), gdata, trace=TRUE, maxit=50)
-coef(fit, matrix=TRUE)
+gdata = transform(gdata, Scale = exp(1), d = exp(0 + 1.2*x),
+ k = exp(-1 + 2*x))
+gdata = transform(gdata, y = rgengamma(nn, scale = Scale, d = d, k = k))
+fit = vglm(y ~ x, gengamma(zero = 1, iscal = 6), gdata, trace = TRUE)
+fit = vglm(y ~ x, gengamma(zero = 1), gdata, trace = TRUE, maxit = 50)
+coef(fit, matrix = TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/gengammaUC.Rd b/man/gengammaUC.Rd
new file mode 100644
index 0000000..6e93fdd
--- /dev/null
+++ b/man/gengammaUC.Rd
@@ -0,0 +1,76 @@
+\name{gengammaUC}
+\alias{gengammaUC}
+\alias{dgengamma}
+\alias{pgengamma}
+\alias{qgengamma}
+\alias{rgengamma}
+\title{The Generalized Gamma Distribution }
+\description{
+ Density, distribution function, quantile function and random
+ generation for the generalized gamma distribution with
+ scale parameter \code{scale},
+ and parameters \code{d} and \code{k}.
+
+}
+\usage{
+dgengamma(x, scale = 1, d = 1, k = 1, log = FALSE)
+pgengamma(q, scale = 1, d = 1, k = 1)
+qgengamma(p, scale = 1, d = 1, k = 1)
+rgengamma(n, scale = 1, d = 1, k = 1)
+}
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{p}{vector of probabilities.}
+ \item{n}{number of observations. Positive integer of length 1.}
+ \item{scale}{the (positive) scale parameter \eqn{b}.}
+ \item{d, k}{the (positive) parameters \eqn{d} and \eqn{k}.}
+ \item{log}{
+ Logical.
+ If \code{log = TRUE} then the logarithm of the density is returned.
+
+ }
+
+}
+\value{
+ \code{dgengamma} gives the density,
+ \code{pgengamma} gives the distribution function,
+ \code{qgengamma} gives the quantile function, and
+ \code{rgengamma} generates random deviates.
+}
+\references{
+Stacy, E. W. and Mihram, G. A. (1965)
+Parameter estimation for a generalized gamma distribution.
+\emph{Technometrics}, \bold{7}, 349--358.
+
+}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{gengamma}}, the \pkg{VGAM} family function
+ for estimating the generalized gamma distribution
+ by maximum likelihood estimation,
+ for formulae and other details.
+ Apart from \code{n}, all the above arguments may be vectors and
+ are recyled to the appropriate length if necessary.
+
+}
+% \note{
+% }
+\seealso{
+ \code{\link{gengamma}}.
+
+}
+\examples{
+\dontrun{ x = seq(0, 14, by = 0.01); d = 1.5; Scale = 2; k = 6
+plot(x, dgengamma(x, Scale, d, k), type = "l", col = "blue", ylim = 0:1,
+ main = "Blue is density, red is cumulative distribution function",
+ sub = "Purple are 5,10,...,95 percentiles", las = 1, ylab = "")
+abline(h = 0, col = "blue", lty = 2)
+lines(qgengamma(seq(0.05,0.95,by = 0.05), Scale, d, k),
+ dgengamma(qgengamma(seq(0.05,0.95,by = 0.05), Scale, d, k),
+ Scale, d, k), col = "purple", lty = 3, type = "h")
+lines(x, pgengamma(x, Scale, d, k), type = "l", col = "red")
+abline(h = 0, lty = 2) }
+}
+\keyword{distribution}
+
+
diff --git a/man/ggammaUC.Rd b/man/ggammaUC.Rd
deleted file mode 100644
index 85e1307..0000000
--- a/man/ggammaUC.Rd
+++ /dev/null
@@ -1,74 +0,0 @@
-\name{ggammaUC}
-\alias{ggammaUC}
-\alias{dggamma}
-\alias{pggamma}
-\alias{qggamma}
-\alias{rggamma}
-\title{The Generalized Gamma Distribution }
-\description{
- Density, distribution function, quantile function and random
- generation for the generalized gamma distribution with
- scale parameter \code{scale},
- and parameters \code{d} and \code{k}.
-}
-\usage{
-dggamma(x, scale=1, d=1, k=1, log=FALSE)
-pggamma(q, scale=1, d=1, k=1)
-qggamma(p, scale=1, d=1, k=1)
-rggamma(n, scale=1, d=1, k=1)
-}
-\arguments{
- \item{x, q}{vector of quantiles.}
- \item{p}{vector of probabilities.}
- \item{n}{number of observations. Positive integer of length 1.}
- \item{scale}{the (positive) scale parameter \eqn{b}.}
- \item{d, k}{the (positive) parameters \eqn{d} and \eqn{k}.}
- \item{log}{
- Logical.
- If \code{log=TRUE} then the logarithm of the density is returned.
-
- }
-
-}
-\value{
- \code{dggamma} gives the density,
- \code{pggamma} gives the distribution function,
- \code{qggamma} gives the quantile function, and
- \code{rggamma} generates random deviates.
-}
-\references{
-Stacy, E. W. and Mihram, G. A. (1965)
-Parameter estimation for a generalized gamma distribution.
-\emph{Technometrics}, \bold{7}, 349--358.
-}
-\author{ T. W. Yee }
-\details{
- See \code{\link{ggamma}}, the \pkg{VGAM} family function
- for estimating the generalized gamma distribution
- by maximum likelihood estimation,
- for formulae and other details.
- Apart from \code{n}, all the above arguments may be vectors and
- are recyled to the appropriate length if necessary.
-}
-% \note{
-% }
-\seealso{
- \code{\link{ggamma}}.
-}
-\examples{
-\dontrun{
-x=seq(0, 14, by=0.01); d=1.5; Scale=2; k=6
-plot(x, dggamma(x, Scale, d, k), type="l", col="blue", ylim=c(0,1),
- main="Blue is density, red is cumulative distribution function",
- sub="Purple are 5,10,...,95 percentiles", las=1, ylab="")
-abline(h=0, col="blue", lty=2)
-lines(qggamma(seq(0.05,0.95,by=0.05), Scale, d, k),
- dggamma(qggamma(seq(0.05,0.95,by=0.05), Scale, d, k), Scale, d, k),
- col="purple", lty=3, type="h")
-lines(x, pggamma(x, Scale, d, k), type="l", col="red")
-abline(h=0, lty=2)
-}
-}
-\keyword{distribution}
-
-
diff --git a/man/gpd.Rd b/man/gpd.Rd
index dbbc92e..7887134 100644
--- a/man/gpd.Rd
+++ b/man/gpd.Rd
@@ -9,10 +9,10 @@
}
\usage{
gpd(threshold = 0, lscale = "loge", lshape = "logoff", escale = list(),
- eshape = if (lshape == "logoff") list(offset=0.5) else
- if (lshape == "elogit") list(min=-0.5, max=0.5) else NULL,
+ eshape = if (lshape == "logoff") list(offset = 0.5) else
+ if (lshape == "elogit") list(min = -0.5, max = 0.5) else NULL,
percentiles = c(90, 95), iscale = NULL, ishape = NULL,
- tolshape0=0.001, giveWarning=TRUE, method.init=1, zero=2)
+ tolshape0 = 0.001, giveWarning = TRUE, method.init = 1, zero = 2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -61,7 +61,7 @@ gpd(threshold = 0, lscale = "loge", lshape = "logoff", escale = list(),
Numeric vector of percentiles used
for the fitted values. Values should be between 0 and 100.
See the example below for illustration.
- However, if \code{percentiles=NULL} then the mean
+ However, if \code{percentiles = NULL} then the mean
\eqn{\mu + \sigma / (1-\xi)}{mu + sigma / (1-xi)} is returned;
this is only defined if \eqn{\xi<1}{xi<1}.
@@ -135,11 +135,14 @@ gpd(threshold = 0, lscale = "loge", lshape = "logoff", escale = list(),
and
\eqn{\mu < y <\mu-\sigma / \xi}{mu < y <mu-sigma / xi} for \eqn{\xi<0}{xi<0}.
- Smith (1985) showed that if \eqn{\xi <= -0.5}{xi <= -0.5} then this
- is known as the nonregular case and problems/difficulties can arise
- both theoretically and numerically. For the (regular) case \eqn{\xi >
- -0.5}{xi > -0.5} the classical asymptotic theory of maximum likelihood
- estimators is applicable; this is the default.
+
+ Smith (1985) showed that if \eqn{\xi <= -0.5}{xi <= -0.5} then
+ this is known as the nonregular case and problems/difficulties
+ can arise both theoretically and numerically. For the (regular)
+ case \eqn{\xi > -0.5}{xi > -0.5} the classical asymptotic
+ theory of maximum likelihood estimators is applicable; this is
+ the default.
+
Although for \eqn{\xi < -0.5}{xi < -0.5} the usual asymptotic properties
do not apply, the maximum likelihood estimator generally exists and
@@ -149,9 +152,11 @@ gpd(threshold = 0, lscale = "loge", lshape = "logoff", escale = list(),
likelihood estimator generally does not exist as it effectively becomes
a two parameter problem.
+
The mean of \eqn{Y} does not exist unless \eqn{\xi < 1}{xi < 1}, and
the variance does not exist unless \eqn{\xi < 0.5}{xi < 0.5}. So if
- you want to fit a model with finite variance use \code{lshape="elogit"}.
+ you want to fit a model with finite variance use \code{lshape = "elogit"}.
+
}
\note{
@@ -159,10 +164,12 @@ gpd(threshold = 0, lscale = "loge", lshape = "logoff", escale = list(),
and \code{\link{vgam}} is \eqn{y}.
Internally, \eqn{y-\mu}{y-mu} is computed.
+
With functions \code{\link{rgpd}}, \code{\link{dgpd}}, etc., the
argument \code{location} matches with the argument \code{threshold}
here.
+
}
\section{Warning}{
Fitting the GPD by maximum likelihood estimation can be numerically
@@ -189,14 +196,17 @@ gpd(threshold = 0, lscale = "loge", lshape = "logoff", escale = list(),
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.
+
Smith, R. L. (1985)
Maximum likelihood estimation in a class of nonregular cases.
\emph{Biometrika}, \bold{72}, 67--90.
+
}
\author{ T. W. Yee }
diff --git a/man/hypersecant.Rd b/man/hypersecant.Rd
index 307ea1b..c9187f1 100644
--- a/man/hypersecant.Rd
+++ b/man/hypersecant.Rd
@@ -9,10 +9,10 @@
}
\usage{
-hypersecant(link.theta="elogit", earg=if(link.theta=="elogit")
- list(min=-pi/2, max=pi/2) else list(), init.theta=NULL)
-hypersecant.1(link.theta="elogit", earg=if(link.theta=="elogit")
- list(min=-pi/2, max=pi/2) else list(), init.theta=NULL)
+hypersecant(link.theta = "elogit", earg = if(link.theta == "elogit")
+ list(min = -pi/2, max = pi/2) else list(), init.theta = NULL)
+hypersecant.1(link.theta = "elogit", earg = if(link.theta == "elogit")
+ list(min = -pi/2, max = pi/2) else list(), init.theta = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -80,15 +80,15 @@ hypersecant.1(link.theta="elogit", earg=if(link.theta=="elogit")
\code{\link{elogit}}.
}
\examples{
-x = rnorm(n <- 200)
-y = rnorm(n) # Not very good data!
-fit = vglm(y ~ x, hypersecant, trace=TRUE, crit="c")
-coef(fit, matrix=TRUE)
+hdata = data.frame(x = rnorm(nn <- 200))
+hdata = transform(hdata, y = rnorm(nn)) # Not very good data!
+fit = vglm(y ~ x, hypersecant, hdata, trace = TRUE, crit = "coef")
+coef(fit, matrix = TRUE)
fit at misc$earg
-# Not recommended
-fit = vglm(y ~ x, hypersecant(link="identity"), trace=TRUE, crit="c")
-coef(fit, matrix=TRUE)
+# Not recommended:
+fit = vglm(y ~ x, hypersecant(link = "identity"), hdata, trace = TRUE)
+coef(fit, matrix = TRUE)
fit at misc$earg
}
\keyword{models}
diff --git a/man/invbinomial.Rd b/man/invbinomial.Rd
index 95af19f..ee27483 100644
--- a/man/invbinomial.Rd
+++ b/man/invbinomial.Rd
@@ -86,6 +86,7 @@ intercept-only models.
Good initial values are needed; if convergence failure occurs use
\code{irho} and/or \code{ilambda}.
+
Some elements of the working weight matrices use the expected
information matrix while other elements use the observed
information matrix.
@@ -100,9 +101,9 @@ results in a EIM that is diagonal.
}
\examples{
-y <- rnbinom(n <- 1000, mu=exp(3), size=exp(1))
-fit <- vglm(y ~ 1, invbinomial, trace=TRUE)
-c(mean(y), head(fitted(fit)))
+idata = data.frame(y = rnbinom(n <- 1000, mu=exp(3), size=exp(1)))
+fit <- vglm(y ~ 1, invbinomial, idata, trace=TRUE)
+with(idata, c(mean(y), head(fitted(fit), 1)))
summary(fit)
coef(fit, matrix=TRUE)
Coef(fit)
diff --git a/man/invlomax.Rd b/man/invlomax.Rd
index 8abe52c..9807fc8 100644
--- a/man/invlomax.Rd
+++ b/man/invlomax.Rd
@@ -45,6 +45,7 @@ invlomax(link.scale = "loge", link.p = "loge",
beta distribution of the second kind with \eqn{q=1}.
More details can be found in Kleiber and Kotz (2003).
+
The inverse Lomax distribution has density
\deqn{f(y) = p y^{p-1} / [b^p \{1 + y/b\}^{p+1}]}{%
f(y) = p y^(p-1) / [b^p (1 + y/b)^(p+1)]}
@@ -53,11 +54,13 @@ Here, \eqn{b} is the scale parameter \code{scale},
and \code{p} is a shape parameter.
The mean does not seem to exist.
+
}
\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{
Kleiber, C. and Kotz, S. (2003)
diff --git a/man/invparalogistic.Rd b/man/invparalogistic.Rd
index 9bf5564..f52df9f 100644
--- a/man/invparalogistic.Rd
+++ b/man/invparalogistic.Rd
@@ -44,6 +44,7 @@ invparalogistic(link.a = "loge", link.scale = "loge",
It is the 3-parameter Dagum distribution with \eqn{a=p}.
More details can be found in Kleiber and Kotz (2003).
+
The inverse paralogistic distribution has density
\deqn{f(y) = a^2 y^{a^2-1} / [b^{a^2} \{1 + (y/b)^a\}^{a+1}]}{%
f(y) = a^2 y^(a^2-1) / [b^(a^2) (1 + (y/b)^a)^(a+1)]}
@@ -55,11 +56,13 @@ The mean is
E(Y) = b gamma(a + 1/a) gamma(1 - 1/a) / gamma(a)}
provided \eqn{a > 1}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
Kleiber, C. and Kotz, S. (2003)
diff --git a/man/levy.Rd b/man/levy.Rd
index 6ac6df4..50449ee 100644
--- a/man/levy.Rd
+++ b/man/levy.Rd
@@ -78,10 +78,6 @@ levy(delta = NULL, link.gamma = "loge", earg=list(),
The Nolan article is at
\url{http://academic2.american.edu/~jpnolan/stable/chap1.pdf}.
- Documentation accompanying the \pkg{VGAM} package at
- \url{http://www.stat.auckland.ac.nz/~yee} contains further information
- and examples.
-
}
\examples{
nn = 1000; delta = 0
diff --git a/man/lgammaUC.Rd b/man/lgammaUC.Rd
index 7388d8b..55a9eba 100644
--- a/man/lgammaUC.Rd
+++ b/man/lgammaUC.Rd
@@ -14,10 +14,10 @@
}
\usage{
-dlgamma(x, location=0, scale=1, k=1, log=FALSE)
-plgamma(q, location=0, scale=1, k=1)
-qlgamma(p, location=0, scale=1, k=1)
-rlgamma(n, location=0, scale=1, k=1)
+dlgamma(x, location = 0, scale = 1, k = 1, log = FALSE)
+plgamma(q, location = 0, scale = 1, k = 1)
+qlgamma(p, location = 0, scale = 1, k = 1)
+rlgamma(n, location = 0, scale = 1, k = 1)
}
\arguments{
\item{x, q}{vector of quantiles.}
@@ -28,7 +28,7 @@ rlgamma(n, location=0, scale=1, k=1)
\item{k}{the (positive) shape parameter \eqn{k}.}
\item{log}{
Logical.
- If \code{log=TRUE} then the logarithm of the density is returned.
+ If \code{log = TRUE} then the logarithm of the density is returned.
}
@@ -38,6 +38,7 @@ rlgamma(n, location=0, scale=1, k=1)
\code{plgamma} gives the distribution function,
\code{qlgamma} gives the quantile function, and
\code{rlgamma} generates random deviates.
+
}
\references{
Kotz, S. and Nadarajah, S. (2000)
@@ -58,25 +59,24 @@ London: Imperial College Press.
\note{
The \pkg{VGAM} family function \code{\link{lgamma3ff}} is
for the three parameter (nonstandard) log-gamma distribution.
+
}
\seealso{
\code{\link{lgammaff}},
\code{\link{prentice74}}.
}
\examples{
-\dontrun{
-loc = 1; Scale = 1.5; k = 1.4
-x = seq(-3.2, 5, by=0.01)
-plot(x, dlgamma(x, loc, Scale, k), type="l", col="blue", ylim=c(0,1),
- main="Blue is density, red is cumulative distribution function",
- sub="Purple are 5,10,...,95 percentiles", las=1, ylab="")
-abline(h=0, col="blue", lty=2)
-lines(qlgamma(seq(0.05,0.95,by=0.05), loc, Scale, k),
- dlgamma(qlgamma(seq(0.05,0.95,by=0.05), loc, Scale, k), loc, Scale, k),
- col="purple", lty=3, type="h")
-lines(x, plgamma(x, loc, Scale, k), type="l", col="red")
-abline(h=0, lty=2)
-}
+\dontrun{ loc = 1; Scale = 1.5; k = 1.4
+x = seq(-3.2, 5, by = 0.01)
+plot(x, dlgamma(x, loc, Scale, k), type = "l", col = "blue", ylim = 0:1,
+ main = "Blue is density, red is cumulative distribution function",
+ sub = "Purple are 5,10,...,95 percentiles", las = 1, ylab = "")
+abline(h = 0, col = "blue", lty = 2)
+lines(qlgamma(seq(0.05, 0.95, by = 0.05), loc, Scale, k),
+ dlgamma(qlgamma(seq(0.05, 0.95, by = 0.05), loc, Scale, k),
+ loc, Scale, k), col = "purple", lty = 3, type = "h")
+lines(x, plgamma(x, loc, Scale, k), type = "l", col = "red")
+abline(h = 0, lty = 2) }
}
\keyword{distribution}
diff --git a/man/lgammaff.Rd b/man/lgammaff.Rd
index 48c292a..409a0a1 100644
--- a/man/lgammaff.Rd
+++ b/man/lgammaff.Rd
@@ -9,22 +9,17 @@
}
\usage{
-lgammaff(link = "loge", earg=list(), init.k = NULL)
-lgamma3ff(llocation="identity", lscale="loge", lshape="loge",
- elocation=list(), escale=list(), eshape=list(),
- ilocation=NULL, iscale=NULL, ishape=1, zero=NULL)
+lgammaff(link = "loge", earg = list(), init.k = NULL)
+lgamma3ff(llocation = "identity", lscale = "loge", lshape = "loge",
+ elocation = list(), escale = list(), eshape = list(),
+ ilocation = NULL, iscale = NULL, ishape = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{llocation}{
+ \item{llocation, lscale}{
Parameter link function applied to the
- location parameter \eqn{a}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{lscale}{
- Parameter link function applied to the
- positive scale parameter \eqn{b}.
+ location parameter \eqn{a}
+ and the positive scale parameter \eqn{b}.
See \code{\link{Links}} for more choices.
}
@@ -43,7 +38,9 @@ lgamma3ff(llocation="identity", lscale="loge", lshape="loge",
Initial value for \eqn{k}.
If given, it must be positive.
If failure to converge occurs, try some other value.
- The default means an initial value is determined internally. }
+ The default means an initial value is determined internally.
+
+ }
\item{ilocation, iscale}{ Initial value for \eqn{a} and \eqn{b}.
The defaults mean an initial value is determined internally for each.
@@ -53,6 +50,7 @@ lgamma3ff(llocation="identity", lscale="loge", lshape="loge",
linear/additive predictors are modelled as intercepts only.
The values must be from the set \{1,2,3\}.
The default value means none are modelled as intercept-only terms.
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
@@ -65,15 +63,17 @@ lgamma3ff(llocation="identity", lscale="loge", lshape="loge",
The mean of \eqn{Y} is \code{digamma(k)} (returned as
the fitted values) and its variance is \code{trigamma(k)}.
+
For the non-standard log-gamma distribution, one replaces \eqn{y}
by \eqn{(y-a)/b}, where \eqn{a} is the location parameter
and \eqn{b} is the positive scale parameter.
Then the density function is
- \deqn{f(y)=\exp[k(y-a)/b - \exp((y-a)/b)] / (b \Gamma(k)).}{%
+ \deqn{f(y)=\exp[k(y-a)/b - \exp((y-a)/b)] / (b \, \Gamma(k)).}{%
f(y) = exp[k(y-a)/b - exp((y-a)/b)]/(b*gamma(k)).}
The mean and variance of \eqn{Y} are \code{a + b*digamma(k)} (returned as
the fitted values) and \code{b^2 * trigamma(k)}, respectively.
+
}
\value{
@@ -88,45 +88,49 @@ Kotz, S. and Nadarajah, S. (2000)
pages 48--49,
London: Imperial College Press.
+
Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1995)
\emph{Continuous Univariate Distributions},
2nd edition, Volume 2, p.89,
New York: Wiley.
+
}
\author{ T. W. Yee }
\note{
The standard log-gamma distribution can be viewed as a generalization
- of the standard type 1 extreme value density: when \eqn{k=1}
+ of the standard type 1 extreme value density: when \eqn{k = 1}
the distribution of \eqn{-Y} is the standard type 1 extreme value
distribution.
+
The standard log-gamma distribution is fitted with \code{lgammaff}
and the non-standard (3-parameter) log-gamma distribution is fitted
with \code{lgamma3ff}.
+
}
\seealso{
\code{\link{rlgamma}},
-\code{\link{ggamma}},
+\code{\link{gengamma}},
\code{\link{prentice74}},
\code{\link{gamma1}},
\code{\link[base:Special]{lgamma}}.
+
}
\examples{
-ldat = data.frame(y = rlgamma(nn <- 100, k=exp(1)))
-fit = vglm(y ~ 1, lgammaff, ldat, trace=TRUE, crit="c")
+ldat = data.frame(y = rlgamma(100, k = exp(1)))
+fit = vglm(y ~ 1, lgammaff, ldat, trace = TRUE, crit = "coef")
summary(fit)
-coef(fit, matrix=TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
ldat = data.frame(x = runif(nn <- 5000)) # Another example
-ldat = transform(ldat, loc = -1 + 2*x,
- Scale = exp(1+x))
-ldat = transform(ldat, y = rlgamma(nn, loc=loc, scale=Scale, k=exp(0)))
-fit = vglm(y ~ x, lgamma3ff(zero=3), ldat, trace=TRUE, crit="c")
-coef(fit, matrix=TRUE)
+ldat = transform(ldat, loc = -1 + 2*x, Scale = exp(1))
+ldat = transform(ldat, y = rlgamma(nn, loc, scale = Scale, k = exp(0)))
+fit = vglm(y ~ x, lgamma3ff(zero = 2:3), ldat, trace = TRUE, crit = "c")
+coef(fit, matrix = TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/lino.Rd b/man/lino.Rd
index 2563e80..339e502 100644
--- a/man/lino.Rd
+++ b/man/lino.Rd
@@ -8,9 +8,9 @@
}
\usage{
-lino(lshape1="loge", lshape2="loge", llambda="loge",
- eshape1=list(), eshape2=list(), elambda=list(),
- ishape1=NULL, ishape2=NULL, ilambda=1, zero=NULL)
+lino(lshape1 = "loge", lshape2 = "loge", llambda = "loge",
+ eshape1 = list(), eshape2 = list(), elambda = list(),
+ ishape1 = NULL, ishape2 = NULL, ilambda = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -52,7 +52,8 @@ lino(lshape1="loge", lshape2="loge", llambda="loge",
B(a,b) \{1 - (1-\lambda) y\}^{a+b}}}{%
f(y;a,b,lambda) = lambda^a y^(a-1) (1-y)^(b-1) /
[B(a,b) (1 - (1-lambda)*y)^(a+b)]}
- for \eqn{a > 0}, \eqn{b > 0}, \eqn{\lambda > 0}{lambda > 0}, \eqn{0 < y < 1}.
+ for \eqn{a > 0}, \eqn{b > 0}, \eqn{\lambda > 0}{lambda > 0},
+ \eqn{0 < y < 1}.
Here \eqn{B} is the beta function (see \code{\link[base:Special]{beta}}).
The mean is a complicated function involving the Gauss hypergeometric
function.
@@ -62,6 +63,7 @@ lino(lshape1="loge", lshape2="loge", llambda="loge",
has a standard beta distribution with parameters \code{shape1},
\code{shape2}.
+
Since \eqn{\log(\lambda)=0}{log(lambda)=0} corresponds to the standard
beta distribution, a \code{summary} of the fitted model performs a
t-test for whether the data belongs to a standard beta distribution
@@ -82,9 +84,12 @@ lino(lshape1="loge", lshape2="loge", llambda="loge",
\emph{Journal of Educational Statistics},
\bold{7}, 271--294.
+
Gupta, A. K. and Nadarajah, S. (2004)
\emph{Handbook of Beta Distribution and Its Applications},
NY: Marcel Dekker, Inc.
+
+
}
\author{ T. W. Yee }
@@ -92,22 +97,26 @@ lino(lshape1="loge", lshape2="loge", llambda="loge",
The fitted values, which is usually the mean, have not been implemented
yet and consequently are \code{NA}s.
+
Although Fisher scoring is used, the working weight matrices
are positive-definite only in a certain region of the parameter
space. Problems with this indicate poor initial values or an
ill-conditioned model or insufficient data etc.
+
This model is can be difficult to fit. A reasonably good value of
\code{ilambda} seems to be needed so if the self-starting initial
values fail, try experimenting with the initial value arguments.
Experience suggests \code{ilambda} is better a little larger, rather
than smaller, compared to the true value.
+
}
\seealso{
\code{\link{Lino}},
\code{\link{genbetaII}}.
+
}
\examples{
diff --git a/man/lirat.Rd b/man/lirat.Rd
index 8230931..df616e0 100644
--- a/man/lirat.Rd
+++ b/man/lirat.Rd
@@ -25,6 +25,7 @@ comes from the experimental setup from Shepard et al. (1980), which is
typical of studies of the effects of chemical agents or dietary regimens
on fetal development in laboratory rats.
+
Female rats were put in iron-deficient diets and divided into 4
groups. One group of controls was given weekly injections of iron
supplement to bring their iron intake to normal levels, while another
@@ -33,6 +34,7 @@ fewer iron-supplement injections than the controls. The rats were made
pregnant, sacrificed 3 weeks later, and the total number of fetuses and
the number of dead fetuses in each litter were counted.
+
For each litter the number of dead fetuses may be considered to be
Binomial(\eqn{N,p}) where \eqn{N} is the litter size and \eqn{p}
is the probability of a fetus dying. The parameter \eqn{p} is expected
@@ -41,6 +43,7 @@ proportions will be greater than that predicted by a binomial model,
even when the covariates for hemoglobin level and experimental group
are accounted for.
+
}
\source{
Moore, D. F. and Tsiatis, A. (1991)
@@ -57,7 +60,7 @@ are accounted for.
\examples{
\dontrun{
# cf. Figure 3 of Moore and Tsiatis (1991)
-with(lirat, plot(hb, R/N, pch=as.character(grp), col=grp, las=1,
- xlab="Hemoglobin level", ylab="Proportion Dead")) }
+plot(R/N ~ hb, data = lirat, pch = as.character(grp), col = grp,
+ las = 1, xlab = "Hemoglobin level", ylab = "Proportion Dead") }
}
\keyword{datasets}
diff --git a/man/lms.bcg.Rd b/man/lms.bcg.Rd
index 11df4c3..c0e14a2 100644
--- a/man/lms.bcg.Rd
+++ b/man/lms.bcg.Rd
@@ -7,10 +7,10 @@
to the gamma distribution.
}
\usage{
-lms.bcg(percentiles = c(25, 50, 75), zero = c(1,3),
- llambda="identity", lmu="identity", lsigma = "loge",
- elambda=list(), emu=list(), esigma=list(), dfmu.init=4,
- dfsigma.init=2, ilambda = 1, isigma = NULL)
+lms.bcg(percentiles = c(25, 50, 75), zero = c(1, 3),
+ llambda = "identity", lmu = "identity", lsigma = "loge",
+ elambda = list(), emu = list(), esigma = list(),
+ dfmu.init = 4, dfsigma.init = 2, ilambda = 1, isigma = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -20,66 +20,30 @@ lms.bcg(percentiles = c(25, 50, 75), zero = c(1,3),
which are the quantiles. They will be returned as `fitted values'.
}
- \item{zero}{
- An integer-valued vector specifying which
- linear/additive predictors are modelled as intercepts only.
- The values must be from the set \{1,2,3\}.
- The default value, \code{NULL}, means they all are
- functions of the covariates.
-
- }
- \item{llambda}{
- Parameter link function applied to the first linear/additive predictor.
- }
- \item{lmu}{
- Parameter link function applied to the second linear/additive predictor.
-
-% The natural log is offered because mu
-% is positive, but it is not the default because mu is more directly
-% interpretable than log(mu)
-% (it is something similar to the running median).
+ \item{zero}{
+ See \code{\link{lms.bcn}}.
}
- \item{lsigma}{
- Parameter link function applied to the third linear/additive predictor.
- See \code{\link{Links}} for more choices.
-% It is the natural log by default because sigma is positive.
+ \item{llambda, lmu, lsigma}{
+ See \code{\link{lms.bcn}}.
}
\item{elambda, emu, esigma}{
- List. Extra argument for each of the links.
- See \code{earg} in \code{\link{Links}} for general information.
+ See \code{\link{lms.bcn}}.
}
- \item{dfmu.init}{
- Degrees of freedom for the cubic smoothing spline fit applied to
- get an initial estimate of mu.
- See \code{\link{vsmooth.spline}}.
+ \item{dfmu.init, dfsigma.init}{
+ See \code{\link{lms.bcn}}.
+
}
- \item{dfsigma.init}{
- Degrees of freedom for the cubic smoothing spline fit applied to
- get an initial estimate of sigma.
- See \code{\link{vsmooth.spline}}.
- This argument may be assigned \code{NULL} to get an initial value
- using some other algorithm.
+ \item{ilambda, isigma}{
+ See \code{\link{lms.bcn}}.
}
- \item{ilambda}{
- Initial value for lambda.
- If necessary, it is recycled to be a vector of length \eqn{n}
- where \eqn{n} is the number of (independent) observations.
- }
- \item{isigma}{
- Optional initial value for sigma.
- If necessary, it is recycled to be a vector of length \eqn{n}.
- The default value, \code{NULL}, means an initial value is computed
- in the \code{@initialize} slot of the family function.
-
- }
}
\details{
Given a value of the covariate, this function applies a Box-Cox
@@ -87,6 +51,7 @@ lms.bcg(percentiles = c(25, 50, 75), zero = c(1,3),
The parameters
chosen to do this are estimated by maximum likelihood or penalized
maximum likelihood.
+ Similar details can be found at \code{\link{lms.bcn}}.
}
\value{
@@ -111,81 +76,65 @@ contains further information and examples.
}
\author{ Thomas W. Yee }
\note{
-The response must be positive because the
-Box-Cox transformation cannot handle negative values.
-The LMS-Yeo-Johnson-normal method can handle
-both positive and negative values.
-
-In general, the lambda and sigma functions should be more smoother
-than the mean function.
-Having \code{zero=1}, \code{zero=3} or \code{zero=c(1,3)} is often a good idea.
-See the example below.
-
-While it is usual to regress the response against a single
-covariate, it is possible to add other explanatory variables,
-e.g., sex.
-See
-\url{http://www.stat.auckland.ac.nz/~yee}
-for further information and examples about this feature.
+ Similar notes can be found at \code{\link{lms.bcn}}.
}
\section{Warning }{
-The computations are not simple, therefore convergence may fail.
-In that case, try different starting values.
-Also, the estimate may diverge quickly near the solution,
-in which case try prematurely
-stopping the iterations by assigning \code{maxits} to be the iteration
-number corresponding to the highest likelihood value.
-See the example below.
-
-The expected value of the second derivative with respect to lambda may
-be incorrect (my calculations do not agree with the Lopatatzidis and
-Green manuscript.)
+ This \pkg{VGAM} family function comes with the same
+ warnings as \code{\link{lms.bcn}}.
+ Also, the expected value of the second derivative with
+ respect to lambda may be incorrect (my calculations do
+ not agree with the Lopatatzidis and Green manuscript.)
}
\seealso{
-\code{\link{lms.bcn}},
-\code{\link{lms.yjn}},
-\code{\link{qtplot.lmscreg}},
-\code{\link{deplot.lmscreg}},
-\code{\link{cdf.lmscreg}},
-\code{\link{bminz}},
-\code{\link{amlnormal}}.
+ \code{\link{lms.bcn}},
+ \code{\link{lms.yjn}},
+ \code{\link{qtplot.lmscreg}},
+ \code{\link{deplot.lmscreg}},
+ \code{\link{cdf.lmscreg}},
+ \code{\link{bminz}},
+ \code{\link{amlexponential}}.
+
}
\examples{
-# This converges, but deplot(fit) and qtplot(fit) does not work
-fit = vglm(BMI ~ bs(age, df=4), fam=lms.bcg(zero=c(1,3)), data=bminz, tr=TRUE)
-coef(fit, matrix=TRUE)
+# This converges, but deplot(fit) and qtplot(fit) do not work
+fit0 = vglm(BMI ~ bs(age, df = 4), lms.bcg, bminz, trace = TRUE)
+coef(fit0, matrix = TRUE)
\dontrun{
-par(mfrow=c(1,1))
-plotvgam(fit, se=TRUE) # Plot mu function (only)
+par(mfrow = c(1, 1))
+plotvgam(fit0, se = TRUE) # Plot mu function (only)
}
-# Difficult to get a model that converges
-# Here, we prematurely stop iterations because it fails near the solution
-fit = vgam(BMI ~ s(age, df=c(4,2)), maxit=4,
- fam=lms.bcg(zero=1, ilam=3), data=bminz, tr=TRUE)
-summary(fit)
-head(predict(fit))
-head(fitted(fit))
+# Use a trick: fit0 is used for initial values for fit1.
+fit1 = vgam(BMI ~ s(age, df = c(4, 2)), etastart = predict(fit0),
+ lms.bcg(zero = 1), bminz, trace = TRUE)
+
+# Difficult to get a model that converges.
+# Here, we prematurely stop iterations because it fails near the solution.
+fit2 = vgam(BMI ~ s(age, df = c(4, 2)), maxit = 4,
+ lms.bcg(zero = 1, ilam = 3), bminz, trace = TRUE)
+summary(fit1)
+head(predict(fit1))
+head(fitted(fit1))
head(bminz)
# Person 1 is near the lower quartile of BMI amongst people his age
-head(cdf(fit))
+head(cdf(fit1))
\dontrun{
# Quantile plot
-par(bty="l", mar=c(5,4,4,3)+0.1, xpd=TRUE)
-qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
- xlim=c(15,90), las=1, ylab="BMI", lwd=2, lcol=4)
+par(bty = "l", mar=c(5, 4, 4, 3) + 0.1, xpd = TRUE)
+qtplot(fit1, 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)
-(aa = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
- main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)"))
-aa = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
-aa = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
+ygrid = seq(15, 43, len = 100) # BMI ranges
+par(mfrow = c(1, 1), lwd = 2)
+(aa = deplot(fit1, x0 = 20, y = ygrid, xlab = "BMI", col = "black",
+ main = "Density functions at Age = 20 (black), 42 (red) and 55 (blue)"))
+aa = deplot(fit1, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
+aa = deplot(fit1, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
aa at post$deplot # Contains density function values
}
}
diff --git a/man/lms.bcn.Rd b/man/lms.bcn.Rd
index bdc97ed..676c82b 100644
--- a/man/lms.bcn.Rd
+++ b/man/lms.bcn.Rd
@@ -1,57 +1,49 @@
\name{lms.bcn}
\alias{lms.bcn}
%- Also NEED an '\alias' for EACH other topic documented here.
-\title{ LMS Quantile Regression with a Box-Cox Transformation to Normality }
+\title{ LMS Quantile/Expectile Regression with a Box-Cox Transformation to Normality }
\description{
- LMS quantile regression with the Box-Cox transformation
+ LMS quantile/expectile regression with the Box-Cox transformation
to normality.
+
}
\usage{
-lms.bcn(percentiles = c(25, 50, 75), zero = c(1,3),
- llambda="identity", lmu="identity", lsigma = "loge",
- elambda=list(), emu=list(), esigma=list(), dfmu.init=4,
- dfsigma.init=2, ilambda = 1, isigma = NULL)
+lms.bcn(percentiles = c(25, 50, 75), zero = c(1, 3),
+ llambda = "identity", lmu = "identity", lsigma = "loge",
+ elambda = list(), emu = list(), esigma = list(),
+ dfmu.init = 4, dfsigma.init = 2, ilambda = 1,
+ isigma = NULL, expectiles = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{percentiles}{
A numerical vector containing values between 0 and 100,
- which are the quantiles. They will be returned as `fitted values'.
+ which are the quantiles or expectiles.
+ They will be returned as `fitted values'.
}
\item{zero}{
An integer-valued vector specifying which
linear/additive predictors are modelled as intercepts only.
The values must be from the set \{1,2,3\}.
- The default value, \code{NULL}, means they all are
+ The default value usually increases the chance of successful convergence.
+ Setting \code{zero = NULL} means they all are
functions of the covariates.
+ For more information see \code{\link{CommonVGAMffArguments}}.
}
- \item{llambda}{
- Parameter link function applied to the first linear/additive predictor.
- See \code{\link{Links}} for more choices.
-
- }
- \item{lmu}{
- Parameter link function applied to the second linear/additive predictor.
- See \code{\link{Links}} for more choices.
-
-% The natural log is offered because mu is positive, but it is not
-% the default because mu is more directly interpretable than log(mu)
-% (it is something similar to the running median).
-
- }
- \item{lsigma}{
- Parameter link function applied to the third linear/additive predictor.
- See \code{\link{Links}} for more choices.
-
-% It is the natural log by default because sigma is positive.
+ \item{llambda, lmu, lsigma}{
+ Parameter link functions applied to the first, second and third
+ linear/additive predictors.
+ See \code{\link{Links}} for more choices,
+ and \code{\link{CommonVGAMffArguments}}.
}
\item{elambda, emu, esigma}{
List. Extra argument for each of the links.
- See \code{earg} in \code{\link{Links}} for general information.
+ See \code{earg} in \code{\link{Links}} for general information,
+ as well as \code{\link{CommonVGAMffArguments}}.
}
\item{dfmu.init}{
@@ -81,12 +73,66 @@ lms.bcn(percentiles = c(25, 50, 75), zero = c(1,3),
in the \code{@initialize} slot of the family function.
}
+ \item{expectiles}{
+ A single logical. If \code{TRUE} then the method is LMS-expectile
+ regression; \emph{expectiles} are returned rather than quantiles.
+ The default is LMS quantile regression based on the normal distribution.
+
+ }
+
}
\details{
- Given a value of the covariate, this function applies a Box-Cox
- transformation to the response to best obtain normality. The parameters
- chosen to do this are estimated by maximum likelihood or penalized
- maximum likelihood.
+
+ Given a value of the covariate, this function applies
+ a Box-Cox transformation to the response to best obtain
+ normality. The parameters chosen to do this are estimated
+ by maximum likelihood or penalized maximum likelihood.
+
+
+In more detail,
+the basic idea behind this method is that, for a fixed
+value of \eqn{x}, a Box-Cox transformation of the response \eqn{Y}
+is applied to obtain standard normality. The 3 parameters
+(\eqn{\lambda}{lambda}, \eqn{\mu}{mu}, \eqn{\sigma}{sigma},
+which start with the letters ``L-M-S''
+respectively, hence its name) are chosen to maximize a penalized
+log-likelihood (with \code{\link{vgam}}). Then the
+appropriate quantiles of the standard normal distribution
+are back-transformed onto the original scale to get the
+desired quantiles.
+The three parameters may vary as a smooth function of \eqn{x}.
+
+
+The Box-Cox power transformation here of the \eqn{Y}, given \eqn{x}, is
+\deqn{Z = [(Y / \mu(x))^{\lambda(x)} - 1] / ( \sigma(x) \, \lambda(x) )}{
+ Z = [(Y / mu(x))^{lambda(x)} - 1] / (sigma(x) * lambda(x))}
+for \eqn{\lambda(x) \neq 0}{lambda(x) != 0}.
+(The singularity at \eqn{\lambda(x) = 0}{lambda(x) = 0}
+is handled by a simple function involving a logarithm.)
+Then \eqn{Z} is assumed to have a standard normal distribution.
+The parameter \eqn{\sigma(x)}{sigma(x)} must be positive, therefore
+\pkg{VGAM} chooses
+\eqn{\eta(x)^T = (\lambda(x), \mu(x), \log(\sigma(x)))}{eta(x)^T =
+(lambda(x), mu(x), log(sigma(x)))}
+by default.
+The parameter \eqn{\mu}{mu} is also positive, but while
+\eqn{\log(\mu)}{log(mu)} is
+available, it is not the default because \eqn{\mu}{mu} is
+more directly interpretable.
+Given the estimated linear/additive predictors, the
+\eqn{100\alpha}{100*alpha} percentile can be estimated
+by inverting the Box-Cox power transformation at the
+\eqn{100\alpha}{100*alpha} percentile of the standard
+normal distribution.
+
+
+Of the three functions, it is often a good idea to allow
+\eqn{\mu(x)}{mu(x)} to be more flexible because the functions
+\eqn{\lambda(x)}{lambda(x)} and \eqn{\sigma(x)}{sigma(x)}
+usually vary more smoothly with \eqn{x}. This is somewhat
+reflected in the default value for the argument \code{zero},
+viz. \code{zero = c(1,3)}.
+
}
\value{
@@ -94,6 +140,7 @@ lms.bcn(percentiles = c(25, 50, 75), zero = c(1,3),
The object is used by modelling functions such as \code{\link{vglm}},
\code{\link{rrvglm}}
and \code{\link{vgam}}.
+
}
\references{
Cole, T. J. and Green, P. J. (1992)
@@ -102,9 +149,18 @@ Penalized Likelihood.
\emph{Statistics in Medicine},
\bold{11}, 1305--1319.
+
+Green, P. J. and Silverman, B. W. (1994)
+\emph{Nonparametric Regression and Generalized Linear Models: A
+Roughness Penalty Approach},
+London: Chapman & Hall.
+
+
Yee, T. W. (2004)
Quantile regression via vector generalized additive models.
-\emph{Statistics in Medicine}, \bold{23}, 2295--2315.
+\emph{Statistics in Medicine},
+\bold{23}, 2295--2315.
+
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
@@ -113,65 +169,85 @@ contains further information and examples.
}
\author{ Thomas W. Yee }
\note{
-The response must be positive because the
-Box-Cox transformation cannot handle negative values.
-The LMS-Yeo-Johnson-normal method can handle
-both positive and negative values.
-
-In general, the lambda and sigma functions should be more smoother
-than the mean function.
-Having \code{zero=1}, \code{zero=3} or \code{zero=c(1,3)} is often a good idea.
-See the example below.
-
-While it is usual to regress the response against a single
-covariate, it is possible to add other explanatory variables,
-e.g., sex.
-See
-\url{http://www.stat.auckland.ac.nz/~yee}
-for further information and examples about this feature.
+ The response must be positive because the Box-Cox
+ transformation cannot handle negative values. The
+ LMS-Yeo-Johnson-normal method can handle both positive
+ and negative values.
+
+
+ LMS-BCN expectile regression is a \emph{new} methodology proposed
+ by myself!
+
+
+ In general, the lambda and sigma functions should be more smoother
+ than the mean function.
+ Having \code{zero = 1}, \code{zero = 3} or \code{zero = c(1,3)}
+ is often a good idea. See the example below.
+
+
+ While it is usual to regress the response against a single
+ covariate, it is possible to add other explanatory variables,
+ e.g., gender.
+ See
+ \url{http://www.stat.auckland.ac.nz/~yee}
+ for further information and examples about this feature.
}
\section{Warning }{
-The computations are not simple, therefore convergence may fail.
-In that case, try different starting values.
-Also, the estimate may diverge quickly near the solution,
-in which case try prematurely
-stopping the iterations by assigning \code{maxits} to be the iteration
-number corresponding to the highest likelihood value.
+ The computations are not simple, therefore convergence may fail.
+ In that case, try different starting values.
+ Also, the estimate may diverge quickly near the solution,
+ in which case try prematurely
+ stopping the iterations by assigning \code{maxits} to be the iteration
+ number corresponding to the highest likelihood value.
+
+ One trick is to fit a simple model and use it to provide
+ initial values for a more complex model; see in the
+ examples below.
+
}
\seealso{
-\code{\link{lms.bcg}},
-\code{\link{lms.yjn}},
-\code{\link{qtplot.lmscreg}},
-\code{\link{deplot.lmscreg}},
-\code{\link{cdf.lmscreg}},
-\code{\link{bminz}},
-\code{\link{alaplace1}},
-\code{\link{amlnormal}}.
+ \code{\link{lms.bcg}},
+ \code{\link{lms.yjn}},
+ \code{\link{qtplot.lmscreg}},
+ \code{\link{deplot.lmscreg}},
+ \code{\link{cdf.lmscreg}},
+ \code{\link{bminz}},
+ \code{\link{alaplace1}},
+ \code{\link{amlnormal}},
+ \code{\link{denorm}},
+ \code{\link{CommonVGAMffArguments}}.
+
}
\examples{
-fit = vgam(BMI ~ s(age, df=c(4,2)), fam=lms.bcn(zero=1), data=bminz, tr=TRUE)
+fit = vgam(BMI ~ s(age, df = c(4,2)), lms.bcn(zero = 1), bminz, trace = TRUE)
head(predict(fit))
head(fitted(fit))
head(bminz)
-# Person 1 is near the lower quartile of BMI amongst people his age
-head(cdf(fit))
+head(cdf(fit)) # Person 1 is near lower BMI quartile amongst his age group
+colMeans(c(fit at y) < fitted(fit)) # Sample proportions below the quantiles
+
+# Convergence problems? Try this trick: fit0 is a simpler model used for fit1
+fit0 = vgam(BMI ~ s(age, df = 4), lms.bcn(zero = c(1,3)), bminz, trace = TRUE)
+fit1 = vgam(BMI ~ s(age, df = c(4, 2)), lms.bcn(zero = 1), bminz,
+ etastart = predict(fit0), trace = TRUE)
\dontrun{
# Quantile plot
-par(bty="l", mar=c(5,4,4,3)+0.1, xpd=TRUE)
-qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
- xlim=c(15,90), las=1, ylab="BMI", lwd=2, lcol=4)
+par(bty = "l", mar = c(5, 4, 4, 3) + 0.1, xpd = TRUE)
+qtplot(fit, percentiles = c(5, 50, 90, 99), main = "Quantiles",
+ xlim = c(15, 90), las = 1, ylab = "BMI", lwd = 2, lcol = 4)
# Density plot
-ygrid = seq(15, 43, len=100) # BMI ranges
-par(mfrow=c(1,1), lwd=2)
-(aa = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
- main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)"))
-aa = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
-aa = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
+ygrid = seq(15, 43, len = 100) # BMI ranges
+par(mfrow=c(1, 1), lwd = 2)
+(aa = deplot(fit, x0 = 20, y = ygrid, xlab = "BMI", col = "black",
+ main = "Density functions at Age = 20 (black), 42 (red) and 55 (blue)"))
+aa = deplot(fit, x0 = 42, y = ygrid, add = TRUE, llty = 2, col = "red")
+aa = deplot(fit, x0 = 55, y = ygrid, add = TRUE, llty = 4, col = "blue",
+ Attach = TRUE)
aa at post$deplot # Contains density function values
}
}
diff --git a/man/lms.yjn.Rd b/man/lms.yjn.Rd
index e0baed6..9570f19 100644
--- a/man/lms.yjn.Rd
+++ b/man/lms.yjn.Rd
@@ -9,15 +9,15 @@
}
\usage{
lms.yjn(percentiles = c(25, 50, 75), zero = c(1,3),
- llambda = "identity", lsigma = "loge", elambda=list(),
- esigma=list(), dfmu.init=4, dfsigma.init=2, ilambda = 1,
- isigma = NULL, rule = c(10, 5), yoffset = NULL, diagW=FALSE,
- iters.diagW=6)
+ llambda = "identity", lsigma = "loge", elambda = list(),
+ esigma = list(), dfmu.init = 4, dfsigma.init = 2,
+ ilambda = 1, isigma = NULL, rule = c(10, 5),
+ yoffset = NULL, diagW = FALSE, iters.diagW = 6)
lms.yjn2(percentiles=c(25,50,75), zero=c(1,3),
- llambda="identity", lmu = "identity", lsigma="loge",
- elambda=list(), emu = list(), esigma=list(), dfmu.init=4,
- dfsigma.init=2, ilambda=1.0, isigma=NULL, yoffset=NULL,
- nsimEIM=250)
+ llambda = "identity", lmu = "identity", lsigma = "loge",
+ elambda = list(), emu = list(), esigma = list(),
+ dfmu.init = 4, dfsigma.init = 2, ilambda = 1.0,
+ isigma = NULL, yoffset = NULL, nsimEIM = 250)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -28,50 +28,27 @@ lms.yjn2(percentiles=c(25,50,75), zero=c(1,3),
}
\item{zero}{
- An integer-valued vector specifying which
- linear/additive predictors are modelled as intercepts only.
- The values must be from the set \{1,2,3\}.
- The default value, \code{NULL}, means they all are
- functions of the covariates.
+ See \code{\link{lms.bcn}}.
}
\item{llambda, lmu, lsigma}{
- Parameter link function applied to the first, second and third
- linear/additive predictors.
- See \code{\link{Links}} for more choices.
+ See \code{\link{lms.bcn}}.
}
\item{elambda, emu, esigma}{
- List. Extra argument for each of the links.
- See \code{earg} in \code{\link{Links}} for general information.
+ See \code{\link{lms.bcn}}.
}
- \item{dfmu.init}{
- Degrees of freedom for the cubic smoothing spline fit applied to
- get an initial estimate of mu.
- See \code{\link{vsmooth.spline}}.
- }
- \item{dfsigma.init}{
- Degrees of freedom for the cubic smoothing spline fit applied to
- get an initial estimate of sigma.
- See \code{\link{vsmooth.spline}}.
- This argument may be assigned \code{NULL} to get an initial value
- using some other algorithm.
+ \item{dfmu.init, dfsigma.init}{
+ See \code{\link{lms.bcn}}.
}
- \item{ilambda}{
- Initial value for lambda.
- If necessary, it is recycled to be a vector of length \eqn{n}
- where \eqn{n} is the number of (independent) observations.
- }
- \item{isigma}{
- Optional initial value for sigma.
- If necessary, it is recycled to be a vector of length \eqn{n}.
- The default value, \code{NULL}, means an initial value is computed
- in the \code{@initialize} slot of the family function.
+ \item{ilambda, isigma}{
+ See \code{\link{lms.bcn}}.
}
+
\item{rule}{
Number of abscissae used in the Gaussian integration
scheme to work out elements of the weight matrices.
@@ -157,17 +134,8 @@ In contrast, the LMS-Box-Cox-normal and LMS-Box-Cox-gamma
methods only handle a positive response because the
Box-Cox transformation cannot handle negative values.
-In general, the lambda and sigma functions should be more smoother
-than the mean function.
-Having \code{zero=1}, \code{zero=3} or \code{zero=c(1,3)} is often a good idea.
-See the example below.
-While it is usual to regress the response against a single
-covariate, it is possible to add other explanatory variables,
-e.g., sex.
-See
-\url{http://www.stat.auckland.ac.nz/~yee}
-for further information and examples about this feature.
+Some other notes can be found at \code{\link{lms.bcn}}.
}
@@ -190,8 +158,7 @@ The generic function \code{predict}, when applied to a
}
\examples{
-fit = vgam(BMI ~ s(age, df=4), fam=lms.yjn(zero=c(1,3)),
- data=bminz, trace=TRUE)
+fit = vgam(BMI ~ s(age, df = 4), lms.yjn, bminz, trace = TRUE)
head(predict(fit))
head(fitted(fit))
head(bminz)
@@ -200,9 +167,9 @@ head(cdf(fit))
\dontrun{
# Quantile plot
-par(bty="l", mar=c(5,4,4,3)+0.1, xpd=TRUE)
-qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
- xlim=c(15,90), las=1, ylab="BMI", lwd=2, lcol=4)
+par(bty = "l", mar = c(5, 4, 4, 3) + 0.1, xpd = TRUE)
+qtplot(fit, percentiles = c(5, 50, 90, 99), main = "Quantiles",
+ xlim = c(15, 90), las = 1, ylab = "BMI", lwd = 2, lcol = 4)
# Density plot
ygrid = seq(15, 43, len=100) # BMI ranges
diff --git a/man/logUC.Rd b/man/logUC.Rd
index d117f5b..01c8737 100644
--- a/man/logUC.Rd
+++ b/man/logUC.Rd
@@ -7,23 +7,22 @@
\title{ Logarithmic Distribution }
\description{
Density, distribution function,
-% quantile function
and random generation
for the logarithmic distribution.
+% quantile function
+
}
\usage{
-dlog(x, prob, log=FALSE)
-plog(q, prob, log.p=FALSE)
-% qlog(p, prob)
-rlog(n, prob, Smallno=1.0e-6)
+dlog(x, prob, log = FALSE)
+plog(q, prob, log.p = FALSE)
+rlog(n, prob, Smallno = 1.0e-6)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x, q}{
Vector of quantiles. For the density, it should be a vector with
positive integer values in order for the probabilities to be positive.
-
}
% \item{p}{vector of probabilities.}
\item{n}{number of observations. A single positive integer.}
@@ -31,19 +30,16 @@ rlog(n, prob, Smallno=1.0e-6)
The parameter value \eqn{c} described in in \code{\link{logff}}.
Here it is called \code{prob} because \eqn{0<c<1} is the range.
For \code{rlog()} this parameter must be of length 1.
-
}
\item{log, log.p}{
Logical.
- If \code{log.p=TRUE} then all probabilities \code{p} are
+ If \code{log.p = TRUE} then all probabilities \code{p} are
given as \code{log(p)}.
-
}
\item{Smallno}{
Numeric, a small value used by the rejection method for determining
the upper limit of the distribution.
That is, \code{plog(U, prob) > 1-Smallno} where \code{U} is the upper limit.
-
}
}
\details{
@@ -83,11 +79,10 @@ New York: Wiley-Interscience, Third edition.
dlog(1:20, 0.5)
rlog(20, 0.5)
-\dontrun{
-prob = 0.8; x = 1:10
-plot(x, dlog(x, prob=prob), type="h", ylim=0:1,
- sub="prob=0.8", las=1, col="blue", ylab="Probability",
+\dontrun{ prob = 0.8; x = 1:10
+plot(x, dlog(x, prob = prob), type = "h", ylim = 0:1,
+ sub = "prob=0.8", las = 1, col = "blue", ylab = "Probability",
main="Logarithmic distribution: blue=density; red=distribution function")
-lines(x+0.1, plog(x, prob=prob), col="red", lty=3, type="h") }
+lines(x + 0.1, plog(x, prob = prob), col = "red", lty = 3, type = "h") }
}
\keyword{distribution}
diff --git a/man/lomax.Rd b/man/lomax.Rd
index af1c244..a213194 100644
--- a/man/lomax.Rd
+++ b/man/lomax.Rd
@@ -44,6 +44,7 @@ It is probably more widely known as the Pareto (II) distribution.
beta distribution of the second kind with \eqn{p=1}.
More details can be found in Kleiber and Kotz (2003).
+
The Lomax distribution has density
\deqn{f(y) = q / [b \{1 + y/b\}^{1+q}]}{%
f(y) = q / [b (1 + y/b)^(1+q)]}
@@ -58,11 +59,13 @@ The mean is
E(Y) = b/(q-1)}
provided \eqn{q > 1}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
Kleiber, C. and Kotz, S. (2003)
diff --git a/man/mckaygamma2.Rd b/man/mckaygamma2.Rd
deleted file mode 100644
index f8d61e4..0000000
--- a/man/mckaygamma2.Rd
+++ /dev/null
@@ -1,108 +0,0 @@
-\name{mckaygamma2}
-\alias{mckaygamma2}
-%- Also NEED an '\alias' for EACH other topic documented here.
-\title{ McKay's Bivariate Gamma Distribution }
-\description{
- Estimate the two parameters of McKay's bivariate gamma distribution
- by maximum likelihood estimation.
-}
-\usage{
-mckaygamma2(la = "loge", lp = "loge", lq = "loge",
- ia = NULL, ip = 1, iq = 1, zero = NULL)
-}
-%- maybe also 'usage' for other objects documented here.
-\arguments{
- \item{la, lp, lq}{
- Link functions applied to the (positive)
- parameters \eqn{a}, \eqn{p} and \eqn{q}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{ia, ip, iq}{
- Initial values for \eqn{a}, \eqn{p} and \eqn{q}.
- The default for \eqn{a} is to estimate it using \code{ip} and \code{iq}.
-
- }
- \item{zero}{
- An integer-valued vector specifying which
- linear/additive predictors are modelled as intercepts only.
- The values must be from the set \{1,2,3\}.
- The default is none of them.
-
- }
-}
-\details{
- The joint probability density function is given by
- \deqn{f(y_1,y_2;a,p,q) = a^{p+q} y_1^{p-1} (y_2-y_1)^{q-1}
- \exp(-a y_2) / [\Gamma(p) \Gamma(q)]}{%
- f(y1,y2;a,p,q) = a^(p+q) y1^(p-1) (y2-y1)^(q-1)
- exp(-a y2) / [gamma(p) gamma(q)] }
- for \eqn{a > 0}, \eqn{p > 0}, \eqn{q > 0} and
- \eqn{0 < y_1 < y_2}{0<y1<y2}.
- Here, \eqn{\Gamma}{gamma} is the gamma
- function, as in \code{\link[base:Special]{gamma}}.
- By default, the linear/additive predictors are
- \eqn{\eta_1=\log(a)}{eta1=log(a)},
- \eqn{\eta_2=\log(p)}{eta2=log(p)},
- \eqn{\eta_3=\log(q)}{eta3=log(q)}.
-
- Although Fisher scoring and Newton-Raphson coincide for this
- distribution, faster convergence may be obtained by choosing
- better values for the arguments \code{ip} and \code{iq}.
-
-}
-\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}}.
-
-}
-
-%% improve the references
-\references{
-
-
-McKay, A. T. (1934)
-Sampling from batches.
-\emph{Journal of the Royal Statistical Society---Supplement},
-\bold{1}, 207--216.
-
-
-Kotz, S. and Balakrishnan, N. and Johnson, N. L. (2000)
-\emph{Continuous Multivariate Distributions Volume 1:
-Models and Applications},
-2nd edition,
-New York: Wiley.
-
-
-}
-\author{ T. W. Yee }
-\note{
- The response must be a two column matrix.
- Currently, the fitted value is a matrix with two columns;
- the first column has values \eqn{(p+q)/a} for the mean of \code{pmin(y1,y2)},
- while the second column is filled with \code{NA}
- for the unknown mean of \code{pmax(y1,y2)}.
- The data are sorted internally and the user need not input the
- data presorted.
-
-}
-
-\seealso{
- \code{\link{gamma2}}.
-
-}
-\examples{
-y1 = rgamma(n <- 200, shape=4)
-y2 = rgamma(n, shape=8)
-ymat = cbind(y1,y2)
-fit = vglm(ymat ~ 1, fam=mckaygamma2, trace=TRUE)
-coef(fit, matrix=TRUE)
-Coef(fit)
-vcov(fit)
-head(fitted(fit))
-summary(fit)
-}
-\keyword{models}
-\keyword{regression}
-
diff --git a/man/micmen.Rd b/man/micmen.Rd
index 5528b5f..17852ad 100644
--- a/man/micmen.Rd
+++ b/man/micmen.Rd
@@ -4,11 +4,12 @@
\title{ Michaelis-Menten Model }
\description{
Fits a Michaelis-Menten nonlinear regression model.
+
}
\usage{
micmen(rpar = 0.001, divisor = 10, init1 = NULL, init2 = NULL,
- link1 = "identity", link2 = "identity", earg1=list(),
- earg2=list(), dispersion = 0, zero = NULL)
+ link1 = "identity", link2 = "identity", earg1 = list(),
+ earg2 = list(), dispersion = 0, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -48,16 +49,18 @@ micmen(rpar = 0.001, divisor = 10, init1 = NULL, init2 = NULL,
linear/additive predictors are modelled as intercepts only.
The values must be from the set \{1,2\}.
A \code{NULL} means none.
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
\details{
- The Michaelis-Menten Model is given by
+ The Michaelis-Menten model is given by
\deqn{E(Y_i) = (\theta_1 u_i) / (\theta_2 + u_i)}{%
- E(Y_i) = theta1 * u_i / (theta2 + u_i)}
+ E(Y_i) = theta1 * u_i / (theta2 + u_i)}
where \eqn{\theta_1}{theta1} and \eqn{\theta_2}{theta2}
are the two parameters.
+
The relationship between iteratively reweighted least squares
and the Gauss-Newton algorithm is given in Wedderburn (1974).
However, the algorithm used by this family function is different.
@@ -68,6 +71,7 @@ micmen(rpar = 0.001, divisor = 10, init1 = NULL, init2 = NULL,
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
Seber, G. A. F. and Wild, C. J. (1989)
@@ -94,12 +98,12 @@ micmen(rpar = 0.001, divisor = 10, init1 = NULL, init2 = NULL,
The regressor values \eqn{u_i}{u_i} are inputted as the RHS of
the \code{form2} argument.
It should just be a simple term; no smart prediction is used.
- It should just a single vector so omit the intercept term.
- The LHS is ignored.
+ It should just a single vector, therefore omit the intercept term.
+ The LHS of the formula \code{form2} is ignored.
-% To predict the response at new values of \eqn{u_i}{u_i} one must assign
-% the \code{@extra$uvec} slot in the fitted object these values, e.g.,
-% see the example below.
+ To predict the response at new values of \eqn{u_i}{u_i} one must assign
+ the \code{@extra$Xm2} slot in the fitted object these values, e.g.,
+ see the example below.
Numerical problems may occur. If so, try setting some initial values
for the parameters. In the future, several self-starting initial values
@@ -110,22 +114,23 @@ micmen(rpar = 0.001, divisor = 10, init1 = NULL, init2 = NULL,
\seealso{
\code{\link{enzyme}}.
% \code{skira}.
+
}
\examples{
-fit = vglm(velocity ~ 1, micmen, enzyme, trace=TRUE, crit="c",
+fit = vglm(velocity ~ 1, micmen, enzyme, trace = TRUE, crit = "coef",
form2 = ~ conc - 1)
-\dontrun{
-with(enzyme, plot(conc, velocity, xlab="concentration", las=1,
- main="Enzyme data", ylim=c(0,max(velocity)),
- xlim=c(0,max(conc))))
-with(enzyme, points(conc, fitted(fit), col="blue", pch="+"))
+summary(fit)
+
+\dontrun{ plot(velocity ~ conc, enzyme, xlab = "concentration", las = 1,
+ col = "blue", main = "Michaelis-Menten equation for the enzyme data",
+ ylim = c(0, max(velocity)), xlim = c(0, max(conc)))
+points(fitted(fit) ~ conc, enzyme, col = "red", pch = "+", cex = 1.5)
# This predicts the response at a finer grid:
-newenzyme = data.frame(conc = with(enzyme, seq(0, max(conc),len=200)))
-with(newenzyme, lines(conc, predict(fit, newenzyme, type="response"),
- col="red"))
-}
-summary(fit)
+newenzyme = data.frame(conc = seq(0, max(with(enzyme, conc)), len = 200))
+fit at extra$Xm2 = newenzyme$conc # This assignment is needed for prediction
+lines(predict(fit, newenzyme, "response") ~ conc, newenzyme, col = "red") }
}
\keyword{models}
\keyword{regression}
+
diff --git a/man/negbinomial.Rd b/man/negbinomial.Rd
index 80c7dae..b778db0 100644
--- a/man/negbinomial.Rd
+++ b/man/negbinomial.Rd
@@ -8,9 +8,10 @@
}
\usage{
negbinomial(lmu = "loge", lk = "loge", emu = list(), ek = list(),
- ik = NULL, nsimEIM = 100, cutoff = 0.995, Maxiter=5000,
- deviance.arg = FALSE, method.init=1,
- shrinkage.init=0.95, zero = -2)
+ imu = NULL, ik = NULL, quantile.probs = 0.75,
+ nsimEIM = 100, cutoff = 0.995,
+ Maxiter = 5000, deviance.arg = FALSE, method.init = 1,
+ shrinkage.init = 0.95, zero = -2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -26,17 +27,24 @@ negbinomial(lmu = "loge", lk = "loge", emu = list(), ek = list(),
See \code{earg} in \code{\link{Links}} for general information.
}
- \item{ik}{
- Optional initial values for \eqn{k}.
- If failure to converge occurs try different values (and/or use
- \code{method.init}).
+ \item{imu, ik}{
+ Optional initial values for the mean and \eqn{k}.
+ For the latter, if failure to converge occurs then try different values
+ (and/or use \code{method.init}).
For a \eqn{S}-column response, \code{ik} can be of length \eqn{S}.
A value \code{NULL} means an initial value for each response is
computed internally using a range of values.
- This argument is ignored if used within \code{\link{cqo}}; see
+ The last argument is ignored if used within \code{\link{cqo}}; see
the \code{iKvector} argument of \code{\link{qrrvglm.control}} instead.
}
+ \item{quantile.probs}{
+ Passed into the \code{probs} argument
+ of \code{\link[stats:quantile]{quantile}}
+ when \code{method.init = 3} to obtain an initial value for the mean.
+
+ }
+
\item{nsimEIM}{
This argument is used
for computing the diagonal element of the
@@ -129,6 +137,7 @@ negbinomial(lmu = "loge", lk = "loge", emu = list(), ek = list(),
the estimated value of the \eqn{\mu}{mu} parameter, i.e., of the mean
\eqn{E(Y)}.
+
The negative binomial distribution can be coerced into the classical
GLM framework, with one of the parameters being of interest and the
other treated as a nuisance/scale parameter (and implemented in the
@@ -138,16 +147,19 @@ negbinomial(lmu = "loge", lk = "loge", emu = list(), ek = list(),
Simulated Fisher scoring is employed as the default
(see the \code{nsimEIM} argument).
+
The parameters \eqn{\mu}{mu} and \eqn{k} are independent (diagonal EIM),
and the confidence region for \eqn{k} is extremely skewed so that its
standard error is often of no practical use. The parameter \eqn{1/k}
has been used as a measure of aggregation.
+
This \pkg{VGAM} function handles \emph{multivariate} responses, so
that a matrix can be used as the response. The number of columns is the
number of species, say, and setting \code{zero=-2} means that \emph{all}
species have a \eqn{k} equalling a (different) intercept only.
+
}
\section{Warning}{
The Poisson model corresponds to \eqn{k} equalling infinity.
@@ -155,15 +167,18 @@ negbinomial(lmu = "loge", lk = "loge", emu = list(), ek = list(),
occur. Possibly choosing a log-log link may help in such cases,
otherwise use \code{\link{poissonff}}.
+
This function is fragile; the maximum likelihood estimate of the
index parameter is fraught (see Lawless, 1987). In general, the
\code{\link{quasipoissonff}} is more robust than this function.
Assigning values to the \code{ik} argument may lead to a local solution,
and smaller values are preferred over large values when using this argument.
+
Yet to do: write a family function which uses the methods of moments
estimator for \eqn{k}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -177,15 +192,18 @@ Negative binomial and mixed Poisson regression.
\emph{The Canadian Journal of Statistics}
\bold{15}, 209--225.
+
Hilbe, J. M. (2007)
\emph{Negative Binomial Regression}.
Cambridge: Cambridge University Press.
+
Bliss, C. and Fisher, R. A. (1953)
Fitting the negative binomial distribution to biological data.
\emph{Biometrics}
\bold{9}, 174--200.
+
}
\author{ Thomas W. Yee }
\note{
@@ -206,6 +224,7 @@ Fitting the negative binomial distribution to biological data.
\code{Maxiter} and
\code{cutoff} are pertinent.
+
Regardless of the algorithm used,
convergence problems may occur, especially when the response has large
outliers or is large in magnitude.
@@ -219,24 +238,29 @@ Fitting the negative binomial distribution to biological data.
\code{ik},
\code{zero}.
+
This function can be used by the fast algorithm in
\code{\link{cqo}}, however, setting \code{EqualTolerances=TRUE} and
\code{ITolerances=FALSE} is recommended.
+
% For \code{\link{cqo}} and \code{\link{cao}}, taking the square-root
% of the response means (approximately) a \code{\link{poissonff}} family
% may be used on the transformed data.
+
% If the negative binomial family function \code{\link{negbinomial}}
% is used for \code{cqo} then set \code{negbinomial(deviance=TRUE)}
% is necessary. This means to minimize the deviance, which the fast
% algorithm can handle.
+
In the first example below (Bliss and Fisher, 1953), from each of 6
McIntosh apple trees in an orchard that had been sprayed, 25 leaves
were randomly selected. On each of the leaves, the number of adult
female European red mites were counted.
+
}
\seealso{
@@ -255,23 +279,23 @@ Fitting the negative binomial distribution to biological data.
\examples{
# Example 1: apple tree data
appletree = data.frame(y = 0:7, w = c(70, 38, 17, 10, 9, 3, 2, 1))
-fit = vglm(y ~ 1, negbinomial, appletree, weights=w)
+fit = vglm(y ~ 1, negbinomial, appletree, weights = w)
summary(fit)
-coef(fit, matrix=TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
# Example 2: simulated data with multivariate response
ndata = data.frame(x = runif(nn <- 500))
-ndata = transform(ndata, y1 = rnbinom(nn, mu=exp(3+x), size=exp(1)),
- y2 = rnbinom(nn, mu=exp(2-x), size=exp(0)))
-fit1 = vglm(cbind(y1,y2) ~ x, negbinomial, ndata, trace=TRUE)
-coef(fit1, matrix=TRUE)
+ndata = transform(ndata, y1 = rnbinom(nn, mu=exp(3+x), size = exp(1)),
+ y2 = rnbinom(nn, mu=exp(2-x), size = exp(0)))
+fit1 = vglm(cbind(y1,y2) ~ x, negbinomial, ndata, trace = TRUE)
+coef(fit1, matrix = TRUE)
# Example 3: large counts so definitely use the nsimEIM argument
-ndata = transform(ndata, y3 = rnbinom(nn, mu=exp(12+x), size=exp(1)))
+ndata = transform(ndata, y3 = rnbinom(nn, mu=exp(12+x), size = exp(1)))
with(ndata, range(y3)) # Large counts
-fit2 = vglm(y3 ~ x, negbinomial(nsimEIM=100), ndata, trace=TRUE)
-coef(fit2, matrix=TRUE)
+fit2 = vglm(y3 ~ x, negbinomial(nsimEIM=100), ndata, trace = TRUE)
+coef(fit2, matrix = TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/normal1.Rd b/man/normal1.Rd
index 7ded1f7..71fcb19 100644
--- a/man/normal1.Rd
+++ b/man/normal1.Rd
@@ -59,13 +59,15 @@ New York: Wiley-Interscience, Third edition.
\author{ T. W. Yee }
\note{
- The response should be univariate. Multivariate responses are more
- generally handled using \code{gaussianff}, however this only handles
- the mean and the variance-covariance matrices are assumed known.
+ The response should be univariate. Multivariate
+ responses are more generally handled using
+ \code{\link{gaussianff}}, however this only handles
+ the mean and the variance-covariance matrices are
+ assumed known.
}
\seealso{
- \code{gaussianff},
+ \code{\link{gaussianff}},
\code{\link{posnormal1}},
\code{\link{mix2normal1}},
\code{\link{tobit}},
@@ -79,17 +81,16 @@ New York: Wiley-Interscience, Third edition.
}
\examples{
ndata = data.frame(x = rnorm(nn <- 200))
-ndata = transform(ndata, y = rnorm(nn, mean=1-3*x, sd=exp(1+0.2*x)))
-fit = vglm(y ~ x, normal1, ndata, trace=TRUE)
-coef(fit, matrix=TRUE)
+ndata = transform(ndata, y = rnorm(nn, mean = 1-3*x, sd = exp(1+0.2*x)))
+fit = vglm(y ~ x, normal1, ndata, trace = TRUE)
+coef(fit, matrix = TRUE)
-# Generate a random sample from a N(mu=theta, sigma=theta)
-# distribution with theta=10. Then estimate theta.
+# Generate data from N(mu = theta = 10, sigma = theta) and estimate theta.
theta = 10
-ndata = data.frame(y = rnorm(100, m=theta, sd=theta))
-fit = vglm(y ~ 1, normal1(lsd="identity"), ndata,
- constraints = list("(Intercept)"=rbind(1,1)))
-coef(fit, matrix=TRUE)
+ndata = data.frame(y = rnorm(100, m = theta, sd = theta))
+fit = vglm(y ~ 1, normal1(lsd = "identity"), ndata,
+ constraints = list("(Intercept)" = rbind(1, 1)))
+coef(fit, matrix = TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/notdocumentedyet.Rd b/man/notdocumentedyet.Rd
index e410d20..bb57d42 100644
--- a/man/notdocumentedyet.Rd
+++ b/man/notdocumentedyet.Rd
@@ -286,6 +286,7 @@
\alias{qtplot.default}
\alias{qtplot.lms.bcg}
\alias{qtplot.lms.bcn}
+\alias{explot.lms.bcn}
\alias{qtplot.lms.yjn}
\alias{qtplot.lms.yjn2}
\alias{qtplot.vextremes}
diff --git a/man/paralogistic.Rd b/man/paralogistic.Rd
index f761490..b5d8a33 100644
--- a/man/paralogistic.Rd
+++ b/man/paralogistic.Rd
@@ -43,6 +43,7 @@ paralogistic(link.a = "loge", link.scale = "loge", earg.a=list(),
It is the 3-parameter Singh-Maddala distribution with \eqn{a=q}.
More details can be found in Kleiber and Kotz (2003).
+
The 2-parameter paralogistic has density
\deqn{f(y) = a^2 y^{a-1} / [b^a \{1 + (y/b)^a\}^{1+a}]}{%
f(y) = a^2 y^(a-1) / [b^a (1 + (y/b)^a)^(1+a)]}
@@ -54,11 +55,13 @@ The mean is
E(Y) = b gamma(1 + 1/a) gamma(a - 1/a) / gamma(a)}
provided \eqn{a > 1}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
Kleiber, C. and Kotz, S. (2003)
diff --git a/man/pareto1.Rd b/man/pareto1.Rd
index 5d7703d..c6b0881 100644
--- a/man/pareto1.Rd
+++ b/man/pareto1.Rd
@@ -64,6 +64,7 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL,
This model is important in many applications due to the power
law probability tail, especially for large values of \eqn{y}.
+
The Pareto distribution, which is used a lot in economics,
has a probability density function that can be written
\deqn{f(y) = k \alpha^k / y^{k+1}}{%
@@ -77,6 +78,7 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL,
\eqn{\alpha^2 k /((k-1)^2 (k-2))}{alpha^2 k /((k-1)^2 (k-2))}
provided \eqn{k>2}.
+
The upper truncated Pareto distribution
has a probability density function that can be written
\deqn{f(y) = k \alpha^k / [y^{k+1} (1-(\alpha/U)^k)]}{%
@@ -115,6 +117,7 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL,
Outside of economics, the Pareto distribution is known as the Bradford
distribution.
+
For \code{pareto1},
if the estimate of \eqn{k} is less than or equal to unity
then the fitted values will be \code{NA}s.
@@ -123,6 +126,7 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL,
distributions, but there is a slight change in notation: \eqn{s=k}
and \eqn{b=\alpha}{b=alpha}.
+
In some applications the Pareto law is truncated by a
natural upper bound on the probability tail.
The upper truncated Pareto distribution has three parameters (called
@@ -152,6 +156,7 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL,
\code{\link{Tpareto}},
\code{\link{paretoIV}},
\code{\link{gpd}}.
+
}
\examples{
alpha = 2; k = exp(3)
diff --git a/man/poissonp.Rd b/man/poissonp.Rd
index 6275880..798c6ec 100644
--- a/man/poissonp.Rd
+++ b/man/poissonp.Rd
@@ -59,6 +59,7 @@ poissonp(ostatistic, dimension=2, link="loge", earg=list(),
\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}
@@ -67,6 +68,7 @@ poissonp(ostatistic, dimension=2, link="loge", earg=list(),
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.
diff --git a/man/predict.vglm.Rd b/man/predict.vglm.Rd
index 563c9c6..6bc1c56 100644
--- a/man/predict.vglm.Rd
+++ b/man/predict.vglm.Rd
@@ -10,7 +10,7 @@
predict.vglm(object, newdata = NULL,
type = c("link", "response", "terms"),
se.fit = FALSE, deriv = 0, dispersion = NULL,
- untransform=FALSE, extra = object at extra, ...)
+ untransform = FALSE, extra = object at extra, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -56,7 +56,7 @@ predict.vglm(object, newdata = NULL,
}
\item{untransform}{
Logical. Reverses any parameter link function.
- This argument only works if \code{type="link", se.fit=FALSE, deriv=0}.
+ This argument only works if \code{type = "link", se.fit = FALSE, deriv = 0}.
}
\item{\dots}{Arguments passed into \code{predict.vlm}.
@@ -91,7 +91,7 @@ Reduced-rank vector generalized linear models.
\author{ Thomas W. Yee }
\note{
- Setting \code{se.fit=TRUE} and \code{type="response"}
+ Setting \code{se.fit = TRUE} and \code{type = "response"}
will generate an error.
}
@@ -111,29 +111,29 @@ Reduced-rank vector generalized linear models.
\examples{
# Illustrates smart prediction
-pneumo = transform(pneumo, let=log(exposure.time))
+pneumo = transform(pneumo, let = log(exposure.time))
fit = vglm(cbind(normal,mild, severe) ~ poly(c(scale(let)), 2),
- propodds, data=pneumo, trace=TRUE, x=FALSE)
+ propodds, data = pneumo, trace = TRUE, x = FALSE)
class(fit)
(q0 = head(predict(fit)))
-(q1 = predict(fit, newdata=head(pneumo)))
-(q2 = predict(fit, newdata=head(pneumo)))
+(q1 = predict(fit, newdata = head(pneumo)))
+(q2 = predict(fit, newdata = head(pneumo)))
all.equal(q0, q1) # Should be TRUE
all.equal(q1, q2) # Should be TRUE
head(predict(fit))
-head(predict(fit, untransform=TRUE))
+head(predict(fit, untransform = TRUE))
-p0 = head(predict(fit, type="res"))
-p1 = head(predict(fit, type="res", newdata=pneumo))
-p2 = head(predict(fit, type="res", newdata=pneumo))
+p0 = head(predict(fit, type = "res"))
+p1 = head(predict(fit, type = "res", newdata = pneumo))
+p2 = head(predict(fit, type = "res", newdata = pneumo))
p3 = head(fitted(fit))
all.equal(p0, p1) # Should be TRUE
all.equal(p1, p2) # Should be TRUE
all.equal(p2, p3) # Should be TRUE
-predict(fit, type="terms", se=TRUE)
+predict(fit, type = "terms", se = TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/prentice74.Rd b/man/prentice74.Rd
index 6a53702..c6ea4ad 100644
--- a/man/prentice74.Rd
+++ b/man/prentice74.Rd
@@ -7,27 +7,17 @@
Prentice (1974).
}
\usage{
-prentice74(llocation="identity", lscale="loge", lshape="identity",
- elocation=list(), escale=list(), eshape=list(),
- ilocation=NULL, iscale=NULL, ishape=NULL, zero=NULL)
+prentice74(llocation = "identity", lscale = "loge", lshape = "identity",
+ elocation = list(), escale = list(), eshape = list(),
+ ilocation = NULL, iscale = NULL, ishape = NULL, zero = 2:3)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{llocation}{
+ \item{llocation, lscale, lshape}{
Parameter link function applied to the
- location parameter \eqn{a}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{lscale}{
- Parameter link function applied to the
- positive scale parameter \eqn{b}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{lshape}{
- Parameter link function applied to
- the shape parameter \eqn{q}.
+ location parameter \eqn{a},
+ positive scale parameter \eqn{b}
+ and the shape parameter \eqn{q}, respectively.
See \code{\link{Links}} for more choices.
}
@@ -49,31 +39,34 @@ prentice74(llocation="identity", lscale="loge", lshape="identity",
}
\item{zero}{
An integer-valued vector specifying which
- linear/additive predictors are modelled as intercepts only.
+ linear/additive predictors are modelled as intercepts-only.
The values must be from the set \{1,2,3\}.
- The default value means none are modelled as intercept-only terms.
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
\details{
The probability density function is given by
- \deqn{f(y;a,b,q) = |q| \exp(w/q^2 - e^w) / (b \Gamma(1/q^2)),}{%
+ \deqn{f(y;a,b,q) = |q|\,\exp(w/q^2 - e^w) / (b \, \Gamma(1/q^2)),}{%
f(y;a,b,q) = |q| * exp(w/q^2 - e^w) / (b*gamma(1/q^2)),}
for shape parameter \eqn{q \ne 0}{q != 0},
positive scale parameter \eqn{b > 0},
location parameter \eqn{a},
and all real \eqn{y}.
Here, \eqn{w = (y-a)q/b+\psi(1/q^2)}{w = (y-a)*q/b+psi(1/q^2)}
-where \eqn{\psi}{psi} is the digamma function.
+where \eqn{\psi}{psi} is the digamma function,
+\code{\link[base:Special]{digamma}}.
The mean of \eqn{Y} is \eqn{a} (returned as the fitted values).
This is a different parameterization compared to \code{\link{lgamma3ff}}.
+
Special cases:
-\eqn{q=0} is the normal distribution with standard deviation \eqn{b},
-\eqn{q=-1} is the extreme value distribution for maxima,
-\eqn{q=1} is the extreme value distribution for minima (Weibull).
-If \eqn{q>0} then the distribution is left skew,
-else \eqn{q<0} is right skew.
+\eqn{q = 0} is the normal distribution with standard deviation \eqn{b},
+\eqn{q = -1} is the extreme value distribution for maxima,
+\eqn{q = 1} is the extreme value distribution for minima (Weibull).
+If \eqn{q > 0} then the distribution is left skew,
+else \eqn{q < 0} is right skew.
+
}
@@ -90,15 +83,15 @@ else \eqn{q<0} is right skew.
}
\section{Warning }{
- The special case \eqn{q=0} is not handled, therefore
+ The special case \eqn{q = 0} is not handled, therefore
estimates of \eqn{q} too close to zero may cause numerical problems.
}
\author{ T. W. Yee }
\note{
The notation used here differs from Prentice (1974):
- \eqn{\alpha=a}{alpha=a},
- \eqn{\sigma=b}{sigma=b}.
+ \eqn{\alpha = a}{alpha = a},
+ \eqn{\sigma = b}{sigma = b}.
Fisher scoring is used.
}
@@ -108,11 +101,11 @@ else \eqn{q<0} is right skew.
}
\examples{
-pdat = data.frame(x = runif(nn <- 5000))
-pdat = transform(pdat, loc = -1 + 2*x, Scale = exp(1+x))
-pdat = transform(pdat, y = rlgamma(nn, loc=loc, scale=Scale, k=1))
-fit = vglm(y ~ x, prentice74(zero=3), pdat, trace=TRUE)
-coef(fit, matrix=TRUE) # Note the coefficients for location
+pdat = data.frame(x = runif(nn <- 1000))
+pdat = transform(pdat, loc = -1 + 2*x, Scale = exp(1))
+pdat = transform(pdat, y = rlgamma(nn, loc = loc, scale = Scale, k = 1))
+fit = vglm(y ~ x, prentice74(zero = 2:3), pdat, trace = TRUE)
+coef(fit, matrix = TRUE) # Note the coefficients for location
}
\keyword{models}
\keyword{regression}
diff --git a/man/propodds.Rd b/man/propodds.Rd
index 5f253ef..96df79f 100644
--- a/man/propodds.Rd
+++ b/man/propodds.Rd
@@ -81,6 +81,7 @@ fit at y # Sample proportions
weights(fit, type="prior") # Number of observations
coef(fit, matrix=TRUE)
constraints(fit) # Constraint matrices
+summary(fit)
# Check that the model is linear in let ----------------------
fit2 = vgam(cbind(normal, mild, severe) ~ s(let, df=2), propodds, pneumo)
diff --git a/man/qrrvglm.control.Rd b/man/qrrvglm.control.Rd
index 28cba85..6ec8968 100644
--- a/man/qrrvglm.control.Rd
+++ b/man/qrrvglm.control.Rd
@@ -10,30 +10,48 @@
}
\usage{
-qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
- checkwz=TRUE, Cinit = NULL, Crow1positive = TRUE,
- epsilon = 1.0e-06, EqualTolerances = ITolerances,
- Etamat.colmax = 10, FastAlgorithm = TRUE,
- GradientFunction=TRUE, Hstep = 0.001,
+qrrvglm.control(Rank = 1,
+ Bestof = if(length(Cinit)) 1 else 10,
+ checkwz = TRUE,
+ Cinit = NULL,
+ Crow1positive = TRUE,
+ epsilon = 1.0e-06,
+ EqualTolerances = TRUE,
+ Etamat.colmax = 10,
+ FastAlgorithm = TRUE,
+ GradientFunction = TRUE,
+ Hstep = 0.001,
isdlv = rep(c(2, 1, rep(0.5, len=Rank)), len=Rank),
- iKvector = 0.1, iShape = 0.1, ITolerances = TRUE,
- maxitl = 40, method.init = 1, Maxit.optim = 250,
- MUXfactor = rep(7, length=Rank), Norrr = ~ 1,
+ iKvector = 0.1,
+ iShape = 0.1,
+ ITolerances = FALSE,
+ maxitl = 40,
+ method.init = 1,
+ Maxit.optim = 250,
+ MUXfactor = rep(7, length=Rank),
+ Norrr = ~ 1,
optim.maxit = 20,
- Parscale = if (ITolerances) 0.001 else 1.0,
- SD.Cinit = 0.02, SmallNo = 5.0e-13, trace = TRUE,
- Use.Init.Poisson.QO=TRUE,
+ Parscale = if(ITolerances) 0.001 else 1.0,
+ SD.Cinit = 0.02,
+ SmallNo = 5.0e-13,
+ trace = TRUE,
+ Use.Init.Poisson.QO = TRUE,
wzepsilon = .Machine$double.eps^0.75, ...)
}
%- maybe also `usage' for other objects documented here.
\arguments{
+ In the following, \eqn{R} is the \code{Rank}, \eqn{M} is the number
+ of linear predictors, and \eqn{S} is the number of responses
+ (species).
+ Thus \eqn{M=S} for binomial and Poisson responses, and
+ \eqn{M=2S} for the negative binomial and 2-parameter gamma distributions.
\item{Rank}{
The numerical rank \eqn{R} of the model, i.e., the
- number of ordination axes. Must be an element from the set
+ number of ordination axes. Must be an element from the set
\{1,2,\ldots,min(\eqn{M},\eqn{p_2}{p2})\} where the vector of explanatory
variables \eqn{x} is partitioned into (\eqn{x_1},\eqn{x_2}), which is
- of dimension \eqn{p_1+p_2}{p1+p2}. The variables making up \eqn{x_1}
+ of dimension \eqn{p_1+p_2}{p1+p2}. The variables making up \eqn{x_1}
are given by the terms in the \code{Norrr} argument, and the rest
of the terms comprise \eqn{x_2}.
@@ -41,7 +59,7 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
\item{Bestof}{
Integer. The best of \code{Bestof} models fitted is returned.
This argument helps guard against local solutions by (hopefully)
- finding the global solution from many fits. The argument has value
+ finding the global solution from many fits. The argument has value
1 if an initial value for \eqn{C} is inputted using \code{Cinit}.
}
@@ -53,68 +71,70 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
}
\item{Cinit}{
Optional initial \eqn{C} matrix, which must be a \eqn{p_2}{p2} by \eqn{R}
- matrix. The default is to apply \code{.Init.Poisson.QO()} to obtain
+ matrix. The default is to apply \code{.Init.Poisson.QO()} to obtain
initial values.
}
\item{Crow1positive}{
Logical vector of length \code{Rank} (recycled if necessary): are
- the elements of the first row of \eqn{C} positive? For example,
+ the elements of the first row of \eqn{C} positive? For example,
if \code{Rank} is 4, then specifying \code{Crow1positive=c(FALSE,
TRUE)} will force \eqn{C[1,1]} and \eqn{C[1,3]} to be negative,
- and \eqn{C[1,2]} and \eqn{C[1,4]} to be positive. This argument
+ and \eqn{C[1,2]} and \eqn{C[1,4]} to be positive. This argument
allows for a reflection in the ordination axes because the
coefficients of the latent variables are unique up to a sign.
}
\item{epsilon}{
- Positive numeric. Used to test for convergence for GLMs fitted
- in FORTRAN. Larger values mean a loosening of the convergence
- criterion.
+ Positive numeric. Used to test for convergence for GLMs fitted in C.
+ Larger values mean a loosening of the convergence criterion.
If an error code of 3 is reported, try increasing this value.
}
\item{EqualTolerances}{
Logical indicating whether each (quadratic) predictor will
- have equal tolerances. Setting \code{EqualTolerances=TRUE}
+ have equal tolerances. Having \code{EqualTolerances = TRUE}
can help avoid numerical problems, especially with binary data.
Note that the estimated (common) tolerance matrix may or may
- not be positive-definite. If it is, then it can be scaled to
+ not be positive-definite. If it is then it can be scaled to
the \eqn{R} by \eqn{R} identity matrix, i.e., made equivalent
- to \code{ITolerances=TRUE}. Setting \code{ITolerances=TRUE}
+ to \code{ITolerances = TRUE}. Setting \code{ITolerances = TRUE}
will \emph{force} a common \eqn{R} by \eqn{R} identity matrix as
the tolerance matrix to the data even if it is not appropriate.
- In general, setting \code{ITolerances=TRUE} is preferred over
- \code{EqualTolerances=TRUE} because, if it works, it is much faster
- and uses less memory. See \bold{Details} for more details.
+ In general, setting \code{ITolerances = TRUE} is
+ preferred over \code{EqualTolerances = TRUE} because,
+ if it works, it is much faster and uses less memory.
+ However, \code{ITolerances = TRUE} requires the
+ environmental variables to be scaled appropriately.
+ See \bold{Details} for more details.
}
% \item{Eta.range}{ Numerical vector of length 2 or \code{NULL}.
% Gives the lower and upper bounds on the values that can be taken
% by the quadratic predictor (i.e., on the eta-scale).
-% Since \code{FastAlgorithm=TRUE}, this argument should be ignored.
+% Since \code{FastAlgorithm = TRUE}, this argument should be ignored.
% }
\item{Etamat.colmax}{
- Positive integer, no smaller than \code{Rank}. Controls the amount
- of memory used by \code{.Init.Poisson.QO()}. It is the maximum
+ Positive integer, no smaller than \code{Rank}. Controls the amount
+ of memory used by \code{.Init.Poisson.QO()}. It is the maximum
number of columns allowed for the pseudo-response and its weights.
In general, the larger the value, the better the initial value.
- Used only if \code{Use.Init.Poisson.QO=TRUE}.
+ Used only if \code{Use.Init.Poisson.QO = TRUE}.
}
\item{FastAlgorithm}{
- Logical. Whether a new fast algorithm is to be used. The fast
+ Logical. Whether a new fast algorithm is to be used. The fast
algorithm results in a large speed increases compared to Yee
- (2004). Some details of the fast algorithm are found in
- Appendix A of Yee (2006).
- Setting \code{FastAlgorithm=FALSE} will give an error.
+ (2004).
+ Some details of the fast algorithm are found in Appendix A of Yee (2006).
+ Setting \code{FastAlgorithm = FALSE} will give an error.
}
\item{GradientFunction}{
Logical. Whether \code{\link[stats]{optim}}'s argument \code{gr}
- is used or not, i.e., to compute gradient values. Used only if
- \code{FastAlgorithm} is \code{TRUE}. The default value is usually
+ is used or not, i.e., to compute gradient values. Used only if
+ \code{FastAlgorithm} is \code{TRUE}. The default value is usually
faster on most problems.
}
@@ -127,13 +147,13 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
\item{isdlv}{
Initial standard deviations for the latent variables (site scores).
Numeric, positive and of length \eqn{R} (recycled if necessary).
- This argument is used only if \code{ITolerances=TRUE}. Used by
+ This argument is used only if \code{ITolerances = TRUE}. Used by
\code{.Init.Poisson.QO()} to obtain initial values for the constrained
coefficients \eqn{C} adjusted to a reasonable value. It adjusts the
spread of the site scores relative to a common species tolerance of 1
- for each ordination axis. A value between 0.5 and 10 is recommended;
+ for each ordination axis. A value between 0.5 and 10 is recommended;
a value such as 10 means that the range of the environmental space is
- very large relative to the niche width of the species. The successive
+ very large relative to the niche width of the species. The successive
values should decrease because the first ordination axis should have
the most spread of site scores, followed by the second ordination
axis, etc.
@@ -151,14 +171,16 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
}
\item{ITolerances}{
Logical. If \code{TRUE} then the (common) tolerance matrix is the
- \eqn{R} by \eqn{R} identity matrix by definition. Note that having
- \code{ITolerances=TRUE} implies \code{EqualTolerances=TRUE}, but
- not vice versa. Internally, the quadratic terms will be treated as
+ \eqn{R} by \eqn{R} identity matrix by definition. Note that having
+ \code{ITolerances = TRUE} implies \code{EqualTolerances = TRUE}, but
+ not vice versa. Internally, the quadratic terms will be treated as
offsets (in GLM jargon) and so the models can potentially be fitted
- very efficiently. \emph{However, it is a very good idea to center all
- numerical variables in the \eqn{x_2} vector}. See \bold{Details}
- for more details. The success of \code{ITolerances=TRUE} often
- depends on suitable values for \code{isdlv} and/or \code{MUXfactor}.
+ very efficiently. \emph{However, it is a very good idea to center
+ and scale all numerical variables in the \eqn{x_2} vector}.
+ See \bold{Details} for more details.
+ The success of \code{ITolerances = TRUE} often
+ depends on suitable values for \code{isdlv} and/or
+ \code{MUXfactor}.
}
\item{maxitl}{
@@ -170,33 +192,33 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
Method of initialization. A positive integer 1 or 2 or 3 etc.
depending on the \pkg{VGAM} family function.
Currently it is used for \code{\link{negbinomial}} and
- \code{\link{gamma2}} only, and used within the FORTRAN.
+ \code{\link{gamma2}} only, and used within the C.
}
\item{Maxit.optim}{
- Positive integer. Number of iterations given to the function
+ Positive integer. Number of iterations given to the function
\code{\link[stats]{optim}} at each of the \code{optim.maxit}
iterations.
}
\item{MUXfactor}{
- Multiplication factor for detecting large offset values. Numeric,
- positive and of length \eqn{R} (recycled if necessary). This argument
- is used only if \code{ITolerances=TRUE}. Offsets are \eqn{-0.5}
+ Multiplication factor for detecting large offset values. Numeric,
+ positive and of length \eqn{R} (recycled if necessary). This argument
+ is used only if \code{ITolerances = TRUE}. Offsets are \eqn{-0.5}
multiplied by the sum of the squares of all \eqn{R} latent variable
values. If the latent variable values are too large then this will
result in numerical problems. By too large, it is meant that the
standard deviation of the latent variable values are greater than
\code{MUXfactor[r] * isdlv[r]} for \code{r=1:Rank} (this is why
centering and scaling all the numerical predictor variables in
- \eqn{x_2} is recommended). A value about 3 or 4 is recommended.
+ \eqn{x_2} is recommended). A value about 3 or 4 is recommended.
If failure to converge occurs, try a slightly lower value.
}
\item{optim.maxit}{
- Positive integer. Number of times \code{\link[stats]{optim}}
- is invoked. At iteration \code{i}, the \code{i}th value of
+ Positive integer. Number of times \code{\link[stats]{optim}}
+ is invoked. At iteration \code{i}, the \code{i}th value of
\code{Maxit.optim} is fed into \code{\link[stats]{optim}}.
}
@@ -215,7 +237,7 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
(recycled if necessary).
Passed into \code{optim(..., control=list(parscale=Parscale))};
the elements of \eqn{C} become \eqn{C} / \code{Parscale}.
- Setting \code{ITolerances=TRUE} results in line searches that
+ Setting \code{ITolerances = TRUE} results in line searches that
are very large, therefore \eqn{C} has to be scaled accordingly
to avoid large step sizes.
See \bold{Details} for more information.
@@ -234,7 +256,7 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
each iteration. The default is \code{TRUE} because the
calculations are numerically intensive, meaning it may take
a long time, so that the user might think the computer has
- locked up if \code{trace=FALSE}.
+ locked up if \code{trace = FALSE}.
}
@@ -249,7 +271,7 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
% are to be zeroed. These linear predictors will correspond to
% a RR-VGLM.
% The values must be elements from the set \{1,2,\ldots,\eqn{M}\}.
-% Used only if \code{Quadratic=TRUE} and \code{FastAlgorithm=FALSE}.
+% Used only if \code{Quadratic = TRUE} and \code{FastAlgorithm = FALSE}.
% }
\item{SmallNo}{
Positive numeric between \code{.Machine$double.eps} and \code{0.0001}.
@@ -266,15 +288,9 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
weight matrices are sufficiently positive.
}
-\item{\dots}{ Ignored at present. }
+\item{\dots}{ Ignored at present. }
}
\details{
- In this help file \eqn{R} is the \code{Rank}, \eqn{M} is the number
- of linear predictors, and \eqn{S} is the number of responses (species).
- Thus \eqn{M=S} for binomial and Poisson responses, and
- \eqn{M=2S} for the negative binomial and 2-parameter gamma distributions.
-
-
Recall that the central formula for CQO is
\deqn{\eta = B_1^T x_1 + A \nu +
\sum_{m=1}^M (\nu^T D_m \nu) e_m}{%
@@ -287,6 +303,7 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
QRR-VGLMs are an extension of RR-VGLMs and allow for maximum
likelihood solutions to constrained quadratic ordination (CQO) models.
+
% For the fitting of QRR-VGLMs, the default is that the \eqn{C} matrix
% (containing the \emph{canonical} or \emph{constrained coefficients}
% corresponding to \eqn{x_2})
@@ -295,49 +312,54 @@ qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
% unit variance and uncorrelated. The tolerance matrices are, in
% general, diagonal under such a constraint.
- Having \code{ITolerances=TRUE} means all the tolerance matrices
+
+ Having \code{ITolerances = TRUE} means all the tolerance matrices
are the order-\eqn{R} identity matrix, i.e., it \emph{forces}
bell-shaped curves/surfaces on all species. This results in a
more difficult optimization problem (especially for 2-parameter
models such as the negative binomial and gamma) because of overflow
- errors and it appears there are more local solutions. To help avoid
+ errors and it appears there are more local solutions. To help avoid
the overflow errors, scaling \eqn{C} by the factor \code{Parscale}
- can help enormously. Even better, scaling \eqn{C} by specifying
- \code{isdlv} is more understandable to humans. If failure to
+ can help enormously. Even better, scaling \eqn{C} by specifying
+ \code{isdlv} is more understandable to humans. If failure to
converge occurs, try adjusting \code{Parscale}, or better, setting
- \code{EqualTolerances=TRUE} (and hope that the estimated tolerance
- matrix is positive-definite). To fit an equal-tolerances model, it
- is firstly best to try setting \code{ITolerances=TRUE} and varying
+ \code{EqualTolerances = TRUE} (and hope that the estimated tolerance
+ matrix is positive-definite). To fit an equal-tolerances model, it
+ is firstly best to try setting \code{ITolerances = TRUE} and varying
\code{isdlv} and/or \code{MUXfactor} if it fails to converge.
If it still fails to converge after many attempts, try setting
- \code{EqualTolerances=TRUE}, however this will usually be a lot slower
+ \code{EqualTolerances = TRUE}, however this will usually be a lot slower
because it requires a lot more memory.
- With a \eqn{R>1} model, the latent variables are always uncorrelated,
+
+ With a \eqn{R > 1} model, the latent variables are always uncorrelated,
i.e., the variance-covariance matrix of the site scores is a diagonal
matrix.
- If setting \code{EqualTolerances=TRUE} is used and the common
+
+ If setting \code{EqualTolerances = TRUE} is used and the common
estimated tolerance matrix is positive-definite then that model is
- effectively the same as the \code{ITolerances=TRUE} model (the two are
- transformations of each other). In general, \code{ITolerances=TRUE}
+ effectively the same as the \code{ITolerances = TRUE} model (the two are
+ transformations of each other). In general, \code{ITolerances = TRUE}
is numerically more unstable and presents a more difficult problem
to optimize; the arguments \code{isdlv} and/or \code{MUXfactor} often
must be assigned some good value(s) (possibly found by trial and error)
- in order for convergence to occur. Setting \code{ITolerances=TRUE}
+ in order for convergence to occur. Setting \code{ITolerances = TRUE}
\emph{forces} a bell-shaped curve or surface onto all the species data,
- therefore this option should be used with deliberation. If unsuitable,
- the resulting fit may be very misleading. Usually it is a good idea
- for the user to set \code{EqualTolerances=FALSE} to see which species
+ therefore this option should be used with deliberation. If unsuitable,
+ the resulting fit may be very misleading. Usually it is a good idea
+ for the user to set \code{EqualTolerances = FALSE} to see which species
appear to have a bell-shaped curve or surface. Improvements to the
fit can often be achieved using transformations, e.g., nitrogen
concentration to log nitrogen concentration.
+
Fitting a CAO model (see \code{\link{cao}}) first is a good idea for
pre-examining the data and checking whether it is appropriate to fit
a CQO model.
-%Suppose \code{FastAlgorithm = FALSE}. In theory (if
+
+%Suppose \code{FastAlgorithm = FALSE}. In theory (if
%\code{Eta.range=NULL}), for QRR-VGLMs, the predictors have the values of
%a quadratic form. However, when \code{Eta.range} is assigned a numerical
%vector of length 2 (giving the endpoints of an interval), then those
@@ -370,28 +392,32 @@ Constrained additive ordination.
}
\author{ Thomas W. Yee }
\note{
- When \code{ITolerances=TRUE} it is a good idea to apply
+ When \code{ITolerances = TRUE} it is a good idea to apply
\code{\link[base]{scale}} to all the numerical variables that make up
the latent variable, i.e., those of \eqn{x_2}{x_2}. This is to make
them have mean 0, and hence avoid large offset values which cause
numerical problems.
+
This function has many arguments that are common with
\code{\link{rrvglm.control}} and \code{\link{vglm.control}}.
+
It is usually a good idea to try fitting a model with
- \code{ITolerances=TRUE} first, and if convergence is unsuccessful,
- then try \code{EqualTolerances=TRUE} and \code{ITolerances=FALSE}.
+ \code{ITolerances = TRUE} first, and if convergence is unsuccessful,
+ then try \code{EqualTolerances = TRUE} and \code{ITolerances = FALSE}.
Ordination diagrams with
- \code{EqualTolerances=TRUE} have a natural interpretation, but
- with \code{EqualTolerances=FALSE} they are more complicated and
+ \code{EqualTolerances = TRUE} have a natural interpretation, but
+ with \code{EqualTolerances = FALSE} they are more complicated and
requires, e.g., contours to be overlaid on the ordination diagram
(see \code{\link{lvplot.qrrvglm}}).
+
% and/or use the \code{Eta.range} argument.
+
In the example below, an equal-tolerances CQO model is fitted to the
- hunting spiders data. Because \code{ITolerances=TRUE}, it is a good idea
+ hunting spiders data. Because \code{ITolerances = TRUE}, it is a good idea
to center all the \eqn{x_2} variables first. Upon fitting the model,
the actual standard deviation of the site scores are computed. Ideally,
the \code{isdlv} argument should have had this value for the best
@@ -401,9 +427,10 @@ Constrained additive ordination.
\section{Warning }{
-The default value of \code{Bestof} is a bare minimum for many datasets,
-therefore it will be necessary to increase its value to increase the
-chances of obtaining the global solution.
+ The default value of \code{Bestof} is a bare minimum for many datasets,
+ therefore it will be necessary to increase its value to increase the
+ chances of obtaining the global solution.
+
%Suppose \code{FastAlgorithm = FALSE}.
%The fitted values of QRR-VGLMs can be restricted to lie between two values
@@ -434,7 +461,34 @@ chances of obtaining the global solution.
\examples{
# Poisson CQO with equal tolerances
set.seed(111) # This leads to the global solution
-hspider[,1:6]=scale(hspider[,1:6]) # Good idea when ITolerances = TRUE
+hspider[,1:6] = scale(hspider[,1:6]) # Good idea when ITolerances = TRUE
+p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
+ Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ quasipoissonff, data = hspider, EqualTolerances = TRUE)
+sort(p1 at misc$deviance.Bestof) # A history of all the iterations
+
+(isdlv = sd(lv(p1))) # Should be approx isdlv
+
+# Refit the model with better initial values
+set.seed(111) # This leads to the global solution
+p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
+ Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ ITolerances = TRUE, isdlv = isdlv, # Note the use of isdlv here
+ fam = quasipoissonff, data = hspider)
+sort(p1 at misc$deviance.Bestof) # A history of all the iterations
+
+# Negative binomial CQO; smallest deviance is about 275.389
+set.seed(1234) # This leads to a reasonable (but not the global) solution?
+nb1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
+ Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ ITol = FALSE, EqualTol = TRUE, # A good idea for negbinomial
+ fam = negbinomial, data = hspider)
+sort(nb1 at misc$deviance.Bestof) # A history of all the iterations
+summary(nb1)
+\dontrun{ lvplot(nb1, lcol=1:12, y = TRUE, pcol=1:12) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/rayleigh.Rd b/man/rayleigh.Rd
index 9175604..f8b6374 100644
--- a/man/rayleigh.Rd
+++ b/man/rayleigh.Rd
@@ -82,6 +82,7 @@ A related distribution is the Maxwell distribution.
\code{\link{Rayleigh}},
\code{\link{riceff}},
\code{\link{maxwell}}.
+
}
\examples{
n = 1000; a = exp(2)
diff --git a/man/rcqo.Rd b/man/rcqo.Rd
index 07ebe1c..9fdeff0 100644
--- a/man/rcqo.Rd
+++ b/man/rcqo.Rd
@@ -16,7 +16,7 @@ rcqo(n, p, S, Rank = 1,
sdOptima = ifelse(ESOptima, 1.5/Rank, 1) * ifelse(scalelv, sdlv, 1),
sdTolerances = 0.25, Kvector = 1, Shape = 1,
sqrt = FALSE, Log = FALSE, rhox = 0.5, breaks = 4,
- seed = NULL, Crow1positive=TRUE, xmat = NULL, scalelv = TRUE)
+ seed = NULL, Crow1positive = TRUE, xmat = NULL, scalelv = TRUE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -109,18 +109,18 @@ rcqo(n, p, S, Rank = 1,
}
\item{sdOptima}{
Numeric, of length \eqn{R} (recycled if necessary).
- If \code{ESOptima=FALSE} then,
+ If \code{ESOptima = FALSE} then,
for the \eqn{r}th latent variable axis,
the optima of the species are generated from a
normal distribution centered about 0.
- If \code{ESOptima=TRUE} then the \eqn{S} optima
+ If \code{ESOptima = TRUE} then the \eqn{S} optima
are equally spaced about 0 along every latent variable axis.
Regardless of the value of \code{ESOptima}, the optima
are then scaled to give standard deviation \code{sdOptima[r]}.
}
\item{sdTolerances}{
- Logical. If \code{EqualTolerances=FALSE} then, for the
+ Logical. If \code{EqualTolerances = FALSE} then, for the
\eqn{r}th latent variable, the
species' tolerances are
chosen from a normal distribution with mean 1 and
@@ -153,7 +153,7 @@ rcqo(n, p, S, Rank = 1,
}
\item{sqrt}{
Logical. Take the square-root of the negative binomial counts?
- Assigning \code{sqrt=TRUE} when \code{family="negbinomial"} means
+ Assigning \code{sqrt = TRUE} when \code{family="negbinomial"} means
that the resulting species data can be considered very crudely to be
approximately Poisson distributed.
They will not integers in general but much easier (less numerical
@@ -162,7 +162,7 @@ rcqo(n, p, S, Rank = 1,
}
\item{Log}{
Logical. Take the logarithm of the gamma random variates?
- Assigning \code{Log=TRUE} when \code{family="gamma2"} means
+ Assigning \code{Log = TRUE} when \code{family="gamma2"} means
that the resulting species data can be considered very crudely to be
approximately Gaussian distributed about its (quadratic) mean.
The result is that it is much easier (less numerical
@@ -201,7 +201,7 @@ rcqo(n, p, S, Rank = 1,
}
\item{xmat}{
The
- \eqn{n \times (p-1)}{n * (p-1)}
+ \eqn{n} by \eqn{p-1}
environmental matrix can be inputted.
}
@@ -228,8 +228,7 @@ rcqo(n, p, S, Rank = 1,
and if \code{family} is binomial or ordinal then it is converted into
these forms.
- In CQO theory the \eqn{n \times p}{n * p}
- matrix \eqn{X} is partitioned
+ In CQO theory the \eqn{n} by \eqn{p} matrix \eqn{X} is partitioned
into two parts \eqn{X_1} and \eqn{X_2}. The matrix
\eqn{X_2} contains the `real' environmental variables whereas
the variables in \eqn{X_1} are just for adjustment purposes;
@@ -241,13 +240,13 @@ rcqo(n, p, S, Rank = 1,
}
\value{
- A \eqn{n \times (p-1+S)}{n * (p-1+S)} data frame with
+ A \eqn{n} by \eqn{p-1+S} data frame with
components and attributes.
In the following the attributes are labelled with double
quotes.
\item{x2, x3, x4, \ldots, xp}{
The environmental variables. This makes up the
- \eqn{n \times (p-1)}{n * (p-1)} \eqn{X_2} matrix.
+ \eqn{n} by \eqn{p-1} \eqn{X_2} matrix.
Note that \code{x1} is not present; it is effectively a vector
of ones since it corresponds to an intercept term when
\code{\link{cqo}} is applied to the data.
@@ -255,13 +254,13 @@ rcqo(n, p, S, Rank = 1,
}
\item{y1, y2, x3, \ldots, yS}{
The species data. This makes up the
- \eqn{n \times S}{n * S} matrix \eqn{Y}.
+ \eqn{n} by \eqn{S} matrix \eqn{Y}.
This will be of the form described by the argument
\code{family}.
}
\item{"ccoefficients"}{
- The \eqn{(p-1) \times R}{(p-1) * R} matrix of
+ The \eqn{p-1} by \eqn{R} matrix of
constrained coefficients
(or canonical coefficients).
These are also known as weights or loadings.
@@ -281,7 +280,7 @@ rcqo(n, p, S, Rank = 1,
}
\item{"lv"}{
- The \eqn{n \times R}{n * R} matrix of site scores.
+ The \eqn{n} by \eqn{R} matrix of site scores.
Each successive column (latent variable) has
sample standard deviation
equal to successive values of \code{sdlv}.
@@ -292,11 +291,11 @@ rcqo(n, p, S, Rank = 1,
}
\item{"optima"}{
- The \eqn{S \times R}{S * R} matrix of species' optima.
+ The \eqn{S} by \eqn{R} matrix of species' optima.
}
\item{"tolerances"}{
- The \eqn{S \times R}{S * R} matrix of species' tolerances.
+ The \eqn{S} by \eqn{R} matrix of species' tolerances.
These are the
square root of the diagonal elements of the tolerance matrices
(recall that all tolerance matrices are restricted to being
@@ -318,10 +317,12 @@ canonical Gaussian ordination.
\emph{Ecological Monographs},
\bold{74}, 685--701.
+
Yee, T. W. (2006)
Constrained additive ordination.
\emph{Ecology}, \bold{87}, 203--213.
+
ter Braak, C. J. F. and Prentice, I. C. (1988)
A theory of gradient analysis.
\emph{Advances in Ecological Research},
@@ -333,6 +334,7 @@ A theory of gradient analysis.
This function is under development and is not finished yet.
There may be a few bugs.
+
Yet to do: add an argument that allows absences to be equal
to the first level if ordinal data is requested.
@@ -345,15 +347,53 @@ A theory of gradient analysis.
\code{\link{poissonff}},
\code{\link{negbinomial}},
\code{\link{gamma2}},
- \code{gaussianff}.
+ \code{\link{gaussianff}}.
+
}
-\examples{
+\examples{
# Example 1: Species packing model:
n = 100; p = 5; S = 5
-mydata = rcqo(n, p, S, ESOpt=TRUE, EqualMax=TRUE)
+mydata = rcqo(n, p, S, ESOpt = TRUE, EqualMax = TRUE)
names(mydata)
+(myform = attr(mydata, "formula"))
+fit = cqo(myform, poissonff, mydata, Bestof = 3) # EqualTol = TRUE
+\dontrun{
+matplot(attr(mydata, "lv"), mydata[,-(1:(p-1))], col=1:S)
+persp(fit, col=1:S, add = TRUE)
+lvplot(fit, lcol=1:S, y = TRUE, pcol=1:S) # The same plot as above
+}
+
+# Compare the fitted model with the 'truth'
+ccoef(fit) # The fitted model
+attr(mydata, "ccoefficients") # The 'truth'
+
+c(sd(attr(mydata, "lv")), sd(lv(fit))) # Both values should be approx equal
+
+
+# Example 2: negative binomial data fitted using a Poisson model:
+n = 200; p = 5; S = 5
+mydata = rcqo(n, p, S, fam="negbin", sqrt = TRUE)
myform = attr(mydata, "formula")
+fit = cqo(myform, fam=poissonff, dat=mydata) # ITol = TRUE,
+\dontrun{
+lvplot(fit, lcol=1:S, y = TRUE, pcol=1:S) }
+# Compare the fitted model with the 'truth'
+ccoef(fit) # The fitted model
+attr(mydata, "ccoefficients") # The 'truth'
+
+
+# Example 3: gamma2 data fitted using a Gaussian model:
+n = 200; p = 5; S = 3
+mydata = rcqo(n, p, S, fam="gamma2", Log = TRUE)
+fit = cqo(attr(mydata, "formula"), fam=gaussianff, dat=mydata) # ITol=TRUE,
+\dontrun{
+matplot(attr(mydata, "lv"), exp(mydata[,-(1:(p-1))]), col=1:S) # 'raw' data
+lvplot(fit, lcol=1:S, y=TRUE, pcol=1:S) # Fitted model to transformed data
+}
+# Compare the fitted model with the 'truth'
+ccoef(fit) # The fitted model
+attr(mydata, "ccoefficients") # The 'truth'
}
\keyword{distribution}
diff --git a/man/riceff.Rd b/man/riceff.Rd
index b72811a..e37767c 100644
--- a/man/riceff.Rd
+++ b/man/riceff.Rd
@@ -42,14 +42,17 @@ riceff(lvee="loge", lsigma="loge", evee=list(), esigma=list(),
}{%
f(y;v,sigma) =
(y/sigma^2) * exp(-(y^2+v^2) / (2*sigma^2)) * I_0(y*v/sigma^2)}
- where \eqn{y>0},
+ where \eqn{y > 0},
\eqn{v > 0},
\eqn{\sigma > 0} and \eqn{I_0} is the modified Bessel function of the
first kind with order zero.
- When \eqn{v=0} the Rice distribution reduces to a Rayleigh distribution.
+ When \eqn{v = 0} the Rice distribution reduces to a Rayleigh distribution.
The mean is
- \eqn{\sigma \sqrt{\pi/2} \exp(z/2) ((1-z) I_0(-z/2)-z I_1(-z/2))}{sigma*sqrt(pi/2)*exp(z/2)*((1-z)*I_0(-z/2)-z*I_1(-z/2))}
- (returned as the fitted values) where \eqn{z=-v^2/(2 \sigma^2)}{z=-v^2/(2*sigma^2)}.
+ \eqn{\sigma \sqrt{\pi/2} \exp(z/2)
+ ((1-z) I_0(-z/2)-z I_1(-z/2))}{sigma*sqrt(pi/2) *
+ exp(z/2)*((1-z) * I_0(-z/2)-z*I_1(-z/2))}
+ (returned as the fitted values) where
+ \eqn{z=-v^2/(2 \sigma^2)}{z=-v^2/(2*sigma^2)}.
Simulated Fisher scoring is implemented.
}
diff --git a/man/rrvglm.Rd b/man/rrvglm.Rd
index 0c7b539..10e6724 100644
--- a/man/rrvglm.Rd
+++ b/man/rrvglm.Rd
@@ -69,6 +69,7 @@ rrvglm(formula, family, data = list(), weights = NULL, subset = NULL,
starting values for the linear predictors.
It is a \eqn{M}-column matrix.
If \eqn{M=1} then it may be a vector.
+
}
\item{mustart}{
starting values for the fitted values. It can be a vector or a matrix.
@@ -156,35 +157,43 @@ rrvglm(formula, family, data = list(), weights = NULL, subset = NULL,
eta = B_1^T x_1 + A nu}
where \eqn{x_1}{x1} is a vector (usually just a 1 for an intercept),
\eqn{x_2}{x2} is another vector of explanatory variables, and
- \eqn{\nu=C^T x_2}{nu=C^T x_2} is an \eqn{R}-vector of
+ \eqn{\nu = C^T x_2}{nu = C^T x_2} is an \eqn{R}-vector of
latent variables.
- Here, \eqn{\eta}{eta} is a vector of linear predictors, e.g., the
- \eqn{m}th element is \eqn{\eta_m = \log(E[Y_m])}{eta_m = log(E[Y_m])}
- for the \eqn{m}th Poisson response. The matrices \eqn{B_1}, \eqn{A}
- and \eqn{C} are estimated from the data, i.e., contain the regression
- coefficients. For ecologists, the central formula represents a
- \emph{constrained linear ordination} (CLO) since it is linear in
- the latent variables. It means that the response is a monotonically
- increasing or decreasing function of the latent variables.
-
- The underlying algorithm of RR-VGLMs is iteratively reweighted least
- squares (IRLS) with an optimizing algorithm applied within each IRLS
- iteration (e.g., alternating algorithm).
+ Here, \eqn{\eta}{eta} is a vector of linear predictors,
+ e.g., the \eqn{m}th element is
+ \eqn{\eta_m = \log(E[Y_m])}{eta_m = log(E[Y_m])} for the \eqn{m}th
+ Poisson response. The matrices \eqn{B_1}, \eqn{A} and
+ \eqn{C} are estimated from the data, i.e., contain the
+ regression coefficients. For ecologists, the central
+ formula represents a \emph{constrained linear ordination}
+ (CLO) since it is linear in the latent variables. It
+ means that the response is a monotonically increasing or
+ decreasing function of the latent variables.
+
+
+ The underlying algorithm of RR-VGLMs is iteratively
+ reweighted least squares (IRLS) with an optimizing
+ algorithm applied within each IRLS iteration (e.g.,
+ alternating algorithm).
+
In theory, any \pkg{VGAM} family function that works for
- \code{\link{vglm}} and \code{\link{vgam}} should work for \code{rrvglm}
- too.
+ \code{\link{vglm}} and \code{\link{vgam}} should work
+ for \code{rrvglm} too.
+
+
+ \code{rrvglm.fit} is the function that actually does the work.
+ It is \code{vglm.fit} with some extra code.
- \code{rrvglm.fit} is the function that actually does the work. It is
- \code{vglm.fit} with some extra code.
}
\value{
- An object of class \code{"rrvglm"}, which has the the same slots as
- a \code{"vglm"} object. The only difference is that the some of the
- constraint matrices are estimates rather than known. But \pkg{VGAM}
- stores the models the same internally. The slots of \code{"vglm"}
- objects are described in \code{\link{vglm-class}}.
+ An object of class \code{"rrvglm"}, which has the the same
+ slots as a \code{"vglm"} object. The only difference is
+ that the some of the constraint matrices are estimates
+ rather than known. But \pkg{VGAM} stores the models the
+ same internally. The slots of \code{"vglm"} objects are
+ described in \code{\link{vglm-class}}.
}
\references{
@@ -194,17 +203,20 @@ Reduced-rank vector generalized linear models.
\emph{Statistical Modelling},
\bold{3}, 15--41.
+
Yee, T. W. (2004)
A new technique for maximum-likelihood
canonical Gaussian ordination.
\emph{Ecological Monographs},
\bold{74}, 685--701.
+
Anderson, J. A. (1984)
Regression and ordered categorical variables.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{46}, 1--30.
+
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
contains further information and examples.
@@ -213,33 +225,43 @@ Regression and ordered categorical variables.
\author{ Thomas W. Yee }
\note{
- The smart prediction (\code{\link{smartpred}}) library is packed with
- the \pkg{VGAM} library.
+ The smart prediction (\code{\link{smartpred}}) library
+ is packed with the \pkg{VGAM} library.
- The arguments of \code{rrvglm} are the same as those of
- \code{\link{vglm}} but with some extras in \code{\link{rrvglm.control}}.
- In the example below, a rank-1 \emph{stereotype} model of Anderson (1984)
- is fitted to some car data. The reduced-rank regression is performed,
- adjusting for two covariates. Setting a trivial constraint matrix for
- the latent variable variables in \eqn{x_2}{x2} avoids a warning message
- when it is overwritten by a (common) estimated constraint matrix.
- It shows that German cars tend to be more expensive than American cars,
- given a car of fixed weight and width.
+ The arguments of \code{rrvglm} are the same as
+ those of \code{\link{vglm}} but with some extras in
+ \code{\link{rrvglm.control}}.
- If \code{fit <- rrvglm(..., data=mydata)} then \code{summary(fit)}
- requires corner constraints and no missing values in \code{mydata}.
- Often the estimated variance-covariance matrix of the parameters is
- not positive-definite; if this occurs, try refitting the model with
- a different value for \code{Index.corner}.
- For \emph{constrained quadratic ordination} (CQO) see \code{\link{cqo}}
- for more details about QRR-VGLMs.
+ In the example below, a rank-1 \emph{stereotype}
+ model of Anderson (1984) is fitted to some car data.
+ The reduced-rank regression is performed, adjusting for
+ two covariates. Setting a trivial constraint matrix for
+ the latent variable variables in \eqn{x_2}{x2} avoids
+ a warning message when it is overwritten by a (common)
+ estimated constraint matrix. It shows that German cars
+ tend to be more expensive than American cars, given a
+ car of fixed weight and width.
+
+
+ If \code{fit <- rrvglm(..., data=mydata)} then
+ \code{summary(fit)} requires corner constraints and no
+ missing values in \code{mydata}. Often the estimated
+ variance-covariance matrix of the parameters is not
+ positive-definite; if this occurs, try refitting the
+ model with a different value for \code{Index.corner}.
+
+
+ For \emph{constrained quadratic ordination} (CQO) see
+ \code{\link{cqo}} for more details about QRR-VGLMs.
+
With multivariate binary responses, one must use
- \code{binomialff(mv=TRUE)} to indicate that the response (matrix)
- is multivariate. Otherwise, it is interpreted as a single binary
- response variable.
+ \code{binomialff(mv=TRUE)} to indicate that the response
+ (matrix) is multivariate. Otherwise, it is interpreted
+ as a single binary response variable.
+
}
@@ -263,31 +285,47 @@ Regression and ordered categorical variables.
\code{\link{Coef.rrvglm}},
\code{summary.rrvglm},
etc.
+
}
\examples{
+# Example 1: negative binomial with Var(Y) = mu + mu^s2, s2 unknown
+nn = 500
+s2 = 1.5 # Specify this
+c2 = 2 - s2
+ndata = data.frame(x2 = runif(nn), x3 = runif(nn))
+ndata = transform(ndata, mu = exp(2 + 1 * x2 + 0 * x3))
+ndata = transform(ndata, y2 = rnbinom(nn, mu=mu, size=mu^c2))
+\dontrun{plot(y2 ~ x2, data = ndata, pch = "+", col = 'blue',
+ main=paste("Var(Y) = mu + mu^", s2, sep="")) }
+Fit2 = rrvglm(y2 ~ x2 + x3, negbinomial(zero = NULL),
+ data = ndata, Norrr = NULL)
+c2hat = (Coef(Fit2)@A)["log(k)", 1]
+s2hat = 2 - c2hat
+s2hat # Estimate of s2
+
+
+# Example 2
data(car.all)
index = with(car.all, Country == "Germany" | Country == "USA" |
- Country == "Japan" | Country == "Korea")
+ Country == "Japan" | Country == "Korea")
scar = car.all[index, ] # standardized car data
fcols = c(13,14,18:20,22:26,29:31,33,34,36) # These are factors
scar[,-fcols] = scale(scar[,-fcols]) # Standardize all numerical vars
ones = matrix(1, 3, 1)
-cms = list("(Intercept)"=diag(3), Width=ones, Weight=ones,
- Disp.=diag(3), Tank=diag(3), Price=diag(3),
- Frt.Leg.Room=diag(3))
+cms = list("(Intercept)" = diag(3), Width = ones, Weight = ones,
+ Disp. = diag(3), Tank = diag(3), Price = diag(3),
+ Frt.Leg.Room = diag(3))
set.seed(111)
fit = rrvglm(Country ~ Width + Weight + Disp. + Tank + Price + Frt.Leg.Room,
multinomial, data = scar, Rank = 2, trace = TRUE,
- constraints=cms, Norrr = ~ 1 + Width + Weight,
- Uncor=TRUE, Corner=FALSE, Bestof=2)
+ constraints = cms, Norrr = ~ 1 + Width + Weight,
+ Uncor = TRUE, Corner = FALSE, Bestof = 2)
fit at misc$deviance # A history of the fits
Coef(fit)
-\dontrun{
-biplot(fit, chull=TRUE, scores=TRUE, clty=2, ccol="blue", scol="red",
- Ccol="darkgreen", Clwd=2, Ccex=2,
- main="1=Germany, 2=Japan, 3=Korea, 4=USA")
-}
+\dontrun{ biplot(fit, chull = TRUE, scores = TRUE, clty = 2, Ccex = 2,
+ ccol = "blue", scol = "red", Ccol = "darkgreen", Clwd = 2,
+ main = "1=Germany, 2=Japan, 3=Korea, 4=USA") }
}
\keyword{models}
\keyword{regression}
diff --git a/man/rrvglm.control.Rd b/man/rrvglm.control.Rd
index 45dc667..2cf2a56 100644
--- a/man/rrvglm.control.Rd
+++ b/man/rrvglm.control.Rd
@@ -11,9 +11,9 @@ rrvglm.control(Rank = 1, Algorithm = c("alternating", "derivative"),
Corner = TRUE, Uncorrelated.lv = FALSE, Wmat = NULL, Svd.arg = FALSE,
Index.corner = if (length(Structural.zero))
head((1:1000)[-Structural.zero], Rank) else 1:Rank,
- Alpha = 0.5, Bestof = 1, Cinit = NULL,
+ Ainit = NULL, Alpha = 0.5, Bestof = 1, Cinit = NULL,
Etamat.colmax = 10,
- SD.Cinit = 0.02, Structural.zero = NULL,
+ SD.Ainit = 0.02, SD.Cinit = 0.02, Structural.zero = NULL,
Norrr = ~1, trace = FALSE, Use.Init.Poisson.QO = FALSE,
checkwz = TRUE, wzepsilon = .Machine$double.eps^0.75, ...)
}
@@ -83,9 +83,9 @@ rrvglm.control(Rank = 1, Algorithm = c("alternating", "derivative"),
i.e., when \bold{C} is \emph{not} passed in as initial values.
}
- \item{Cinit}{
- Initial \bold{C} matrix which may speed up convergence.
- It must be of the correct dimension.
+ \item{Ainit, Cinit}{
+ Initial \bold{A} and \bold{C} matrices which may speed up convergence.
+ They must be of the correct dimension.
}
\item{Etamat.colmax}{
@@ -106,19 +106,23 @@ rrvglm.control(Rank = 1, Algorithm = c("alternating", "derivative"),
Integer vector specifying which rows
of the constraint matrices are to be all zeros.
}
- \item{SD.Cinit}{
+ \item{SD.Ainit, SD.Cinit}{
Standard deviation of the initial values for the elements
- of \bold{C}.
+ of \bold{A} and \bold{C}.
These are normally distributed with mean zero.
This argument is used only if \code{Use.Init.Poisson.QO = FALSE}.
+
}
% \item{ppar}{ Ignore this. }
\item{Norrr}{
- Formula giving terms that are not to be included in the reduced-rank
- regression. These variables constitute the \eqn{\bold{B}_1}{\bold{B}1}
- matrix in the Yee and Hastie paper. Those variables which
- are subject to the reduced-rank regression correspond to the
- \eqn{\bold{B}_2}{\bold{B}2} matrix.
+ Formula giving terms that are \emph{not} to be included
+ in the reduced-rank regression. These variables constitute
+ the \eqn{\bold{B}_1}{\bold{B}1} matrix in the Yee and Hastie
+ paper. Those variables which are subject to the reduced-rank
+ regression correspond to the \eqn{\bold{B}_2}{\bold{B}2}
+ matrix.
+ Set \code{Norrr = NULL} for the reduced-rank regression to
+ be applied to every explanatory variable including the intercept.
}
\item{trace}{
diff --git a/man/seq2binomial.Rd b/man/seq2binomial.Rd
index 60acea9..17556e1 100644
--- a/man/seq2binomial.Rd
+++ b/man/seq2binomial.Rd
@@ -58,6 +58,7 @@ seq2binomial(lprob1 = "logit", lprob2 = "logit", eprob1 = list(),
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.
@@ -86,6 +87,9 @@ seq2binomial(lprob1 = "logit", lprob2 = "logit", eprob1 = list(),
and \code{\link{vgam}}.
The fitted value is a two-column matrix of estimated probabilities
\eqn{p} and \eqn{q}.
+ A common form of error is when there are no trials
+ for \eqn{y_1}{y1}, e.g., if \code{mvector} below has some values
+ which are zero.
}
@@ -94,17 +98,18 @@ seq2binomial(lprob1 = "logit", lprob2 = "logit", eprob1 = list(),
}
\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)
+sdata = data.frame(mvector = round(rnorm(nn <- 100, m = 10, sd = 2)),
+ x = runif(nn))
+sdata = transform(sdata, prob1 = logit(+2 - x, inverse = TRUE),
+ prob2 = logit(-2 + x, inverse = TRUE))
+sdata = transform(sdata, successes1 = rbinom(nn, size=mvector, prob=prob1))
+sdata = transform(sdata, successes2 = rbinom(nn, size=successes1, prob=prob2))
+sdata = transform(sdata, y1 = successes1 / mvector)
+sdata = transform(sdata, y2 = successes2 / successes1)
+fit = vglm(cbind(y1,y2) ~ x, seq2binomial, weight=mvector,
+ data = sdata, trace=TRUE)
coef(fit)
-coef(fit, mat=TRUE)
+coef(fit, matrix = TRUE)
head(fitted(fit))
}
\keyword{models}
diff --git a/man/simplex.Rd b/man/simplex.Rd
index b031c80..49f1e05 100644
--- a/man/simplex.Rd
+++ b/man/simplex.Rd
@@ -1,26 +1,24 @@
\name{simplex}
\alias{simplex}
%- Also NEED an '\alias' for EACH other topic documented here.
-\title{ Simplex distribution }
+\title{ Simplex Distribution Family Function }
\description{
- The two parameters of the univariate simplex distribution are estimated.
+ The two parameters of the univariate standard simplex
+ distribution are estimated by full maximum likelihood
+ estimation.
+
}
\usage{
simplex(lmu = "logit", lsigma = "loge", emu=list(), esigma=list(),
- imu = NULL, isigma = NULL)
+ imu = NULL, isigma = NULL,
+ method.init = 1, shrinkage.init = 0.95, zero = 2)
+
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lmu}{
- Link function for \code{mu}.
- See \code{\link{Links}} for more choices.
- The parameter lies in the unit interval.
-
- }
- \item{lsigma}{
- Link function for \code{sigma}.
+ \item{lmu, lsigma}{
+ Link function for \code{mu} and \code{sigma}.
See \code{\link{Links}} for more choices.
- The parameter is positive, therefore the log link is the default.
}
\item{emu, esigma}{
@@ -33,38 +31,81 @@ simplex(lmu = "logit", lsigma = "loge", emu=list(), esigma=list(),
A \code{NULL} means a value is obtained internally.
}
+ \item{method.init, shrinkage.init, zero}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
}
\details{
- See Jorgensen (1997) for details.
+ The probability density function can be written
+ \deqn{f(y; \mu, \sigma) = [2 \pi \sigma^2 (y (1-y))^3]^{-0.5}
+ \exp[-0.5 (y-\mu)^2 / (\sigma^2 y (1-y) \mu^2 (1-\mu)^2)]
+ }{%
+ f(y; mu, sigma) = [2* pi * sigma^2 * (y*(1-y))^3]^(-0.5) *
+ exp[-0.5 * (y-mu)^2 / (sigma^2 * y * (1-y) * mu^2 * (1-mu)^2)] }
+ for \eqn{0 < y < 1},
+ \eqn{0 < \mu < 1}{0 < mu < 1},
+ and \eqn{\sigma > 0}{sigma > 0}.
+ The mean of \eqn{Y} is \eqn{\mu}{mu} (called \code{mu}, and
+ returned as the fitted values).
+
+
+% This comes from Jorgensen but it is not confirmed by simulations:
+% The variance of \eqn{Y} is \eqn{\mu (1 - \mu) - \sqrt{ \lambda / 2}
+% \exp\{ \lambda / (\mu^2 (1 - \mu)^2) \}
+% \Gamma(\lambda / (2 \mu^2 (1 - \mu)^2), 0.5)}{
+% mu * (1 - mu) - sqrt(lambda / 2) *
+% exp(lambda / (mu^2 * (1 - mu)^2)) *
+% Gamma(lambda / (2 * mu^2 * (1 - mu)^2), 0.5)}.
+% Here, \eqn{\Gamma(x, a)}{Gamma(x, a)} is the
+% `upper' normalized incomplete gamma function given by
+% \code{pgamma(x, a, lower = FALSE) * gamma(a)}.
+
+
+ The second parameter, \code{sigma}, of this standard simplex
+ distribution is known as the dispersion parameter.
+ The unit variance function is
+ \eqn{V(\mu) = \mu^3 (1-\mu)^3}{V(mu) = mu^3 (1-mu)^3}.
+ Fisher scoring is applied to both parameters.
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
-Jorgensen, B. (1997)
-\emph{The Theory of Dispersion Models}.
-London: Chapman & Hall
+ Jorgensen, B. (1997)
+ \emph{The Theory of Dispersion Models}.
+ London: Chapman & Hall
+
+ Song, P. X.-K. (2007)
+ \emph{Correlated Data Analysis: Modeling, Analytics, and Applications}.
+ Springer.
+
}
\author{ T. W. Yee }
\note{
This distribution is potentially useful for dispersion modelling.
- This family function only works for intercept-only models, i.e.,
- the formula should have \code{~ 1}.
+ Numerical problems may occur when \code{mu} is very close to 0 or 1.
}
\seealso{
- \code{\link{rig}}.
+ \code{\link{dsimplex}},
+ \code{\link{dirichlet}},
+ \code{\link{rig}},
+ \code{\link{binomialff}}.
+
}
\examples{
-x = runif(n <- 100)
-y = rbeta(n, shape1=3+x, shape2=4-x)
-(fit = vglm(y ~ 1, simplex, trace=TRUE, cri="coef"))
-coef(fit, matrix=TRUE)
-Coef(fit)
+nn = 1000
+sdata = data.frame(x = runif(nn))
+sdata = transform(sdata, y = rsimplex(nn, mu = logit(1+2*x, inverse = TRUE),
+ dispersion = exp(1 - 2*x)))
+(fit = vglm(y ~ x, simplex(zero = NULL), sdata, trace = TRUE))
+coef(fit, matrix = TRUE)
summary(fit)
}
\keyword{models}
@@ -72,8 +113,6 @@ summary(fit)
-% zz fitted values and formulas needed here
-
diff --git a/man/simplexUC.Rd b/man/simplexUC.Rd
new file mode 100644
index 0000000..6a5196d
--- /dev/null
+++ b/man/simplexUC.Rd
@@ -0,0 +1,72 @@
+\name{Simplex }
+\alias{dsimplex}
+\alias{psimplex}
+\alias{qsimplex}
+\alias{rsimplex}
+\title{ Simplex Distribution }
+\description{
+ Density function,
+ and random generation for the simplex distribution.
+
+}
+\usage{
+dsimplex(x, mu = 0.5, dispersion = 1, log = FALSE)
+rsimplex(n, mu = 0.5, dispersion = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{
+ Vector of quantiles.
+ The support of the distribution is the interval \eqn{(0,1)}.
+
+ }
+ \item{mu, dispersion}{Mean and dispersion parameters.
+ The former lies in the interval \eqn{(0,1)} and the latter is positive.
+
+ }
+ \item{n, log}{Same usage as \code{\link[stats:Uniform]{runif}}.}
+}
+\details{
+
+ The \pkg{VGAM} family function \code{\link{simplex}} fits this model;
+ see that online help for more information.
+ For \code{rsimplex()} the rejection method is used;
+ it may be very slow if the density is highly peaked,
+ and will fail if the density asymptotes at the boundary.
+
+}
+\value{
+ \code{dsimplex(x)} gives the density function,
+ \code{rsimplex(n)} gives \eqn{n} random variates.
+
+}
+% \references{
+%
+%}
+\author{ T. W. Yee }
+
+\seealso{
+ \code{\link{simplex}}.
+
+}
+
+\examples{
+sigma = c(4, 2, 1) # Dispersion parameter
+mymu = c(.1, .5, .7); xxx = seq(0, 1, len = 501)
+\dontrun{ par(mfrow=c(3,3)) # Figure 2.1 of Song (2007)
+for(iii in 1:3)
+ for(jjj in 1:3) {
+ plot(xxx, dsimplex(xxx, mymu[jjj], sigma[iii]),
+ type = "l", col = "blue", xlab = "", ylab = "", main =
+ paste("mu = ", mymu[jjj], ", sigma = ", sigma[iii], sep = "")) } }
+}
+\keyword{distribution}
+
+% mean(rsimplex(1000, mymu[2], sigma[2])) # Should be mu below
+% var(rsimplex(1000, mymu[2], sigma[2])) # Should be as below
+% (mu <- mymu[2])
+% lambda <- (1 / sigma[2])^2
+% mu * (1 - mu) - sqrt(lambda / 2) * exp(lambda / (mu^2 * (1 - mu)^2)) *
+% pgamma(lambda / (2 * mu^2 * (1 - mu)^2), 0.5, lower = FALSE) * gamma(0.5)
+
+
diff --git a/man/sinmad.Rd b/man/sinmad.Rd
index c3f999a..2ac9161 100644
--- a/man/sinmad.Rd
+++ b/man/sinmad.Rd
@@ -8,7 +8,7 @@
}
\usage{
sinmad(link.a = "loge", link.scale = "loge", link.q = "loge",
- earg.a=list(), earg.scale=list(), earg.q=list(),
+ earg.a = list(), earg.scale = list(), earg.q = list(),
init.a = NULL, init.scale = NULL, init.q = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -44,10 +44,12 @@ just the Burr distribution), Pareto IV,
beta-P, and generalized log-logistic distribution.
More details can be found in Kleiber and Kotz (2003).
+
Some distributions which are special cases of the 3-parameter Singh-Maddala
are the Lomax (\eqn{a=1}), Fisk (\eqn{q=1}), and
paralogistic (\eqn{a=q}).
+
The Singh-Maddala distribution has density
\deqn{f(y) = aq y^{a-1} / [b^a \{1 + (y/b)^a\}^{1+q}]}{%
f(y) = aq y^(a-1) / [b^a (1 + (y/b)^a)^(1+q)]}
@@ -62,6 +64,7 @@ The mean is
E(Y) = b gamma(1 + 1/a) gamma(q - 1/a) / gamma(q)}
provided \eqn{-a < 1 < aq}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -94,6 +97,7 @@ default value is not \code{NULL}.
\code{\link{lomax}},
\code{\link{paralogistic}},
\code{\link{invparalogistic}}.
+
}
\examples{
diff --git a/man/vgam.Rd b/man/vgam.Rd
index a013d98..ba85130 100644
--- a/man/vgam.Rd
+++ b/man/vgam.Rd
@@ -70,19 +70,8 @@ vgam(formula, family, data = list(), weights = NULL, subset = NULL,
The ``factory-fresh'' default is \code{na.omit}.
}
- \item{etastart}{
- starting values for the linear/additive predictors.
- It is a \eqn{M}-column matrix. If \eqn{M=1} then it may be a vector.
-
- }
- \item{mustart}{
- starting values for the
- fitted values. It can be a vector or a matrix.
- Some family functions do not make use of this argument.
-
- }
- \item{coefstart}{
- starting values for the coefficient vector.
+ \item{etastart, mustart, coefstart}{
+ Same as for \code{\link{vglm}}.
}
\item{control}{
diff --git a/man/vglm.Rd b/man/vglm.Rd
index a4a2d16..5f5ea29 100644
--- a/man/vglm.Rd
+++ b/man/vglm.Rd
@@ -68,17 +68,25 @@ vglm(formula, family, data = list(), weights = NULL, subset = NULL,
}
\item{etastart}{
starting values for the linear predictors.
- It is a \eqn{M}-column matrix. If \eqn{M=1} then it may be a vector.
+ It is a \eqn{M}-column matrix with the same number of rows as the response.
+ If \eqn{M=1} then it may be a vector.
+ Note that \code{etastart} and the output of \code{predict(fit)}
+ should be comparable.
+ Here, \code{fit} is the fitted object.
}
\item{mustart}{
- starting values for the
- fitted values. It can be a vector or a matrix.
+ starting values for the fitted values.
+ It can be a vector or a matrix;
+ if a matrix, then it has the same number of rows as the response.
+ Usually \code{mustart} and the output of \code{fitted(fit)}
+ should be comparable.
Some family functions do not make use of this argument.
}
\item{coefstart}{
starting values for the coefficient vector.
+ The length and order must match that of \code{coef(fit)}.
}
\item{control}{
@@ -87,8 +95,9 @@ vglm(formula, family, data = list(), weights = NULL, subset = NULL,
}
\item{offset}{
- a vector or \eqn{M}-column matrix of offset values. These are \emph{a
- priori} known and are added to the linear predictors during fitting.
+ a vector or \eqn{M}-column matrix of offset values.
+ These are \emph{a priori} known and are added to the linear predictors
+ during fitting.
}
\item{method}{
@@ -178,9 +187,10 @@ vglm(formula, family, data = list(), weights = NULL, subset = NULL,
\eqn{\eta=(\eta_1,\ldots,\eta_M)^T}{eta=(eta_1,\ldots,\eta_M)^T}
as a vector of linear predictors.
+
Most users will find \code{vglm} similar in flavour to
- \code{\link[stats]{glm}}. The function \code{vglm.fit} actually does
- the work.
+ \code{\link[stats]{glm}}.
+ The function \code{vglm.fit} actually does the work.
% If more than one of \code{etastart}, \code{start} and \code{mustart}
% is specified, the first in the list will be used.
@@ -285,6 +295,7 @@ The \code{VGAM} Package.
A third step is to make use of arguments such as \code{etastart},
\code{coefstart} and \code{mustart}.
+
Some \pkg{VGAM} family functions end in \code{"ff"} to avoid
interference with other functions, e.g., \code{\link{binomialff}},
\code{\link{poissonff}}, \code{\link{gaussianff}},
@@ -293,13 +304,16 @@ The \code{VGAM} Package.
(and also \code{\link[gam]{gam}} in the \pkg{gam} library and
\code{\link[mgcv]{gam}} in the \pkg{mgcv} library).
+
The smart prediction (\code{\link{smartpred}}) library is incorporated
within the \pkg{VGAM} library.
+
The theory behind the scaling parameter is currently being made more
rigorous, but it it should give the same value as the scale parameter
for GLMs.
+
In Example 5 below, the \code{xij} argument to illustrate covariates
that are specific to a linear predictor. Here, \code{lop}/\code{rop} are
the ocular pressures of the left/right eye (artificial data).
@@ -311,6 +325,7 @@ The \code{VGAM} Package.
\code{\link{fill}}
for more details and examples.
+
}
%~Make other sections like WARNING with \section{WARNING }{....} ~
@@ -330,6 +345,7 @@ The \code{VGAM} Package.
\code{summary.vglm},
\code{AIC.vglm},
etc.
+
}
\examples{
diff --git a/man/vonmises.Rd b/man/vonmises.Rd
index 98eda8e..6f0be1d 100644
--- a/man/vonmises.Rd
+++ b/man/vonmises.Rd
@@ -96,6 +96,7 @@ vonmises(llocation="elogit", lscale="loge",
Evans, M., Hastings, N. and Peacock, B. (2000)
\emph{Statistical Distributions},
New York: Wiley-Interscience, Third edition.
+
}
\author{ T. W. Yee }
\note{
@@ -123,7 +124,7 @@ New York: Wiley-Interscience, Third edition.
}
\examples{
vdata = data.frame(x = runif(nn <- 1000))
-vdata = transform(vdata, y = rnorm(nn, m=2+x, sd=exp(0.2))) # Not good data!!
+vdata = transform(vdata, y = rnorm(nn, m=2+x, sd=exp(0.2))) # Bad data!!
fit = vglm(y ~ x, vonmises(zero=2), vdata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
diff --git a/man/vsmooth.spline.Rd b/man/vsmooth.spline.Rd
index 92c0735..9c19d50 100644
--- a/man/vsmooth.spline.Rd
+++ b/man/vsmooth.spline.Rd
@@ -6,10 +6,11 @@
Fits a vector cubic smoothing spline.
}
\usage{
-vsmooth.spline(x, y, w, df = rep(5, M), spar = NULL, all.knots = FALSE,
+vsmooth.spline(x, y, w = NULL, df = rep(5, M), spar = NULL, all.knots = FALSE,
iconstraint = diag(M), xconstraint = diag(M),
constraints = list("(Intercepts)" = diag(M), x = diag(M)),
- tol.nl = 0.01, var.arg = FALSE, scale.w = TRUE, nk = NULL)
+ var.arg = FALSE, scale.w = TRUE, nk = NULL,
+ control.spar = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -94,11 +95,6 @@ intercept and \code{x} respectively. They must both be a
\code{M}-row constraint matrix with full column rank.
}
- \item{tol.nl}{ Tolerance for testing nonlinearity for the
-component functions. If \code{df} is within \code{tol.nl} of
-2 then the function is treated as linear.
-
-}
\item{var.arg}{ Logical: return the pointwise variances
of the fit?
Currently, this corresponds only to the nonlinear part of the
@@ -116,6 +112,10 @@ If used, this argument overrides \code{all.knots}, and
must lie between 6 and \code{n}+2 inclusive.
}
+ \item{control.spar}{
+See \code{\link[stats]{smooth.spline}}.
+
+}
}
\details{
The algorithm implemented is detailed in Yee (2000).
@@ -129,6 +129,7 @@ must lie between 6 and \code{n}+2 inclusive.
\value{
An object of class \code{"vsmooth.spline"} (see
\code{vsmooth.spline-class}).
+
}
\references{
Yee, T. W. (2000)
@@ -141,13 +142,15 @@ Heidelberg: Physica-Verlag.
}
\author{ Thomas W. Yee }
\note{
- This function is quite similar to \code{\link[stats]{smooth.spline}}.
- For \code{M=1}, the results will be generally different, mainly due to
- the different way the knots are selected.
+ This function is quite similar to \code{\link[stats]{smooth.spline}}
+ but offers less functionality.
+ For example, cross validation is not implemented here.
+ For \code{M = 1}, the results will be generally different,
+ mainly due to the different way the knots are selected.
The vector cubic smoothing spline which \code{s()} represents is
- computationally demanding for large \eqn{M}. The cost is approximately
- \eqn{O(M^3)}.
+ computationally demanding for large \eqn{M}.
+ The cost is approximately \eqn{O(M^3)}.
Yet to be done: return the \emph{unscaled} smoothing parameters.
@@ -160,18 +163,18 @@ Heidelberg: Physica-Verlag.
\code{iam},
\code{\link[VGAM]{s}},
\code{\link[stats]{smooth.spline}}.
+
}
\examples{
-n = 20
-x = 2 + 5*(n:1)/n
+nn = 20; x = 2 + 5*(nn:1)/nn
x[2:4] = x[5:7] # Allow duplication
-y1 = sin(x) + rnorm(n, sd=0.13)
-y2 = cos(x) + rnorm(n, sd=0.13)
-y3 = 1 + sin(x) + rnorm(n, sd=0.13) # Run this for constraints
+y1 = sin(x) + rnorm(nn, sd=0.13)
+y2 = cos(x) + rnorm(nn, sd=0.13)
+y3 = 1 + sin(x) + rnorm(nn, sd=0.13) # Run this for constraints
y = cbind(y1, y2, y3)
-ww = cbind(rep(3,n), 4, (1:n)/n)
+ww = cbind(rep(3,nn), 4, (1:nn)/nn)
-(fit = vsmooth.spline(x, y, w=ww, df=5))
+(fit = vsmooth.spline(x, y, w = ww, df = 5))
\dontrun{
plot(fit) # The 1st and 3rd functions do not differ by a constant
}
@@ -180,20 +183,17 @@ mat = matrix(c(1,0,1, 0,1,0), 3, 2)
(fit2 = vsmooth.spline(x, y, w=ww, df=5, iconstr=mat, xconstr=mat))
# The 1st and 3rd functions do differ by a constant:
mycols = c("red","blue","red")
-\dontrun{
-plot(fit2, lcol=mycols, pcol=mycols, las=1)
-}
+\dontrun{ plot(fit2, lcol=mycols, pcol=mycols, las=1) }
p = predict(fit, x=fit at x, deriv=0)
max(abs(fit at y - with(p, y))) # Should be zero
par(mfrow=c(3,1))
-ux = seq(1, 8, len=100)
+ux = seq(1, 8, len = 100)
for(d in 1:3) {
- p = predict(fit, x=ux, deriv=d)
-\dontrun{
- with(p, matplot(x, y, type="l", main=paste("deriv =", d), lwd=2))
-}
+ p = predict(fit, x=ux, deriv = d)
+\dontrun{with(p, matplot(x, y, type="l", main=paste("deriv =", d), lwd=2,
+ ylab="", cex.axis=1.5, cex.lab=1.5, cex.main=1.5))}
}
}
\keyword{regression}
diff --git a/man/weibull.Rd b/man/weibull.Rd
index d45fa44..1d69162 100644
--- a/man/weibull.Rd
+++ b/man/weibull.Rd
@@ -10,8 +10,7 @@
\usage{
weibull(lshape = "loge", lscale = "loge",
eshape = list(), escale = list(),
- ishape = NULL, iscale = NULL,
- nrfs = 1, imethod=1, zero = 2)
+ ishape = NULL, iscale = NULL, nrfs = 1, imethod=1, zero = 2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -70,6 +69,7 @@ weibull(lshape = "loge", 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 currently does not handle
censored data.
Fisher scoring is used to estimate the two parameters.
@@ -82,6 +82,7 @@ weibull(lshape = "loge", lscale = "loge",
One can enforce \eqn{a>2} by choosing \code{lshape = "logoff"}
and \code{eshape=list(offset=-2)}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -94,10 +95,12 @@ Kleiber, C. and Kotz, S. (2003)
\emph{Statistical Size Distributions in Economics and Actuarial Sciences},
Hoboken, NJ: Wiley-Interscience.
+
Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1994)
\emph{Continuous Univariate Distributions},
2nd edition, Volume 1, New York: Wiley.
+
Gupta, R. D. and Kundu, D. (2006)
On the comparison of Fisher information of the
Weibull and GE distributions,
@@ -105,6 +108,7 @@ Weibull and GE distributions,
\bold{136},
3130--3144.
+
}
\author{ T. W. Yee }
\note{
@@ -112,6 +116,7 @@ Weibull and GE distributions,
values. If the initial values chosen by this function are not good,
make use the two initial value arguments.
+
The Weibull distribution is often an alternative to the lognormal
distribution. The inverse Weibull distribution, which is that of
\eqn{1/Y} where \eqn{Y} has a Weibull(\eqn{a,b}) distribution, is
@@ -125,6 +130,7 @@ Weibull and GE distributions,
\code{\link{SurvS4}} as input.
It should be released in later versions of \pkg{VGAM}.
+
If the shape parameter is less than two then misleading inference may
result, e.g., in the \code{summary} and \code{vcov} of the object.
@@ -138,10 +144,10 @@ Weibull and GE distributions,
}
\examples{
# Complete data
-x = runif(n <- 1000)
-y = rweibull(n, shape=exp(1+x), scale = exp(-0.5))
-fit = vglm(y ~ x, weibull, trace=TRUE)
-coef(fit, mat=TRUE)
+wdata = data.frame(x = runif(nn <- 1000))
+wdata = transform(wdata, y = rweibull(nn, shape = exp(1+x), scale = exp(-2)))
+fit = vglm(y ~ x, weibull, wdata, trace = TRUE)
+coef(fit, mat = TRUE)
vcov(fit)
summary(fit)
}
diff --git a/man/yulesimon.Rd b/man/yulesimon.Rd
index fed28ee..472eb85 100644
--- a/man/yulesimon.Rd
+++ b/man/yulesimon.Rd
@@ -32,7 +32,8 @@ yulesimon(link="loge", earg=list(), irho=NULL, nsimEIM=200)
The probability function is
\deqn{f(y;\rho) = rho*beta(y,rho+1),}{%
f(y;rho) = rho*beta(y,rho+1),}
- where the parameter \eqn{\rho>0}{rho>0}
+ where the parameter \eqn{\rho>0}{rho>0},
+ \eqn{beta} is the \code{\link[base]{beta}} function,
and \eqn{y=1,2,\ldots}{y=1,2,...}.
The function \code{\link{dyules}} computes this probability function.
The mean of \eqn{Y}, which is returned as fitted values, is
diff --git a/man/zanegbinomial.Rd b/man/zanegbinomial.Rd
index 870e7f1..a8ce3c0 100644
--- a/man/zanegbinomial.Rd
+++ b/man/zanegbinomial.Rd
@@ -9,10 +9,10 @@
}
\usage{
-zanegbinomial(lp0="logit", lmunb = "loge", lk = "loge",
- ep0=list(), emunb =list(), ek = list(), ipnb0 = NULL,
- ik = NULL, zero = -3, cutoff = 0.995, method.init=1,
- shrinkage.init=0.95)
+zanegbinomial(lp0 = "logit", lmunb = "loge", lk = "loge",
+ ep0 = list(), emunb =list(), ek = list(), ipnb0 = NULL,
+ ik = NULL, zero = -3, cutoff = 0.995, method.init = 1,
+ shrinkage.init = 0.95)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -153,16 +153,16 @@ for counts with extra zeros.
}
\examples{
-zdata = data.frame(x = runif(nn <- 2000))
-zdata = transform(zdata, p0 = logit(-1 + 2*x, inverse=TRUE),
- y1 = rposnegbin(nn, munb=exp(0+2*x), size=exp(1)),
- y2 = rposnegbin(nn, munb=exp(1+2*x), size=exp(1)))
-zdata = transform(zdata, y1 = ifelse(runif(nn) < p0, 0, y1),
- y2 = ifelse(runif(nn) < p0, 0, y2))
+zdata <- data.frame(x = runif(nn <- 2000))
+zdata <- transform(zdata, p0 = logit(-1 + 2*x, inverse=TRUE),
+ y1 = rposnegbin(nn, munb=exp(0+2*x), size=exp(1)),
+ y2 = rposnegbin(nn, munb=exp(1+2*x), size=exp(1)))
+zdata <- transform(zdata, y1 = ifelse(runif(nn) < p0, 0, y1),
+ y2 = ifelse(runif(nn) < p0, 0, y2))
with(zdata, table(y1))
with(zdata, table(y2))
-fit = vglm(cbind(y1,y2) ~ x, zanegbinomial, zdata, trace=TRUE)
+fit <- vglm(cbind(y1,y2) ~ x, zanegbinomial, zdata, trace=TRUE)
coef(fit, matrix=TRUE)
head(fitted(fit))
head(predict(fit))
diff --git a/man/zetaff.Rd b/man/zetaff.Rd
index 5f2abe3..bff8e35 100644
--- a/man/zetaff.Rd
+++ b/man/zetaff.Rd
@@ -93,7 +93,7 @@ Boca Raton: Chapman & Hall/CRC Press.
zdata = data.frame(y = 1:5, w = c(63, 14, 5, 1, 2)) # Knight, p.304
fit = vglm(y ~ 1, zetaff, zdata, trace=TRUE, wei=w, crit="c")
(phat = Coef(fit)) # 1.682557
-with(zdata, cbind(dzeta(y, phat) * sum(w), w))
+with(zdata, cbind(round(dzeta(y, phat) * sum(w), 1), w))
with(zdata, weighted.mean(y, w))
fitted(fit, mat=FALSE)
diff --git a/man/zipoisson.Rd b/man/zipoisson.Rd
index 62cbe3f..cd9edf2 100644
--- a/man/zipoisson.Rd
+++ b/man/zipoisson.Rd
@@ -140,8 +140,8 @@ zipoisson(lphi="logit", llambda = "loge", ephi=list(), elambda =list(),
}
\examples{
zipdat = data.frame(x = runif(nn <- 2000))
-zipdat = transform(zipdat, phi = logit(-0.5 + 1*x, inverse=TRUE),
- lambda = loge(0.5 + 2*x, inverse=TRUE))
+zipdat = transform(zipdat, phi = logit(-0.5 + 1*x, inverse=TRUE),
+ lambda = loge( 0.5 + 2*x, inverse=TRUE))
zipdat = transform(zipdat, y = rzipois(nn, lambda, phi))
with(zipdat, table(y))
fit = vglm(y ~ x, zipoisson, zipdat, trace=TRUE)
diff --git a/src/caqo3.c b/src/caqo3.c
new file mode 100644
index 0000000..aac8551
--- /dev/null
+++ b/src/caqo3.c
@@ -0,0 +1,2640 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#include<math.h>
+#include<stdio.h>
+#include<stdlib.h>
+#include<R.h>
+#include<Rmath.h>
+
+void yiumjq3npnm1or(double *objzgdk0, double *lfu2qhid);
+void yiumjq3npnm1ow(double objzgdk0[], double lfu2qhid[], int *f8yswcat);
+void yiumjq3nn2howibc2a(double *objzgdk0, double *i9mwnvqt, double *lfu2qhid);
+void yiumjq3nbewf1pzv9(double *objzgdk0, double *lfu2qhid);
+void yiumjq3ng2vwexyk9(double *objzgdk0, double *lfu2qhid);
+void yiumjq3npkc4ejib(double w8znmyce[], double zshtfg8c[], double m0ibglfx[],
+ int *ftnjamu2, int *wy1vqfzu, int *br5ovgcj, int *xlpjcg3s,
+ int *vtsou9pz, int *hj3ftvzu, int *qfx3vhct, int *unhycz0e,
+ double vm4xjosb[]);
+void yiumjq3nnipyajc1(double m0ibglfx[], double t8hwvalr[], int *ftnjamu2, int *wy1vqfzu,
+ int *afpc0kns, int *qfx3vhct, int *hj3ftvzu);
+void yiumjq3nshjlwft5(int *qfx3vhct, double tlgduey8[], double ufgqj9ck[],
+ double t8hwvalr[], int *ftnjamu2, int *wy1vqfzu, int *afpc0kns,
+ int *kvowz9ht, double m0ibglfx[], double *jxacz5qu, int *hj3ftvzu,
+ double *dn3iasxug, double *vsoihn1r, int *dqk5muto);
+void yiumjq3nflncwkfq76(double lncwkfq7[], double w8znmyce[], int *ftnjamu2,
+ int *br5ovgcj, int *xwdf5ltg, int *qfx3vhct);
+void yiumjq3nflncwkfq71(double lncwkfq7[], double w8znmyce[], int *ftnjamu2,
+ int *xwdf5ltg, int *qfx3vhct, double vm4xjosb[], int *br5ovgcj,
+ int *xlpjcg3s,
+ double kifxa0he[], int *yru9olks, int *unhycz0e);
+void yiumjq3nflncwkfq72(double lncwkfq7[], double w8znmyce[], int *ftnjamu2, int *wy1vqfzu,
+ int *br5ovgcj, int *xwdf5ltg, int *qfx3vhct, int *afpc0kns,
+ int *fmzq7aob, int *eu3oxvyb,
+ int *unhycz0e, double vm4xjosb[]);
+void yiumjq3nietam6(double tlgduey8[], double m0ibglfx[], double y7sdgtqi[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *qfx3vhct,
+ int *hj3ftvzu, double ufgqj9ck[], int *wr0lbopv);
+void yiumjq3ndlgpwe0c(double tlgduey8[], double ufgqj9ck[], double m0ibglfx[],
+ double t8hwvalr[], double ghz9vuba[], double rbne6ouj[],
+ double wpuarq2m[], double *rsynp1go, double *dn3iasxug, double *uaf2xgqy,
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *hj3ftvzu, int *qfx3vhct, int *zjkrtol8, int *unhycz0e, double vm4xjosb[]);
+void cqo_2(double lncwkfq7[], double tlgduey8[], double kifxa0he[],
+ double ufgqj9ck[], double m0ibglfx[], double vm4xjosb[],
+ double t8hwvalr[], double ghz9vuba[], double rbne6ouj[],
+ double wpuarq2m[], double w8znmyce[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *zjkrtol8, int xui7hqwl[],
+ double *tlq9wpes, double zshtfg8c[],
+ double y7sdgtqi[]);
+void cqo_1(double lncwkfq7[], double tlgduey8[], double kifxa0he[],
+ double ufgqj9ck[], double m0ibglfx[], double vm4xjosb[],
+ double t8hwvalr[], double ghz9vuba[], double rbne6ouj[],
+ double wpuarq2m[], double w8znmyce[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *zjkrtol8, int xui7hqwl[],
+ double *tlq9wpes, double zshtfg8c[],
+ double y7sdgtqi[]);
+void vcao6(double lncwkfq7[], double tlgduey8[], double ufgqj9ck[],
+ double m0ibglfx[], double t8hwvalr[], double ghz9vuba[],
+ double rbne6ouj[], double wpuarq2m[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *zjkrtol8, int xui7hqwl[],
+ double *tlq9wpes, double zshtfg8c[],
+ double y7sdgtqi[], int psdvgce3[], int *qfozcl5b,
+ double hdnw2fts[], double lamvec[], double wbkq9zyi[],
+ int ezlgm2up[], int lqsahu0r[], int which[],
+ double kispwgx3[],
+ double mbvnaor6[],
+ double hjm2ktyr[],
+ int jnxpuym2[], int hnpt1zym[],
+ int iz2nbfjc[],
+ double ifys6woa[], double rpyis2kc[], double gkdx5jals[],
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[]);
+void dcqo1(double lncwkfq7[], double tlgduey8[], double kifxa0he[],
+ double ufgqj9ck[], double m0ibglfx[], double vm4xjosb[],
+ double t8hwvalr[], double ghz9vuba[], double rbne6ouj[],
+ double wpuarq2m[], double w8znmyce[], double vc6hatuj[],
+ double fasrkub3[], int ges1xpkr[], int *ftnjamu2, int *wy1vqfzu,
+ int *afpc0kns, int *br5ovgcj, int *npjlv3mr, int *zjkrtol8,
+ int xui7hqwl[], double *tlq9wpes, double zshtfg8c[],
+ double y7sdgtqi[],
+ double atujnxb8[],
+ double k7hulceq[], int *eoviz2fb,
+ double kpzavbj3mat[], double *ydcnh9xl);
+void vdcao6(double lncwkfq7[], double tlgduey8[], double ufgqj9ck[],
+ double m0ibglfx[], double t8hwvalr[], double ghz9vuba[],
+ double rbne6ouj[], double wpuarq2m[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *zjkrtol8, int xui7hqwl[],
+ double *tlq9wpes, double zshtfg8c[],
+ double y7sdgtqi[],
+ double atujnxb8[],
+ double k7hulceq[],
+ int *eoviz2fb, double kpzavbj3mat[],
+ double ajul8wkv[],
+ int psdvgce3[], int *qfozcl5b,
+ double hdnw2fts[], double lamvec[], double wbkq9zyi[],
+ int ezlgm2up[], int lqsahu0r[], int which[],
+ double kispwgx3[],
+ double mbvnaor6[],
+ double hjm2ktyr[],
+ int jnxpuym2[], int hnpt1zym[],
+ int iz2nbfjc[],
+ double ifys6woa[],
+ double rpyis2kc[], double gkdx5jals[],
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[]);
+
+double fvlmz9iyC_tldz5ion(double xx);
+void fvlmz9iyC_qpsedg8x(int tgiyxdw1[], int dufozmt7[], int *wy1vqfzu);
+void fvlmz9iyC_enbin9(double lfu2qhid[], double hdqsx7bk[], double nm0eljqk[],
+ double *n2kersmx, int *f8yswcat, int *dvhw1ulq, int *zy1mchbf,
+ double *ux3nadiw, double *rsynp1go, int *sguwj9ty);
+
+void Yee_vbfa(int psdvgce3[], double *doubvec, double he7mqnvy[], double tlgduey8[],
+ double rbne6ouj[], double hdnw2fts[], double lamvec[], double wbkq9zyi[],
+ int ezlgm2up[], int lqsahu0r[], int which[],
+ double kispwgx3[], double m0ibglfx[],
+ double zshtfg8c[], double ui8ysltq[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ double wpuarq2m[], double hjm2ktyr[],
+ int ulm3dvzg[], int hnpt1zym[], int iz2nbfjc[],
+ double ifys6woa[],
+ double rpyis2kc[], double gkdx5jals[],
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[]);
+
+
+
+
+void F77_NAME(vqrdca)(double*, int*, int*, int*, double*, int*,
+ double*, int*, double*);
+void F77_NAME(vdqrsl)(double*, int*, int*, int*, double*, double*, double*,
+ double*, double*, double*, double*, int*, int*);
+
+void tyee_C_vdgam1(double*, double*, int*);
+void tyee_C_vtgam1(double*, double*, int*);
+
+
+void yiumjq3nn2howibc2a(double *objzgdk0, double *i9mwnvqt, double *lfu2qhid) {
+
+ double pq0hfucn, xd4mybgj;
+
+
+ if (1.0e0 - *objzgdk0 >= 1.0e0) {
+ *lfu2qhid = -8.12589e0 / (3.0 * sqrt(*i9mwnvqt));
+ } else
+ if (1.0e0 - *objzgdk0 <= 0.0e0) {
+ *lfu2qhid = 8.12589e0 / (3.0 * sqrt(*i9mwnvqt));
+ } else {
+ pq0hfucn = 1.0e0 - *objzgdk0;
+ yiumjq3npnm1or(&pq0hfucn, &xd4mybgj);
+ xd4mybgj /= 3.0e0 * sqrt(*i9mwnvqt);
+ *lfu2qhid = -3.0e0 * log(1.0e0 + xd4mybgj);
+ }
+}
+
+
+void yiumjq3nbewf1pzv9(double *objzgdk0, double *lfu2qhid) {
+
+ double pq0hfucn, xd4mybgj;
+
+ if (*objzgdk0 <= 2.0e-200) {
+ *lfu2qhid = -460.0e0;
+ } else
+ if (*objzgdk0 <= 1.0e-14) {
+ *lfu2qhid = log( *objzgdk0 );
+ } else
+ if (1.0e0 - *objzgdk0 <= 0.0e0) {
+ *lfu2qhid = 3.542106e0;
+ } else {
+ *lfu2qhid = log(-log(1.0e0 - *objzgdk0));
+ }
+}
+
+
+void yiumjq3ng2vwexyk9(double *objzgdk0, double *lfu2qhid) {
+
+ if (*objzgdk0 <= 2.0e-200) {
+ *lfu2qhid = -460.0e0;
+ } else
+ if (*objzgdk0 <= 1.0e-14) {
+ *lfu2qhid = log( *objzgdk0 );
+ } else
+ if (1.0e0 - *objzgdk0 <= 0.0e0) {
+ *lfu2qhid = 34.53958e0;
+ } else {
+ *lfu2qhid = log(*objzgdk0 / (1.0e0 - *objzgdk0));
+ }
+}
+
+
+void yiumjq3npkc4ejib(double w8znmyce[], double zshtfg8c[], double m0ibglfx[],
+ int *ftnjamu2, int *wy1vqfzu, int *br5ovgcj, int *xlpjcg3s,
+ int *vtsou9pz, int *hj3ftvzu, int *qfx3vhct, int *unhycz0e,
+ double vm4xjosb[]) {
+
+
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, uw3favmo, sedf7mxb;
+ double vogkfwt8, *fpdlcqk9zshtfg8c, *fpdlcqk9w8znmyce, *fpdlcqk9f9piukdx,
+ *fpdlcqk9m0ibglfx, *fpdlcqk9vm4xjosb;
+
+ if (*vtsou9pz == 1) {
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ sedf7mxb = 2 * *hj3ftvzu - 1;
+
+ if (*br5ovgcj != 2 * *ftnjamu2) //Rprinf
+ Rprintf("Error: *br5ovgcj != 2 * *ftnjamu2 in C_pkc4ejib\n");
+ fpdlcqk9m0ibglfx = m0ibglfx + sedf7mxb-1;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx = 0.0;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+
+ fpdlcqk9zshtfg8c = zshtfg8c;
+ for (gp1jxzuh = 1; gp1jxzuh <= *xlpjcg3s; gp1jxzuh++) {
+ fpdlcqk9w8znmyce = w8znmyce + 0 + (gp1jxzuh-1) * *br5ovgcj;
+ fpdlcqk9m0ibglfx = m0ibglfx + sedf7mxb-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9w8znmyce++ * *fpdlcqk9zshtfg8c;
+ fpdlcqk9w8znmyce++;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ fpdlcqk9zshtfg8c++;
+ }
+
+ sedf7mxb = 2 * *hj3ftvzu;
+
+ fpdlcqk9m0ibglfx = m0ibglfx + sedf7mxb-1;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx = 0.0;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+
+ fpdlcqk9zshtfg8c = zshtfg8c;
+ for (gp1jxzuh = 1; gp1jxzuh <= *xlpjcg3s; gp1jxzuh++) {
+ fpdlcqk9w8znmyce = w8znmyce + 1 + (gp1jxzuh-1) * *br5ovgcj;
+ fpdlcqk9m0ibglfx = m0ibglfx + sedf7mxb-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9w8znmyce++ * *fpdlcqk9zshtfg8c;
+ fpdlcqk9w8znmyce++;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ fpdlcqk9zshtfg8c++;
+ }
+
+
+ } else {
+
+ fpdlcqk9m0ibglfx = m0ibglfx + *hj3ftvzu-1;
+ for (ayfnwr1v = 0; ayfnwr1v < *br5ovgcj; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx = 0.0;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+
+ fpdlcqk9zshtfg8c = zshtfg8c;
+ fpdlcqk9w8znmyce = w8znmyce; // + (gp1jxzuh-1) * *br5ovgcj;
+ for (gp1jxzuh = 1; gp1jxzuh <= *xlpjcg3s; gp1jxzuh++) {
+ fpdlcqk9m0ibglfx = m0ibglfx + *hj3ftvzu-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *br5ovgcj; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9w8znmyce++ * *fpdlcqk9zshtfg8c;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ fpdlcqk9zshtfg8c++;
+ }
+ }
+ } else {
+ if (*br5ovgcj != *wy1vqfzu * *ftnjamu2) //Rprinf
+ Rprintf("Error: *br5ovgcj != *wy1vqfzu * *ftnjamu2 in C_pkc4ejib\n");
+ fpdlcqk9m0ibglfx = m0ibglfx;
+ fpdlcqk9f9piukdx = w8znmyce;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9m0ibglfx = 0.0e0;
+ fpdlcqk9zshtfg8c = zshtfg8c;
+ fpdlcqk9w8znmyce = fpdlcqk9f9piukdx++;
+ for (gp1jxzuh = 1; gp1jxzuh <= *xlpjcg3s; gp1jxzuh++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9w8znmyce * *fpdlcqk9zshtfg8c++;
+ fpdlcqk9w8znmyce += *br5ovgcj;
+ }
+ fpdlcqk9m0ibglfx++;
+ }
+ }
+ }
+
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ if (*unhycz0e == 1) {
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ fpdlcqk9m0ibglfx = m0ibglfx + 2 * *hj3ftvzu - 2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9vm4xjosb++;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ } else {
+ fpdlcqk9m0ibglfx = m0ibglfx + *hj3ftvzu - 1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9vm4xjosb++;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ }
+}
+
+
+void yiumjq3nnipyajc1(double m0ibglfx[], double t8hwvalr[], int *ftnjamu2, int *wy1vqfzu,
+ int *afpc0kns, int *qfx3vhct, int *hj3ftvzu) {
+
+
+ int ayfnwr1v, yq6lorbx;
+ double tmpwk, *fpdlcqk9t8hwvalr, *fpdlcqk9m0ibglfx;
+
+
+ if (*hj3ftvzu == 0) {
+ fpdlcqk9t8hwvalr = t8hwvalr;
+ fpdlcqk9m0ibglfx = m0ibglfx;
+ if (*qfx3vhct == 1) {
+ if (*afpc0kns != *wy1vqfzu) Rprintf("Error: *afpc0kns != *wy1vqfzu in C_nipyajc1\n");
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++)
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ tmpwk = exp(*fpdlcqk9m0ibglfx++);
+ *fpdlcqk9t8hwvalr++ = tmpwk / (1.0 + tmpwk);
+ }
+ }
+ if (*qfx3vhct == 2) {
+ if (*afpc0kns != *wy1vqfzu) Rprintf("Error: *afpc0kns != *wy1vqfzu in C_nipyajc1\n");
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++)
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++)
+ *fpdlcqk9t8hwvalr++ = exp(*fpdlcqk9m0ibglfx++);
+ }
+ if (*qfx3vhct == 4) {
+ if (*afpc0kns != *wy1vqfzu) Rprintf("Error: *afpc0kns != *wy1vqfzu in C_nipyajc1\n");
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++)
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++)
+ *fpdlcqk9t8hwvalr++ = 1.0e0 - exp(-exp(*fpdlcqk9m0ibglfx++));
+ }
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ if (2 * *afpc0kns != *wy1vqfzu) { //Rprintf
+ Rprintf("Error: 2 * *afpc0kns != *wy1vqfzu in C_nipyajc1\n");
+ } //Rprintf
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++)
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ *fpdlcqk9t8hwvalr++ = exp(*fpdlcqk9m0ibglfx++);
+ fpdlcqk9m0ibglfx++;
+ }
+ }
+ if (*qfx3vhct == 8) {
+ if (*afpc0kns != *wy1vqfzu) Rprintf("Error: *afpc0kns != *wy1vqfzu in C_nipyajc1\n");
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++)
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++)
+ *fpdlcqk9t8hwvalr++ = *fpdlcqk9m0ibglfx++;
+ }
+ } else {
+ fpdlcqk9t8hwvalr = t8hwvalr + *hj3ftvzu-1;
+ fpdlcqk9m0ibglfx = m0ibglfx + *hj3ftvzu-1;
+ if (*qfx3vhct == 1) {
+ if (*afpc0kns != *wy1vqfzu) Rprintf("Error: *afpc0kns != *wy1vqfzu in C_nipyajc1\n");
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ tmpwk = exp(*fpdlcqk9m0ibglfx);
+ *fpdlcqk9t8hwvalr = tmpwk / (1.0 + tmpwk);
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ if (*qfx3vhct == 2) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9t8hwvalr = exp(*fpdlcqk9m0ibglfx);
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ if (*qfx3vhct == 4) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9t8hwvalr = 1.0e0 - exp(-exp(*fpdlcqk9m0ibglfx));
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ fpdlcqk9t8hwvalr = t8hwvalr + *hj3ftvzu-1;
+ fpdlcqk9m0ibglfx = m0ibglfx + 2 * *hj3ftvzu-2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9t8hwvalr = exp(*fpdlcqk9m0ibglfx);
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ if (*qfx3vhct == 8) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9t8hwvalr = *fpdlcqk9m0ibglfx;
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ }
+}
+
+
+
+void yiumjq3nshjlwft5(int *qfx3vhct, double tlgduey8[], double ufgqj9ck[],
+ double t8hwvalr[], int *ftnjamu2, int *wy1vqfzu, int *afpc0kns,
+ int *kvowz9ht, double m0ibglfx[], double *jxacz5qu, int *hj3ftvzu,
+ double *dn3iasxug, double *vsoihn1r, int *dqk5muto) {
+
+
+
+ int ayfnwr1v, yq6lorbx, lbgwvp3q;
+ double txlvcey5, xd4mybgj, uqnkc6zg, hofjnx2e, smmu, afwp5imx, ivqk2ywz, qvd7yktm,
+ hdqsx7bk, anopu9vi, jtnbu2hz, prev_lfu2qhid = 0.0e0, lfu2qhid = 0.0e0,
+ *fpdlcqk9m0ibglfx, *fpdlcqk9t8hwvalr, *fpdlcqk9ufgqj9ck, *fpdlcqk9tlgduey8;
+
+
+
+
+ if (*hj3ftvzu == 0) {
+ fpdlcqk9tlgduey8 = tlgduey8;
+
+ if (*qfx3vhct == 1 || *qfx3vhct == 4) {
+ if (*afpc0kns != *wy1vqfzu) Rprintf("Error: *afpc0kns != *wy1vqfzu in C_shjlwft5\n");
+ fpdlcqk9tlgduey8 = tlgduey8;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) { // yyy
+ fpdlcqk9t8hwvalr = t8hwvalr + yq6lorbx-1;
+ fpdlcqk9ufgqj9ck = ufgqj9ck;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) { // bbb
+ ivqk2ywz = *fpdlcqk9tlgduey8 > 0.0 ? *fpdlcqk9tlgduey8*log(*fpdlcqk9tlgduey8) :0.0;
+ if (*fpdlcqk9tlgduey8 < 1.0e0)
+ ivqk2ywz += (1.0e0 - *fpdlcqk9tlgduey8) * log(1.0e0 - *fpdlcqk9tlgduey8);
+ xd4mybgj = *fpdlcqk9t8hwvalr * (1.0e0 - *fpdlcqk9t8hwvalr);
+ if (xd4mybgj < *dn3iasxug) {
+ smmu = *fpdlcqk9t8hwvalr;
+ qvd7yktm = *fpdlcqk9tlgduey8 *
+ ((smmu < *dn3iasxug) ? *vsoihn1r : log(smmu));
+ afwp5imx = 1.0e0 - smmu;
+ qvd7yktm += (afwp5imx < *dn3iasxug ? *vsoihn1r : log(afwp5imx))*
+ (1.0 - *fpdlcqk9tlgduey8);
+ } else {
+ qvd7yktm = *fpdlcqk9tlgduey8 * log( *fpdlcqk9t8hwvalr) +
+ (1.0 - *fpdlcqk9tlgduey8) * log(1.0 - *fpdlcqk9t8hwvalr);
+ }
+ lfu2qhid += *fpdlcqk9ufgqj9ck++ * (ivqk2ywz - qvd7yktm);
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9tlgduey8++;
+ } // bbb
+ jxacz5qu[yq6lorbx] = 2.0e0 * (lfu2qhid - prev_lfu2qhid);
+ prev_lfu2qhid = lfu2qhid;
+ } // yyy
+ }
+ if (*qfx3vhct == 2) {
+ if (*afpc0kns != *wy1vqfzu) Rprintf("Error: *afpc0kns != *wy1vqfzu in C_shjlwft5\n");
+ fpdlcqk9tlgduey8 = tlgduey8;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ fpdlcqk9t8hwvalr = t8hwvalr + yq6lorbx-1;
+ fpdlcqk9ufgqj9ck = ufgqj9ck;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ xd4mybgj = *fpdlcqk9tlgduey8 > 0.0 ? *fpdlcqk9t8hwvalr - *fpdlcqk9tlgduey8 +
+ *fpdlcqk9tlgduey8 * log(*fpdlcqk9tlgduey8 / *fpdlcqk9t8hwvalr) :
+ *fpdlcqk9t8hwvalr - *fpdlcqk9tlgduey8;
+ lfu2qhid += *fpdlcqk9ufgqj9ck++ * xd4mybgj;
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9tlgduey8++;
+ }
+ jxacz5qu[yq6lorbx] = 2.0e0 * (lfu2qhid - prev_lfu2qhid);
+ prev_lfu2qhid = lfu2qhid;
+ }
+ }
+ if (*qfx3vhct == 5) {
+ fpdlcqk9tlgduey8 = tlgduey8;
+ if (2 * *afpc0kns != *wy1vqfzu) { //Rprintf
+ Rprintf("Error: 2 * *afpc0kns != *wy1vqfzu in C_nipyajc1\n");
+ } //Rprintf
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ fpdlcqk9m0ibglfx = m0ibglfx + 2*yq6lorbx-1;
+ fpdlcqk9t8hwvalr = t8hwvalr + yq6lorbx-1;
+ fpdlcqk9ufgqj9ck = ufgqj9ck;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ jtnbu2hz = exp(*fpdlcqk9m0ibglfx);
+ uqnkc6zg = fvlmz9iyC_tldz5ion(jtnbu2hz);
+ xd4mybgj = *fpdlcqk9tlgduey8 > 0.0 ? (jtnbu2hz - 1.0e0) *
+ log(*fpdlcqk9tlgduey8) + (log(jtnbu2hz) -
+ *fpdlcqk9tlgduey8 / *fpdlcqk9t8hwvalr -
+ log(*fpdlcqk9t8hwvalr)) * jtnbu2hz - uqnkc6zg :
+ -1000.0e0;
+ xd4mybgj = -xd4mybgj;
+ lfu2qhid += *fpdlcqk9ufgqj9ck++ * xd4mybgj;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9tlgduey8++;
+ }
+ jxacz5qu[yq6lorbx] = 2.0e0 * (lfu2qhid - prev_lfu2qhid);
+ prev_lfu2qhid = lfu2qhid;
+ }
+ }
+ if (*qfx3vhct == 3) {
+ if (*dqk5muto == 0) {
+ anopu9vi = 34.0e0;
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ if (m0ibglfx[2*yq6lorbx-1 + (ayfnwr1v-1)* *wy1vqfzu] > anopu9vi) {
+ hdqsx7bk = exp(anopu9vi);
+ lbgwvp3q = 1;
+ } else
+ if (m0ibglfx[2*yq6lorbx-1 + (ayfnwr1v-1)* *wy1vqfzu] < -anopu9vi) {
+ hdqsx7bk = exp(-anopu9vi);
+ lbgwvp3q = 1;
+ } else {
+ hdqsx7bk = exp(m0ibglfx[2*yq6lorbx-1 + (ayfnwr1v-1) *
+ *wy1vqfzu]);
+ lbgwvp3q = 0;
+ }
+ xd4mybgj = (tlgduey8[ayfnwr1v-1+ (yq6lorbx-1)* *ftnjamu2] < 1.0e0) ?
+ 1.0e0 : tlgduey8[ayfnwr1v-1+ (yq6lorbx-1)* *ftnjamu2];
+ lfu2qhid += ufgqj9ck[ayfnwr1v-1] *
+ (tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] *
+ log(xd4mybgj/t8hwvalr[yq6lorbx-1 + (ayfnwr1v-1) * *afpc0kns]) +
+ (tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] +
+ hdqsx7bk) *
+ log((t8hwvalr[yq6lorbx-1 + (ayfnwr1v-1) * *afpc0kns ] +
+ hdqsx7bk) / (hdqsx7bk +
+ tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2])));
+ }
+ jxacz5qu[yq6lorbx] = 2.0e0 * (lfu2qhid - prev_lfu2qhid);
+ prev_lfu2qhid = lfu2qhid;
+ }
+ } else {
+ anopu9vi = 34.0e0;
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ if (m0ibglfx[2*yq6lorbx-1 + (ayfnwr1v-1)* *wy1vqfzu] > anopu9vi) {
+ hdqsx7bk = exp(anopu9vi);
+ lbgwvp3q = 1;
+ } else
+ if (m0ibglfx[2*yq6lorbx-1 + (ayfnwr1v-1)* *wy1vqfzu] < -anopu9vi) {
+ hdqsx7bk = exp(-anopu9vi);
+ lbgwvp3q = 1;
+ } else {
+ hdqsx7bk = exp(m0ibglfx[2*yq6lorbx-1 + (ayfnwr1v-1)* *wy1vqfzu]);
+ lbgwvp3q = 0;
+ }
+ if (lbgwvp3q) {
+ uqnkc6zg = hofjnx2e = 0.0e0;
+ } else {
+ uqnkc6zg = fvlmz9iyC_tldz5ion(hdqsx7bk +
+ tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2]);
+ hofjnx2e = fvlmz9iyC_tldz5ion(hdqsx7bk);
+ }
+ txlvcey5 = fvlmz9iyC_tldz5ion(1.0e0 +
+ tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2]);
+ xd4mybgj = hdqsx7bk * log(hdqsx7bk / (hdqsx7bk +
+ t8hwvalr[yq6lorbx-1 + (ayfnwr1v-1) * *afpc0kns])) +
+ uqnkc6zg - hofjnx2e - txlvcey5;
+ if (tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] > 0.0e0) {
+ xd4mybgj += tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] *
+ log(t8hwvalr[yq6lorbx-1 + (ayfnwr1v-1) * *afpc0kns]
+ / (hdqsx7bk + t8hwvalr[yq6lorbx-1 + (ayfnwr1v-1) * *afpc0kns]));
+ }
+ lfu2qhid += ufgqj9ck[ayfnwr1v-1] * xd4mybgj;
+ }
+ jxacz5qu[yq6lorbx] = 2.0 * (-0.5 * lfu2qhid + 0.5 * prev_lfu2qhid);
+ prev_lfu2qhid = lfu2qhid;
+ }
+ lfu2qhid *= (-0.5);
+ }
+ }
+ if (*qfx3vhct == 8) {
+ fpdlcqk9tlgduey8 = tlgduey8;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ fpdlcqk9t8hwvalr = t8hwvalr + yq6lorbx-1;
+ fpdlcqk9ufgqj9ck = ufgqj9ck;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ xd4mybgj = *fpdlcqk9tlgduey8++ - *fpdlcqk9t8hwvalr;
+ lfu2qhid += *fpdlcqk9ufgqj9ck++ * pow(xd4mybgj, (double) 2.0);
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ }
+ jxacz5qu[yq6lorbx] = 2.0e0 * (lfu2qhid - prev_lfu2qhid);
+ prev_lfu2qhid = lfu2qhid;
+ }
+ }
+ } else {
+ fpdlcqk9tlgduey8 = tlgduey8 + (*hj3ftvzu-1) * *ftnjamu2;
+ fpdlcqk9t8hwvalr = t8hwvalr + *hj3ftvzu-1;
+ fpdlcqk9ufgqj9ck = ufgqj9ck;
+
+ if (*qfx3vhct == 1 || *qfx3vhct == 4) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ ivqk2ywz = *fpdlcqk9tlgduey8 > 0.0 ? *fpdlcqk9tlgduey8 * log(*fpdlcqk9tlgduey8) : 0.0;
+ if (*fpdlcqk9tlgduey8 < 1.0e0)
+ ivqk2ywz += (1.0e0 - *fpdlcqk9tlgduey8) * log(1.0e0 - *fpdlcqk9tlgduey8);
+ xd4mybgj = *fpdlcqk9t8hwvalr * (1.0e0 - *fpdlcqk9t8hwvalr);
+ if (xd4mybgj < *dn3iasxug) {
+ smmu = *fpdlcqk9t8hwvalr;
+ qvd7yktm = *fpdlcqk9tlgduey8 *
+ ((smmu < *dn3iasxug) ? *vsoihn1r : log(smmu));
+ afwp5imx = 1.0e0 - smmu;
+ qvd7yktm += (afwp5imx < *dn3iasxug ? *vsoihn1r : log(afwp5imx)) *
+ (1.0 - *fpdlcqk9tlgduey8);
+ } else {
+ qvd7yktm = *fpdlcqk9tlgduey8 * log( *fpdlcqk9t8hwvalr) +
+ (1.0 - *fpdlcqk9tlgduey8) * log(1.0e0 - *fpdlcqk9t8hwvalr);
+ }
+ lfu2qhid += *fpdlcqk9ufgqj9ck++ * (ivqk2ywz - qvd7yktm);
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9tlgduey8++;
+ }
+ }
+ if (*qfx3vhct == 2) {
+ if (*afpc0kns != *wy1vqfzu) Rprintf("Error: *afpc0kns != *wy1vqfzu in C_shjlwft5\n");
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ xd4mybgj = *fpdlcqk9tlgduey8 > 0.0e0 ? *fpdlcqk9t8hwvalr - *fpdlcqk9tlgduey8 +
+ *fpdlcqk9tlgduey8 * log(*fpdlcqk9tlgduey8 / *fpdlcqk9t8hwvalr) :
+ *fpdlcqk9t8hwvalr - *fpdlcqk9tlgduey8;
+ lfu2qhid += *fpdlcqk9ufgqj9ck++ * xd4mybgj;
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9tlgduey8++;
+ }
+ }
+ if (*qfx3vhct == 5) {
+ fpdlcqk9tlgduey8 = tlgduey8 + (*hj3ftvzu-1) * *ftnjamu2;
+ fpdlcqk9t8hwvalr = t8hwvalr + *hj3ftvzu-1;
+ fpdlcqk9ufgqj9ck = ufgqj9ck;
+ fpdlcqk9m0ibglfx = m0ibglfx + 2 * *hj3ftvzu-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ jtnbu2hz = exp(*fpdlcqk9m0ibglfx);
+ uqnkc6zg = fvlmz9iyC_tldz5ion(jtnbu2hz);
+ xd4mybgj = *fpdlcqk9tlgduey8 > 0.0 ? (jtnbu2hz - 1.0e0) *
+ log(*fpdlcqk9tlgduey8) + jtnbu2hz * (log(jtnbu2hz) -
+ *fpdlcqk9tlgduey8 / *fpdlcqk9t8hwvalr - log(*fpdlcqk9t8hwvalr)) -
+ uqnkc6zg : -1000.0e0;
+ xd4mybgj = -xd4mybgj;
+ lfu2qhid += *fpdlcqk9ufgqj9ck++ * xd4mybgj;
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ fpdlcqk9tlgduey8++;
+ }
+ }
+ if (*qfx3vhct == 3) {
+ if (*dqk5muto == 0) {
+ anopu9vi = 34.0e0;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ if (m0ibglfx[2 * *hj3ftvzu -1 + (ayfnwr1v-1) * *wy1vqfzu] > anopu9vi) {
+ hdqsx7bk = exp(anopu9vi);
+ lbgwvp3q = 1;
+ } else
+ if (m0ibglfx[2 * *hj3ftvzu -1 + (ayfnwr1v-1) * *wy1vqfzu] < -anopu9vi) {
+ hdqsx7bk = exp(-anopu9vi);
+ lbgwvp3q = 1;
+ } else {
+ hdqsx7bk = exp(m0ibglfx[2* *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu]);
+ lbgwvp3q = 0;
+ }
+ xd4mybgj = (tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] < 1.0e0) ?
+ 1.0e0 : tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2];
+ lfu2qhid += ufgqj9ck[ayfnwr1v-1] *
+ (tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] *
+ log(xd4mybgj/t8hwvalr[*hj3ftvzu-1 + (ayfnwr1v-1) * *afpc0kns]) +
+ (tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] + hdqsx7bk) *
+ log((t8hwvalr[*hj3ftvzu-1 + (ayfnwr1v-1) * *afpc0kns] + hdqsx7bk)
+ / (hdqsx7bk+tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2])));
+ }
+ } else {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ hdqsx7bk = exp(m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu]);
+ uqnkc6zg = fvlmz9iyC_tldz5ion(hdqsx7bk + tlgduey8[ayfnwr1v-1 +
+ (*hj3ftvzu-1) * *ftnjamu2]);
+ hofjnx2e = fvlmz9iyC_tldz5ion(hdqsx7bk);
+ txlvcey5 = fvlmz9iyC_tldz5ion(1.0e0 + tlgduey8[ayfnwr1v-1 +
+ (*hj3ftvzu-1) * *ftnjamu2]);
+ xd4mybgj = hdqsx7bk * log(hdqsx7bk / (hdqsx7bk + t8hwvalr[*hj3ftvzu-1 +
+ (ayfnwr1v-1) * *afpc0kns])) + uqnkc6zg - hofjnx2e - txlvcey5;
+
+ if (tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] > 0.0e0) {
+ xd4mybgj += tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] *
+ log(t8hwvalr[*hj3ftvzu-1 + (ayfnwr1v-1) * *afpc0kns]
+ / (hdqsx7bk + t8hwvalr[*hj3ftvzu-1 + (ayfnwr1v-1) * *afpc0kns]));
+ }
+ lfu2qhid += ufgqj9ck[ayfnwr1v-1] * xd4mybgj;
+ }
+ lfu2qhid *= (-0.5e0);
+ }
+ }
+ if (*qfx3vhct == 8) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ lfu2qhid += *fpdlcqk9ufgqj9ck++ *
+ pow(*fpdlcqk9tlgduey8++ - *fpdlcqk9t8hwvalr, (double) 2.0);
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ }
+ }
+ }
+ *jxacz5qu = 2.0e0 * lfu2qhid;
+}
+
+
+void yiumjq3nflncwkfq76(double lncwkfq7[], double w8znmyce[], int *ftnjamu2,
+ int *br5ovgcj, int *xwdf5ltg, int *qfx3vhct) {
+
+
+ int ayfnwr1v, hpmwnav2; // sedf7mxb = 1;
+ double *fpdlcqk9w8znmyce, *fpdlcqk9lncwkfq7;
+
+ fpdlcqk9w8znmyce = w8znmyce;
+ fpdlcqk9lncwkfq7 = lncwkfq7;
+
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = 1.0e0;
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ }
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ *fpdlcqk9w8znmyce++ = 1.0e0;
+ }
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9lncwkfq7++;
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ }
+ }
+ } else {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = 1.0e0;
+ }
+ if (*br5ovgcj != *ftnjamu2) Rprintf("Error: *br5ovgcj != *ftnjamu2 in C_flncwkfq76\n");
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9lncwkfq7++;
+ }
+ }
+ }
+}
+
+
+void yiumjq3nflncwkfq71(double lncwkfq7[], double w8znmyce[], int *ftnjamu2, int *xwdf5ltg,
+ int *qfx3vhct, double vm4xjosb[], int *br5ovgcj, int *xlpjcg3s,
+ double kifxa0he[], int *yru9olks, int *unhycz0e) {
+
+
+ int i0spbklx, ayfnwr1v, hpmwnav2, // sedf7mxb = *xwdf5ltg + 1,
+ hyqwtp6i = *xwdf5ltg * (*xwdf5ltg + 1) / 2;
+ double tad5vhsu, uqnkc6zg, *fpdlcqk9lncwkfq7, *fpdlcqk9lncwkfq71, *fpdlcqk9lncwkfq72,
+ *fpdlcqk9w8znmyce, *fpdlcqk9vm4xjosb, *fpdlcqk9kifxa0he;
+
+ int *wkumc9idtgiyxdw1, *wkumc9iddufozmt7;
+ wkumc9idtgiyxdw1 = Calloc(hyqwtp6i, int);
+ wkumc9iddufozmt7 = Calloc(hyqwtp6i, int);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw1, wkumc9iddufozmt7, xwdf5ltg);
+
+ fpdlcqk9w8znmyce = w8znmyce;
+ fpdlcqk9lncwkfq7 =
+ fpdlcqk9lncwkfq71 =
+ fpdlcqk9lncwkfq72 = lncwkfq7;
+
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) { // ggg
+ if (*br5ovgcj != 2 * *ftnjamu2) //Rprinf
+ Rprintf("Error: *br5ovgcj != 2 * *ftnjamu2 in C_flncwkfq71\n");
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9lncwkfq7++;
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ }
+ }
+
+ if (*unhycz0e == 0) {
+ for (i0spbklx = 1; i0spbklx <= hyqwtp6i; i0spbklx++) {
+ fpdlcqk9lncwkfq71 = lncwkfq7 + (wkumc9idtgiyxdw1[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9lncwkfq72 = lncwkfq7 + (wkumc9iddufozmt7[i0spbklx-1]-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9lncwkfq71++ * *fpdlcqk9lncwkfq72++;
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ }
+ }
+ } else {
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++)
+ *fpdlcqk9vm4xjosb++ = 0.0;
+
+ fpdlcqk9lncwkfq7 = lncwkfq7;
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9vm4xjosb += pow(*fpdlcqk9lncwkfq7++, (double) 2.0);
+ fpdlcqk9vm4xjosb++;
+ }
+ }
+
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9vm4xjosb *= (-0.50e0);
+ fpdlcqk9vm4xjosb++;
+ }
+ }
+
+ } else { // ggg and hhh
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9lncwkfq7++;
+ }
+ }
+
+ if (*unhycz0e == 0) {
+ for (i0spbklx = 1; i0spbklx <= hyqwtp6i; i0spbklx++) {
+ fpdlcqk9lncwkfq71 = lncwkfq7 + (wkumc9idtgiyxdw1[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9lncwkfq72 = lncwkfq7 + (wkumc9iddufozmt7[i0spbklx-1]-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9lncwkfq71++ * *fpdlcqk9lncwkfq72++;
+ }
+ }
+ } else {
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++)
+ *fpdlcqk9vm4xjosb++ = 0.0;
+
+ fpdlcqk9lncwkfq7 = lncwkfq7;
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9vm4xjosb += pow(*fpdlcqk9lncwkfq7++, (double) 2.0);
+ fpdlcqk9vm4xjosb++;
+ }
+ }
+
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9vm4xjosb *= (-0.50e0);
+ fpdlcqk9vm4xjosb++;
+ }
+ }
+ } // hhh
+
+ if (*yru9olks > 0) {
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) { // kkk
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = 1.0e0;
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ }
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ *fpdlcqk9w8znmyce++ = 1.0e0;
+ }
+ if (*yru9olks > 1) {
+ fpdlcqk9kifxa0he = kifxa0he; // + (i0spbklx-1) * *ftnjamu2;
+ for (i0spbklx = 2; i0spbklx <= *yru9olks; i0spbklx++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9kifxa0he++;
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ }
+ }
+ }
+ } else { // kkk and iii
+ fpdlcqk9kifxa0he = kifxa0he; // + (i0spbklx-1) * *ftnjamu2;
+ for (i0spbklx = 1; i0spbklx <= *yru9olks; i0spbklx++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9kifxa0he++;
+ }
+ }
+ } // iii
+ } // if (*yru9olks > 0)
+ Free(wkumc9idtgiyxdw1); Free(wkumc9iddufozmt7);
+}
+
+
+void yiumjq3nflncwkfq72(double lncwkfq7[], double w8znmyce[], int *ftnjamu2, int *wy1vqfzu,
+ int *br5ovgcj, int *xwdf5ltg, int *qfx3vhct, int *afpc0kns,
+ int *fmzq7aob, int *eu3oxvyb, int *unhycz0e, double vm4xjosb[]) {
+
+
+
+ int i0spbklx, ayfnwr1v, yq6lorbx, gp1jxzuh, hpmwnav2, g3psxjru, sedf7mxb = 0,
+ hyqwtp6i = *xwdf5ltg * (*xwdf5ltg + 1) / 2;
+ double tad5vhsu, uqnkc6zg, *fpdlcqk9lncwkfq7, *fpdlcqk9lncwkfq71, *fpdlcqk9lncwkfq72,
+ *fpdlcqk9w8znmyce, *fpdlcqk9vm4xjosb, *fpdlcqk9kifxa0he;
+
+ int *wkumc9idtgiyxdw1, *wkumc9iddufozmt7;
+ wkumc9idtgiyxdw1 = Calloc(hyqwtp6i, int);
+ wkumc9iddufozmt7 = Calloc(hyqwtp6i, int);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw1, wkumc9iddufozmt7, xwdf5ltg);
+
+
+ fpdlcqk9w8znmyce = w8znmyce;
+ fpdlcqk9lncwkfq7 = lncwkfq7;
+
+ for (gp1jxzuh = 1; gp1jxzuh <= *eu3oxvyb; gp1jxzuh++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *br5ovgcj; ayfnwr1v++)
+ *fpdlcqk9w8znmyce++ = 0.0e0;
+ }
+ fpdlcqk9w8znmyce = w8znmyce;
+
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+
+ if (*br5ovgcj != 2 * *ftnjamu2) //Rprinf
+ Rprintf("Error: *br5ovgcj != 2 * *ftnjamu2 in C_flncwkfq72\n");
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ fpdlcqk9w8znmyce = w8znmyce + sedf7mxb * *br5ovgcj;
+ fpdlcqk9lncwkfq7 = lncwkfq7 + (hpmwnav2-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ *fpdlcqk9w8znmyce = *fpdlcqk9lncwkfq7;
+ fpdlcqk9w8znmyce += 2 + *br5ovgcj;
+ }
+ fpdlcqk9lncwkfq7++;
+ fpdlcqk9w8znmyce -= *afpc0kns * *br5ovgcj; // fixed at 20100406
+ }
+ sedf7mxb += *afpc0kns;
+ }
+ } else {
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ fpdlcqk9w8znmyce = w8znmyce + sedf7mxb * *br5ovgcj;
+ fpdlcqk9lncwkfq7 = lncwkfq7 + (hpmwnav2-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9w8znmyce++ = *fpdlcqk9lncwkfq7;
+ fpdlcqk9w8znmyce += *br5ovgcj;
+ }
+ fpdlcqk9lncwkfq7++;
+ fpdlcqk9w8znmyce -= *wy1vqfzu * *br5ovgcj; // fixed at 20100406
+ }
+ sedf7mxb += *wy1vqfzu;
+ }
+ }
+
+ if (*fmzq7aob == 0) {
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ for (i0spbklx = 1; i0spbklx <= hyqwtp6i; i0spbklx++) {
+ fpdlcqk9lncwkfq71 = lncwkfq7 + (wkumc9idtgiyxdw1[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9lncwkfq72 = lncwkfq7 + (wkumc9iddufozmt7[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9w8znmyce = w8znmyce + sedf7mxb * *br5ovgcj;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ uqnkc6zg = *fpdlcqk9lncwkfq71++ * *fpdlcqk9lncwkfq72++;
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ *fpdlcqk9w8znmyce = uqnkc6zg;
+ fpdlcqk9w8znmyce += 2 + *br5ovgcj;
+ }
+ fpdlcqk9w8znmyce -= *afpc0kns * *br5ovgcj; // fixed at 20100406
+ }
+ sedf7mxb += *afpc0kns;
+ }
+ } else {
+ for (i0spbklx = 1; i0spbklx <= hyqwtp6i; i0spbklx++) {
+ fpdlcqk9lncwkfq71 = lncwkfq7 + (wkumc9idtgiyxdw1[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9lncwkfq72 = lncwkfq7 + (wkumc9iddufozmt7[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9w8znmyce = w8znmyce + sedf7mxb * *br5ovgcj;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ uqnkc6zg = *fpdlcqk9lncwkfq71++ * *fpdlcqk9lncwkfq72++;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9w8znmyce++ = uqnkc6zg;
+ fpdlcqk9w8znmyce += *br5ovgcj;
+ }
+ fpdlcqk9w8znmyce -= *wy1vqfzu * *br5ovgcj; // fixed at 20100406
+ }
+ sedf7mxb += *wy1vqfzu;
+ }
+ }
+ } else {
+ if (*unhycz0e == 1) {
+
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++)
+ *fpdlcqk9vm4xjosb++ = 0.0;
+
+ fpdlcqk9lncwkfq7 = lncwkfq7;
+ for (hpmwnav2 = 1; hpmwnav2 <= *xwdf5ltg; hpmwnav2++) {
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9vm4xjosb += pow(*fpdlcqk9lncwkfq7++, (double) 2.0);
+ fpdlcqk9vm4xjosb++;
+ }
+ }
+
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9vm4xjosb *= (-0.50e0);
+ fpdlcqk9vm4xjosb++;
+ }
+ } else {
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ for (i0spbklx = 1; i0spbklx <= hyqwtp6i; i0spbklx++) {
+ fpdlcqk9lncwkfq71 = lncwkfq7 + (wkumc9idtgiyxdw1[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9lncwkfq72 = lncwkfq7 + (wkumc9iddufozmt7[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9w8znmyce = w8znmyce + (sedf7mxb+i0spbklx-1) * *br5ovgcj;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ uqnkc6zg = *fpdlcqk9lncwkfq71++ * *fpdlcqk9lncwkfq72++;
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ *fpdlcqk9w8znmyce++ = uqnkc6zg;
+ fpdlcqk9w8znmyce++;
+ }
+ }
+ }
+ sedf7mxb += hyqwtp6i;
+ } else {
+ for (i0spbklx = 1; i0spbklx <= hyqwtp6i; i0spbklx++) {
+ fpdlcqk9lncwkfq71 = lncwkfq7 + (wkumc9idtgiyxdw1[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9lncwkfq72 = lncwkfq7 + (wkumc9iddufozmt7[i0spbklx-1]-1) * *ftnjamu2;
+ fpdlcqk9w8znmyce = w8znmyce + (sedf7mxb+i0spbklx-1) * *br5ovgcj;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ uqnkc6zg = *fpdlcqk9lncwkfq71++ * *fpdlcqk9lncwkfq72++;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++)
+ *fpdlcqk9w8znmyce++ = uqnkc6zg;
+ }
+ }
+ sedf7mxb += hyqwtp6i;
+ }
+ }
+ }
+ Free(wkumc9idtgiyxdw1); Free(wkumc9iddufozmt7);
+}
+
+
+void yiumjq3nietam6(double tlgduey8[], double m0ibglfx[], double y7sdgtqi[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *qfx3vhct,
+ int *hj3ftvzu, double ufgqj9ck[], int *wr0lbopv) {
+
+
+ int ayfnwr1v;
+ double gyuq8dex, g2vwexykp, qa8ltuhj, vogkfwt8 = 0.0e0, msrdjh5f = 0.0e0,
+ kwvo4ury, cpz4fgkx, tad5vhsu, khl0iysgk, myoffset = 1.0 / 32.0;
+ double *fpdlcqk9tlgduey8, *fpdlcqk9m0ibglfx, *fpdlcqk9m0ibglfx1, *fpdlcqk9m0ibglfx2,
+ *fpdlcqk9ufgqj9ck;
+
+ fpdlcqk9tlgduey8 = tlgduey8 + (*hj3ftvzu-1) * *ftnjamu2;
+ fpdlcqk9ufgqj9ck = ufgqj9ck;
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ fpdlcqk9m0ibglfx1 = m0ibglfx + 2 * *hj3ftvzu-1;
+ fpdlcqk9m0ibglfx2 = m0ibglfx + 2 * *hj3ftvzu-2;
+ } else
+ fpdlcqk9m0ibglfx = m0ibglfx + *hj3ftvzu-1;
+
+ if (*qfx3vhct == 1 || *qfx3vhct == 4 ||
+ *qfx3vhct == 3 || *qfx3vhct == 5) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ msrdjh5f += *fpdlcqk9ufgqj9ck;
+ vogkfwt8 += *fpdlcqk9tlgduey8++ * *fpdlcqk9ufgqj9ck++;
+ }
+ gyuq8dex = vogkfwt8 / msrdjh5f;
+ fpdlcqk9tlgduey8 = tlgduey8 + (*hj3ftvzu-1) * *ftnjamu2;
+ }
+ if (*qfx3vhct == 1) {
+ yiumjq3ng2vwexyk9(&gyuq8dex, &g2vwexykp);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx = g2vwexykp;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ if (*qfx3vhct == 2) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx = log(*fpdlcqk9tlgduey8++ + myoffset);
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ if (*qfx3vhct == 4) {
+ yiumjq3nbewf1pzv9(&gyuq8dex, &qa8ltuhj);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx = qa8ltuhj;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ if (*qfx3vhct == 5) {
+ if (*wr0lbopv == 1 || *wr0lbopv == 2) {
+ kwvo4ury = *wr0lbopv == 1 ? log(gyuq8dex + myoffset) :
+ log((6.0 / 8.0) * gyuq8dex);
+ cpz4fgkx = log(y7sdgtqi[3 + *afpc0kns + *hj3ftvzu -1] + myoffset);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx2 = kwvo4ury;
+ *fpdlcqk9m0ibglfx1 = cpz4fgkx;
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ fpdlcqk9m0ibglfx2 += *wy1vqfzu;
+ }
+ } else {
+ cpz4fgkx = log(y7sdgtqi[3 + *afpc0kns + *hj3ftvzu -1] + myoffset);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx2 = log(*fpdlcqk9tlgduey8++ + myoffset);
+ *fpdlcqk9m0ibglfx1 = cpz4fgkx;
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ fpdlcqk9m0ibglfx2 += *wy1vqfzu;
+ }
+ }
+ }
+ if (*qfx3vhct == 3) {
+ if (*wr0lbopv == 1) {
+ kwvo4ury = log(gyuq8dex + myoffset);
+ cpz4fgkx = log(y7sdgtqi[3 + *hj3ftvzu -1] + myoffset);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx2 = kwvo4ury;
+ *fpdlcqk9m0ibglfx1 = cpz4fgkx;
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ fpdlcqk9m0ibglfx2 += *wy1vqfzu;
+ }
+ } else if (*wr0lbopv == 2) {
+ kwvo4ury = log(gyuq8dex + myoffset);
+ khl0iysgk = y7sdgtqi[3 + *hj3ftvzu -1];
+ cpz4fgkx = log(khl0iysgk);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ tad5vhsu = *fpdlcqk9tlgduey8 - gyuq8dex;
+ *fpdlcqk9m0ibglfx2 = (tad5vhsu < 3.0 * gyuq8dex) ? kwvo4ury :
+ log(sqrt(*fpdlcqk9tlgduey8));
+ *fpdlcqk9m0ibglfx1 = cpz4fgkx;
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ fpdlcqk9m0ibglfx2 += *wy1vqfzu;
+ fpdlcqk9tlgduey8++;
+ }
+ } else if (*wr0lbopv == 3) {
+ kwvo4ury = log(gyuq8dex + myoffset);
+ khl0iysgk = y7sdgtqi[3 + *hj3ftvzu -1];
+ cpz4fgkx = log(khl0iysgk);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ tad5vhsu = *fpdlcqk9tlgduey8 - gyuq8dex;
+ if (tad5vhsu > gyuq8dex) {
+ *fpdlcqk9m0ibglfx2 = log(0.5 * (*fpdlcqk9tlgduey8 + gyuq8dex));
+ *fpdlcqk9m0ibglfx1 = log(khl0iysgk / (tad5vhsu / gyuq8dex));
+ } else
+ if (*fpdlcqk9tlgduey8 < (gyuq8dex / 4.0)) {
+ *fpdlcqk9m0ibglfx2 = log(gyuq8dex / 4.0);
+ *fpdlcqk9m0ibglfx1 = cpz4fgkx;
+ } else {
+ *fpdlcqk9m0ibglfx2 = kwvo4ury;
+ *fpdlcqk9m0ibglfx1 = cpz4fgkx;
+ }
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ fpdlcqk9m0ibglfx2 += *wy1vqfzu;
+ fpdlcqk9tlgduey8++;
+ }
+ } else {
+ cpz4fgkx = log(y7sdgtqi[3 + *hj3ftvzu - 1]);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx2 = log(*fpdlcqk9tlgduey8++ + myoffset);
+ *fpdlcqk9m0ibglfx1 = cpz4fgkx;
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ fpdlcqk9m0ibglfx2 += *wy1vqfzu;
+ }
+ }
+ }
+ if (*qfx3vhct == 8) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx = *fpdlcqk9tlgduey8++;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+}
+
+
+
+void yiumjq3ndlgpwe0c(double tlgduey8[], double ufgqj9ck[], double m0ibglfx[],
+ double t8hwvalr[], double ghz9vuba[], double rbne6ouj[],
+ double wpuarq2m[], double *rsynp1go, double *dn3iasxug, double *uaf2xgqy,
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *hj3ftvzu, int *qfx3vhct, int *zjkrtol8, int *unhycz0e, double vm4xjosb[]) {
+
+ int ayfnwr1v, lbgwvp3q; //qfx3vhct # kvowz9ht
+ double xd4mybgja, xd4mybgjb, xd4mybgjc, anopu9vi;
+ double *fpdlcqk9m0ibglfx, *fpdlcqk9m0ibglfx1, *fpdlcqk9m0ibglfx2, *fpdlcqk9t8hwvalr,
+ *fpdlcqk9vm4xjosb, *fpdlcqk9wpuarq2m, *fpdlcqk9ufgqj9ck, *fpdlcqk9rbne6ouj,
+ *fpdlcqk9tlgduey8, *fpdlcqk9ghz9vuba;
+
+ double hdqsx7bk, dkdeta, dldk, ux3nadiw, ed2ldk2, n2kersmx;
+ double bzmd6ftvmat[1], kkmat[1], nm0eljqk[1];
+ int dvhw1ulq, sguwj9ty, pqneb2ra = 1;
+
+ double jtnbu2hz, uqnkc6zgd, uqnkc6zgt, dldshape, fvn3iasxug, xk7dnvei;
+ int okobr6tcex;
+ double tmp1;
+
+
+ n2kersmx = 0.990e0;
+ n2kersmx = 0.995e0;
+
+ fpdlcqk9m0ibglfx = m0ibglfx + *hj3ftvzu-1;
+ if (*qfx3vhct == 3 || *qfx3vhct == 5) {
+ fpdlcqk9m0ibglfx1 = m0ibglfx + 2 * *hj3ftvzu-1;
+ fpdlcqk9m0ibglfx2 = m0ibglfx + 2 * *hj3ftvzu-2;
+ }
+ fpdlcqk9t8hwvalr = t8hwvalr + *hj3ftvzu-1;
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ fpdlcqk9wpuarq2m = wpuarq2m + *hj3ftvzu-1;
+ fpdlcqk9ufgqj9ck = ufgqj9ck;
+ fpdlcqk9rbne6ouj = rbne6ouj + (*hj3ftvzu-1) * *ftnjamu2;
+ fpdlcqk9tlgduey8 = tlgduey8 + (*hj3ftvzu-1) * *ftnjamu2;
+ fpdlcqk9ghz9vuba = ghz9vuba + (*hj3ftvzu-1) * *ftnjamu2;
+
+ if (*qfx3vhct == 1) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ xd4mybgja = *fpdlcqk9t8hwvalr * (1.0e0 - *fpdlcqk9t8hwvalr);
+ xd4mybgjb = xd4mybgja * *fpdlcqk9ufgqj9ck++;
+ if (xd4mybgja < *dn3iasxug) xd4mybgja = *dn3iasxug;
+ if (xd4mybgjb < *dn3iasxug) {
+ xd4mybgjb = *dn3iasxug;
+ *fpdlcqk9wpuarq2m = *uaf2xgqy;
+ } else {
+ *fpdlcqk9wpuarq2m = sqrt(xd4mybgjb);
+ }
+ *fpdlcqk9rbne6ouj++ = xd4mybgjb;
+ *fpdlcqk9ghz9vuba++ = *fpdlcqk9m0ibglfx +
+ (*fpdlcqk9tlgduey8++ - *fpdlcqk9t8hwvalr) / xd4mybgja;
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9wpuarq2m += *npjlv3mr;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ if (*qfx3vhct == 2) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ xd4mybgja = *fpdlcqk9t8hwvalr;
+ xd4mybgjb = xd4mybgja * *fpdlcqk9ufgqj9ck++;
+ if (xd4mybgjb < *dn3iasxug) {
+ xd4mybgjb = *dn3iasxug;
+ *fpdlcqk9wpuarq2m = *uaf2xgqy;
+ } else {
+ *fpdlcqk9wpuarq2m = sqrt(xd4mybgjb);
+ }
+ *fpdlcqk9rbne6ouj = xd4mybgjb;
+ if (*fpdlcqk9tlgduey8 > 0.0e0) {
+ xd4mybgjc = xd4mybgja;
+ if (xd4mybgjc < *dn3iasxug) xd4mybgjc = *dn3iasxug;
+ *fpdlcqk9ghz9vuba = *fpdlcqk9m0ibglfx + (*fpdlcqk9tlgduey8 - xd4mybgjc) / xd4mybgjc;
+ } else {
+ *fpdlcqk9ghz9vuba = *fpdlcqk9m0ibglfx - 1.0e0;
+ }
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9wpuarq2m += *npjlv3mr;
+ fpdlcqk9rbne6ouj++;
+ fpdlcqk9tlgduey8++;
+ fpdlcqk9ghz9vuba++;
+ }
+ }
+ if (*qfx3vhct == 4) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ if (*fpdlcqk9t8hwvalr < *dn3iasxug || *fpdlcqk9t8hwvalr > 1.0e0 - *dn3iasxug) {
+ xd4mybgja = *dn3iasxug;
+ xd4mybgjb = xd4mybgja * *fpdlcqk9ufgqj9ck;
+ if (xd4mybgjb < *dn3iasxug) {
+ xd4mybgjb = *dn3iasxug;
+ *fpdlcqk9wpuarq2m = *uaf2xgqy;
+ } else {
+ *fpdlcqk9wpuarq2m = sqrt(xd4mybgjb);
+ }
+ *fpdlcqk9rbne6ouj = xd4mybgjb;
+ *fpdlcqk9ghz9vuba = *fpdlcqk9m0ibglfx +
+ (*fpdlcqk9tlgduey8 - *fpdlcqk9t8hwvalr) / xd4mybgja;
+ } else {
+ xd4mybgja = -(1.0e0 - *fpdlcqk9t8hwvalr) * log(1.0e0 - *fpdlcqk9t8hwvalr);
+ if (xd4mybgja < *dn3iasxug) {
+ xd4mybgja = *dn3iasxug;
+ }
+ xd4mybgjb = -xd4mybgja * *fpdlcqk9ufgqj9ck *
+ log(1.0e0 - *fpdlcqk9t8hwvalr) / *fpdlcqk9t8hwvalr;
+ if (xd4mybgjb < *dn3iasxug) {
+ xd4mybgjb = *dn3iasxug;
+ }
+ *fpdlcqk9rbne6ouj = xd4mybgjb;
+ *fpdlcqk9wpuarq2m = sqrt(xd4mybgjb);
+ *fpdlcqk9ghz9vuba = *fpdlcqk9m0ibglfx +
+ (*fpdlcqk9tlgduey8 - *fpdlcqk9t8hwvalr) / xd4mybgja;
+ }
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ fpdlcqk9t8hwvalr += *afpc0kns;
+ fpdlcqk9wpuarq2m += *npjlv3mr;
+ fpdlcqk9ufgqj9ck++;
+ fpdlcqk9rbne6ouj++;
+ fpdlcqk9tlgduey8++;
+ fpdlcqk9ghz9vuba++;
+ }
+ }
+ if (*qfx3vhct == 5) {
+ fvn3iasxug = 1.0e-20;
+ anopu9vi = 34.0e0;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ if (m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu] > anopu9vi) {
+ jtnbu2hz = exp(anopu9vi);
+ lbgwvp3q = 1;
+ } else
+ if (m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu] < -anopu9vi) {
+ jtnbu2hz = exp(-anopu9vi);
+ lbgwvp3q = 1;
+ } else {
+ jtnbu2hz = exp(m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu]);
+ lbgwvp3q = 0;
+ }
+ tyee_C_vdgam1(&jtnbu2hz, &uqnkc6zgd, &okobr6tcex);
+ if (okobr6tcex != 1) {
+ Rprintf("Error 1 in dlgpwe0c okobr6tcex=%d. Ploughing on.\n", okobr6tcex);
+ }
+ xk7dnvei = t8hwvalr[*hj3ftvzu-1 + (ayfnwr1v-1) * *afpc0kns];
+ if (xk7dnvei < fvn3iasxug) { xk7dnvei = fvn3iasxug; }
+ dldshape = log(tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2]) +
+ log(jtnbu2hz) - log(xk7dnvei) + 1.0e0 - uqnkc6zgd -
+ tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] / xk7dnvei;
+
+
+
+ tyee_C_vtgam1(&jtnbu2hz, &uqnkc6zgt, &okobr6tcex);
+ if (okobr6tcex != 1) {
+ Rprintf("Error 2 in dlgpwe0c okobr6tcex=%d. Ploughing on.\n", okobr6tcex);
+ }
+ rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2] =
+ ufgqj9ck[ayfnwr1v-1] * jtnbu2hz;
+ xd4mybgja = jtnbu2hz * uqnkc6zgt - 1.0e0;
+ rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2] =
+ ufgqj9ck[ayfnwr1v-1] * jtnbu2hz * xd4mybgja;
+
+ if (rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2] < *dn3iasxug) {
+ rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2] = *dn3iasxug;
+ wpuarq2m[2 * *hj3ftvzu-2 + (ayfnwr1v-1) * *npjlv3mr] = *uaf2xgqy;
+ } else {
+ wpuarq2m[2 * *hj3ftvzu-2 + (ayfnwr1v-1) * *npjlv3mr] =
+ sqrt(rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2]);
+ }
+ if (rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2] < *dn3iasxug) {
+ rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2] = *dn3iasxug;
+ wpuarq2m[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *npjlv3mr] = *uaf2xgqy;
+ } else {
+ wpuarq2m[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *npjlv3mr] =
+ sqrt(rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2]);
+ }
+
+
+ if (xd4mybgja < fvn3iasxug) { xd4mybgja = fvn3iasxug; }
+ ghz9vuba[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2] =
+ m0ibglfx[2 * *hj3ftvzu-2 + (ayfnwr1v-1) * *wy1vqfzu] +
+ tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] / xk7dnvei - 1.0e0;
+
+ ghz9vuba[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2] =
+ m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu] + dldshape / xd4mybgja;
+ }
+ }
+ if (*qfx3vhct == 3) {
+ anopu9vi = 34.0e0;
+ fvn3iasxug = 1.0e-20;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ if (m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu] > anopu9vi) {
+ hdqsx7bk = exp(anopu9vi);
+ lbgwvp3q = 1;
+ } else
+ if (m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu] < -anopu9vi) {
+ hdqsx7bk = exp(-anopu9vi);
+ lbgwvp3q = 1;
+ } else {
+ hdqsx7bk = exp(m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu]);
+ lbgwvp3q = 0;
+ }
+
+ xk7dnvei = t8hwvalr[*hj3ftvzu-1 + (ayfnwr1v-1) * *afpc0kns];
+ if (xk7dnvei < fvn3iasxug) { xk7dnvei = fvn3iasxug; }
+ tmp1 = tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] + hdqsx7bk;
+ tyee_C_vdgam1(&tmp1, &xd4mybgja, &okobr6tcex);
+
+ if (okobr6tcex != 1) {
+ Rprintf("error in dlgpwe0c okobr6tcex 3: %3d \n", okobr6tcex);
+ }
+ tyee_C_vdgam1(&hdqsx7bk, &xd4mybgjb, &okobr6tcex);
+ if (okobr6tcex != 1) {
+ Rprintf("error in dlgpwe0c okobr6tcex 4: %3d \n", okobr6tcex);
+ }
+ dldk = xd4mybgja - xd4mybgjb -
+ (tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] + hdqsx7bk)
+ / (xk7dnvei + hdqsx7bk) + 1.0 + log(hdqsx7bk / (xk7dnvei + hdqsx7bk));
+
+ dkdeta = hdqsx7bk;
+
+ kkmat[0] = hdqsx7bk;
+ nm0eljqk[0] = xk7dnvei;
+ sguwj9ty = 5000;
+ fvlmz9iyC_enbin9(bzmd6ftvmat, kkmat, nm0eljqk,
+ &n2kersmx, &pqneb2ra, &dvhw1ulq, &pqneb2ra,
+ &ux3nadiw, rsynp1go, &sguwj9ty);
+ if (dvhw1ulq != 1) {
+ *zjkrtol8 = 5;
+ Rprintf("Error. Exiting enbin9; dvhw1ulq is %d\n", dvhw1ulq);
+ return;
+ }
+
+ ed2ldk2 = -bzmd6ftvmat[0] - 1.0e0 / hdqsx7bk + 1.0e0 / (hdqsx7bk + xk7dnvei);
+ rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2] =
+ ufgqj9ck[ayfnwr1v-1] * xk7dnvei * hdqsx7bk / (xk7dnvei + hdqsx7bk);
+ rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2] =
+ ufgqj9ck[ayfnwr1v-1] * hdqsx7bk *
+ (-bzmd6ftvmat[0] * hdqsx7bk - 1.0e0 + hdqsx7bk / (hdqsx7bk + xk7dnvei));
+
+ if (rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2] < *dn3iasxug) {
+ rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2] = *dn3iasxug;
+ wpuarq2m[2 * *hj3ftvzu-2 + (ayfnwr1v-1) * *npjlv3mr] = *uaf2xgqy;
+ } else
+ wpuarq2m[2 * *hj3ftvzu-2 + (ayfnwr1v-1) * *npjlv3mr] =
+ sqrt(rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2]);
+ if (rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2] < *dn3iasxug) {
+ rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2] = *dn3iasxug;
+ wpuarq2m[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *npjlv3mr] = *uaf2xgqy;
+ } else {
+ wpuarq2m[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *npjlv3mr] =
+ sqrt(rbne6ouj[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2]);
+ }
+
+ ghz9vuba[ayfnwr1v-1 + (2 * *hj3ftvzu-2) * *ftnjamu2] =
+ m0ibglfx[2 * *hj3ftvzu-2 + (ayfnwr1v-1) * *wy1vqfzu] +
+ tlgduey8[ayfnwr1v-1 + (*hj3ftvzu-1) * *ftnjamu2] / xk7dnvei - 1.0e0;
+ ghz9vuba[ayfnwr1v-1 + (2 * *hj3ftvzu-1) * *ftnjamu2] =
+ m0ibglfx[2 * *hj3ftvzu-1 + (ayfnwr1v-1) * *wy1vqfzu] +
+ dldk / (dkdeta * ed2ldk2);
+ }
+ }
+ if (*qfx3vhct == 8) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9rbne6ouj = *fpdlcqk9ufgqj9ck++;
+ *fpdlcqk9wpuarq2m = sqrt(*fpdlcqk9rbne6ouj);
+ *fpdlcqk9ghz9vuba++ = *fpdlcqk9tlgduey8++;
+ fpdlcqk9wpuarq2m += *npjlv3mr;
+ fpdlcqk9rbne6ouj++;
+ }
+ }
+
+ if (*unhycz0e == 1) {
+ fpdlcqk9ghz9vuba = ghz9vuba + ((*qfx3vhct == 3 || *qfx3vhct == 5) ?
+ (2 * *hj3ftvzu-2) : (*hj3ftvzu-1)) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9ghz9vuba -= *fpdlcqk9vm4xjosb++;
+ fpdlcqk9ghz9vuba++;
+ }
+ }
+}
+
+
+
+void cqo_2(double lncwkfq7[], double tlgduey8[], double kifxa0he[],
+ double ufgqj9ck[], double m0ibglfx[], double vm4xjosb[],
+ double t8hwvalr[], double ghz9vuba[], double rbne6ouj[],
+ double wpuarq2m[], double w8znmyce[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *zjkrtol8, int xui7hqwl[],
+ double *tlq9wpes, double zshtfg8c[],
+ double y7sdgtqi[]) {
+
+
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, uw3favmo, bpvaqm5z, g3psxjru, yu6izdrc = 0,
+ kcm6jfob, fmzq7aob, xwdf5ltg, kvowz9ht, f7svlajr, qfx3vhct, c5aesxkul, pqneb2ra = 1;
+ int ybnsqgo9, algpft4y, qemj9asg, xlpjcg3s, eu3oxvyb, vtsou9pz, unhycz0e, zaupqv9b, wr0lbopv;
+ double dn3iasxug, wiptsjx8, bh2vgiay, pvofyg8z = 1.0e-7, uylxqtc7 = 0.0,
+ uaf2xgqy, vsoihn1r, rsynp1go; // rpto5qwb,
+ double *qnwamo0e1, *fpdlcqk9w8znmyce,
+ *fpdlcqk9m0ibglfx, *fpdlcqk9vm4xjosb, *fpdlcqk9vc6hatuj, *fpdlcqk9wpuarq2m, *fpdlcqk9ghz9vuba;
+ double hmayv1xt1 = 1.0, hmayv1xt2 = 0.0;
+ int x1jrewny = 0;
+
+ double *wkumc9idrpto5qwb, *wkumc9idtwk;
+ wkumc9idrpto5qwb = Calloc(1 + *afpc0kns , double);
+ wkumc9idtwk = Calloc(*wy1vqfzu * *ftnjamu2 * 2, double);
+
+
+ xwdf5ltg = xui7hqwl[0];
+ fmzq7aob = xui7hqwl[1];
+ xlpjcg3s = xui7hqwl[2];
+ kvowz9ht = xui7hqwl[3];
+ f7svlajr = xui7hqwl[4];
+ qfx3vhct = xui7hqwl[5];
+ c5aesxkul = xui7hqwl[6];
+ xui7hqwl[8] = 0;
+ eu3oxvyb = xui7hqwl[10];
+ vtsou9pz = xui7hqwl[11];
+ unhycz0e = xui7hqwl[13];
+ zaupqv9b = xui7hqwl[14];
+ wr0lbopv = xui7hqwl[17];
+ dn3iasxug = y7sdgtqi[0];
+ uaf2xgqy = sqrt(dn3iasxug);
+ if (qfx3vhct == 1 || qfx3vhct == 4)
+ vsoihn1r = log(dn3iasxug);
+ bh2vgiay = y7sdgtqi[1];
+ rsynp1go = y7sdgtqi[2];
+
+ *zjkrtol8 = 1;
+
+ yiumjq3nflncwkfq72(lncwkfq7, w8znmyce, ftnjamu2, wy1vqfzu,
+ br5ovgcj, &xwdf5ltg, &qfx3vhct, afpc0kns,
+ &fmzq7aob, &eu3oxvyb, &unhycz0e, vm4xjosb);
+
+ ceqzd1hi653: hmayv1xt2 = 1.0e0;
+
+ if (f7svlajr == 0) {
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ yiumjq3nietam6(tlgduey8, m0ibglfx, y7sdgtqi, ftnjamu2,
+ wy1vqfzu, afpc0kns, &qfx3vhct, &yq6lorbx, ufgqj9ck, &wr0lbopv);
+ }
+ } else
+ if (f7svlajr == 2) {
+ yiumjq3npkc4ejib(w8znmyce, zshtfg8c, m0ibglfx,
+ ftnjamu2, wy1vqfzu, br5ovgcj, &xlpjcg3s,
+ &vtsou9pz, &yu6izdrc, &qfx3vhct, &unhycz0e,
+ vm4xjosb);
+ }
+
+ yiumjq3nnipyajc1(m0ibglfx, t8hwvalr, ftnjamu2, wy1vqfzu,
+ afpc0kns, &qfx3vhct, &yu6izdrc);
+
+ if (f7svlajr == 2) {
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, wkumc9idrpto5qwb, &yu6izdrc,
+ &dn3iasxug, &vsoihn1r, &pqneb2ra);
+ } else {
+ wkumc9idrpto5qwb[0] = -1.0e0;
+ }
+
+
+ for (kcm6jfob = 1; kcm6jfob <= c5aesxkul; kcm6jfob++) {
+
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ yiumjq3ndlgpwe0c(tlgduey8, ufgqj9ck, m0ibglfx,
+ t8hwvalr, ghz9vuba, rbne6ouj,
+ wpuarq2m, &rsynp1go, &dn3iasxug, &uaf2xgqy,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ &yq6lorbx, &qfx3vhct, zjkrtol8, &unhycz0e, vm4xjosb);
+ }
+
+
+ fpdlcqk9vc6hatuj = vc6hatuj; fpdlcqk9w8znmyce = w8znmyce;
+ for (yq6lorbx = 1; yq6lorbx <= xlpjcg3s; yq6lorbx++)
+ for (ayfnwr1v = 1; ayfnwr1v <= *br5ovgcj; ayfnwr1v++)
+ *fpdlcqk9vc6hatuj++ = *fpdlcqk9w8znmyce++;
+
+
+
+ if (qfx3vhct == 3 || qfx3vhct == 5) {
+ Rprintf("20100410; Error: this definitely does not work\n");
+ if (2 * *wy1vqfzu * *ftnjamu2 != *br5ovgcj) //Rprintf
+ Rprintf("Error: 2 * *wy1vqfzu * *ftnjamu2 != *br5ovgcj in C_cqo_2\n");
+ fpdlcqk9vc6hatuj = vc6hatuj;
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++) {
+ fpdlcqk9wpuarq2m = wpuarq2m;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (bpvaqm5z = 1; bpvaqm5z <= *wy1vqfzu; bpvaqm5z++) {
+ *fpdlcqk9vc6hatuj *= *fpdlcqk9wpuarq2m++;
+ fpdlcqk9vc6hatuj++;
+ }
+ }
+ }
+ } else {
+ if (*wy1vqfzu * *ftnjamu2 != *br5ovgcj) //Rprintf
+ Rprintf("Error: *wy1vqfzu * *ftnjamu2 != *br5ovgcj in C_cqo_2\n");
+ fpdlcqk9vc6hatuj = vc6hatuj;
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++) {
+ fpdlcqk9wpuarq2m = wpuarq2m;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (bpvaqm5z = 1; bpvaqm5z <= *wy1vqfzu; bpvaqm5z++) {
+ *fpdlcqk9vc6hatuj *= *fpdlcqk9wpuarq2m++;
+ fpdlcqk9vc6hatuj++;
+ }
+ }
+ }
+ }
+
+
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++)
+ ges1xpkr[gp1jxzuh-1] = gp1jxzuh;
+
+ F77_CALL(vqrdca)(vc6hatuj, br5ovgcj, br5ovgcj, &xlpjcg3s, fasrkub3, ges1xpkr,
+ wkumc9idtwk, &qemj9asg, &pvofyg8z);
+
+ if (qemj9asg != xlpjcg3s) {
+ *zjkrtol8 = 2;
+ Rprintf("Failure or Error in cqo_2: vc6hatuj is not of full xwdf5ltg.\n");
+ Free(wkumc9idrpto5qwb); Free(wkumc9idtwk);
+ return;
+ }
+
+ if (*npjlv3mr != *wy1vqfzu) //Rprintf
+ Rprintf("Error: *wy1vqfzu != *npjlv3mr in C_cqo_2\n");
+ qnwamo0e1 = wkumc9idtwk;
+ fpdlcqk9wpuarq2m = wpuarq2m;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ fpdlcqk9ghz9vuba = ghz9vuba + ayfnwr1v-1;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *qnwamo0e1++ = *fpdlcqk9wpuarq2m++ * *fpdlcqk9ghz9vuba;
+ fpdlcqk9ghz9vuba += *ftnjamu2;
+ }
+ }
+
+ ybnsqgo9 = 101;
+
+ F77_CALL(vdqrsl)(vc6hatuj, br5ovgcj, br5ovgcj, &qemj9asg, fasrkub3, wkumc9idtwk,
+ &uylxqtc7, wkumc9idtwk + *wy1vqfzu * *ftnjamu2, zshtfg8c,
+ &uylxqtc7, m0ibglfx, &ybnsqgo9, &algpft4y);
+
+
+ if (*npjlv3mr != *wy1vqfzu) //Rprintf
+ Rprintf("Error: *wy1vqfzu != *npjlv3mr in C_cqo_2\n");
+ fpdlcqk9m0ibglfx = m0ibglfx;
+ fpdlcqk9wpuarq2m = wpuarq2m;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9m0ibglfx /= *fpdlcqk9wpuarq2m++;
+ fpdlcqk9m0ibglfx++;
+ }
+ }
+
+
+ if (unhycz0e == 1) {
+ if (qfx3vhct == 3 || qfx3vhct == 5) {
+ if (2 * *afpc0kns != *wy1vqfzu) //Rprintf
+ Rprintf("Error: 2 * *afpc0kns != *wy1vqfzu in C_cqo_2\n");
+ fpdlcqk9m0ibglfx = m0ibglfx;
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *afpc0kns; yq6lorbx++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9vm4xjosb;
+ fpdlcqk9m0ibglfx += 2;
+ }
+ fpdlcqk9vm4xjosb++;
+ }
+ } else {
+ fpdlcqk9m0ibglfx = m0ibglfx;
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9vm4xjosb;
+ fpdlcqk9m0ibglfx++;
+ }
+ fpdlcqk9vm4xjosb++;
+ }
+ }
+ }
+
+ yiumjq3nnipyajc1(m0ibglfx, t8hwvalr, ftnjamu2, wy1vqfzu,
+ afpc0kns, &qfx3vhct, &yu6izdrc);
+
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, tlq9wpes, &yu6izdrc,
+ &dn3iasxug, &vsoihn1r, &pqneb2ra);
+
+ wiptsjx8 = fabs(*tlq9wpes - *wkumc9idrpto5qwb) / (1.0e0 +
+ fabs(*tlq9wpes));
+ if (wiptsjx8 < bh2vgiay) { // xxx
+ *zjkrtol8 = 0;
+ xui7hqwl[7] = kcm6jfob;
+
+
+ if (qfx3vhct == 3 || qfx3vhct == 5) {
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, tlq9wpes, &yu6izdrc,
+ &dn3iasxug, &vsoihn1r, &yu6izdrc);
+ }
+ x1jrewny = 1;
+ goto ceqzd1hi20097;
+ } else { // xxx and
+ *wkumc9idrpto5qwb = *tlq9wpes;
+ x1jrewny = 0;
+ }
+ }
+
+ ceqzd1hi20097: hmayv1xt1 = 0.0e0;
+
+ if (x1jrewny == 1) {
+ Free(wkumc9idrpto5qwb); Free(wkumc9idtwk);
+ return;
+ }
+
+ if (f7svlajr == 1 || f7svlajr == 2) {
+ f7svlajr = 0;
+ xui7hqwl[8] = 1;
+ goto ceqzd1hi653;
+ }
+
+ *zjkrtol8 = 3;
+
+ Free(wkumc9idrpto5qwb); Free(wkumc9idtwk);
+}
+
+
+
+
+
+
+void cqo_1(double lncwkfq7[], double tlgduey8[],
+ double kifxa0he[],
+ double ufgqj9ck[], double m0ibglfx[],
+ double vm4xjosb[],
+ double t8hwvalr[], double ghz9vuba[], double rbne6ouj[],
+ double wpuarq2m[], double w8znmyce[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *zjkrtol8, int xui7hqwl[],
+ double *tlq9wpes, double zshtfg8c[],
+ double y7sdgtqi[]) {
+
+
+
+ int ayfnwr1v, hj3ftvzu, yu6izdrc = 0, pqneb2ra = 1,
+ kcm6jfob, fmzq7aob, unhycz0e, xwdf5ltg, kvowz9ht, f7svlajr, qfx3vhct, c5aesxkul,
+ ybnsqgo9, algpft4y, qemj9asg, xlpjcg3s, vtsou9pz, zaupqv9b, yru9olks, wr0lbopv;
+ double dn3iasxug, wiptsjx8, pvofyg8z = 1.0e-7, uylxqtc7 = 0.0,
+ bh2vgiay, uaf2xgqy, vsoihn1r, rsynp1go, rpto5qwb;
+ double *fpdlcqk9zshtfg8c, *fpdlcqk9w8znmyce,
+ *fpdlcqk9m0ibglfx, *fpdlcqk9m0ibglfx1, *fpdlcqk9m0ibglfx2,
+ *fpdlcqk9vm4xjosb, *fpdlcqk9vc6hatuj, *fpdlcqk9twk,
+ *fpdlcqk9wpuarq2m, *fpdlcqk9wpuarq2m1, *fpdlcqk9wpuarq2m2,
+ *fpdlcqk9ghz9vuba1, *fpdlcqk9ghz9vuba2;
+
+ int gp1jxzuh, loopCnt, loopCnt2;
+ double hmayv1xt = 2.0, Totdev = 0.0e0;
+
+ double *wkumc9idtwk;
+ wkumc9idtwk = Calloc(*br5ovgcj * 3 , double);
+
+ xwdf5ltg = xui7hqwl[0];
+ fmzq7aob = xui7hqwl[1];
+ xlpjcg3s = xui7hqwl[2];
+ kvowz9ht = xui7hqwl[3];
+ f7svlajr = xui7hqwl[4];
+ qfx3vhct = xui7hqwl[5];
+ c5aesxkul = xui7hqwl[6];
+ xui7hqwl[8] = 0; // twice
+ vtsou9pz = xui7hqwl[11];
+
+ zjkrtol8[0] = -1;
+ for(ayfnwr1v = 1; ayfnwr1v <= *afpc0kns; ayfnwr1v++)
+ zjkrtol8[ayfnwr1v] = 1;
+
+ if (vtsou9pz != 1) {
+ Rprintf("Error: vtsou9pz is not unity in cqo_1!\n");
+ *zjkrtol8 = 4;
+ Free(wkumc9idtwk);
+ return;
+ }
+ unhycz0e = xui7hqwl[13];
+ zaupqv9b = xui7hqwl[14];
+ yru9olks = xui7hqwl[15];
+ wr0lbopv = xui7hqwl[17];
+
+ dn3iasxug = y7sdgtqi[0];
+ uaf2xgqy = sqrt(dn3iasxug);
+ if (qfx3vhct == 1 || qfx3vhct == 4)
+ vsoihn1r = log(dn3iasxug);
+ bh2vgiay = y7sdgtqi[1];
+ rsynp1go = y7sdgtqi[2];
+
+
+
+
+ yiumjq3nflncwkfq71(lncwkfq7, w8znmyce, ftnjamu2, &xwdf5ltg,
+ &qfx3vhct, vm4xjosb, br5ovgcj, &xlpjcg3s,
+ kifxa0he, &yru9olks, &unhycz0e);
+
+
+
+
+
+
+
+ for (hj3ftvzu = 1; hj3ftvzu <= *afpc0kns; hj3ftvzu++) {
+ ceqzd1hi653: hmayv1xt = 1.0e0;
+
+ if (f7svlajr == 0) {
+ yiumjq3nietam6(tlgduey8, m0ibglfx, y7sdgtqi, ftnjamu2,
+ wy1vqfzu, afpc0kns, &qfx3vhct, &hj3ftvzu, ufgqj9ck, &wr0lbopv);
+
+ } else
+ if (f7svlajr == 2) {
+ yiumjq3npkc4ejib(w8znmyce, zshtfg8c + (hj3ftvzu-1) * xlpjcg3s, m0ibglfx,
+ ftnjamu2, wy1vqfzu, br5ovgcj, &xlpjcg3s,
+ &vtsou9pz, &hj3ftvzu, &qfx3vhct, &unhycz0e,
+ vm4xjosb);
+ }
+
+ yiumjq3nnipyajc1(m0ibglfx, t8hwvalr, ftnjamu2, wy1vqfzu,
+ afpc0kns, &qfx3vhct, &hj3ftvzu);
+
+ if (f7svlajr == 2) {
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, &rpto5qwb, &hj3ftvzu,
+ &dn3iasxug, &vsoihn1r, &pqneb2ra);
+ } else {
+ rpto5qwb = -1.0e0;
+ }
+
+ for (kcm6jfob = 1; kcm6jfob <= c5aesxkul; kcm6jfob++) {
+
+
+
+ yiumjq3ndlgpwe0c(tlgduey8, ufgqj9ck, m0ibglfx,
+ t8hwvalr, ghz9vuba, rbne6ouj,
+ wpuarq2m, &rsynp1go, &dn3iasxug, &uaf2xgqy,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ &hj3ftvzu, &qfx3vhct, zjkrtol8 + hj3ftvzu, &unhycz0e, vm4xjosb);
+
+
+
+ fpdlcqk9vc6hatuj = vc6hatuj; fpdlcqk9w8znmyce = w8znmyce;
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++)
+ for (ayfnwr1v = 1; ayfnwr1v <= *br5ovgcj; ayfnwr1v++)
+ *fpdlcqk9vc6hatuj++ = *fpdlcqk9w8znmyce++;
+
+ if (qfx3vhct == 3 || qfx3vhct == 5) {
+ if (2 * *ftnjamu2 != *br5ovgcj) //Rprintf
+ Rprintf("Error: 2 * *ftnjamu2 != *br5ovgcj in C_cqo_1\n");
+ fpdlcqk9vc6hatuj = vc6hatuj;
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++) {
+ fpdlcqk9wpuarq2m2 = wpuarq2m + 2*hj3ftvzu -2;
+ fpdlcqk9wpuarq2m1 = wpuarq2m + 2*hj3ftvzu -1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9vc6hatuj *= *fpdlcqk9wpuarq2m2;
+ fpdlcqk9vc6hatuj++;
+ *fpdlcqk9vc6hatuj *= *fpdlcqk9wpuarq2m1;
+ fpdlcqk9vc6hatuj++;
+ fpdlcqk9wpuarq2m1 += *npjlv3mr;
+ fpdlcqk9wpuarq2m2 += *npjlv3mr;
+ }
+ }
+ } else {
+ if (1 * *ftnjamu2 != *br5ovgcj) //Rprintf
+ Rprintf("Error: 1 * *ftnjamu2 != *br5ovgcj in C_cqo_1\n");
+ fpdlcqk9vc6hatuj = vc6hatuj;
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++) {
+ fpdlcqk9wpuarq2m = wpuarq2m + hj3ftvzu -1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9vc6hatuj *= *fpdlcqk9wpuarq2m;
+ fpdlcqk9vc6hatuj++;
+ fpdlcqk9wpuarq2m += *npjlv3mr;
+ }
+ }
+ }
+
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++)
+ ges1xpkr[gp1jxzuh-1] = gp1jxzuh;
+
+
+ F77_CALL(vqrdca)(vc6hatuj, br5ovgcj, br5ovgcj, &xlpjcg3s, fasrkub3, ges1xpkr,
+ wkumc9idtwk, &qemj9asg, &pvofyg8z);
+
+ if (qemj9asg != xlpjcg3s) {
+ Rprintf("Error in cqo_1: vc6hatuj is not of full xwdf5ltg.\n");
+ *zjkrtol8 = 2;
+ Free(wkumc9idtwk);
+ return;
+ }
+
+ if (qfx3vhct == 3 || qfx3vhct == 5) {
+ fpdlcqk9ghz9vuba1 = ghz9vuba + (2*hj3ftvzu-1) * *ftnjamu2;
+ fpdlcqk9ghz9vuba2 = ghz9vuba + (2*hj3ftvzu-2) * *ftnjamu2;
+ fpdlcqk9wpuarq2m1 = wpuarq2m + 2*hj3ftvzu-1;
+ fpdlcqk9wpuarq2m2 = wpuarq2m + 2*hj3ftvzu-2;
+ fpdlcqk9twk = wkumc9idtwk;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9twk++ = *fpdlcqk9wpuarq2m2 * *fpdlcqk9ghz9vuba2++;
+ *fpdlcqk9twk++ = *fpdlcqk9wpuarq2m1 * *fpdlcqk9ghz9vuba1++;
+ fpdlcqk9wpuarq2m1 += *npjlv3mr;
+ fpdlcqk9wpuarq2m2 += *npjlv3mr;
+ }
+ } else {
+ fpdlcqk9ghz9vuba1 = ghz9vuba + (hj3ftvzu-1) * *ftnjamu2;
+ fpdlcqk9twk = wkumc9idtwk;
+ fpdlcqk9wpuarq2m = wpuarq2m + hj3ftvzu-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9twk++ = *fpdlcqk9wpuarq2m * *fpdlcqk9ghz9vuba1++;
+ fpdlcqk9wpuarq2m += *npjlv3mr;
+ }
+ }
+
+ ybnsqgo9 = 101;
+
+ F77_CALL(vdqrsl)(vc6hatuj, br5ovgcj, br5ovgcj, &qemj9asg, fasrkub3, wkumc9idtwk,
+ &uylxqtc7, wkumc9idtwk + *br5ovgcj,
+ zshtfg8c + (hj3ftvzu-1) * xlpjcg3s,
+ &uylxqtc7, wkumc9idtwk + 2 * *br5ovgcj, &ybnsqgo9, &algpft4y);
+
+
+ fpdlcqk9twk = wkumc9idtwk;
+ fpdlcqk9zshtfg8c = zshtfg8c + (hj3ftvzu-1) * xlpjcg3s;
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++) {
+ *fpdlcqk9twk++ = *fpdlcqk9zshtfg8c++;
+ }
+
+ fpdlcqk9twk = wkumc9idtwk;
+ fpdlcqk9zshtfg8c = zshtfg8c + (hj3ftvzu-1) * xlpjcg3s;
+ for (gp1jxzuh = 1; gp1jxzuh <= xlpjcg3s; gp1jxzuh++) {
+ *(fpdlcqk9zshtfg8c + ges1xpkr[gp1jxzuh-1] - 1) = *fpdlcqk9twk++;
+ }
+
+ if (qfx3vhct == 3 || qfx3vhct == 5) {
+
+ fpdlcqk9m0ibglfx2 = m0ibglfx + 2 * hj3ftvzu -2;
+ fpdlcqk9m0ibglfx1 = m0ibglfx + 2 * hj3ftvzu -1;
+ fpdlcqk9twk = wkumc9idtwk + 2 * *br5ovgcj;
+ fpdlcqk9wpuarq2m2 = wpuarq2m + 2 * hj3ftvzu -2;
+ fpdlcqk9wpuarq2m1 = wpuarq2m + 2 * hj3ftvzu -1;
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx2 = *fpdlcqk9twk++ / *fpdlcqk9wpuarq2m2;
+ *fpdlcqk9m0ibglfx1 = *fpdlcqk9twk++ / *fpdlcqk9wpuarq2m1;
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ fpdlcqk9m0ibglfx2 += *wy1vqfzu;
+ fpdlcqk9wpuarq2m1 += *npjlv3mr;
+ fpdlcqk9wpuarq2m2 += *npjlv3mr;
+ }
+
+ if (unhycz0e == 1) {
+ fpdlcqk9m0ibglfx = m0ibglfx + 2*hj3ftvzu-2;
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9vm4xjosb++;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ } else {
+ fpdlcqk9m0ibglfx = m0ibglfx + hj3ftvzu -1;
+ fpdlcqk9twk = wkumc9idtwk + 2 * *br5ovgcj;
+ fpdlcqk9wpuarq2m = wpuarq2m + hj3ftvzu -1;
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx = *fpdlcqk9twk++ / *fpdlcqk9wpuarq2m;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ fpdlcqk9wpuarq2m += *npjlv3mr;
+ }
+ if (unhycz0e == 1) {
+ fpdlcqk9m0ibglfx = m0ibglfx + hj3ftvzu-1;
+ fpdlcqk9vm4xjosb = vm4xjosb;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9vm4xjosb++;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+ }
+
+ yiumjq3nnipyajc1(m0ibglfx, t8hwvalr, ftnjamu2, wy1vqfzu,
+ afpc0kns, &qfx3vhct, &hj3ftvzu);
+
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, tlq9wpes + hj3ftvzu, &hj3ftvzu,
+ &dn3iasxug, &vsoihn1r, &pqneb2ra);
+
+ wiptsjx8 = fabs(tlq9wpes[hj3ftvzu] - rpto5qwb) / (1.0e0 +
+ fabs(tlq9wpes[hj3ftvzu]));
+ if (wiptsjx8 < bh2vgiay) {
+ zjkrtol8[hj3ftvzu] = 0;
+ xui7hqwl[7] = kcm6jfob;
+ if (qfx3vhct == 3 || qfx3vhct == 5) {
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, tlq9wpes + hj3ftvzu, &hj3ftvzu,
+ &dn3iasxug, &vsoihn1r, &yu6izdrc);
+ }
+ Totdev += tlq9wpes[hj3ftvzu];
+ goto ceqzd1hi1011;
+ } else {
+ rpto5qwb = tlq9wpes[hj3ftvzu];
+ }
+ }
+
+ Rprintf("cqo_1; no convergence for Species ");
+ Rprintf("number %3d. Trying internal starting values.\n", hj3ftvzu);
+ if (f7svlajr == 1) {
+ f7svlajr = 0;
+ xui7hqwl[8] = 1;
+ goto ceqzd1hi653;
+ }
+
+ *zjkrtol8 = 3;
+ zjkrtol8[hj3ftvzu] = 2;
+ Rprintf("cqo_1; no convergence for Species ");
+ Rprintf("number %3d. Continuing on with other species.\n", hj3ftvzu);
+ Totdev += tlq9wpes[hj3ftvzu];
+
+ ceqzd1hi1011: hmayv1xt = 3.0e0;
+ }
+
+
+ if(zjkrtol8[0] == -1)
+ for(ayfnwr1v = 1; ayfnwr1v <= *afpc0kns; ayfnwr1v++)
+ if(zjkrtol8[ayfnwr1v] != 0) zjkrtol8[0] = 1;
+ if(zjkrtol8[0] == -1)
+ zjkrtol8[0] = 0;
+
+ *tlq9wpes = Totdev;
+
+ Free(wkumc9idtwk);
+}
+
+
+
+
+
+void dcqo1(double lncwkfq7[], double tlgduey8[], double kifxa0he[],
+ double ufgqj9ck[], double m0ibglfx[], double vm4xjosb[],
+ double t8hwvalr[], double ghz9vuba[], double rbne6ouj[],
+ double wpuarq2m[], double w8znmyce[], double vc6hatuj[],
+ double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu,
+ int *afpc0kns, int *br5ovgcj, int *npjlv3mr, int *zjkrtol8,
+ int xui7hqwl[], double *tlq9wpes, double zshtfg8c[],
+ double y7sdgtqi[],
+ double atujnxb8[],
+ double k7hulceq[], int *eoviz2fb,
+ double kpzavbj3mat[], double *ydcnh9xl) {
+
+
+
+ int ayfnwr1v, gp1jxzuh, xvr7bonh, hpmwnav2, idlosrw8, xwdf5ltg = xui7hqwl[ 0],
+ vtsou9pz, wr0lbopv, exrkcn5d = xui7hqwl[12];
+ double fxnhilr3, *fpdlcqk9k7hulceq,
+ *fpdlcqk9kpzavbj3mat, *fpdlcqk9lncwkfq7, *fpdlcqk9yxiwebc5, *fpdlcqk9atujnxb8;
+
+ double *wkumc9idajul8wkv, *wkumc9iddev0, *wkumc9idyxiwebc5;
+ wkumc9idajul8wkv = Calloc(exrkcn5d , double);
+ wkumc9iddev0 = Calloc(1 + *afpc0kns , double);
+ wkumc9idyxiwebc5 = Calloc(*ftnjamu2 * xwdf5ltg , double);
+
+ fpdlcqk9kpzavbj3mat = kpzavbj3mat;
+
+ idlosrw8 = xui7hqwl[ 4];
+ vtsou9pz = xui7hqwl[11];
+ wr0lbopv = xui7hqwl[17];
+
+ fpdlcqk9lncwkfq7 = lncwkfq7;
+ fpdlcqk9yxiwebc5 = wkumc9idyxiwebc5;
+ for (hpmwnav2 = 1; hpmwnav2 <= xwdf5ltg; hpmwnav2++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ fxnhilr3 = 0.0e0;
+ fpdlcqk9k7hulceq = k7hulceq + (hpmwnav2-1) * *eoviz2fb;
+ fpdlcqk9atujnxb8 = atujnxb8 + ayfnwr1v-1;
+ for (xvr7bonh = 1; xvr7bonh <= *eoviz2fb; xvr7bonh++) {
+ fxnhilr3 += *fpdlcqk9atujnxb8 * *fpdlcqk9k7hulceq++;
+ fpdlcqk9atujnxb8 += *ftnjamu2;
+ }
+ *fpdlcqk9yxiwebc5++ = *fpdlcqk9lncwkfq7++ = fxnhilr3;
+ }
+ }
+ if (vtsou9pz == 1) {
+ cqo_1(lncwkfq7, tlgduey8, kifxa0he, ufgqj9ck,
+ m0ibglfx, vm4xjosb, t8hwvalr, ghz9vuba, rbne6ouj, wpuarq2m, w8znmyce,
+ vc6hatuj, fasrkub3, ges1xpkr,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ zjkrtol8, xui7hqwl, wkumc9iddev0, wkumc9idajul8wkv, y7sdgtqi);
+
+ } else {
+ cqo_2(lncwkfq7, tlgduey8, kifxa0he, ufgqj9ck,
+ m0ibglfx, vm4xjosb, t8hwvalr, ghz9vuba, rbne6ouj, wpuarq2m, w8znmyce,
+ vc6hatuj, fasrkub3, ges1xpkr,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ zjkrtol8, xui7hqwl, wkumc9iddev0, wkumc9idajul8wkv, y7sdgtqi);
+ }
+
+
+ fpdlcqk9atujnxb8 = atujnxb8;
+ for (xvr7bonh = 1; xvr7bonh <= *eoviz2fb; xvr7bonh++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9atujnxb8 *= *ydcnh9xl;
+ fpdlcqk9atujnxb8++;
+ }
+ }
+
+ for (hpmwnav2 = 1; hpmwnav2 <= xwdf5ltg; hpmwnav2++) {
+ for (xvr7bonh = 1; xvr7bonh <= *eoviz2fb; xvr7bonh++) {
+ fpdlcqk9lncwkfq7 = lncwkfq7 + (hpmwnav2-1) * *ftnjamu2;
+ fpdlcqk9yxiwebc5 = wkumc9idyxiwebc5 + (hpmwnav2-1) * *ftnjamu2;
+ fpdlcqk9atujnxb8 = atujnxb8 + (xvr7bonh-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9lncwkfq7++ = *fpdlcqk9yxiwebc5++ + *fpdlcqk9atujnxb8++;
+ }
+
+
+ xui7hqwl[4] = 2;
+
+ for (gp1jxzuh = 1; gp1jxzuh <= exrkcn5d; gp1jxzuh++)
+ zshtfg8c[gp1jxzuh-1] = wkumc9idajul8wkv[gp1jxzuh-1];
+
+ if (vtsou9pz == 1) {
+ cqo_1(lncwkfq7, tlgduey8, kifxa0he, ufgqj9ck,
+ m0ibglfx, vm4xjosb, t8hwvalr, ghz9vuba, rbne6ouj, wpuarq2m, w8znmyce,
+ vc6hatuj, fasrkub3, ges1xpkr,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ zjkrtol8, xui7hqwl,
+ tlq9wpes, zshtfg8c, y7sdgtqi);
+ } else {
+ cqo_2(lncwkfq7, tlgduey8, kifxa0he, ufgqj9ck,
+ m0ibglfx, vm4xjosb, t8hwvalr, ghz9vuba, rbne6ouj, wpuarq2m, w8znmyce,
+ vc6hatuj, fasrkub3, ges1xpkr,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ zjkrtol8, xui7hqwl,
+ tlq9wpes, zshtfg8c, y7sdgtqi);
+ }
+
+ if (*zjkrtol8 != 0) {
+ Rprintf("Error in dcqo1: zjkrtol8 = %d\n", *zjkrtol8);
+ Rprintf("Continuing.\n");
+ }
+ *fpdlcqk9kpzavbj3mat++ = (*tlq9wpes - *wkumc9iddev0) / *ydcnh9xl;
+ }
+
+ if (xwdf5ltg > 1) {
+ fpdlcqk9lncwkfq7 = lncwkfq7 + (hpmwnav2-1) * *ftnjamu2;
+ fpdlcqk9yxiwebc5 = wkumc9idyxiwebc5 + (hpmwnav2-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++)
+ *fpdlcqk9lncwkfq7++ = *fpdlcqk9yxiwebc5++;
+ }
+ }
+
+ Free(wkumc9idajul8wkv); Free(wkumc9iddev0); Free(wkumc9idyxiwebc5);
+
+ xui7hqwl[4] = idlosrw8;
+}
+
+
+
+
+
+
+
+
+void vcao6(double lncwkfq7[], double tlgduey8[], double ufgqj9ck[],
+ double m0ibglfx[], double t8hwvalr[], double ghz9vuba[],
+ double rbne6ouj[], double wpuarq2m[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *zjkrtol8, int xui7hqwl[],
+ double tlq9wpes[], double zshtfg8c[],
+ double y7sdgtqi[], int psdvgce3[], int *qfozcl5b,
+ double hdnw2fts[], double lamvec[], double wbkq9zyi[],
+ int ezlgm2up[], int lqsahu0r[], int which[],
+ double kispwgx3[],
+ double mbvnaor6[],
+ double hjm2ktyr[],
+ int jnxpuym2[], int hnpt1zym[], int iz2nbfjc[],
+ double ifys6woa[], double rpyis2kc[], double gkdx5jals[],
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[]) {
+
+
+
+
+ int hj3ftvzu, ehtjigf4, kvowz9ht, yu6izdrc = 0, pqneb2ra = 1, xwdf5ltg = xui7hqwl[0],
+ f7svlajr, qfx3vhct, c5aesxkul, wr0lbopv, vtsou9pz, zaupqv9b, xlpjcg3s,
+ sedf7mxb, kcm6jfob, lensmo = (xwdf5ltg == 1 ? 2 : 4) * *afpc0kns;
+ double rpto5qwb, dn3iasxug, wiptsjx8, bh2vgiay, uaf2xgqy, vsoihn1r,
+ rsynp1go, doubvec[6], zpcqv3uj, ghdetj8v;
+ double *fpdlcqk9kispwgx3;
+
+ double hmayv1xt = 0.0, Totdev = 0.0e0;
+
+
+
+ int qes4mujl, ayfnwr1v, kij0gwer, xumj5dnk, lyma1kwc; // = xui7hqwl[10];
+
+ double hmayv1xtvm4xjosb[2];
+
+ double *fpdlcqk9ui8ysltq, *fpdlcqk9lxyst1eb, *fpdlcqk9zyodca3j,
+ *fpdlcqk9m0ibglfx1, *fpdlcqk9m0ibglfx2, *fpdlcqk9wpuarq2m1, *fpdlcqk9wpuarq2m2;
+ double *wkumc9idui8ysltq, *wkumc9idlxyst1eb, *wkumc9idzyodca3j;
+ double *fpdlcqk9hdnw2fts, *fpdlcqk9wbkq9zyi;
+ double *wkumc9idhdnw2fts, *wkumc9idwbkq9zyi;
+
+
+ doubvec[0] = 0.001; // bf.qaltf0nz
+ doubvec[1] = 0.0; // ghdetj8v
+ doubvec[2] = -1.5; // low
+ doubvec[3] = 1.5; // high
+ doubvec[4] = 1.0e-4; // tol
+ doubvec[5] = 2.0e-8; // eps
+
+ wkumc9idui8ysltq = Calloc((*ftnjamu2 * *wy1vqfzu) * (*afpc0kns * *wy1vqfzu), double);
+ wkumc9idlxyst1eb = Calloc( *qfozcl5b * *ftnjamu2 , double);
+ wkumc9idzyodca3j = Calloc( *qfozcl5b * *ftnjamu2 , double);
+ wkumc9idhdnw2fts = Calloc(lensmo , double);
+ wkumc9idwbkq9zyi = Calloc(lensmo , double);
+
+ for(ayfnwr1v = 0; ayfnwr1v < lensmo; ayfnwr1v++) {
+ wkumc9idhdnw2fts[ayfnwr1v] = hdnw2fts[ayfnwr1v];
+ wkumc9idwbkq9zyi[ayfnwr1v] = wbkq9zyi[ayfnwr1v];
+ }
+
+
+ xlpjcg3s = xui7hqwl[2];
+ kvowz9ht = xui7hqwl[3]; // # = 1
+ f7svlajr = xui7hqwl[4];
+ qfx3vhct = xui7hqwl[5];
+ c5aesxkul = xui7hqwl[6];
+ xui7hqwl[8] = 0;
+
+ lyma1kwc = psdvgce3[10]; //
+
+ vtsou9pz = xui7hqwl[11];
+ if (vtsou9pz != 1 || lyma1kwc != xwdf5ltg) {
+ Rprintf("Error: 'vtsou9pz' != 1, or 'lyma1kwc' != 'xwdf5ltg', in vcao6!\n");
+ *zjkrtol8 = 4;
+ Free(wkumc9idui8ysltq); Free(wkumc9idlxyst1eb); Free(wkumc9idzyodca3j);
+ Free(wkumc9idhdnw2fts); Free(wkumc9idwbkq9zyi);
+ return;
+ }
+ zaupqv9b = xui7hqwl[14];
+ wr0lbopv = xui7hqwl[17];
+ zpcqv3uj = y7sdgtqi[3 + *afpc0kns + *afpc0kns + 1];
+ dn3iasxug = y7sdgtqi[0];
+ uaf2xgqy = sqrt(dn3iasxug);
+ vsoihn1r = log(dn3iasxug);
+ bh2vgiay = y7sdgtqi[1];
+ rsynp1go = y7sdgtqi[2];
+
+ *zjkrtol8 = 1;
+
+ for (hj3ftvzu = 1; hj3ftvzu <= *afpc0kns; hj3ftvzu++) {
+ ceqzd1hi653: hmayv1xt = 1.0;
+
+ qes4mujl = (qfx3vhct == 3 || qfx3vhct == 5) ? 2 * hj3ftvzu - 1 : hj3ftvzu;
+
+ if (f7svlajr == 0) {
+ yiumjq3nietam6(tlgduey8, m0ibglfx, y7sdgtqi, ftnjamu2,
+ wy1vqfzu, afpc0kns, &qfx3vhct, &hj3ftvzu, ufgqj9ck, &wr0lbopv);
+ } else
+ if (f7svlajr != 1) {
+ Rprintf("Failure due to bad input of 'f7svlajr' variable\n");
+ *zjkrtol8 = 6;
+ Free(wkumc9idui8ysltq); Free(wkumc9idlxyst1eb); Free(wkumc9idzyodca3j);
+ Free(wkumc9idhdnw2fts); Free(wkumc9idwbkq9zyi);
+ return;
+ }
+
+ yiumjq3nnipyajc1(m0ibglfx, t8hwvalr, ftnjamu2, wy1vqfzu,
+ afpc0kns, &qfx3vhct, &hj3ftvzu);
+
+ if (f7svlajr == 2) {
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, &rpto5qwb, &hj3ftvzu,
+ &dn3iasxug, &vsoihn1r, &pqneb2ra);
+ } else {
+ rpto5qwb = -1.0e0;
+ }
+
+ for (kcm6jfob = 1; kcm6jfob <= c5aesxkul; kcm6jfob++) {
+
+ yiumjq3nflncwkfq76(lncwkfq7, vc6hatuj, ftnjamu2, br5ovgcj, &xwdf5ltg, &qfx3vhct);
+
+ psdvgce3[6] = 0;
+
+ yiumjq3ndlgpwe0c(tlgduey8, ufgqj9ck, m0ibglfx,
+ t8hwvalr, ghz9vuba, rbne6ouj,
+ wpuarq2m, &rsynp1go, &dn3iasxug, &uaf2xgqy,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ &hj3ftvzu, &qfx3vhct, zjkrtol8, &yu6izdrc, hmayv1xtvm4xjosb);
+
+
+ fpdlcqk9lxyst1eb = wkumc9idlxyst1eb;
+ fpdlcqk9zyodca3j = wkumc9idzyodca3j;
+ fpdlcqk9m0ibglfx1 = m0ibglfx + qes4mujl-1;
+ fpdlcqk9wpuarq2m1 = wpuarq2m + qes4mujl-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ fpdlcqk9m0ibglfx2 = fpdlcqk9m0ibglfx1;
+ fpdlcqk9wpuarq2m2 = fpdlcqk9wpuarq2m1;
+ for (kij0gwer = 1; kij0gwer <= *qfozcl5b; kij0gwer++) {
+ *fpdlcqk9lxyst1eb++ = *fpdlcqk9m0ibglfx2++;
+ *fpdlcqk9zyodca3j++ = *fpdlcqk9wpuarq2m2++;
+ }
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ fpdlcqk9wpuarq2m1 += *npjlv3mr;
+ }
+
+
+
+ sedf7mxb = 0; // 20100416 a stop gap. Used for xwdf5ltg==2 only i think.
+ ehtjigf4 = xwdf5ltg * (hj3ftvzu-1);
+
+ if (kcm6jfob == 1) {
+ for (kij0gwer = 1; kij0gwer <= lyma1kwc; kij0gwer++) {
+ fpdlcqk9kispwgx3 = kispwgx3 + (ehtjigf4 + hnpt1zym[kij0gwer-1]-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++)
+ *fpdlcqk9kispwgx3++ = 0.0e0;
+ }
+ } else {
+ wbkq9zyi[ ehtjigf4 + hnpt1zym[0]-1] =
+ wkumc9idwbkq9zyi[ ehtjigf4 + hnpt1zym[0]-1];
+ hdnw2fts[ ehtjigf4 + hnpt1zym[0]-1] =
+ wkumc9idhdnw2fts[ ehtjigf4 + hnpt1zym[0]-1];
+ if (xwdf5ltg == 2) {
+ wbkq9zyi[ ehtjigf4 + hnpt1zym[1]-1] =
+ wkumc9idwbkq9zyi[ ehtjigf4 + hnpt1zym[1]-1]; // wkumc9idr3eoxkzp;
+ hdnw2fts[sedf7mxb + ehtjigf4 + hnpt1zym[1]-1] =
+ wkumc9idhdnw2fts[sedf7mxb + ehtjigf4 + hnpt1zym[1]-1]; // wkumc9idwld4qctn;
+ }
+ }
+
+ Yee_vbfa(psdvgce3, doubvec,
+ mbvnaor6, ghz9vuba + (qes4mujl-1) * *ftnjamu2,
+ rbne6ouj + (qes4mujl-1) * *ftnjamu2,
+ hdnw2fts + sedf7mxb + ehtjigf4 + hnpt1zym[0] - 1,
+ lamvec + ehtjigf4 + hnpt1zym[0] - 1,
+ wbkq9zyi + ehtjigf4 + hnpt1zym[0] - 1,
+ ezlgm2up, lqsahu0r, which,
+ kispwgx3 + (ehtjigf4 + *hnpt1zym - 1) * *ftnjamu2, wkumc9idlxyst1eb,
+ zshtfg8c + (hj3ftvzu - 1) * xlpjcg3s, wkumc9idui8ysltq,
+ vc6hatuj, fasrkub3, ges1xpkr,
+ wkumc9idzyodca3j, hjm2ktyr,
+ jnxpuym2, hnpt1zym, iz2nbfjc,
+ ifys6woa + (ehtjigf4 + hnpt1zym[0] - 1) * *ftnjamu2,
+ rpyis2kc + (hj3ftvzu-1) * (nbzjkpi3[xwdf5ltg] - 1), gkdx5jals,
+ nbzjkpi3, acpios9q, jwbkl9fp);
+
+
+ y7sdgtqi[3 + *afpc0kns + *afpc0kns] = ghdetj8v;
+ xumj5dnk = psdvgce3[13];
+ if (xumj5dnk != 0) {
+ Rprintf("vcao6: Error... exiting; error code = %d\n", xumj5dnk);
+ *zjkrtol8 = 8;
+ Free(wkumc9idui8ysltq); Free(wkumc9idlxyst1eb); Free(wkumc9idzyodca3j);
+ Free(wkumc9idhdnw2fts); Free(wkumc9idwbkq9zyi);
+ return;
+ }
+
+ fpdlcqk9lxyst1eb = wkumc9idlxyst1eb;
+ fpdlcqk9m0ibglfx1 = m0ibglfx + qes4mujl-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ fpdlcqk9m0ibglfx2 = fpdlcqk9m0ibglfx1;
+ for (kij0gwer = 1; kij0gwer <= *qfozcl5b; kij0gwer++) {
+ *fpdlcqk9m0ibglfx2++ = *fpdlcqk9lxyst1eb++;
+ }
+ fpdlcqk9m0ibglfx1 += *wy1vqfzu;
+ }
+
+ yiumjq3nnipyajc1(m0ibglfx, t8hwvalr, ftnjamu2, wy1vqfzu,
+ afpc0kns, &qfx3vhct, &hj3ftvzu);
+
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, tlq9wpes + hj3ftvzu, &hj3ftvzu,
+ &dn3iasxug, &vsoihn1r, &pqneb2ra);
+
+ wiptsjx8 = fabs(tlq9wpes[hj3ftvzu] - rpto5qwb) / (1.0e0 +
+ fabs(tlq9wpes[hj3ftvzu]));
+
+ if (wiptsjx8 < bh2vgiay) {
+ *zjkrtol8 = 0;
+ xui7hqwl[7] = kcm6jfob;
+ if (qfx3vhct == 3 || qfx3vhct == 5) {
+ yiumjq3nshjlwft5(&qfx3vhct, tlgduey8, ufgqj9ck,
+ t8hwvalr, ftnjamu2, wy1vqfzu, afpc0kns,
+ &kvowz9ht, m0ibglfx, tlq9wpes + hj3ftvzu, &hj3ftvzu,
+ &dn3iasxug, &vsoihn1r, &yu6izdrc);
+ }
+ Totdev += tlq9wpes[hj3ftvzu];
+ goto ceqzd1hi1011;
+ } else {
+ rpto5qwb = tlq9wpes[hj3ftvzu];
+ }
+ }
+
+ if (f7svlajr == 1) {
+ f7svlajr = 0;
+ xui7hqwl[8] = 1;
+ goto ceqzd1hi653;
+ }
+
+ *zjkrtol8 = 3;
+ Totdev += tlq9wpes[hj3ftvzu];
+
+ ceqzd1hi1011: hmayv1xt = 2.0e0;
+ }
+
+ *tlq9wpes = Totdev;
+ Free(wkumc9idui8ysltq); Free(wkumc9idlxyst1eb); Free(wkumc9idzyodca3j);
+ Free(wkumc9idhdnw2fts); Free(wkumc9idwbkq9zyi);
+}
+
+
+
+
+void vdcao6(double lncwkfq7[], double tlgduey8[], double ufgqj9ck[],
+ double m0ibglfx[], double t8hwvalr[], double ghz9vuba[],
+ double rbne6ouj[], double wpuarq2m[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ int *ftnjamu2, int *wy1vqfzu, int *afpc0kns, int *br5ovgcj, int *npjlv3mr,
+ int *zjkrtol8, int xui7hqwl[],
+ double tlq9wpes[], double zshtfg8c[],
+ double y7sdgtqi[],
+ double atujnxb8[],
+ double k7hulceq[],
+ int *eoviz2fb, double kpzavbj3mat[],
+ double ajul8wkv[],
+ int psdvgce3[], int *qfozcl5b,
+ double hdnw2fts[], double lamvec[], double wbkq9zyi[],
+ int ezlgm2up[], int lqsahu0r[], int which[],
+ double kispwgx3[],
+ double mbvnaor6[],
+ double hjm2ktyr[],
+ int jnxpuym2[], int hnpt1zym[],
+ int iz2nbfjc[],
+ double ifys6woa[],
+ double rpyis2kc[], double gkdx5jals[],
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[]) {
+
+
+
+ int ayfnwr1v, xvr7bonh, hpmwnav2, idlosrw8, exrkcn5d, xwdf5ltg = xui7hqwl[ 0],
+ vtsou9pz, wr0lbopv;
+ double fxnhilr3;
+
+
+
+ double ghdetj8v = 0.0e0, ydcnh9xl = y7sdgtqi[3 + *afpc0kns + *afpc0kns + 3 -1];
+ double *fpdlcqk9k7hulceq, *fpdlcqk9kpzavbj3mat, *fpdlcqk9lncwkfq7, *fpdlcqk9yxiwebc5,
+ *fpdlcqk9atujnxb8;
+
+ double *wkumc9idyxiwebc5;
+ double *wkumc9idlxyst1eb, *wkumc9idzyodca3j;
+ double *wkumc9idhdnw2fts, *wkumc9idwbkq9zyi;
+ double *wkumc9iddev0;
+
+ wkumc9idyxiwebc5 = Calloc(*ftnjamu2 * xwdf5ltg , double);
+ fpdlcqk9kpzavbj3mat = kpzavbj3mat;
+
+ wkumc9iddev0 = Calloc(1 + *afpc0kns , double);
+ wkumc9idlxyst1eb = Calloc( *qfozcl5b * *ftnjamu2 , double);
+ wkumc9idzyodca3j = Calloc( *qfozcl5b * *ftnjamu2 , double);
+
+ idlosrw8 = xui7hqwl[ 4];
+ vtsou9pz = xui7hqwl[11];
+ exrkcn5d = xui7hqwl[12];
+ wr0lbopv = xui7hqwl[17];
+
+ fpdlcqk9lncwkfq7 = lncwkfq7;
+ fpdlcqk9yxiwebc5 = wkumc9idyxiwebc5;
+ for (hpmwnav2 = 1; hpmwnav2 <= xwdf5ltg; hpmwnav2++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ fxnhilr3 = 0.0e0;
+ fpdlcqk9k7hulceq = k7hulceq + (hpmwnav2-1) * *eoviz2fb;
+ fpdlcqk9atujnxb8 = atujnxb8 + ayfnwr1v-1;
+ for (xvr7bonh = 1; xvr7bonh <= *eoviz2fb; xvr7bonh++) {
+ fxnhilr3 += *fpdlcqk9atujnxb8 * *fpdlcqk9k7hulceq++;
+ fpdlcqk9atujnxb8 += *ftnjamu2;
+ }
+ *fpdlcqk9yxiwebc5++ = *fpdlcqk9lncwkfq7++ = fxnhilr3;
+ }
+ }
+
+ if (vtsou9pz == 1) {
+ vcao6(lncwkfq7, tlgduey8, ufgqj9ck,
+ m0ibglfx, t8hwvalr, ghz9vuba,
+ rbne6ouj, wpuarq2m,
+ vc6hatuj, fasrkub3, ges1xpkr,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ zjkrtol8, xui7hqwl,
+ wkumc9iddev0, ajul8wkv,
+ y7sdgtqi, psdvgce3, qfozcl5b,
+ hdnw2fts, lamvec, wbkq9zyi,
+ ezlgm2up, lqsahu0r, which,
+ kispwgx3,
+ mbvnaor6,
+ hjm2ktyr,
+ jnxpuym2, hnpt1zym, iz2nbfjc,
+ ifys6woa, rpyis2kc, gkdx5jals,
+ nbzjkpi3, acpios9q, jwbkl9fp);
+
+ y7sdgtqi[3 + *afpc0kns + *afpc0kns] = ghdetj8v;
+ }
+
+ fpdlcqk9atujnxb8 = atujnxb8;
+ for (xvr7bonh = 1; xvr7bonh <= *eoviz2fb; xvr7bonh++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9atujnxb8 *= ydcnh9xl;
+ fpdlcqk9atujnxb8++;
+ }
+ }
+
+ for (hpmwnav2 = 1; hpmwnav2 <= xwdf5ltg; hpmwnav2++) {
+ fpdlcqk9atujnxb8 = atujnxb8; // + (xvr7bonh-1) * *ftnjamu2;
+ for (xvr7bonh = 1; xvr7bonh <= *eoviz2fb; xvr7bonh++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9lncwkfq7++ = *fpdlcqk9yxiwebc5++ + *fpdlcqk9atujnxb8++;
+ }
+ xui7hqwl[4] = 0;
+
+
+ if (vtsou9pz == 1) {
+ vcao6(lncwkfq7, tlgduey8, ufgqj9ck,
+ m0ibglfx, t8hwvalr, ghz9vuba,
+ rbne6ouj, wpuarq2m,
+ vc6hatuj, fasrkub3, ges1xpkr,
+ ftnjamu2, wy1vqfzu, afpc0kns, br5ovgcj, npjlv3mr,
+ zjkrtol8, xui7hqwl,
+ tlq9wpes, zshtfg8c,
+ y7sdgtqi, psdvgce3, qfozcl5b,
+ hdnw2fts, lamvec, wbkq9zyi,
+ ezlgm2up, lqsahu0r, which,
+ kispwgx3,
+ mbvnaor6,
+ hjm2ktyr,
+ jnxpuym2, hnpt1zym, iz2nbfjc,
+ ifys6woa, rpyis2kc, gkdx5jals,
+ nbzjkpi3, acpios9q, jwbkl9fp);
+
+ y7sdgtqi[3 + *afpc0kns + *afpc0kns] = ghdetj8v;
+ }
+
+ if (*zjkrtol8 != 0) {
+ Rprintf("Warning: failured to converge in vdcao6. \n");
+ Rprintf("Continuing.\n");
+ }
+ *fpdlcqk9kpzavbj3mat++ = (*tlq9wpes - *wkumc9iddev0) / ydcnh9xl;
+ }
+
+ if (xwdf5ltg > 1) {
+ fpdlcqk9lncwkfq7 = lncwkfq7 + (hpmwnav2-1) * *ftnjamu2;
+ fpdlcqk9yxiwebc5 = wkumc9idyxiwebc5 + (hpmwnav2-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++)
+ *fpdlcqk9lncwkfq7++ = *fpdlcqk9yxiwebc5++;
+ }
+ }
+
+ Free(wkumc9idyxiwebc5); Free(wkumc9iddev0 );
+ Free(wkumc9idlxyst1eb); Free(wkumc9idzyodca3j);
+
+ xui7hqwl[4] = idlosrw8;
+}
+
+
+void yiumjq3npnm1or(double *objzgdk0, double *lfu2qhid) {
+
+ int sn;
+ double R1, R2, y, y2, y3, y4, y5, y6, y7;
+ double erf, erfc, z, z2, z3, z4;
+
+
+ double
+ SQRT2 = 1.414213562373095049e0,
+ SQRTPI = 1.772453850905516027e0,
+
+
+ ULIMIT = 20.0e0,
+
+ P10 = 242.66795523053175e0,
+ P11 = 21.979261618294152e0,
+ P12 = 6.9963834886191355e0,
+ P13 = -.035609843701815385e0,
+ Q10 = 215.05887586986120e0,
+ Q11 = 91.164905404514901e0,
+ Q12 = 15.082797630407787e0,
+ Q13 = 1.0e0,
+
+ P20 = 300.4592610201616005e0,
+ P21 = 451.9189537118729422e0,
+ P22 = 339.3208167343436870e0,
+ P23 = 152.9892850469404039e0,
+ P24 = 43.16222722205673530e0,
+ P25 = 7.211758250883093659e0,
+ P26 = .5641955174789739711e0,
+ P27 = -.0000001368648573827167067e0,
+ Q20 = 300.4592609569832933e0,
+ Q21 = 790.9509253278980272e0,
+ Q22 = 931.3540948506096211e0,
+ Q23 = 638.9802644656311665e0,
+ Q24 = 277.5854447439876434e0,
+ Q25 = 77.00015293522947295e0,
+ Q26 = 12.78272731962942351e0,
+ Q27 = 1.0e0,
+
+ P30 = -.00299610707703542174e0,
+ P31 = -.0494730910623250734e0,
+ P32 = -.226956593539686930e0,
+ P33 = -.278661308609647788e0,
+ P34 = -.0223192459734184686e0,
+ Q30 = .0106209230528467918e0,
+ Q31 = .191308926107829841e0,
+ Q32 = 1.05167510706793207e0,
+ Q33 = 1.98733201817135256e0,
+ Q34 = 1.0e0;
+
+ if (*objzgdk0 < -ULIMIT) {
+ *lfu2qhid = 2.753624e-89;
+ return;
+ }
+ if (*objzgdk0 > ULIMIT) {
+ *lfu2qhid = 1.0e0;
+ return;
+ }
+
+ y = *objzgdk0 / SQRT2;
+ if (y < 0.0e0) {
+ y = -y;
+ sn = -1;
+ } else {
+ sn = 1;
+ }
+ y2 = y * y;
+ y4 = y2 * y2;
+ y6 = y4 * y2;
+ if (y < 0.46875e0) {
+ R1 = P10 + P11 * y2 + P12 * y4 + P13 * y6;
+ R2 = Q10 + Q11 * y2 + Q12 * y4 + Q13 * y6;
+ erf = y * R1 / R2;
+ *lfu2qhid = (sn == 1) ? 0.5e0 + 0.5 * erf : 0.5e0 - 0.5 * erf;
+ } else
+ if (y < 4.0e0) {
+ y3 = y2 * y;
+ y5 = y4 * y;
+ y7 = y6 * y;
+ R1 = P20 + P21 * y + P22 * y2 + P23 * y3 +
+ P24 * y4 + P25 * y5 + P26 * y6 + P27 * y7;
+ R2 = Q20 + Q21 * y + Q22 * y2 + Q23 * y3 +
+ Q24 * y4 + Q25 * y5 + Q26 * y6 + Q27 * y7;
+ erfc = exp(-y2) * R1 / R2;
+ *lfu2qhid = (sn == 1) ? 1.0 - 0.5 * erfc : 0.5 * erfc;
+ } else {
+ z = y4;
+ z2 = z * z;
+ z3 = z2 * z;
+ z4 = z2 * z2;
+ R1 = P30 + P31 * z + P32 * z2 + P33 * z3 + P34 * z4;
+ R2 = Q30 + Q31 * z + Q32 * z2 + Q33 * z3 + Q34 * z4;
+ erfc = (exp(-y2)/y) * (1.0 / SQRTPI + R1 / (R2 * y2));
+ *lfu2qhid = (sn == 1) ? 1.0 - 0.5 * erfc : 0.5 * erfc;
+ }
+}
+
+
+void yiumjq3npnm1ow(double objzgdk0[], double lfu2qhid[], int *f8yswcat) {
+
+
+ int ayfnwr1v;
+
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ yiumjq3npnm1or(objzgdk0++, lfu2qhid++);
+ }
+}
+
+
diff --git a/src/cqof.f b/src/cqof.f
deleted file mode 100644
index 0af9699..0000000
--- a/src/cqof.f
+++ /dev/null
@@ -1,2114 +0,0 @@
- subroutine nw22ca(te4qac, ghry8z)
- implicit logical (a-z)
- double precision te4qac, ghry8z
- integer sn
- double precision r1, r2, y, y2, y3, y4, y5, y6, y7
- double precision erf, yhg7o7, z, z2, z3, z4
- double precision gln1k1, hqt8l8, a66epi, p10,p11,p12,p13, q10,q11,
- &q12,q13
- double precision p20,p21,p22,p23,p24,p25,p26,p27
- double precision q20,q21,q22,q23,q24,q25,q26,q27
- double precision p30,p31,p32,p33,p34
- double precision q30,q31,q32,q33,q34
- gln1k1 = 1.414213562373095049d0
- hqt8l8 = 1.772453850905516027d0
- a66epi = 20.0d0
- p10 = 242.66795523053175d0
- p11 = 21.979261618294152d0
- p12 = 6.9963834886191355d0
- p13 = -.035609843701815385d0
- q10 = 215.05887586986120d0
- q11 = 91.164905404514901d0
- q12 = 15.082797630407787d0
- q13 = 1.0d0
- p20 = 300.4592610201616005d0
- p21 = 451.9189537118729422d0
- p22 = 339.3208167343436870d0
- p23 = 152.9892850469404039d0
- p24 = 43.16222722205673530d0
- p25 = 7.211758250883093659d0
- p26 = .5641955174789739711d0
- p27 = -.0000001368648573827167067d0
- q20 = 300.4592609569832933d0
- q21 = 790.9509253278980272d0
- q22 = 931.3540948506096211d0
- q23 = 638.9802644656311665d0
- q24 = 277.5854447439876434d0
- q25 = 77.00015293522947295d0
- q26 = 12.78272731962942351d0
- q27 = 1.0d0
- p30 = -.00299610707703542174d0
- p31 = -.0494730910623250734d0
- p32 = -.226956593539686930d0
- p33 = -.278661308609647788d0
- p34 = -.0223192459734184686d0
- q30 = .0106209230528467918d0
- q31 = .191308926107829841d0
- q32 = 1.05167510706793207d0
- q33 = 1.98733201817135256d0
- q34 = 1.0d0
- if(.not.(te4qac .lt. -a66epi))goto 23000
- ghry8z = 2.753624d-89
- return
-23000 continue
- if(.not.(te4qac .gt. a66epi))goto 23002
- ghry8z = 1.0d0
- return
-23002 continue
- y = te4qac / gln1k1
- if(.not.(y .lt. 0.0d0))goto 23004
- y = -y
- sn = -1
- goto 23005
-23004 continue
- sn = 1
-23005 continue
- y2 = y * y
- y4 = y2 * y2
- y6 = y4 * y2
- if(.not.(y .lt. 0.46875d0))goto 23006
- r1 = p10 + p11 * y2 + p12 * y4 + p13 * y6
- r2 = q10 + q11 * y2 + q12 * y4 + q13 * y6
- erf = y * r1 / r2
- if(.not.(sn .eq. 1))goto 23008
- ghry8z = 0.5d0 + 0.5*erf
- goto 23009
-23008 continue
- ghry8z = 0.5d0 - 0.5*erf
-23009 continue
- goto 23007
-23006 continue
- if(.not.(y .lt. 4.0d0))goto 23010
- y3 = y2 * y
- y5 = y4 * y
- y7 = y6 * y
- r1 = p20 + p21 * y + p22 * y2 + p23 * y3 + p24 * y4 + p25 * y5 +
- &p26 * y6 + p27 * y7
- r2 = q20 + q21 * y + q22 * y2 + q23 * y3 + q24 * y4 + q25 * y5 +
- &q26 * y6 + q27 * y7
- yhg7o7 = dexp(-y2) * r1 / r2
- if(.not.(sn .eq. 1))goto 23012
- ghry8z = 1.0 - 0.5*yhg7o7
- goto 23013
-23012 continue
- ghry8z = 0.5*yhg7o7
-23013 continue
- goto 23011
-23010 continue
- z = y4
- z2 = z * z
- z3 = z2 * z
- z4 = z2 * z2
- r1 = p30 + p31 * z + p32 * z2 + p33 * z3 + p34 * z4
- r2 = q30 + q31 * z + q32 * z2 + q33 * z3 + q34 * z4
- yhg7o7 = (dexp(-y2)/y) * (1.0 / hqt8l8 + r1 / (r2 * y2))
- if(.not.(sn .eq. 1))goto 23014
- ghry8z = 1.0d0 - 0.5*yhg7o7
- goto 23015
-23014 continue
- ghry8z = 0.5*yhg7o7
-23015 continue
-23011 continue
-23007 continue
- return
- end
- subroutine pnm1ow(te4qac, ghry8z, nfiumb4)
- implicit logical (a-z)
- integer nfiumb4, w3gohz
- double precision te4qac(nfiumb4), ghry8z(nfiumb4)
- do 23016 w3gohz=1,nfiumb4
- call nw22ca(te4qac(w3gohz), ghry8z(w3gohz))
-23016 continue
- return
- end
- subroutine q4cgho(te4qac, dwgkz6, ghry8z)
- implicit logical (a-z)
- double precision te4qac, dwgkz6, ghry8z
- double precision mu4ygka
- if(.not.(1.0d0 - te4qac .ge. 1.0d0))goto 23018
- ghry8z = -8.12589d0 / (3.0*dsqrt(dwgkz6))
- goto 23019
-23018 continue
- if(.not.(1.0d0 - te4qac .le. 0.0d0))goto 23020
- ghry8z = 8.12589d0 / (3.0*dsqrt(dwgkz6))
- goto 23021
-23020 continue
- call nw22ca(1.0d0-te4qac, mu4ygka)
- mu4ygka = mu4ygka / (3.0*dsqrt(dwgkz6))
- ghry8z = -3.0d0 * dlog(1.0d0 + mu4ygka)
-23021 continue
-23019 continue
- return
- end
- subroutine wgf0al(te4qac, ghry8z)
- implicit logical (a-z)
- double precision te4qac, ghry8z
- if(.not.(1.0d0 - te4qac .ge. 1.0d0))goto 23022
- ghry8z = -35.0d0
- goto 23023
-23022 continue
- if(.not.(1.0d0 - te4qac .le. 0.0d0))goto 23024
- ghry8z = 3.542106d0
- goto 23025
-23024 continue
- ghry8z = dlog(-dlog(1.0d0 - te4qac))
-23025 continue
-23023 continue
- return
- end
- subroutine u10e3o(te4qac, ghry8z)
- implicit logical (a-z)
- double precision te4qac, ghry8z
- if(.not.(1.0d0 - te4qac .ge. 1.0d0))goto 23026
- ghry8z = -34.53958d0
- goto 23027
-23026 continue
- if(.not.(1.0d0 - te4qac .le. 0.0d0))goto 23028
- ghry8z = 34.53958d0
- goto 23029
-23028 continue
- ghry8z = dlog(te4qac / (1.0d0 - te4qac))
-23029 continue
-23027 continue
- return
- end
- subroutine pjw1l(ur73jo, lq8reh, go0l1q, nfiumb4, lku8xq, vi231l,
- &zxiwf1, dyt0pg, lir0o1, zvxw1l, h3mrfq, q121lc)
- implicit logical (a-z)
- integer nfiumb4, lku8xq, vi231l, zxiwf1, dyt0pg, lir0o1, zvxw1l,
- &h3mrfq
- double precision ur73jo(vi231l,zxiwf1), lq8reh(zxiwf1), go0l1q(
- &lku8xq,nfiumb4), q121lc(nfiumb4)
- integer w3gohz, d9rjek, nd6mep, opf6cv, c3qxjo
- double precision nqvu3e
- if(.not.(dyt0pg .eq. 1))goto 23030
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23032
- c3qxjo = 2*lir0o1-1
- do 23034 w3gohz=1,nfiumb4
- nqvu3e = 0.0d0
- do 23036 nd6mep=1,zxiwf1
- nqvu3e = nqvu3e + ur73jo(2*w3gohz-1,nd6mep) * lq8reh(nd6mep)
-23036 continue
- go0l1q(c3qxjo,w3gohz) = nqvu3e
-23034 continue
- c3qxjo = 2*lir0o1
- do 23038 w3gohz=1,nfiumb4
- nqvu3e = 0.0d0
- do 23040 nd6mep=1,zxiwf1
- nqvu3e = nqvu3e + ur73jo(2*w3gohz ,nd6mep) * lq8reh(nd6mep)
-23040 continue
- go0l1q(c3qxjo,w3gohz) = nqvu3e
-23038 continue
- goto 23033
-23032 continue
- do 23042 w3gohz=1,vi231l
- nqvu3e = 0.0d0
- do 23044 nd6mep=1,zxiwf1
- nqvu3e = nqvu3e + ur73jo(w3gohz,nd6mep) * lq8reh(nd6mep)
-23044 continue
- go0l1q(lir0o1,w3gohz) = nqvu3e
-23042 continue
-23033 continue
- goto 23031
-23030 continue
- opf6cv = 1
- do 23046 w3gohz=1,nfiumb4
- do 23048 d9rjek=1,lku8xq
- nqvu3e = 0.0d0
- do 23050 nd6mep=1,zxiwf1
- nqvu3e = nqvu3e + ur73jo(opf6cv,nd6mep) * lq8reh(nd6mep)
-23050 continue
- opf6cv = opf6cv + 1
- go0l1q(d9rjek,w3gohz) = nqvu3e
-23048 continue
-23046 continue
-23031 continue
- if(.not.(h3mrfq .eq. 1))goto 23052
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23054
- do 23056 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz) = go0l1q(2*lir0o1-1,w3gohz) + q121lc(
- &w3gohz)
-23056 continue
- goto 23055
-23054 continue
- do 23058 w3gohz=1,nfiumb4
- go0l1q(lir0o1,w3gohz) = go0l1q(lir0o1,w3gohz) + q121lc(w3gohz)
-23058 continue
-23055 continue
-23052 continue
- return
- end
- subroutine o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
- & lir0o1)
- implicit logical (a-z)
- integer nfiumb4, lku8xq, aqk377, zvxw1l, lir0o1
- double precision go0l1q(lku8xq,nfiumb4), w5poyv(aqk377,nfiumb4)
- integer w3gohz, d9rjek
- double precision xkwp2m0
- if(.not.(lir0o1 .eq. 0))goto 23060
- if(.not.(zvxw1l .eq. 1))goto 23062
- do 23064 w3gohz=1,nfiumb4
- do 23066 d9rjek=1,lku8xq
- xkwp2m0 = dexp(go0l1q(d9rjek,w3gohz))
- w5poyv(d9rjek,w3gohz) = xkwp2m0 / (1.0d0 + xkwp2m0)
-23066 continue
-23064 continue
-23062 continue
- if(.not.(zvxw1l .eq. 2))goto 23068
- do 23070 w3gohz=1,nfiumb4
- do 23072 d9rjek=1,lku8xq
- w5poyv(d9rjek,w3gohz) = dexp(go0l1q(d9rjek,w3gohz))
-23072 continue
-23070 continue
-23068 continue
- if(.not.(zvxw1l .eq. 4))goto 23074
- do 23076 w3gohz=1,nfiumb4
- do 23078 d9rjek=1,lku8xq
- w5poyv(d9rjek,w3gohz) = 1.0d0-dexp(-dexp(go0l1q(d9rjek,w3gohz)))
-23078 continue
-23076 continue
-23074 continue
- if(.not.(zvxw1l .eq. 5))goto 23080
- do 23082 w3gohz=1,nfiumb4
- do 23084 d9rjek=1,aqk377
- w5poyv(d9rjek,w3gohz) = dexp(go0l1q(2*d9rjek-1,w3gohz))
-23084 continue
-23082 continue
-23080 continue
- if(.not.(zvxw1l .eq. 3))goto 23086
- do 23088 w3gohz=1,nfiumb4
- do 23090 d9rjek=1,aqk377
- w5poyv(d9rjek,w3gohz) = dexp(go0l1q(2*d9rjek-1,w3gohz))
-23090 continue
-23088 continue
-23086 continue
- if(.not.(zvxw1l .eq. 8))goto 23092
- do 23094 w3gohz=1,nfiumb4
- do 23096 d9rjek=1,lku8xq
- w5poyv(d9rjek,w3gohz) = go0l1q(d9rjek,w3gohz)
-23096 continue
-23094 continue
-23092 continue
- goto 23061
-23060 continue
- if(.not.(zvxw1l .eq. 1))goto 23098
- do 23100 w3gohz=1,nfiumb4
- xkwp2m0 = dexp(go0l1q(lir0o1,w3gohz))
- w5poyv(lir0o1,w3gohz) = xkwp2m0 / (1.0d0 + xkwp2m0)
-23100 continue
-23098 continue
- if(.not.(zvxw1l .eq. 2))goto 23102
- do 23104 w3gohz=1,nfiumb4
- w5poyv(lir0o1,w3gohz) = dexp(go0l1q(lir0o1,w3gohz))
-23104 continue
-23102 continue
- if(.not.(zvxw1l .eq. 4))goto 23106
- do 23108 w3gohz=1,nfiumb4
- w5poyv(lir0o1,w3gohz) = 1.0d0 - dexp(-dexp(go0l1q(lir0o1,w3gohz)))
-23108 continue
-23106 continue
- if(.not.(zvxw1l .eq. 5))goto 23110
- do 23112 w3gohz=1,nfiumb4
- w5poyv(lir0o1,w3gohz) = dexp(go0l1q(2*lir0o1-1,w3gohz))
-23112 continue
-23110 continue
- if(.not.(zvxw1l .eq. 3))goto 23114
- do 23116 w3gohz=1,nfiumb4
- w5poyv(lir0o1,w3gohz) = dexp(go0l1q(2*lir0o1-1,w3gohz))
-23116 continue
-23114 continue
- if(.not.(zvxw1l .eq. 8))goto 23118
- do 23120 w3gohz=1,nfiumb4
- w5poyv(lir0o1,w3gohz) = go0l1q(lir0o1,w3gohz)
-23120 continue
-23118 continue
-23061 continue
- return
- end
- subroutine kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- & aqk377, xhe4cg, go0l1q, dev, lir0o1, fiumb4, wlkaa3, cll)
- implicit logical (a-z)
- integer zvxw1l, nfiumb4, lku8xq, aqk377, xhe4cg, lir0o1, cll
- double precision jmwo0z(nfiumb4, aqk377), w8xfic(nfiumb4, xhe4cg),
- & w5poyv(aqk377, nfiumb4), go0l1q(lku8xq,nfiumb4), dev, fiumb4,
- &wlkaa3
- integer w3gohz, d9rjek
- double precision qe3jcd, ue1phr, mu4ygk, ig5cma, j0izmn, smu,
- &mqs3rp, mdk7tp, oesul2
- double precision gq815b, aho01l, dh3rio
- logical xyiu19
- qe3jcd = 0.0d0
- if(.not.(lir0o1 .eq. 0))goto 23122
- if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23124
- do 23126 d9rjek=1,lku8xq
- do 23128 w3gohz=1,nfiumb4
- if(.not.(jmwo0z(w3gohz,d9rjek) .gt. 0.0d0))goto 23130
- mdk7tp = jmwo0z(w3gohz,d9rjek) * dlog(jmwo0z(w3gohz,d9rjek))
- goto 23131
-23130 continue
- mdk7tp = 0.0d0
-23131 continue
- if(.not.(jmwo0z(w3gohz,d9rjek) .lt. 1.0d0))goto 23132
- mdk7tp = mdk7tp + (1.0d0 - jmwo0z(w3gohz,d9rjek)) * dlog(1.0d0 -
- &jmwo0z(w3gohz,d9rjek))
-23132 continue
- mu4ygk = w5poyv(d9rjek,w3gohz) * (1.0d0 - w5poyv(d9rjek,w3gohz))
- if(.not.(mu4ygk .lt. fiumb4))goto 23134
- smu = w5poyv(d9rjek,w3gohz)
- if(.not.(smu .lt. fiumb4))goto 23136
- oesul2 = jmwo0z(w3gohz,d9rjek) * wlkaa3
- goto 23137
-23136 continue
- oesul2 = jmwo0z(w3gohz,d9rjek) * dlog(smu)
-23137 continue
- mqs3rp = 1.0d0 - smu
- if(.not.(mqs3rp .lt. fiumb4))goto 23138
- oesul2 = oesul2 + (1.0d0 - jmwo0z(w3gohz,d9rjek)) * wlkaa3
- goto 23139
-23138 continue
- oesul2 = oesul2 + (1.0d0 - jmwo0z(w3gohz,d9rjek)) * dlog(mqs3rp)
-23139 continue
- goto 23135
-23134 continue
- oesul2 = (jmwo0z(w3gohz,d9rjek) * dlog(w5poyv(d9rjek,w3gohz)) + (
- &1.0d0 - jmwo0z(w3gohz,d9rjek)) * dlog(1.0d0 - w5poyv(d9rjek,
- &w3gohz)))
-23135 continue
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * (mdk7tp - oesul2)
-23128 continue
-23126 continue
-23124 continue
- if(.not.(zvxw1l .eq. 2))goto 23140
- do 23142 d9rjek=1,lku8xq
- do 23144 w3gohz=1,nfiumb4
- if(.not.(jmwo0z(w3gohz,d9rjek) .gt. 0.0d0))goto 23146
- mu4ygk = w5poyv(d9rjek,w3gohz) - jmwo0z(w3gohz,d9rjek) + jmwo0z(
- &w3gohz,d9rjek) * dlog(jmwo0z(w3gohz,d9rjek) / w5poyv(d9rjek,
- &w3gohz))
- goto 23147
-23146 continue
- mu4ygk = w5poyv(d9rjek,w3gohz) - jmwo0z(w3gohz,d9rjek)
-23147 continue
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * mu4ygk
-23144 continue
-23142 continue
-23140 continue
- if(.not.(zvxw1l .eq. 5))goto 23148
- do 23150 d9rjek=1,aqk377
- do 23152 w3gohz=1,nfiumb4
- dh3rio = dexp(go0l1q(2*d9rjek,w3gohz))
- call atez9d(dh3rio, ig5cma)
- if(.not.(jmwo0z(w3gohz,d9rjek) .gt. 0.0d0))goto 23154
- mu4ygk = (dh3rio - 1.0d0) * dlog(jmwo0z(w3gohz,d9rjek)) + (dlog(
- &dh3rio)-jmwo0z(w3gohz,d9rjek) / w5poyv(d9rjek,w3gohz) - dlog(
- &w5poyv(d9rjek,w3gohz)) ) * dh3rio - ig5cma
- goto 23155
-23154 continue
- mu4ygk = -1000.0d0
-23155 continue
- mu4ygk = -mu4ygk
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * mu4ygk
-23152 continue
-23150 continue
-23148 continue
- if(.not.(zvxw1l .eq. 3))goto 23156
- if(.not.(cll .eq. 0))goto 23158
- aho01l = 34.0d0
- do 23160 d9rjek=1,aqk377
- do 23162 w3gohz=1,nfiumb4
- if(.not.(go0l1q(2*d9rjek,w3gohz) .gt. aho01l))goto 23164
- gq815b = dexp(aho01l)
- xyiu19 = .true.
- goto 23165
-23164 continue
- if(.not.(go0l1q(2*d9rjek,w3gohz) .lt. -aho01l))goto 23166
- gq815b = dexp(-aho01l)
- xyiu19 = .true.
- goto 23167
-23166 continue
- gq815b = dexp(go0l1q(2*d9rjek,w3gohz))
- xyiu19 = .false.
-23167 continue
-23165 continue
- if(.not.(jmwo0z(w3gohz,d9rjek) .lt. 1.0d0))goto 23168
- mu4ygk = 1.0d0
- goto 23169
-23168 continue
- mu4ygk = jmwo0z(w3gohz,d9rjek)
-23169 continue
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * (jmwo0z(w3gohz,d9rjek) *
- &dlog(mu4ygk/w5poyv(d9rjek,w3gohz)) + (jmwo0z(w3gohz,d9rjek) +
- &gq815b) * dlog((w5poyv(d9rjek,w3gohz)+gq815b) / (gq815b+ jmwo0z(
- &w3gohz,d9rjek))))
-23162 continue
-23160 continue
- goto 23159
-23158 continue
- aho01l = 34.0d0
- do 23170 d9rjek=1,aqk377
- do 23172 w3gohz=1,nfiumb4
- if(.not.(go0l1q(2*d9rjek,w3gohz) .gt. aho01l))goto 23174
- gq815b = dexp(aho01l)
- xyiu19 = .true.
- goto 23175
-23174 continue
- if(.not.(go0l1q(2*d9rjek,w3gohz) .lt. -aho01l))goto 23176
- gq815b = dexp(-aho01l)
- xyiu19 = .true.
- goto 23177
-23176 continue
- gq815b = dexp(go0l1q(2*d9rjek,w3gohz))
- xyiu19 = .false.
-23177 continue
-23175 continue
- if(.not.( xyiu19 ))goto 23178
- ig5cma = 0.0d0
- j0izmn = 0.0d0
- goto 23179
-23178 continue
- call atez9d(gq815b + jmwo0z(w3gohz,d9rjek), ig5cma)
- call atez9d(gq815b, j0izmn)
-23179 continue
- call atez9d(1.0d0 + jmwo0z(w3gohz,d9rjek), ue1phr)
- mu4ygk = gq815b * dlog(gq815b / (gq815b + w5poyv(d9rjek,w3gohz)))
- &+ ig5cma - j0izmn - ue1phr
- if(.not.(jmwo0z(w3gohz,d9rjek) .gt. 0.0d0))goto 23180
- mu4ygk = mu4ygk + jmwo0z(w3gohz,d9rjek) * dlog(w5poyv(d9rjek,
- &w3gohz) / (gq815b + w5poyv(d9rjek,w3gohz)))
-23180 continue
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * mu4ygk
-23172 continue
-23170 continue
- qe3jcd = -qe3jcd / 2.0d0
-23159 continue
-23156 continue
- if(.not.(zvxw1l .eq. 8))goto 23182
- do 23184 d9rjek=1,lku8xq
- do 23186 w3gohz=1,nfiumb4
- mu4ygk = jmwo0z(w3gohz,d9rjek) - w5poyv(d9rjek,w3gohz)
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * mu4ygk**2
-23186 continue
-23184 continue
-23182 continue
- goto 23123
-23122 continue
- if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23188
- do 23190 w3gohz=1,nfiumb4
- if(.not.(jmwo0z(w3gohz,lir0o1) .gt. 0.0d0))goto 23192
- mdk7tp = jmwo0z(w3gohz,lir0o1) * dlog(jmwo0z(w3gohz,lir0o1))
- goto 23193
-23192 continue
- mdk7tp = 0.0d0
-23193 continue
- if(.not.(jmwo0z(w3gohz,lir0o1) .lt. 1.0d0))goto 23194
- mdk7tp = mdk7tp + (1.0d0 - jmwo0z(w3gohz,lir0o1)) * dlog(1.0d0 -
- &jmwo0z(w3gohz,lir0o1))
-23194 continue
- mu4ygk = w5poyv(lir0o1,w3gohz) * (1.0d0 - w5poyv(lir0o1,w3gohz))
- if(.not.(mu4ygk .lt. fiumb4))goto 23196
- smu = w5poyv(lir0o1,w3gohz)
- if(.not.(smu .lt. fiumb4))goto 23198
- oesul2 = jmwo0z(w3gohz,lir0o1) * wlkaa3
- goto 23199
-23198 continue
- oesul2 = jmwo0z(w3gohz,lir0o1) * dlog(smu)
-23199 continue
- mqs3rp = 1.0d0 - smu
- if(.not.(mqs3rp .lt. fiumb4))goto 23200
- oesul2 = oesul2 + (1.0d0-jmwo0z(w3gohz,lir0o1))*wlkaa3
- goto 23201
-23200 continue
- oesul2 = oesul2 + (1.0d0-jmwo0z(w3gohz,lir0o1))*dlog(mqs3rp)
-23201 continue
- goto 23197
-23196 continue
- oesul2 = (jmwo0z(w3gohz,lir0o1) * dlog(w5poyv(lir0o1,w3gohz)) + (
- &1.0d0 - jmwo0z(w3gohz,lir0o1)) * dlog(1.0d0 - w5poyv(lir0o1,
- &w3gohz)))
-23197 continue
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * (mdk7tp - oesul2)
-23190 continue
-23188 continue
- if(.not.(zvxw1l .eq. 2))goto 23202
- do 23204 w3gohz=1,nfiumb4
- if(.not.(jmwo0z(w3gohz,lir0o1) .gt. 0.0d0))goto 23206
- mu4ygk = w5poyv(lir0o1,w3gohz) - jmwo0z(w3gohz,lir0o1) + jmwo0z(
- &w3gohz,lir0o1) * dlog(jmwo0z(w3gohz,lir0o1) / w5poyv(lir0o1,
- &w3gohz))
- goto 23207
-23206 continue
- mu4ygk = w5poyv(lir0o1,w3gohz) - jmwo0z(w3gohz,lir0o1)
-23207 continue
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * mu4ygk
-23204 continue
-23202 continue
- if(.not.(zvxw1l .eq. 5))goto 23208
- do 23210 w3gohz=1,nfiumb4
- dh3rio = dexp(go0l1q(2*lir0o1,w3gohz))
- call atez9d(dh3rio, ig5cma)
- if(.not.(jmwo0z(w3gohz,lir0o1) .gt. 0.0d0))goto 23212
- mu4ygk = (dh3rio - 1.0d0) * dlog(jmwo0z(w3gohz,lir0o1)) + dh3rio *
- & (dlog(dh3rio) - jmwo0z(w3gohz,lir0o1) / w5poyv(lir0o1,w3gohz) -
- &dlog(w5poyv(lir0o1,w3gohz))) - ig5cma
- goto 23213
-23212 continue
- mu4ygk = -1000.0d0
-23213 continue
- mu4ygk = -mu4ygk
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * mu4ygk
-23210 continue
-23208 continue
- if(.not.(zvxw1l .eq. 3))goto 23214
- if(.not.(cll .eq. 0))goto 23216
- aho01l = 34.0d0
- do 23218 w3gohz=1,nfiumb4
- if(.not.(go0l1q(2*lir0o1,w3gohz) .gt. aho01l))goto 23220
- gq815b = dexp(aho01l)
- xyiu19 = .true.
- goto 23221
-23220 continue
- if(.not.(go0l1q(2*lir0o1,w3gohz) .lt. -aho01l))goto 23222
- gq815b = dexp(-aho01l)
- xyiu19 = .true.
- goto 23223
-23222 continue
- gq815b = dexp(go0l1q(2*lir0o1,w3gohz))
- xyiu19 = .false.
-23223 continue
-23221 continue
- if(.not.(jmwo0z(w3gohz,lir0o1) .lt. 1.0d0))goto 23224
- mu4ygk = 1.0d0
- goto 23225
-23224 continue
- mu4ygk = jmwo0z(w3gohz,lir0o1)
-23225 continue
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * (jmwo0z(w3gohz,lir0o1) *
- &dlog(mu4ygk/w5poyv(lir0o1,w3gohz)) + (jmwo0z(w3gohz,lir0o1)+
- &gq815b) * dlog((w5poyv(lir0o1,w3gohz) + gq815b) / ( gq815b+jmwo0z(
- &w3gohz,lir0o1))))
-23218 continue
- goto 23217
-23216 continue
- do 23226 w3gohz=1,nfiumb4
- gq815b = dexp(go0l1q(2*lir0o1,w3gohz))
- call atez9d(gq815b + jmwo0z(w3gohz,lir0o1), ig5cma)
- call atez9d(gq815b, j0izmn)
- call atez9d(1.0d0 + jmwo0z(w3gohz,lir0o1), ue1phr)
- mu4ygk = gq815b * dlog(gq815b / (gq815b + w5poyv(lir0o1,w3gohz)))
- &+ ig5cma - j0izmn - ue1phr
- if(.not.(jmwo0z(w3gohz,lir0o1) .gt. 0.0d0))goto 23228
- mu4ygk = mu4ygk + jmwo0z(w3gohz,lir0o1) * dlog(w5poyv(lir0o1,
- &w3gohz) / (gq815b + w5poyv(lir0o1,w3gohz)))
-23228 continue
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * mu4ygk
-23226 continue
- qe3jcd = -qe3jcd / 2.0d0
-23217 continue
-23214 continue
- if(.not.(zvxw1l .eq. 8))goto 23230
- do 23232 w3gohz=1,nfiumb4
- mu4ygk = jmwo0z(w3gohz,lir0o1) - w5poyv(lir0o1,w3gohz)
- qe3jcd = qe3jcd + w8xfic(w3gohz,1) * mu4ygk**2
-23232 continue
-23230 continue
-23123 continue
- dev = 2.0d0 * qe3jcd
- return
- end
- subroutine sptoq8(hft28, ur73jo, nfiumb4, vi231l, cqui1v, zvxw1l)
- implicit logical (a-z)
- integer nfiumb4, vi231l, cqui1v, zvxw1l
- double precision hft28(nfiumb4,cqui1v), ur73jo(vi231l,1)
- integer w3gohz, c3qxjo, pvnfr4
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq.5 )))goto 23234
- c3qxjo = 1
- do 23236 w3gohz=1,nfiumb4
- ur73jo(2*w3gohz-1,c3qxjo) = 1.0d0
- ur73jo(2*w3gohz, c3qxjo) = 0.0d0
-23236 continue
- c3qxjo = c3qxjo + 1
- do 23238 w3gohz=1,nfiumb4
- ur73jo(2*w3gohz-1,c3qxjo) = 0.0d0
- ur73jo(2*w3gohz, c3qxjo) = 1.0d0
-23238 continue
- c3qxjo = c3qxjo + 1
- do 23240 pvnfr4=1,cqui1v
- do 23242 w3gohz=1,nfiumb4
- ur73jo(2*w3gohz-1,c3qxjo) = hft28(w3gohz,pvnfr4)
- ur73jo(2*w3gohz, c3qxjo) = 0.0d0
-23242 continue
- c3qxjo = c3qxjo + 1
-23240 continue
- goto 23235
-23234 continue
- c3qxjo = 1
- do 23244 w3gohz=1,nfiumb4
- ur73jo(w3gohz,c3qxjo) = 1.0d0
-23244 continue
- c3qxjo = c3qxjo + 1
- do 23246 pvnfr4=1,cqui1v
- do 23248 w3gohz=1,nfiumb4
- ur73jo(w3gohz,c3qxjo)=hft28(w3gohz,pvnfr4)
-23248 continue
- c3qxjo = c3qxjo + 1
-23246 continue
-23235 continue
- return
- end
- subroutine u16zxj(hft28, ur73jo, nfiumb4, cqui1v, zvxw1l, q121lc,
- &vi231l, zxiwf1, i5uvkm, zqve1l, vvl1li, oju3yh, p1, h3mrfq)
- implicit logical (a-z)
- integer nfiumb4, cqui1v, zvxw1l, vi231l, zxiwf1, i5uvkm, zqve1l(
- &i5uvkm), vvl1li(i5uvkm), p1, h3mrfq
- double precision hft28(nfiumb4,cqui1v), ur73jo(vi231l,zxiwf1),
- &oju3yh(nfiumb4,p1)
- double precision q121lc(nfiumb4)
- integer hv3wja, w3gohz, c3qxjo, pvnfr4
- double precision mw6reg, ig5cma
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23250
- do 23252 pvnfr4=1,cqui1v
- do 23254 w3gohz=1,nfiumb4
- ur73jo(2*w3gohz-1,pvnfr4) = hft28(w3gohz,pvnfr4)
- ur73jo(2*w3gohz ,pvnfr4) = 0.0d0
-23254 continue
-23252 continue
- c3qxjo = cqui1v + 1
- if(.not.(h3mrfq .eq. 0))goto 23256
- do 23258 hv3wja=1,i5uvkm
- do 23260 w3gohz=1,nfiumb4
- ur73jo(2*w3gohz-1,c3qxjo) = hft28(w3gohz,zqve1l(hv3wja)) * hft28(
- &w3gohz,vvl1li(hv3wja))
- ur73jo(2*w3gohz ,c3qxjo) = 0.0d0
-23260 continue
- c3qxjo = c3qxjo + 1
-23258 continue
- goto 23257
-23256 continue
- do 23262 w3gohz=1,nfiumb4
- mw6reg = 0.0d0
- do 23264 pvnfr4=1,cqui1v
- ig5cma = hft28(w3gohz,pvnfr4)
- mw6reg = mw6reg + ig5cma * ig5cma
-23264 continue
- q121lc(w3gohz) = -0.50d0 * mw6reg
-23262 continue
-23257 continue
- goto 23251
-23250 continue
- do 23266 pvnfr4=1,cqui1v
- do 23268 w3gohz=1,nfiumb4
- ur73jo(w3gohz,pvnfr4) = hft28(w3gohz,pvnfr4)
-23268 continue
-23266 continue
- c3qxjo = cqui1v + 1
- if(.not.(h3mrfq .eq. 0))goto 23270
- do 23272 hv3wja=1,i5uvkm
- do 23274 w3gohz=1,nfiumb4
- ur73jo(w3gohz,c3qxjo) = hft28(w3gohz,zqve1l(hv3wja)) * hft28(
- &w3gohz,vvl1li(hv3wja))
-23274 continue
- c3qxjo = c3qxjo + 1
-23272 continue
- goto 23271
-23270 continue
- do 23276 w3gohz=1,nfiumb4
- mw6reg = 0.0d0
- do 23278 pvnfr4=1,cqui1v
- ig5cma = hft28(w3gohz,pvnfr4)
- mw6reg = mw6reg + ig5cma * ig5cma
-23278 continue
- q121lc(w3gohz) = -0.50d0 * mw6reg
-23276 continue
-23271 continue
-23251 continue
- if(.not.(p1 .gt. 0))goto 23280
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23282
- do 23284 w3gohz=1,nfiumb4
- ur73jo(2*w3gohz-1,c3qxjo) = 1.0d0
- ur73jo(2*w3gohz, c3qxjo) = 0.0d0
-23284 continue
- c3qxjo = c3qxjo + 1
- do 23286 w3gohz=1,nfiumb4
- ur73jo(2*w3gohz-1,c3qxjo) = 0.0d0
- ur73jo(2*w3gohz, c3qxjo) = 1.0d0
-23286 continue
- c3qxjo = c3qxjo + 1
- if(.not.(p1 .gt. 1))goto 23288
- do 23290 hv3wja=2,p1
- do 23292 w3gohz=1,nfiumb4
- ur73jo(2*w3gohz-1,c3qxjo) = oju3yh(w3gohz,hv3wja)
- ur73jo(2*w3gohz, c3qxjo) = 0.0d0
-23292 continue
- c3qxjo = c3qxjo + 1
-23290 continue
-23288 continue
- goto 23283
-23282 continue
- do 23294 hv3wja=1,p1
- do 23296 w3gohz=1,nfiumb4
- ur73jo(w3gohz,c3qxjo) = oju3yh(w3gohz,hv3wja)
-23296 continue
- c3qxjo = c3qxjo + 1
-23294 continue
-23283 continue
-23280 continue
- return
- end
- subroutine p0lk40(hft28, ur73jo, nfiumb4, lku8xq, vi231l, cqui1v,
- &zvxw1l, aqk377, w5tcfp, cr8hav, i5uvkm, zqve1l, vvl1li, h3mrfq,
- &q121lc)
- implicit logical (a-z)
- integer nfiumb4, lku8xq, vi231l, cqui1v, zvxw1l, aqk377, w5tcfp,
- &cr8hav, i5uvkm, zqve1l(i5uvkm), vvl1li(i5uvkm), h3mrfq
- double precision hft28(nfiumb4,cqui1v), ur73jo(vi231l,cr8hav),
- &q121lc(nfiumb4)
- integer hv3wja, w3gohz, d9rjek, nd6mep, ptr, c3qxjo, pvnfr4
- double precision ig5cma, mw6reg
- do 23298 nd6mep=1,cr8hav
- do 23300 w3gohz=1,vi231l
- ur73jo(w3gohz,nd6mep) = 0.0d0
-23300 continue
-23298 continue
- c3qxjo = 0
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23302
- do 23304 pvnfr4=1,cqui1v
- ptr = 1
- do 23306 w3gohz=1,nfiumb4
- do 23308 d9rjek=1,aqk377
- ur73jo(ptr,c3qxjo+d9rjek) = hft28(w3gohz,pvnfr4)
- ptr = ptr + 2
-23308 continue
-23306 continue
- c3qxjo = c3qxjo + aqk377
-23304 continue
- goto 23303
-23302 continue
- do 23310 pvnfr4=1,cqui1v
- ptr = 0
- do 23312 w3gohz=1,nfiumb4
- do 23314 d9rjek=1,lku8xq
- ptr = ptr + 1
- ur73jo(ptr,c3qxjo+d9rjek) = hft28(w3gohz,pvnfr4)
-23314 continue
-23312 continue
- c3qxjo = c3qxjo + lku8xq
-23310 continue
-23303 continue
- if(.not.(w5tcfp .eq. 0))goto 23316
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23318
- do 23320 hv3wja=1,i5uvkm
- ptr = 1
- do 23322 w3gohz=1,nfiumb4
- ig5cma = hft28(w3gohz,zqve1l(hv3wja)) * hft28(w3gohz,vvl1li(
- &hv3wja))
- do 23324 d9rjek=1,aqk377
- ur73jo(ptr,c3qxjo+d9rjek) = ig5cma
- ptr = ptr + 2
-23324 continue
-23322 continue
- c3qxjo = c3qxjo + aqk377
-23320 continue
- goto 23319
-23318 continue
- do 23326 hv3wja=1,i5uvkm
- ptr = 0
- do 23328 w3gohz=1,nfiumb4
- ig5cma = hft28(w3gohz,zqve1l(hv3wja)) * hft28(w3gohz,vvl1li(
- &hv3wja))
- do 23330 d9rjek=1,lku8xq
- ptr = ptr + 1
- ur73jo(ptr,c3qxjo+d9rjek) = ig5cma
-23330 continue
-23328 continue
- c3qxjo = c3qxjo + lku8xq
-23326 continue
-23319 continue
- goto 23317
-23316 continue
- if(.not.(h3mrfq .eq. 1))goto 23332
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23334
- do 23336 w3gohz=1,nfiumb4
- mw6reg = 0.0d0
- do 23338 pvnfr4=1,cqui1v
- ig5cma = hft28(w3gohz,pvnfr4)
- mw6reg = mw6reg + ig5cma * ig5cma
-23338 continue
- q121lc(w3gohz) = -0.50d0 * mw6reg
-23336 continue
- goto 23335
-23334 continue
- do 23340 w3gohz=1,nfiumb4
- mw6reg = 0.0d0
- do 23342 pvnfr4=1,cqui1v
- ig5cma = hft28(w3gohz,pvnfr4)
- mw6reg = mw6reg + ig5cma * ig5cma
-23342 continue
- q121lc(w3gohz) = -0.50d0 * mw6reg
-23340 continue
-23335 continue
- goto 23333
-23332 continue
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23344
- do 23346 hv3wja=1,i5uvkm
- ptr = 1
- do 23348 w3gohz=1,nfiumb4
- ig5cma = hft28(w3gohz,zqve1l(hv3wja)) * hft28(w3gohz,vvl1li(
- &hv3wja))
- do 23350 d9rjek=1,aqk377
- ur73jo(ptr,c3qxjo+hv3wja) = ig5cma
- ptr = ptr + 2
-23350 continue
-23348 continue
-23346 continue
- c3qxjo = c3qxjo + i5uvkm
- goto 23345
-23344 continue
- do 23352 hv3wja=1,i5uvkm
- ptr = 0
- do 23354 w3gohz=1,nfiumb4
- ig5cma = hft28(w3gohz,zqve1l(hv3wja)) * hft28(w3gohz,vvl1li(
- &hv3wja))
- do 23356 d9rjek=1,lku8xq
- ptr = ptr + 1
- ur73jo(ptr,c3qxjo+hv3wja) = ig5cma
-23356 continue
-23354 continue
-23352 continue
- c3qxjo = c3qxjo + i5uvkm
-23345 continue
-23333 continue
-23317 continue
- return
- end
- subroutine nbq4ua(jmwo0z, go0l1q, l1zvxx, nfiumb4, lku8xq, aqk377,
- & zvxw1l, lir0o1, w8xfic, foej1u)
- implicit logical (a-z)
- integer nfiumb4, lku8xq, aqk377, zvxw1l, lir0o1, foej1u
- double precision jmwo0z(nfiumb4,aqk377), go0l1q(lku8xq,nfiumb4),
- &l1zvxx(15)
- double precision w8xfic(nfiumb4,1)
- double precision nqvu3e, pg2aqx, ozpqa0, ghys4c, qg8fdc, bdgzx3,
- &cy0nqs, reg6st, wo8cqk
- integer w3gohz
- if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4) .or.(zvxw1l .eq. 3)
- &.or. (zvxw1l .eq. 5)))goto 23358
- nqvu3e = 0.0d0
- pg2aqx = 0.0d0
- do 23360 w3gohz=1,nfiumb4
- nqvu3e = nqvu3e + jmwo0z(w3gohz,lir0o1) * w8xfic(w3gohz,1)
- pg2aqx = pg2aqx + w8xfic(w3gohz,1)
-23360 continue
- ozpqa0 = nqvu3e / pg2aqx
-23358 continue
- if(.not.(zvxw1l .eq. 1))goto 23362
- call u10e3o(ozpqa0, ghys4c)
- do 23364 w3gohz=1,nfiumb4
- go0l1q(lir0o1,w3gohz) = ghys4c
-23364 continue
-23362 continue
- if(.not.(zvxw1l .eq. 2))goto 23366
- do 23368 w3gohz=1,nfiumb4
- go0l1q(lir0o1,w3gohz) = dlog(jmwo0z(w3gohz,lir0o1) + 0.125d0)
-23368 continue
-23366 continue
- if(.not.(zvxw1l .eq. 4))goto 23370
- call wgf0al(ozpqa0, qg8fdc)
- do 23372 w3gohz=1,nfiumb4
- go0l1q(lir0o1,w3gohz) = qg8fdc
-23372 continue
-23370 continue
- if(.not.(zvxw1l .eq. 5))goto 23374
- if(.not.(foej1u .eq. 1))goto 23376
- bdgzx3 = dlog(ozpqa0 + 0.03125d0)
- cy0nqs = dlog(l1zvxx(3+aqk377+lir0o1)+0.01d0)
- do 23378 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz) = bdgzx3
- go0l1q(2*lir0o1, w3gohz) = cy0nqs
-23378 continue
- goto 23377
-23376 continue
- if(.not.(foej1u .eq. 2))goto 23380
- bdgzx3 = dlog((6.0/8.0)*ozpqa0+0.000d0)
- cy0nqs = dlog(l1zvxx(3+aqk377+lir0o1)+0.01d0)
- do 23382 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz) = bdgzx3
- go0l1q(2*lir0o1 ,w3gohz) = cy0nqs
-23382 continue
- goto 23381
-23380 continue
- cy0nqs = dlog(l1zvxx(3+aqk377+lir0o1)+0.01d0)
- do 23384 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz) = dlog(jmwo0z(w3gohz,lir0o1) + 0.
- &03125d0)
- go0l1q(2*lir0o1, w3gohz) = cy0nqs
-23384 continue
-23381 continue
-23377 continue
-23374 continue
- if(.not.(zvxw1l .eq. 3))goto 23386
- if(.not.(foej1u .eq. 1))goto 23388
- bdgzx3 = dlog(ozpqa0 + 0.03125d0)
- cy0nqs = dlog(l1zvxx(3+lir0o1)+0.03125d0)
- do 23390 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz) = bdgzx3
- go0l1q(2*lir0o1,w3gohz) = cy0nqs
-23390 continue
- goto 23389
-23388 continue
- if(.not.(foej1u .eq. 2))goto 23392
- bdgzx3 = dlog(ozpqa0 + 0.03125d0)
- wo8cqk = l1zvxx(3+lir0o1)
- cy0nqs = dlog(wo8cqk)
- do 23394 w3gohz=1,nfiumb4
- reg6st = jmwo0z(w3gohz,lir0o1) - ozpqa0
- if(.not.(reg6st .gt. 3.0 * ozpqa0))goto 23396
- go0l1q(2*lir0o1-1,w3gohz) = dlog(dsqrt(jmwo0z(w3gohz,lir0o1)))
- go0l1q(2*lir0o1 ,w3gohz) = cy0nqs
- goto 23397
-23396 continue
- go0l1q(2*lir0o1-1,w3gohz) = bdgzx3
- go0l1q(2*lir0o1 ,w3gohz) = cy0nqs
-23397 continue
-23394 continue
- goto 23393
-23392 continue
- if(.not.(foej1u .eq. 3))goto 23398
- bdgzx3 = dlog(ozpqa0 + 0.03125d0)
- wo8cqk = l1zvxx(3+lir0o1)
- cy0nqs = dlog(wo8cqk)
- do 23400 w3gohz=1,nfiumb4
- reg6st = jmwo0z(w3gohz,lir0o1) - ozpqa0
- if(.not.(reg6st .gt. ozpqa0))goto 23402
- go0l1q(2*lir0o1-1,w3gohz) = dlog(0.5*(jmwo0z(w3gohz,lir0o1)+
- &ozpqa0))
- go0l1q(2*lir0o1 ,w3gohz) = dlog(wo8cqk / (reg6st / ozpqa0))
- goto 23403
-23402 continue
- if(.not.(jmwo0z(w3gohz,lir0o1) .lt. (ozpqa0 / 4.0)))goto 23404
- go0l1q(2*lir0o1-1,w3gohz) = dlog(ozpqa0 / 4.0)
- go0l1q(2*lir0o1 ,w3gohz) = cy0nqs
- goto 23405
-23404 continue
- go0l1q(2*lir0o1-1,w3gohz) = bdgzx3
- go0l1q(2*lir0o1 ,w3gohz) = cy0nqs
-23405 continue
-23403 continue
-23400 continue
- goto 23399
-23398 continue
- cy0nqs = dlog(l1zvxx(3+lir0o1))
- do 23406 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz) = dlog(jmwo0z(w3gohz,lir0o1) + 0.
- &03125d0)
- go0l1q(2*lir0o1, w3gohz) = cy0nqs
-23406 continue
-23399 continue
-23393 continue
-23389 continue
-23386 continue
- if(.not.(zvxw1l .eq. 8))goto 23408
- do 23410 w3gohz=1,nfiumb4
- go0l1q(lir0o1,w3gohz) = jmwo0z(w3gohz,lir0o1)
-23410 continue
-23408 continue
- return
- end
- subroutine kqsxz1(jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph,
- &jrxg6l, jftq1, fiumb4, zl11l0, nfiumb4, lku8xq, aqk377, vi231l,
- &zkjqhi, lir0o1, zvxw1l, gqxvz8, h3mrfq, q121lc)
- implicit logical (a-z)
- integer nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, lir0o1, gqxvz8,
- &h3mrfq
- double precision jmwo0z(nfiumb4,aqk377), w8xfic(nfiumb4,1),
- &go0l1q(lku8xq,nfiumb4), w5poyv(aqk377,nfiumb4), q121lc(nfiumb4),
- &hr83e(nfiumb4,lku8xq), lj4dph(nfiumb4,lku8xq), jrxg6l(zkjqhi,
- &nfiumb4), jftq1, fiumb4, zl11l0
- integer w3gohz, zvxw1l
- double precision mu4ygka, zixm0o, mu4ygkc, aho01l
- logical xyiu19
- double precision gq815b, p4je8, da51l0o, hmr3dx, yqsco4, ogq67o,
- &qpzx6l(1,1), qxvi5(1,1), xkcm3b(1,1)
- integer uxzze7, c4uxow, nh2qxl
- double precision dh3rio, ig5cmad, ig5v8gzsp, dldshape
- double precision l0zqm, q1znur
- integer lqhm2g
- vi231l = 1
- uxzze7 = 1
- ogq67o = 0.990d0
- ogq67o = 0.995d0
- if(.not.(zvxw1l .eq. 1))goto 23412
- do 23414 w3gohz=1,nfiumb4
- mu4ygka = w5poyv(lir0o1,w3gohz) * (1.0d0 - w5poyv(lir0o1,w3gohz))
- zixm0o = mu4ygka * w8xfic(w3gohz,1)
- if(.not.(mu4ygka .lt. fiumb4))goto 23416
- mu4ygka = fiumb4
-23416 continue
- if(.not.(zixm0o .lt. fiumb4))goto 23418
- zixm0o = fiumb4
- jrxg6l(lir0o1,w3gohz) = zl11l0
- goto 23419
-23418 continue
- jrxg6l(lir0o1,w3gohz) = dsqrt(zixm0o)
-23419 continue
- lj4dph(w3gohz,lir0o1) = zixm0o
- hr83e(w3gohz,lir0o1) = go0l1q(lir0o1,w3gohz) + (jmwo0z(w3gohz,
- &lir0o1)-w5poyv(lir0o1,w3gohz)) / mu4ygka
-23414 continue
-23412 continue
- if(.not.(zvxw1l .eq. 2))goto 23420
- do 23422 w3gohz=1,nfiumb4
- mu4ygka = w5poyv(lir0o1,w3gohz)
- zixm0o = mu4ygka * w8xfic(w3gohz,1)
- if(.not.(zixm0o .lt. fiumb4))goto 23424
- zixm0o = fiumb4
- jrxg6l(lir0o1,w3gohz) = zl11l0
- goto 23425
-23424 continue
- jrxg6l(lir0o1,w3gohz) = dsqrt(zixm0o)
-23425 continue
- lj4dph(w3gohz,lir0o1) = zixm0o
- if(.not.(jmwo0z(w3gohz,lir0o1) .gt. 0.0d0))goto 23426
- mu4ygkc = mu4ygka
- if(.not.(mu4ygkc .lt. fiumb4))goto 23428
- mu4ygkc = fiumb4
-23428 continue
- hr83e(w3gohz,lir0o1) = go0l1q(lir0o1,w3gohz) + (jmwo0z(w3gohz,
- &lir0o1)-mu4ygkc)/mu4ygkc
- goto 23427
-23426 continue
- hr83e(w3gohz,lir0o1) = go0l1q(lir0o1,w3gohz) - 1.0d0
-23427 continue
-23422 continue
-23420 continue
- if(.not.(zvxw1l .eq. 4))goto 23430
- do 23432 w3gohz=1,nfiumb4
- if(.not.((w5poyv(lir0o1,w3gohz) .lt. fiumb4) .or.(w5poyv(lir0o1,
- &w3gohz) .gt. 1.0d0 - fiumb4)))goto 23434
- mu4ygka = fiumb4
- zixm0o = mu4ygka * w8xfic(w3gohz,1)
- if(.not.(zixm0o .lt. fiumb4))goto 23436
- zixm0o = fiumb4
- jrxg6l(lir0o1,w3gohz) = zl11l0
- goto 23437
-23436 continue
- jrxg6l(lir0o1,w3gohz) = dsqrt(zixm0o)
-23437 continue
- lj4dph(w3gohz,lir0o1) = zixm0o
- hr83e(w3gohz,lir0o1) = go0l1q(lir0o1,w3gohz) + (jmwo0z(w3gohz,
- &lir0o1)-w5poyv(lir0o1,w3gohz)) / mu4ygka
- goto 23435
-23434 continue
- mu4ygka = -(1.0d0 - w5poyv(lir0o1,w3gohz)) * dlog(1.0d0 - w5poyv(
- &lir0o1,w3gohz))
- if(.not.(mu4ygka .lt. fiumb4))goto 23438
- mu4ygka = fiumb4
-23438 continue
- zixm0o = -mu4ygka * w8xfic(w3gohz,1) * dlog(1.0d0 - w5poyv(lir0o1,
- &w3gohz)) / w5poyv(lir0o1,w3gohz)
- if(.not.(zixm0o .lt. fiumb4))goto 23440
- zixm0o = fiumb4
-23440 continue
- lj4dph(w3gohz,lir0o1) = zixm0o
- jrxg6l(lir0o1,w3gohz) = dsqrt(zixm0o)
- hr83e(w3gohz,lir0o1) = go0l1q(lir0o1,w3gohz) + (jmwo0z(w3gohz,
- &lir0o1)-w5poyv(lir0o1,w3gohz)) / mu4ygka
-23435 continue
-23432 continue
-23430 continue
- if(.not.(zvxw1l .eq. 5))goto 23442
- l0zqm = 1.0d-20
- aho01l = 34.0d0
- do 23444 w3gohz=1,nfiumb4
- if(.not.(go0l1q(2*lir0o1,w3gohz) .gt. aho01l))goto 23446
- dh3rio = dexp(aho01l)
- xyiu19 = .true.
- goto 23447
-23446 continue
- if(.not.(go0l1q(2*lir0o1,w3gohz) .lt. -aho01l))goto 23448
- dh3rio = dexp(-aho01l)
- xyiu19 = .true.
- goto 23449
-23448 continue
- dh3rio = dexp(go0l1q(2*lir0o1,w3gohz))
- xyiu19 = .false.
-23449 continue
-23447 continue
- call vdgam1(dh3rio, ig5cmad, lqhm2g)
- if(.not.(lqhm2g .ne. 1))goto 23450
- call intpr("error in kqsxz1 lqhm2g 1: ",-1,lqhm2g,1)
-23450 continue
- q1znur = w5poyv(lir0o1,w3gohz)
- if(.not.(q1znur .lt. l0zqm))goto 23452
- q1znur = l0zqm
-23452 continue
- dldshape = dlog(jmwo0z(w3gohz,lir0o1)) + dlog(dh3rio) - dlog(
- &q1znur) + 1.0d0 - ig5cmad - jmwo0z(w3gohz,lir0o1) / q1znur
- call vtgam1(dh3rio, ig5v8gzsp, lqhm2g)
- if(.not.(lqhm2g .ne. 1))goto 23454
- call intpr("error in kqsxz1 lqhm2g 2: ",-1,lqhm2g,1)
-23454 continue
- lj4dph(w3gohz,2*lir0o1-1) = w8xfic(w3gohz,1) * dh3rio
- mu4ygka = dh3rio * ig5v8gzsp - 1.0d0
- lj4dph(w3gohz,2*lir0o1 ) = w8xfic(w3gohz,1) * dh3rio * mu4ygka
- if(.not.(lj4dph(w3gohz,2*lir0o1-1) .lt. fiumb4))goto 23456
- lj4dph(w3gohz,2*lir0o1-1) = fiumb4
- jrxg6l(2*lir0o1-1,w3gohz) = zl11l0
- goto 23457
-23456 continue
- jrxg6l(2*lir0o1-1,w3gohz) = dsqrt(lj4dph(w3gohz,2*lir0o1-1))
-23457 continue
- if(.not.(lj4dph(w3gohz,2*lir0o1) .lt. fiumb4))goto 23458
- lj4dph(w3gohz,2*lir0o1) = fiumb4
- jrxg6l(2*lir0o1,w3gohz) = zl11l0
- goto 23459
-23458 continue
- jrxg6l(2*lir0o1,w3gohz) = dsqrt(lj4dph(w3gohz,2*lir0o1))
-23459 continue
- if(.not.(mu4ygka .lt. l0zqm))goto 23460
- mu4ygka = l0zqm
-23460 continue
- hr83e(w3gohz,2*lir0o1-1) = go0l1q(2*lir0o1-1,w3gohz) + jmwo0z(
- &w3gohz,lir0o1) / q1znur - 1.0d0
- hr83e(w3gohz,2*lir0o1 ) = go0l1q(2*lir0o1 ,w3gohz) + dldshape /
- &mu4ygka
-23444 continue
-23442 continue
- if(.not.(zvxw1l .eq. 3))goto 23462
- aho01l = 34.0d0
- l0zqm = 1.0d-20
- do 23464 w3gohz=1,nfiumb4
- if(.not.(go0l1q(2*lir0o1,w3gohz) .gt. aho01l))goto 23466
- gq815b = dexp(aho01l)
- xyiu19 = .true.
- goto 23467
-23466 continue
- if(.not.(go0l1q(2*lir0o1,w3gohz) .lt. -aho01l))goto 23468
- gq815b = dexp(-aho01l)
- xyiu19 = .true.
- goto 23469
-23468 continue
- gq815b = dexp(go0l1q(2*lir0o1,w3gohz))
- xyiu19 = .false.
-23469 continue
-23467 continue
- q1znur = w5poyv(lir0o1,w3gohz)
- if(.not.(q1znur .lt. l0zqm))goto 23470
- q1znur = l0zqm
-23470 continue
- call vdgam1(jmwo0z(w3gohz,lir0o1) + gq815b, mu4ygka, lqhm2g)
- if(.not.(lqhm2g .ne. 1))goto 23472
-23472 continue
- call vdgam1(gq815b, zixm0o, lqhm2g)
- if(.not.(lqhm2g .ne. 1))goto 23474
-23474 continue
- da51l0o = mu4ygka - zixm0o - (jmwo0z(w3gohz,lir0o1) + gq815b) / (
- &q1znur + gq815b) + 1.0d0 + dlog(gq815b / (q1znur + gq815b))
- p4je8 = gq815b
- qxvi5(1,1) = gq815b
- xkcm3b(1,1) = q1znur
- nh2qxl = 5000
- call enbin9(qpzx6l, qxvi5, xkcm3b, ogq67o, uxzze7, c4uxow, uxzze7,
- & hmr3dx, jftq1, nh2qxl)
- if(.not.(c4uxow .ne. 1))goto 23476
- gqxvz8 = 5
- return
-23476 continue
- yqsco4 = -qpzx6l(1,1) - 1.0d0 / gq815b + 1.0d0 / (gq815b + q1znur)
- lj4dph(w3gohz,2*lir0o1-1) = w8xfic(w3gohz,1) * q1znur * gq815b / (
- &q1znur + gq815b)
- lj4dph(w3gohz,2*lir0o1 ) = w8xfic(w3gohz,1) * gq815b * (-qpzx6l(1,
- &1)*gq815b - 1.0d0 + gq815b / (gq815b + q1znur))
- if(.not.(lj4dph(w3gohz,2*lir0o1-1) .lt. fiumb4))goto 23478
- lj4dph(w3gohz,2*lir0o1-1) = fiumb4
- jrxg6l(2*lir0o1-1,w3gohz) = zl11l0
- goto 23479
-23478 continue
- jrxg6l(2*lir0o1-1,w3gohz) = dsqrt(lj4dph(w3gohz,2*lir0o1-1))
-23479 continue
- if(.not.(lj4dph(w3gohz,2*lir0o1) .lt. fiumb4))goto 23480
- lj4dph(w3gohz,2*lir0o1) = fiumb4
- jrxg6l(2*lir0o1,w3gohz) = zl11l0
- goto 23481
-23480 continue
- jrxg6l(2*lir0o1,w3gohz) = dsqrt(lj4dph(w3gohz,2*lir0o1))
-23481 continue
- hr83e(w3gohz,2*lir0o1-1) = go0l1q(2*lir0o1-1,w3gohz) + jmwo0z(
- &w3gohz,lir0o1) / q1znur - 1.0d0
- hr83e(w3gohz,2*lir0o1 ) = go0l1q(2*lir0o1 ,w3gohz) + da51l0o / (
- &p4je8 * yqsco4)
-23464 continue
-23462 continue
- if(.not.(zvxw1l .eq. 8))goto 23482
- do 23484 w3gohz=1,nfiumb4
- lj4dph(w3gohz,lir0o1) = w8xfic(w3gohz,1)
- jrxg6l(lir0o1,w3gohz) = dsqrt(lj4dph(w3gohz,lir0o1))
- hr83e(w3gohz,lir0o1) = jmwo0z(w3gohz,lir0o1)
-23484 continue
-23482 continue
- if(.not.(h3mrfq .eq. 1))goto 23486
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23488
- do 23490 w3gohz=1,nfiumb4
- hr83e(w3gohz,2*lir0o1-1) = hr83e(w3gohz,2*lir0o1-1) - q121lc(
- &w3gohz)
-23490 continue
- goto 23489
-23488 continue
- do 23492 w3gohz=1,nfiumb4
- hr83e(w3gohz,lir0o1) = hr83e(w3gohz,lir0o1) - q121lc(w3gohz)
-23492 continue
-23489 continue
-23486 continue
- return
- end
- subroutine cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc,
- &w5poyv, hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1,
- &nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l,
- &vvl1li, nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
- implicit logical (a-z)
- integer p1i8xz(18), zqve1l(1), vvl1li(1)
- integer nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, i83h1(1)
- double precision hft28(nfiumb4,1), jmwo0z(nfiumb4,aqk377), oju3yh(
- &nfiumb4,9), w8xfic(nfiumb4,1), go0l1q(lku8xq,nfiumb4), q121lc(
- &nfiumb4), w5poyv(aqk377,nfiumb4)
- double precision hr83e(nfiumb4,lku8xq), lj4dph(nfiumb4,lku8xq),
- &jrxg6l(zkjqhi,nfiumb4), ur73jo(vi231l,1)
- double precision ioqzvb(vi231l,1), i0qvzl(1), nx1bat, lq8reh(1),
- &l1zvxx(4)
- double precision t5vlzq(lku8xq,nfiumb4,2), zxao0o(lku8xq*(lku8xq+
- &1))
- integer w3gohz, d9rjek, nd6mep, i5uvkm, ptr, opf6cv, i2, oht3ga,
- &ucgi1r, w5tcfp, cqui1v, xhe4cg, ugsma5, zvxw1l, pga6nul
- integer tvyd2b, fjg0qv, zx1610, zxiwf1, cr8hav, dyt0pg, h3mrfq,
- &uvnk0i
- integer uxzze7, foej1u
- double precision hq710, fiumb4, t7sbea, xmr7cj, elq2cs, qik6ym,
- &zl11l0, wlkaa3, jftq1
- double precision epx9jf1, epx9jf2
- integer scvgce
- uxzze7 = 1
- scvgce = 0
- oju3yh(1,1) = 1
- zxao0o(1) = 0.0d0
- cqui1v = p1i8xz(1)
- w5tcfp = p1i8xz(2)
- zxiwf1 = p1i8xz(3)
- xhe4cg = p1i8xz(4)
- ugsma5 = p1i8xz(5)
- zvxw1l = p1i8xz(6)
- pga6nul = p1i8xz(7)
- p1i8xz(9) = 0
- cr8hav = p1i8xz(11)
- dyt0pg = p1i8xz(12)
- h3mrfq = p1i8xz(14)
- uvnk0i = p1i8xz(15)
- foej1u = p1i8xz(18)
- fiumb4 = l1zvxx(1)
- zl11l0 = dsqrt(fiumb4)
- if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23494
- wlkaa3 = dlog(fiumb4)
-23494 continue
- qik6ym = l1zvxx(2)
- jftq1 = l1zvxx(3)
- elq2cs = 0.0d0
- oht3ga = 0
- gqxvz8 = 1
- call qh4ulb(zqve1l, vvl1li, cqui1v)
- i5uvkm = cqui1v * (cqui1v+1) / 2
- call p0lk40(hft28, ur73jo, nfiumb4, lku8xq, vi231l, cqui1v,
- &zvxw1l, aqk377, w5tcfp, cr8hav, i5uvkm, zqve1l, vvl1li, h3mrfq,
- &q121lc)
-653 epx9jf2 = 1.0d0
- if(.not.(ugsma5 .eq. 0))goto 23496
- do 23498 d9rjek=1,aqk377
- call nbq4ua(jmwo0z, go0l1q, l1zvxx, nfiumb4, lku8xq, aqk377,
- &zvxw1l, d9rjek, w8xfic, foej1u)
-23498 continue
- goto 23497
-23496 continue
- if(.not.(ugsma5 .eq. 2))goto 23500
- call pjw1l(ur73jo, lq8reh, go0l1q, nfiumb4, lku8xq, vi231l,
- &zxiwf1, dyt0pg, oht3ga, zvxw1l, h3mrfq, q121lc)
-23500 continue
-23497 continue
- call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
- &oht3ga)
- if(.not.(ugsma5 .eq. 2))goto 23502
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, hq710, oht3ga, fiumb4, wlkaa3, uxzze7)
- goto 23503
-23502 continue
- hq710 = -1.0d0
-23503 continue
- do 23504 ucgi1r=1,pga6nul
- do 23506 d9rjek=1,aqk377
- call kqsxz1(jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph, jrxg6l,
- & jftq1, fiumb4, zl11l0, nfiumb4, lku8xq, aqk377, vi231l, zkjqhi,
- &d9rjek, zvxw1l, gqxvz8, h3mrfq, q121lc)
-23506 continue
- do 23508 d9rjek=1,zxiwf1
- do 23510 w3gohz=1,vi231l
- ioqzvb(w3gohz,d9rjek) = ur73jo(w3gohz,d9rjek)
-23510 continue
-23508 continue
- do 23512 d9rjek=1,zxiwf1
- ptr = 1
- do 23514 opf6cv=1,nfiumb4
- do 23516 i2=1,lku8xq
- ioqzvb(ptr,d9rjek) = jrxg6l(i2,opf6cv) * ioqzvb(ptr,d9rjek)
- ptr = ptr + 1
-23516 continue
-23514 continue
-23512 continue
- do 23518 nd6mep=1,zxiwf1
- i83h1(nd6mep) = nd6mep
-23518 continue
- t7sbea = 1.0d-7
- call dhkt9w(ioqzvb,vi231l,vi231l,zxiwf1,i0qvzl,i83h1,t5vlzq,
- &zx1610,t7sbea)
- if(.not.(zx1610 .ne. zxiwf1))goto 23520
- gqxvz8 = 2
- return
-23520 continue
- do 23522 w3gohz=1,nfiumb4
- do 23524 d9rjek=1,lku8xq
- t5vlzq(d9rjek,w3gohz,1) = jrxg6l(d9rjek,w3gohz) * hr83e(w3gohz,
- &d9rjek)
-23524 continue
-23522 continue
- tvyd2b = 101
- call vdqrsl(ioqzvb,vi231l,vi231l,zx1610,i0qvzl, t5vlzq, elq2cs,
- &t5vlzq(1,1,2), lq8reh, elq2cs,go0l1q,tvyd2b,fjg0qv)
- do 23526 w3gohz=1,nfiumb4
- do 23528 d9rjek=1,lku8xq
- go0l1q(d9rjek,w3gohz) = go0l1q(d9rjek,w3gohz) / jrxg6l(d9rjek,
- &w3gohz)
-23528 continue
-23526 continue
- if(.not.(h3mrfq .eq. 1))goto 23530
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23532
- do 23534 w3gohz=1,nfiumb4
- do 23536 d9rjek=1,aqk377
- go0l1q(2*d9rjek-1,w3gohz) = go0l1q(2*d9rjek-1,w3gohz) + q121lc(
- &w3gohz)
-23536 continue
-23534 continue
- goto 23533
-23532 continue
- do 23538 w3gohz=1,nfiumb4
- do 23540 d9rjek=1,lku8xq
- go0l1q(d9rjek,w3gohz) = go0l1q(d9rjek,w3gohz) + q121lc(w3gohz)
-23540 continue
-23538 continue
-23533 continue
-23530 continue
- call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
- &oht3ga)
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, nx1bat,oht3ga,fiumb4,wlkaa3, uxzze7)
- xmr7cj = dabs(nx1bat - hq710) / (1.0d0 + dabs(nx1bat))
- if(.not.(xmr7cj .lt. qik6ym))goto 23542
- gqxvz8 = 0
- p1i8xz(8) = ucgi1r
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23544
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, nx1bat,oht3ga,fiumb4,wlkaa3, oht3ga)
-23544 continue
- scvgce = 1
- goto 20097
- goto 23543
-23542 continue
- hq710 = nx1bat
- scvgce = 0
-23543 continue
-23504 continue
-20097 epx9jf1 = 0.0d0
- if(.not.(scvgce .eq. 1))goto 23546
- return
-23546 continue
- if(.not.(ugsma5 .eq. 1 .or. ugsma5 .eq. 2))goto 23548
- ugsma5 = 0
- p1i8xz(9) = 1
- goto 653
-23548 continue
- gqxvz8 = 3
- return
- end
- subroutine cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc,
- &w5poyv, hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1,
- &nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l,
- &vvl1li, nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
- implicit logical (a-z)
- integer p1i8xz(18), zqve1l(1), vvl1li(1)
- integer nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, i83h1(1)
- double precision hft28(nfiumb4,1), jmwo0z(nfiumb4,aqk377), w8xfic(
- &nfiumb4,1), go0l1q(lku8xq,nfiumb4), q121lc(nfiumb4), w5poyv(
- &aqk377,nfiumb4), oju3yh(nfiumb4,9), hr83e(nfiumb4,lku8xq), lj4dph(
- &nfiumb4,lku8xq), jrxg6l(zkjqhi,nfiumb4), ur73jo(vi231l,1)
- double precision ioqzvb(vi231l,1), i0qvzl(1), nx1bat, lq8reh(1),
- &l1zvxx(4)
- double precision t5vlzq(vi231l,3), zxao0o(lku8xq*(lku8xq+1))
- integer w3gohz, lir0o1, i5uvkm, oht3ga, ucgi1r, w5tcfp, h3mrfq,
- &cqui1v, xhe4cg, ugsma5, zvxw1l, pga6nul
- integer tvyd2b, fjg0qv, zx1610, zxiwf1, dyt0pg, uvnk0i
- integer uxzze7, p1, foej1u
- double precision hq710, fiumb4, t7sbea, xmr7cj, elq2cs, qik6ym,
- &zl11l0, wlkaa3, jftq1
- integer nd6mep
- double precision ni1qfp, epx9jf
- ni1qfp = 0.0d0
- uxzze7 = 1
- zxao0o(1) = 1.0d0
- call intpr(
- &"entering cqo1f uxzze7 -------------------------------: ",-1,
- &uxzze7,1)
- call intpr("in cqo1f aqk377: ",-1,aqk377,1)
- cqui1v = p1i8xz(1)
- w5tcfp = p1i8xz(2)
- zxiwf1 = p1i8xz(3)
- xhe4cg = p1i8xz(4)
- ugsma5 = p1i8xz(5)
- zvxw1l = p1i8xz(6)
- pga6nul = p1i8xz(7)
- p1i8xz(9) = 0
- dyt0pg = p1i8xz(12)
- if(.not.(dyt0pg .ne. 1))goto 23550
- gqxvz8 = 4
- return
-23550 continue
- h3mrfq = p1i8xz(14)
- uvnk0i = p1i8xz(15)
- p1 = p1i8xz(16)
- foej1u = p1i8xz(18)
- call intpr("Entry to cqo1f: ugsma5 ",-1,ugsma5,1)
- fiumb4 = l1zvxx(1)
- zl11l0 = dsqrt(fiumb4)
- if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23552
- wlkaa3 = dlog(fiumb4)
-23552 continue
- qik6ym = l1zvxx(2)
- jftq1 = l1zvxx(3)
- elq2cs = 0.0d0
- oht3ga = 0
- gqxvz8 = 1
- call qh4ulb(zqve1l, vvl1li, cqui1v)
- i5uvkm = cqui1v * (cqui1v+1) / 2
- call u16zxj(hft28, ur73jo, nfiumb4, cqui1v, zvxw1l, q121lc,
- &vi231l, zxiwf1, i5uvkm, zqve1l, vvl1li, oju3yh, p1, h3mrfq)
- call dblepr("cqo1f: q121lc()",-1,q121lc,nfiumb4)
- call dblepr("cqo1f: ur73jo(,)",-1,ur73jo,vi231l*zxiwf1)
- call dblepr("cqo1f: w8xfic(,1)",-1,w8xfic(1,1),nfiumb4)
- do 23554 lir0o1=1,aqk377
- call intpr("cqo1f: lir0o1======================: ",-1,lir0o1,1)
-653 epx9jf = 1.0d0
- if(.not.(ugsma5 .eq. 0))goto 23556
- call intpr("cqo1f: calling nbq4ua ",-1,lir0o1,1)
- call nbq4ua(jmwo0z, go0l1q, l1zvxx, nfiumb4, lku8xq, aqk377,
- &zvxw1l, lir0o1, w8xfic, foej1u)
- goto 23557
-23556 continue
- if(.not.(ugsma5 .eq. 2))goto 23558
- call intpr("cqo1f: calling pjw1l; dyt0pg== ",-1,dyt0pg,1)
- call pjw1l(ur73jo, lq8reh(1+(lir0o1-1)*zxiwf1), go0l1q, nfiumb4,
- &lku8xq, vi231l, zxiwf1, dyt0pg, lir0o1, zvxw1l, h3mrfq, q121lc)
-23558 continue
-23557 continue
- call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
- &lir0o1)
- if(.not.(ugsma5 .eq. 2))goto 23560
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, hq710, lir0o1, fiumb4, wlkaa3, uxzze7)
- goto 23561
-23560 continue
- hq710 = -1.0d0
-23561 continue
- do 23562 ucgi1r=1,pga6nul
- call intpr("ucgi1r: ",-1,ucgi1r,1)
- call intpr("posn 7: ",-1,uxzze7,1)
- call intpr("zvxw1l: ",-1,zvxw1l,1)
- call dblepr("hq710",-1,hq710,1)
- call kqsxz1(jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph, jrxg6l,
- & jftq1, fiumb4, zl11l0, nfiumb4, lku8xq, aqk377, vi231l, zkjqhi,
- &lir0o1, zvxw1l, gqxvz8, h3mrfq, q121lc)
- call dblepr("cqo1f: go0l1q",-1,go0l1q,lku8xq*nfiumb4)
- call dblepr("cqo1f: jrxg6l",-1,jrxg6l,zkjqhi*nfiumb4)
- call dblepr("cqo1f: hr83e",-1,hr83e,nfiumb4*lku8xq)
- call dblepr("cqo1f: lj4dph",-1,lj4dph,nfiumb4*lku8xq)
- do 23564 nd6mep=1,zxiwf1
- do 23566 w3gohz=1,vi231l
- ioqzvb(w3gohz,nd6mep) = ur73jo(w3gohz,nd6mep)
-23566 continue
-23564 continue
- call intpr("posn 3: ",-1,uxzze7,1)
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23568
- do 23570 nd6mep=1,zxiwf1
- do 23572 w3gohz=1,nfiumb4
- ioqzvb(2*w3gohz-1,nd6mep) = jrxg6l(2*lir0o1-1,w3gohz) * ioqzvb(2*
- &w3gohz-1,nd6mep)
- ioqzvb(2*w3gohz ,nd6mep) = jrxg6l(2*lir0o1 ,w3gohz) * ioqzvb(2*
- &w3gohz ,nd6mep)
-23572 continue
-23570 continue
- goto 23569
-23568 continue
- do 23574 nd6mep=1,zxiwf1
- do 23576 w3gohz=1,nfiumb4
- ioqzvb(w3gohz,nd6mep) = jrxg6l(lir0o1,w3gohz) * ioqzvb(w3gohz,
- &nd6mep)
-23576 continue
-23574 continue
-23569 continue
- call intpr("posn 4: ",-1,uxzze7,1)
- do 23578 nd6mep=1,zxiwf1
- i83h1(nd6mep) = nd6mep
-23578 continue
- call dblepr("cqo1f: ioqzvb",-1,ioqzvb,vi231l*zxiwf1)
- call intpr("ucgi1r: ",-1,ucgi1r,1)
- t7sbea = 1.0d-7
- call dhkt9w(ioqzvb,vi231l,vi231l,zxiwf1,i0qvzl,i83h1,t5vlzq,
- &zx1610,t7sbea)
- call intpr("i83h1: ",-1,i83h1,zxiwf1)
- if(.not.(zx1610 .ne. zxiwf1))goto 23580
- gqxvz8 = 2
- return
-23580 continue
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23582
- do 23584 w3gohz=1,nfiumb4
- t5vlzq(2*w3gohz-1,1) = jrxg6l(2*lir0o1-1,w3gohz) * hr83e(w3gohz,2*
- &lir0o1-1)
- t5vlzq(2*w3gohz ,1) = jrxg6l(2*lir0o1 ,w3gohz) * hr83e(w3gohz,2*
- &lir0o1 )
-23584 continue
- goto 23583
-23582 continue
- do 23586 w3gohz=1,nfiumb4
- t5vlzq(w3gohz,1) = jrxg6l(lir0o1,w3gohz) * hr83e(w3gohz,lir0o1)
-23586 continue
-23583 continue
- call intpr("posn 5: ",-1,uxzze7,1)
- tvyd2b = 101
- call intpr("posn 6: ",-1,uxzze7,1)
- call vdqrsl(ioqzvb,vi231l,vi231l,zx1610,i0qvzl, t5vlzq(1,1),
- &elq2cs, t5vlzq(1,2), lq8reh(1+(lir0o1-1)*zxiwf1), elq2cs,t5vlzq(1,
- &3),tvyd2b,fjg0qv)
- call dblepr("lq8reh(1+(lir0o1-1)*zxiwf1)",-1,lq8reh(1+(lir0o1-1)*
- &zxiwf1),zxiwf1)
- if(.not.(uvnk0i .gt. 1))goto 23588
-23588 continue
- do 23590 nd6mep=1,zxiwf1
- t5vlzq(nd6mep,1) = lq8reh((lir0o1-1)*zxiwf1 + nd6mep)
-23590 continue
- do 23592 nd6mep=1,zxiwf1
- lq8reh((lir0o1-1)*zxiwf1 + i83h1(nd6mep)) = t5vlzq(nd6mep,1)
-23592 continue
- call intpr("posn 7: ",-1,uxzze7,1)
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23594
- do 23596 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz) = t5vlzq(2*w3gohz-1,3) / jrxg6l(2*
- &lir0o1-1,w3gohz)
- go0l1q(2*lir0o1 ,w3gohz) = t5vlzq(2*w3gohz ,3) / jrxg6l(2*lir0o1 ,
- &w3gohz)
-23596 continue
- if(.not.(h3mrfq .eq. 1))goto 23598
- do 23600 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz) = go0l1q(2*lir0o1-1,w3gohz) + q121lc(
- &w3gohz)
-23600 continue
-23598 continue
- goto 23595
-23594 continue
- do 23602 w3gohz=1,nfiumb4
- go0l1q(lir0o1,w3gohz) = t5vlzq(w3gohz,3) / jrxg6l(lir0o1,w3gohz)
-23602 continue
- if(.not.(h3mrfq .eq. 1))goto 23604
- do 23606 w3gohz=1,nfiumb4
- go0l1q(lir0o1,w3gohz) = go0l1q(lir0o1,w3gohz) + q121lc(w3gohz)
-23606 continue
-23604 continue
-23595 continue
- call intpr("posn 8: ",-1,uxzze7,1)
- call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
- &lir0o1)
- call intpr("posn 8b: ",-1,uxzze7,1)
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, nx1bat,lir0o1,fiumb4,wlkaa3,uxzze7)
- call intpr("posn 8c: ",-1,uxzze7,1)
- xmr7cj = dabs(nx1bat - hq710) / (1.0d0 + dabs(nx1bat))
- call intpr("cqo1f: ucgi1r -------------",-1,ucgi1r,1)
- call dblepr("cqo1f: xmr7cj",-1,xmr7cj,1)
- if(.not.(xmr7cj .lt. qik6ym))goto 23608
- gqxvz8 = 0
- p1i8xz(8)=ucgi1r
- call intpr("cqo1f p1i8xz(8): ",-1,p1i8xz(8),1)
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23610
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, nx1bat,lir0o1,fiumb4,wlkaa3, oht3ga)
-23610 continue
- ni1qfp = ni1qfp + nx1bat
- goto 1011
- goto 23609
-23608 continue
- hq710 = nx1bat
-23609 continue
- call intpr("posn 9: ",-1,uxzze7,1)
-23562 continue
- call intpr("cqo1f; unsuccessful convergence: ",-1,uxzze7,1)
- if(.not.(ugsma5 .eq. 1))goto 23612
- ugsma5 = 0
- p1i8xz(9) = 1
- goto 653
-23612 continue
- gqxvz8 = 3
-1011 epx9jf = 1.0d0
-23554 continue
- call intpr(
- &"exiting cqo1f uxzze7 ============================ : ",-1,uxzze7,
- &1)
- nx1bat = ni1qfp
- return
- end
- subroutine vcao6f(hft28, jmwo0z, w8xfic, go0l1q, w5poyv, hr83e,
- &lj4dph, jrxg6l, ioqzvb, i0qvzl, i83h1, nfiumb4, lku8xq, aqk377,
- &vi231l, zkjqhi, gqxvz8, p1i8xz, nx1bat, lq8reh, t5vlzq, zxao0o,
- &l1zvxx, gqai81,h2mzlo, sq5cvf, ynk9ah, uxs1iq, vliac4, vfd2pw,
- &sazp9g,s0, zrcbl2, nyg3mt, e6tljz, ifo4ew, ozuw3p, hwi2tb, nbd5rl,
- & wj5shg, ykdc2t, wk2, wzxao0o, phqco4, vb81l0, bmb, rjcq9o, mwk,
- &n1zwoi, j1l0o1, qc7zyb, vlni8d, jko0o1, mnh3up, fg3pxq)
- implicit logical (a-z)
- integer p1i8xz(19)
- integer nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, i83h1(1)
- double precision hft28(nfiumb4,1), jmwo0z(nfiumb4,aqk377), w8xfic(
- &nfiumb4,1), go0l1q(lku8xq,nfiumb4), w5poyv(aqk377,nfiumb4)
- double precision hr83e(nfiumb4,lku8xq), lj4dph(nfiumb4,lku8xq),
- &jrxg6l(zkjqhi,nfiumb4)
- double precision ioqzvb(vi231l,2), i0qvzl(1), nx1bat, lq8reh(1),
- &l1zvxx(6)
- double precision t5vlzq(vi231l,3), zxao0o(lku8xq*(lku8xq+1))
- integer lir0o1, sglfr1, oht3ga, ucgi1r, cqui1v, xhe4cg, ugsma5,
- &zvxw1l, pga6nul
- integer dyt0pg, uvnk0i, zxiwf1
- integer uxzze7, c3qxjo
- double precision hq710, fiumb4, xmr7cj, elq2cs, qik6ym, zl11l0,
- &wlkaa3, jftq1
- double precision ni1qfp, epx9jf
- integer gqai81(15), h2mzlo, ynk9ah(1),uxs1iq(1),vliac4(1), ozuw3p(
- &1), hwi2tb(3), nbd5rl(1), wj5shg(1)
- integer foej1u, jko0o1(1), mnh3up(1), fg3pxq(2), vlni8d(2)
- double precision sq5cvf(aqk377)
- double precision vfd2pw(h2mzlo,nfiumb4), sazp9g(nfiumb4,1),s0(
- &lku8xq), zrcbl2(h2mzlo,nfiumb4), nyg3mt(h2mzlo,nfiumb4), e6tljz(
- &nfiumb4,2), ifo4ew(h2mzlo,1), ykdc2t(1), wk2(nfiumb4,h2mzlo),
- &phqco4(1), vb81l0(1), bmb(1), rjcq9o(1), mwk(1), j1l0o1(1),
- &qc7zyb(1)
- integer ymetu2
- integer w3gohz, myx3od, ibd3vc
- integer d8gwha, tiav4e
- double precision purf2k(2), x1boaf, ad3xzo, j6gbnx, rk3jet
- double precision h4fgoy, das4bx
- double precision q121lc(2)
- x1boaf=0.0d0
- ad3xzo=0.0d0
- j6gbnx=0.0d0
- rk3jet=0.0d0
- d8gwha = p1i8xz(19)
- ni1qfp = 0.0d0
- uxzze7 = 1
- zxao0o(1) = 1.0d0
- t5vlzq(1,1) = 1.0d0
- cqui1v = p1i8xz(1)
- zxiwf1 = p1i8xz(3)
- xhe4cg = p1i8xz(4)
- ugsma5 = p1i8xz(5)
- zvxw1l = p1i8xz(6)
- pga6nul = p1i8xz(7)
- p1i8xz(9) = 0
- tiav4e = p1i8xz(11)
- dyt0pg = p1i8xz(12)
- if(.not.((dyt0pg .ne. 1) .or. (tiav4e .ne. cqui1v)))goto 23614
- gqxvz8 = 4
- return
-23614 continue
- uvnk0i = p1i8xz(15)
- foej1u = p1i8xz(18)
- h4fgoy = l1zvxx(3+aqk377+aqk377+2)
- fiumb4 = l1zvxx(1)
- zl11l0 = dsqrt(fiumb4)
- if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23616
- wlkaa3 = dlog(fiumb4)
-23616 continue
- qik6ym = l1zvxx(2)
- jftq1 = l1zvxx(3)
- elq2cs = 0.0d0
- oht3ga = 0
- gqxvz8 = 1
- do 23618 lir0o1=1,aqk377
-653 epx9jf = 1.0d0
- if(.not.(ugsma5 .eq. 0))goto 23620
- call nbq4ua(jmwo0z, go0l1q, l1zvxx, nfiumb4, lku8xq, aqk377,
- &zvxw1l, lir0o1, w8xfic, foej1u)
- goto 23621
-23620 continue
- if(.not.(ugsma5 .ne. 1))goto 23622
- gqxvz8 = 6
- return
-23622 continue
-23621 continue
- call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
- &lir0o1)
- if(.not.(ugsma5 .eq. 2))goto 23624
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, hq710, lir0o1, fiumb4, wlkaa3, uxzze7)
- goto 23625
-23624 continue
- hq710 = -1.0d0
-23625 continue
- do 23626 ucgi1r=1,pga6nul
- call sptoq8(hft28, ioqzvb, nfiumb4, vi231l, cqui1v, zvxw1l)
- gqai81(7) = 0
- call kqsxz1(jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph, jrxg6l,
- & jftq1, fiumb4, zl11l0, nfiumb4, lku8xq, aqk377, vi231l, zkjqhi,
- &lir0o1, zvxw1l, gqxvz8, oht3ga, q121lc)
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23628
- ymetu2 = 2*lir0o1-1
- goto 23629
-23628 continue
- ymetu2 = lir0o1
-23629 continue
- do 23630 myx3od=1,h2mzlo
- do 23632 w3gohz=1,nfiumb4
- zrcbl2(myx3od,w3gohz) = jrxg6l(ymetu2-1+myx3od,w3gohz)
- nyg3mt(myx3od,w3gohz) = go0l1q(ymetu2-1+myx3od,w3gohz)
-23632 continue
-23630 continue
- c3qxjo = tiav4e * aqk377
- sglfr1 = cqui1v * (lir0o1-1)
- if(.not.(ucgi1r .eq. 1))goto 23634
- x1boaf = sq5cvf( sglfr1 + hwi2tb(1))
- ad3xzo = sq5cvf(c3qxjo + sglfr1 + hwi2tb(1))
- if(.not.(cqui1v .eq. 2))goto 23636
- j6gbnx = sq5cvf( sglfr1 + hwi2tb(2))
- rk3jet = sq5cvf(c3qxjo + sglfr1 + hwi2tb(2))
-23636 continue
- do 23638 myx3od=1,tiav4e
- do 23640 w3gohz=1,nfiumb4
- sazp9g(w3gohz,sglfr1 + hwi2tb(myx3od)) = 0.0d0
-23640 continue
-23638 continue
- goto 23635
-23634 continue
- sq5cvf( sglfr1 + hwi2tb(1)) = x1boaf
- sq5cvf(c3qxjo + sglfr1 + hwi2tb(1)) = ad3xzo
- if(.not.(cqui1v .eq. 2))goto 23642
- sq5cvf( sglfr1 + hwi2tb(2)) = j6gbnx
- sq5cvf(c3qxjo + sglfr1 + hwi2tb(2)) = rk3jet
-23642 continue
-23635 continue
- call vbfa(d8gwha,nfiumb4,h2mzlo,gqai81, e6tljz, hr83e(1,ymetu2),
- &lj4dph(1,ymetu2), sq5cvf( sglfr1 + hwi2tb(1)), sq5cvf(c3qxjo +
- &sglfr1 + hwi2tb(1)), ynk9ah,uxs1iq,vliac4, vfd2pw,sazp9g(1,sglfr1
- &+ hwi2tb(1)), nyg3mt,s0, lq8reh(1+(lir0o1-1)*zxiwf1), zo5jyl,
- &h4fgoy, ioqzvb,i0qvzl, i83h1, purf2k, zrcbl2, ifo4ew, ozuw3p,
- &hwi2tb, nbd5rl, wj5shg, ykdc2t, wk2, wzxao0o, phqco4, vb81l0, bmb,
- & rjcq9o, mwk, n1zwoi, j1l0o1(1+(lir0o1-1)*(vlni8d(1+cqui1v)-1)),
- &qc7zyb, das4bx, vlni8d, jko0o1, mnh3up, fg3pxq)
- l1zvxx(3+aqk377+aqk377+1) = das4bx
- ibd3vc = gqai81(14)
- if(.not.(ibd3vc .ne. 0))goto 23644
- call intpr("vcao6f: exiting because of an error",-1,ibd3vc,1)
- gqxvz8 = 8
- return
-23644 continue
- do 23646 myx3od=1,h2mzlo
- do 23648 w3gohz=1,nfiumb4
- go0l1q(ymetu2-1+myx3od,w3gohz) = nyg3mt(myx3od,w3gohz)
-23648 continue
-23646 continue
- call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
- &lir0o1)
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, nx1bat, lir0o1, fiumb4, wlkaa3, uxzze7)
- xmr7cj = dabs(nx1bat - hq710) / (1.0d0 + dabs(nx1bat))
- if(.not.(xmr7cj .lt. qik6ym))goto 23650
- gqxvz8 = 0
- p1i8xz(8) = ucgi1r
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23652
- call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
- &aqk377, xhe4cg, go0l1q, nx1bat,lir0o1,fiumb4,wlkaa3, oht3ga)
-23652 continue
- ni1qfp = ni1qfp + nx1bat
- goto 1011
- goto 23651
-23650 continue
- hq710 = nx1bat
-23651 continue
-23626 continue
- if(.not.(ugsma5 .eq. 1))goto 23654
- ugsma5 = 0
- p1i8xz(9) = 1
- goto 653
-23654 continue
- gqxvz8 = 3
-1011 epx9jf = 1.0d0
-23618 continue
- nx1bat = ni1qfp
- return
- end
- subroutine dcqof(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc,
- &w5poyv, hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1,
- &nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l,
- &vvl1li, nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx, ize5km, ip0ox8,
- &v8gzsp, p2, xt3fko, o4xmfj, zclbn2)
- implicit logical (a-z)
- integer p1i8xz(19), zqve1l(1), vvl1li(1)
- integer nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, i83h1(1)
- integer dyt0pg
- double precision hft28(nfiumb4,1), jmwo0z(nfiumb4,aqk377), oju3yh(
- &nfiumb4,9), w8xfic(nfiumb4,1), go0l1q(lku8xq,nfiumb4), q121lc(
- &nfiumb4), w5poyv(aqk377,nfiumb4), hr83e(nfiumb4,lku8xq), lj4dph(
- &nfiumb4,lku8xq), jrxg6l(zkjqhi,nfiumb4), ur73jo(vi231l,1)
- double precision ioqzvb(vi231l,1), i0qvzl(1), nx1bat, lq8reh(1),
- &l1zvxx(4)
- double precision t5vlzq(lku8xq,nfiumb4,2), zxao0o(lku8xq*(lku8xq+
- &1))
- integer p2
- double precision ize5km(nfiumb4,p2), ip0ox8(nfiumb4,1), v8gzsp(p2,
- &1), xt3fko(p2,1), o4xmfj, zclbn2(1)
- integer w3gohz, s9otpy, pvnfr4, cqui1v, fiy4lc, nd6mep, z2q1li,
- &foej1u
- double precision wrbc3q, gibj6t
- cqui1v = p1i8xz(1)
- fiy4lc = p1i8xz(5)
- dyt0pg = p1i8xz(12)
- z2q1li = p1i8xz(13)
- foej1u = p1i8xz(18)
- do 23656 pvnfr4=1,cqui1v
- do 23658 w3gohz=1,nfiumb4
- wrbc3q = 0.0d0
- do 23660 s9otpy=1,p2
- wrbc3q = wrbc3q + ize5km(w3gohz,s9otpy) * v8gzsp(s9otpy,pvnfr4)
-23660 continue
- ip0ox8(w3gohz,pvnfr4) = wrbc3q
- hft28(w3gohz,pvnfr4) = wrbc3q
-23658 continue
-23656 continue
- if(.not.(dyt0pg.eq.1))goto 23662
- call cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
- &hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
- &lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
- &gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx)
- goto 23663
-23662 continue
- call cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
- &hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
- &lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
- &gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx)
-23663 continue
- do 23664 s9otpy=1,p2
- do 23666 w3gohz=1,nfiumb4
- ize5km(w3gohz,s9otpy) = o4xmfj * ize5km(w3gohz,s9otpy)
-23666 continue
-23664 continue
- do 23668 pvnfr4=1,cqui1v
- do 23670 s9otpy=1,p2
- do 23672 w3gohz=1,nfiumb4
- hft28(w3gohz,pvnfr4)=ip0ox8(w3gohz,pvnfr4)+ize5km(w3gohz,s9otpy)
-23672 continue
- p1i8xz(5) = 2
- do 23674 nd6mep=1,z2q1li
- lq8reh(nd6mep) = zclbn2(nd6mep)
-23674 continue
- if(.not.(dyt0pg.eq.1))goto 23676
- call cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
- &hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
- &lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
- &nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
- goto 23677
-23676 continue
- call cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
- &hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
- &lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
- &nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
-23677 continue
- if(.not.(gqxvz8 .ne. 0))goto 23678
- return
-23678 continue
- xt3fko(s9otpy,pvnfr4) = (nx1bat - gibj6t) / o4xmfj
-23670 continue
- if(.not.(cqui1v .gt. 1))goto 23680
- do 23682 w3gohz=1,nfiumb4
- hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4)
-23682 continue
-23680 continue
-23668 continue
- p1i8xz(5) = fiy4lc
- return
- end
- subroutine vdcaof(hft28, jmwo0z, w8xfic, go0l1q, w5poyv, hr83e,
- &lj4dph, jrxg6l, ioqzvb, i0qvzl, i83h1, nfiumb4, lku8xq, aqk377,
- &vi231l, zkjqhi, gqxvz8, p1i8xz, nx1bat, lq8reh, t5vlzq, zxao0o,
- &l1zvxx, ize5km, ip0ox8, v8gzsp, p2, xt3fko, zclbn2, gqai81,h2mzlo,
- & sq5cvf, ynk9ah, uxs1iq, vliac4, vfd2pw,sazp9g,s0, zrcbl2, nyg3mt,
- & e6tljz, ifo4ew, ozuw3p, hwi2tb, nbd5rl, wj5shg, ykdc2t, wk2,
- &wzxao0o, phqco4, vb81l0, bmb, rjcq9o, mwk, n1zwoi, j1l0o1, qc7zyb,
- & vlni8d, jko0o1, mnh3up, fg3pxq)
- implicit logical (a-z)
- integer p1i8xz(19)
- integer nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, i83h1(1)
- integer dyt0pg
- double precision hft28(nfiumb4,1), jmwo0z(nfiumb4,aqk377), w8xfic(
- &nfiumb4,1), go0l1q(lku8xq,nfiumb4), w5poyv(aqk377,nfiumb4), hr83e(
- &nfiumb4,lku8xq), lj4dph(nfiumb4,lku8xq), jrxg6l(zkjqhi,nfiumb4)
- double precision ioqzvb(vi231l,1), i0qvzl(1), nx1bat, lq8reh(1),
- &l1zvxx(6)
- double precision t5vlzq(lku8xq,nfiumb4,2)
- double precision zxao0o(lku8xq*(lku8xq+1))
- integer p2
- double precision ize5km(nfiumb4,p2), ip0ox8(nfiumb4,1), v8gzsp(p2,
- &1), xt3fko(p2,1), o4xmfj, zclbn2(1)
- integer w3gohz, pp, pvnfr4, cqui1v, fiy4lc, z2q1li, foej1u
- double precision wrbc3q, gibj6t
- integer gqai81(15), h2mzlo, ynk9ah(1),uxs1iq(1),vliac4(1), ozuw3p(
- &1), hwi2tb(1), nbd5rl(1), wj5shg(1), vlni8d(2), jko0o1(1), mnh3up(
- &1), fg3pxq(2)
- double precision sq5cvf(aqk377)
- double precision vfd2pw(h2mzlo,nfiumb4), sazp9g(nfiumb4,1),s0(
- &lku8xq), zrcbl2(h2mzlo,nfiumb4)
- double precision nyg3mt(h2mzlo,nfiumb4), e6tljz(nfiumb4,1),
- &ifo4ew(h2mzlo,1), ykdc2t(1), wk2(nfiumb4,h2mzlo), phqco4(1),
- &vb81l0(1), bmb(1), rjcq9o(1), mwk(1), j1l0o1(1), qc7zyb(1),
- &das4bx
- integer d8gwha
- double precision h4fgoy
- das4bx = 0.0d0
- d8gwha = 0
- cqui1v = p1i8xz(1)
- fiy4lc = p1i8xz(5)
- dyt0pg = p1i8xz(12)
- z2q1li = p1i8xz(13)
- foej1u = p1i8xz(18)
- h4fgoy = l1zvxx(3+aqk377+aqk377+2)
- o4xmfj = l1zvxx(3+aqk377+aqk377+3)
- do 23684 pvnfr4=1,cqui1v
- do 23686 w3gohz=1,nfiumb4
- wrbc3q = 0.0d0
- do 23688 pp=1,p2
- wrbc3q = wrbc3q + ize5km(w3gohz,pp) * v8gzsp(pp,pvnfr4)
-23688 continue
- ip0ox8(w3gohz,pvnfr4) = wrbc3q
- hft28(w3gohz,pvnfr4) = wrbc3q
-23686 continue
-23684 continue
- if(.not.(dyt0pg.eq.1))goto 23690
- call vcao6f(hft28, jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph,
- &jrxg6l, ioqzvb, i0qvzl, i83h1, nfiumb4, lku8xq, aqk377, vi231l,
- &zkjqhi, gqxvz8, p1i8xz, gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx,
- &gqai81,h2mzlo, sq5cvf, ynk9ah, uxs1iq, vliac4, vfd2pw,sazp9g,s0,
- &zrcbl2, nyg3mt, e6tljz, ifo4ew, ozuw3p, hwi2tb, nbd5rl, wj5shg,
- &ykdc2t, wk2, wzxao0o, phqco4, vb81l0, bmb, rjcq9o, mwk, n1zwoi,
- &j1l0o1, qc7zyb, vlni8d, jko0o1, mnh3up, fg3pxq)
- l1zvxx(3+aqk377+aqk377+1) = das4bx
- goto 23691
-23690 continue
-23691 continue
- do 23692 pp=1,p2
- do 23694 w3gohz=1,nfiumb4
- ize5km(w3gohz,pp) = o4xmfj * ize5km(w3gohz,pp)
-23694 continue
-23692 continue
- do 23696 pvnfr4=1,cqui1v
- do 23698 pp=1,p2
- do 23700 w3gohz=1,nfiumb4
- hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4) + ize5km(w3gohz,pp)
-23700 continue
- p1i8xz(5) = 0
- if(.not.(dyt0pg.eq.1))goto 23702
- call vcao6f(hft28, jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph,
- &jrxg6l, ioqzvb, i0qvzl, i83h1, nfiumb4, lku8xq, aqk377, vi231l,
- &zkjqhi, gqxvz8, p1i8xz, nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx,
- &gqai81,h2mzlo, sq5cvf, ynk9ah, uxs1iq, vliac4, vfd2pw,sazp9g,s0,
- &zrcbl2, nyg3mt, e6tljz, ifo4ew, ozuw3p, hwi2tb, nbd5rl, wj5shg,
- &ykdc2t, wk2, wzxao0o, phqco4, vb81l0, bmb, rjcq9o, mwk, n1zwoi,
- &j1l0o1, qc7zyb, vlni8d, jko0o1, mnh3up, fg3pxq)
- l1zvxx(3+aqk377+aqk377+1) = das4bx
- goto 23703
-23702 continue
-23703 continue
- if(.not.(gqxvz8 .ne. 0))goto 23704
- return
-23704 continue
- xt3fko(pp,pvnfr4) = (nx1bat - gibj6t) / o4xmfj
-23698 continue
- if(.not.(cqui1v .gt. 1))goto 23706
- do 23708 w3gohz=1,nfiumb4
- hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4)
-23708 continue
-23706 continue
-23696 continue
- p1i8xz(5) = fiy4lc
- return
- end
- subroutine duqof(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc,
- &w5poyv, hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1,
- &nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l,
- &vvl1li, nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx, ip0ox8, xt3fko,
- &o4xmfj, zclbn2)
- implicit logical (a-z)
- integer p1i8xz(19), zqve1l(1), vvl1li(1)
- integer nfiumb4, lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, i83h1(1)
- integer dyt0pg
- double precision hft28(nfiumb4,1), jmwo0z(nfiumb4,aqk377), oju3yh(
- &nfiumb4,9), w8xfic(nfiumb4,1), go0l1q(lku8xq,nfiumb4), q121lc(
- &nfiumb4), w5poyv(aqk377,nfiumb4), hr83e(nfiumb4,lku8xq), lj4dph(
- &nfiumb4,lku8xq), jrxg6l(zkjqhi,nfiumb4), ur73jo(vi231l,1)
- double precision ioqzvb(vi231l,1), i0qvzl(1), nx1bat, lq8reh(1),
- &l1zvxx(4)
- double precision t5vlzq(lku8xq,nfiumb4,2), zxao0o(lku8xq*(lku8xq+
- &1))
- double precision ip0ox8(nfiumb4,1), xt3fko(nfiumb4,1), o4xmfj,
- &zclbn2(1)
- integer w3gohz, pvnfr4, cqui1v, fiy4lc, nd6mep, z2q1li
- double precision gibj6t
- cqui1v = p1i8xz(1)
- fiy4lc = p1i8xz(5)
- dyt0pg = p1i8xz(12)
- z2q1li = p1i8xz(13)
- if(.not.(dyt0pg.eq.1))goto 23710
- call cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
- &hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
- &lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
- &gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx)
- goto 23711
-23710 continue
- call cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
- &hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
- &lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
- &gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx)
-23711 continue
- do 23712 pvnfr4=1,cqui1v
- do 23714 w3gohz=1,nfiumb4
- hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4) + o4xmfj
- p1i8xz(5) = 2
- do 23716 nd6mep=1,z2q1li
- lq8reh(nd6mep) = zclbn2(nd6mep)
-23716 continue
- if(.not.(dyt0pg.eq.1))goto 23718
- call cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
- &hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
- &lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
- &nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
- goto 23719
-23718 continue
- call cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
- &hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
- &lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
- &nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
-23719 continue
- if(.not.(gqxvz8 .ne. 0))goto 23720
- return
-23720 continue
- xt3fko(w3gohz,pvnfr4) = (nx1bat - gibj6t) / o4xmfj
- hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4)
-23714 continue
-23712 continue
- p1i8xz(5) = fiy4lc
- return
- end
diff --git a/src/lms.f b/src/lms.f
index 1910f2e..5c0e908 100644
--- a/src/lms.f
+++ b/src/lms.f
@@ -1,195 +1,204 @@
- subroutine dpdlyjn(psi, dwgkz6, sfnva0, fpqrt7, g8jieq, ghry8z)
+ subroutine dpdlyjn(psi, i9mwnvqt, mymu, sigma, kpzavbj3ative,
+ &lfu2qhid)
implicit logical (a-z)
- integer g8jieq
- double precision psi, dwgkz6, sfnva0, fpqrt7, ghry8z(3)
- integer uxzze7, oht3ga
- double precision aa, bb, ig5cma, fiumb4
+ integer kpzavbj3ative
+ double precision psi, i9mwnvqt, mymu, sigma, lfu2qhid(3)
+ integer hbsl0gto, izero0
+ double precision aa, bb, uqnkc6zg, n3iasxug
logical cc, pos
- uxzze7 = 1
- oht3ga = 0
- fiumb4 = 1.0d-04
- sfnva0 = 0.0d0
- fpqrt7 = 1.0d0
+ hbsl0gto = 1
+ izero0 = 0
+ n3iasxug = 1.0d-04
+ mymu = 0.0d0
+ sigma = 1.0d0
cc = (psi .ge. 0.0d0)
if(.not.(cc))goto 23000
- bb = dwgkz6
- pos = (dabs(dwgkz6) .le. fiumb4)
+ bb = i9mwnvqt
+ pos = (dabs(i9mwnvqt) .le. n3iasxug)
goto 23001
23000 continue
- bb = -2.0d0 + dwgkz6
- pos = (dabs(dwgkz6-2.0d0) .le. fiumb4)
+ bb = -2.0d0 + i9mwnvqt
+ pos = (dabs(i9mwnvqt-2.0d0) .le. n3iasxug)
23001 continue
aa = 1.0d0 + psi * bb
- if(.not.(g8jieq .ge. 0))goto 23002
+ if(.not.(kpzavbj3ative .ge. 0))goto 23002
if(.not.(pos))goto 23004
- ghry8z(1) = psi
+ lfu2qhid(1) = psi
goto 23005
23004 continue
- ghry8z(1) = aa / bb
+ lfu2qhid(1) = aa / bb
23005 continue
23002 continue
- if(.not.(g8jieq .ge. 1))goto 23006
+ if(.not.(kpzavbj3ative .ge. 1))goto 23006
if(.not.(pos))goto 23008
- ghry8z(2) = (ghry8z(1)**2) / 2
+ lfu2qhid(2) = (lfu2qhid(1)**2) / 2
goto 23009
23008 continue
- ig5cma = ghry8z(1)
- ghry8z(2) = (aa * (dlog(aa)/bb) - ig5cma) / bb
+ uqnkc6zg = lfu2qhid(1)
+ lfu2qhid(2) = (aa * (dlog(aa)/bb) - uqnkc6zg) / bb
23009 continue
23006 continue
- if(.not.(g8jieq .ge. 2))goto 23010
+ if(.not.(kpzavbj3ative .ge. 2))goto 23010
if(.not.(pos))goto 23012
- ghry8z(3) = (ghry8z(1)**3) / 3
+ lfu2qhid(3) = (lfu2qhid(1)**3) / 3
goto 23013
23012 continue
- ig5cma = ghry8z(2) * 2.0d0
- ghry8z(3) = (aa * (dlog(aa)/bb) ** 2 - ig5cma) / bb
+ uqnkc6zg = lfu2qhid(2) * 2.0d0
+ lfu2qhid(3) = (aa * (dlog(aa)/bb) ** 2 - uqnkc6zg) / bb
23013 continue
23010 continue
return
end
- subroutine gleg11(hr83e, dwgkz6, sfnva0, fpqrt7, uvf4mp, ws5jcg,
- &ghry8z)
+ subroutine gleg11(ghz9vuba, i9mwnvqt, mymu, sigma, kpzavbj3mat,
+ &lenkpzavbj3mat, lfu2qhid)
implicit logical (a-z)
- integer ws5jcg
- double precision hr83e, dwgkz6, sfnva0, fpqrt7, uvf4mp(4), ghry8z
- integer uxzze7, itwo2, ynmzp6
- double precision psi, hc0tub, xkwp2m(3), dq3rxy
- ynmzp6 = 3
+ integer lenkpzavbj3mat
+ double precision ghz9vuba, i9mwnvqt, mymu, sigma, kpzavbj3mat(4),
+ &lfu2qhid
+ integer hbsl0gto, itwo2, three3
+ double precision psi, pim12, o3jyipdf(3), two12
+ three3 = 3
itwo2 = 2
- uxzze7 = 1
- dq3rxy = 1.41421356237309515d0
- if(.not.(ws5jcg .gt. 0))goto 23014
- ghry8z = uvf4mp(4) * (uvf4mp(2)**2 + dq3rxy * fpqrt7 * hr83e *
- &uvf4mp(3))
+ hbsl0gto = 1
+ two12 = 1.41421356237309515d0
+ if(.not.(lenkpzavbj3mat .gt. 0))goto 23014
+ lfu2qhid = kpzavbj3mat(4) * (kpzavbj3mat(2)**2 + two12 * sigma *
+ &ghz9vuba * kpzavbj3mat(3))
goto 23015
23014 continue
- hc0tub = 0.564189583547756279d0
- psi = sfnva0 + dq3rxy * fpqrt7 * hr83e
- call dpdlyjn(psi, dwgkz6, sfnva0, fpqrt7, itwo2, xkwp2m)
- ghry8z = (dexp(-hr83e*hr83e) * hc0tub) * (xkwp2m(2)**2 + (psi -
- &sfnva0) * xkwp2m(3)) / fpqrt7**2
+ pim12 = 0.564189583547756279d0
+ psi = mymu + two12 * sigma * ghz9vuba
+ call dpdlyjn(psi, i9mwnvqt, mymu, sigma, itwo2, o3jyipdf)
+ lfu2qhid = (dexp(-ghz9vuba*ghz9vuba) * pim12) * (o3jyipdf(2)**2 +
+ &(psi - mymu) * o3jyipdf(3)) / sigma**2
23015 continue
return
end
- subroutine zuqx1p(hr83e, dwgkz6, sfnva0, fpqrt7, uvf4mp, ws5jcg,
- &ghry8z)
+ subroutine gleg12(ghz9vuba, i9mwnvqt, mymu, sigma, kpzavbj3mat,
+ &lenkpzavbj3mat, lfu2qhid)
implicit logical (a-z)
- integer ws5jcg
- double precision hr83e, dwgkz6, sfnva0, fpqrt7, uvf4mp(4), ghry8z
- integer uxzze7, itwo2
- double precision psi, hc0tub, mw6reg(2), dq3rxy
+ integer lenkpzavbj3mat
+ double precision ghz9vuba, i9mwnvqt, mymu, sigma, kpzavbj3mat(4),
+ &lfu2qhid
+ integer hbsl0gto, itwo2
+ double precision psi, pim12, tad5vhsu(2), two12
itwo2 = 2
- uxzze7 = 1
- if(.not.(ws5jcg .gt. 0))goto 23016
- ghry8z = uvf4mp(4) * (-uvf4mp(2))
+ hbsl0gto = 1
+ if(.not.(lenkpzavbj3mat .gt. 0))goto 23016
+ lfu2qhid = kpzavbj3mat(4) * (-kpzavbj3mat(2))
goto 23017
23016 continue
- hc0tub = 0.564189583547756279d0
- dq3rxy = 1.41421356237309515d0
- psi = sfnva0 + dq3rxy * fpqrt7 * hr83e
- call dpdlyjn(psi, dwgkz6, sfnva0, fpqrt7, uxzze7, mw6reg)
- ghry8z = (dexp(-hr83e*hr83e) * hc0tub) * (-mw6reg(2)) / fpqrt7**2
+ pim12 = 0.564189583547756279d0
+ two12 = 1.41421356237309515d0
+ psi = mymu + two12 * sigma * ghz9vuba
+ call dpdlyjn(psi, i9mwnvqt, mymu, sigma, hbsl0gto, tad5vhsu)
+ lfu2qhid = (dexp(-ghz9vuba*ghz9vuba) * pim12) * (-tad5vhsu(2)) /
+ &sigma**2
23017 continue
return
end
- subroutine gleg13(hr83e, dwgkz6, sfnva0, fpqrt7, uvf4mp, ws5jcg,
- &ghry8z)
+ subroutine gleg13(ghz9vuba, i9mwnvqt, mymu, sigma, kpzavbj3mat,
+ &lenkpzavbj3mat, lfu2qhid)
implicit logical (a-z)
- integer ws5jcg
- double precision hr83e, dwgkz6, sfnva0, fpqrt7, uvf4mp(4), ghry8z
- integer uxzze7, itwo2
- double precision psi, oaqng6, mw6reg(2), dq3rxy
+ integer lenkpzavbj3mat
+ double precision ghz9vuba, i9mwnvqt, mymu, sigma, kpzavbj3mat(4),
+ &lfu2qhid
+ integer hbsl0gto, itwo2
+ double precision psi, mtpim12, tad5vhsu(2), two12
itwo2 = 2
- uxzze7 = 1
- if(.not.(ws5jcg .gt. 0))goto 23018
- ghry8z = uvf4mp(4) * (-uvf4mp(2)) * dsqrt(8.0d0) * hr83e
+ hbsl0gto = 1
+ if(.not.(lenkpzavbj3mat .gt. 0))goto 23018
+ lfu2qhid = kpzavbj3mat(4) * (-kpzavbj3mat(2)) * dsqrt(8.0d0) *
+ &ghz9vuba
goto 23019
23018 continue
- oaqng6 = -1.12837916709551256d0
- dq3rxy = 1.41421356237309515d0
- psi = sfnva0 + dq3rxy * fpqrt7 * hr83e
- call dpdlyjn(psi, dwgkz6, sfnva0, fpqrt7, uxzze7, mw6reg)
- ghry8z = dexp(-hr83e*hr83e) * oaqng6 * mw6reg(2) * (psi - sfnva0)
- &/ fpqrt7**3
+ mtpim12 = -1.12837916709551256d0
+ two12 = 1.41421356237309515d0
+ psi = mymu + two12 * sigma * ghz9vuba
+ call dpdlyjn(psi, i9mwnvqt, mymu, sigma, hbsl0gto, tad5vhsu)
+ lfu2qhid = dexp(-ghz9vuba*ghz9vuba) * mtpim12 * tad5vhsu(2) * (
+ &psi - mymu) / sigma**3
23019 continue
return
end
- subroutine rnvz5t(r7zvis, bd8olv, wts, oqie8v, dwgkz6, sfnva0,
- &fpqrt7, kk, ghry8z, nepms8)
+ subroutine gint3(minx, maxx, wts, ahl0onwx, i9mwnvqt, mymu, sigma,
+ & kk, lfu2qhid, elemnt)
implicit logical (a-z)
- integer kk, nepms8
- double precision r7zvis, bd8olv, wts(kk), oqie8v(kk), ghry8z,
- &dwgkz6, sfnva0, fpqrt7
- integer nd6mep, ws5jcg
- double precision atx, tns0gf, dy3ljx, uvf4mp(4), byn1gh, k8ousd
- ws5jcg = 0
- byn1gh = 0.50d0 * (r7zvis + bd8olv)
- k8ousd = 0.50d0 * (bd8olv - r7zvis)
- tns0gf = 0.0d0
- if(.not.(nepms8 .eq. 1))goto 23020
- do 23022 nd6mep=1,kk
- atx = byn1gh + k8ousd * oqie8v(nd6mep)
- call gleg11(atx, dwgkz6, sfnva0, fpqrt7, uvf4mp, ws5jcg, dy3ljx)
- tns0gf = tns0gf + dy3ljx * wts(nd6mep)
+ integer kk, elemnt
+ double precision minx, maxx, wts(kk), ahl0onwx(kk), lfu2qhid,
+ &i9mwnvqt, mymu, sigma
+ integer gp1jxzuh, lenkpzavbj3mat
+ double precision atx, dint, tint, kpzavbj3mat(4), midpt, range12
+ lenkpzavbj3mat = 0
+ midpt = 0.50d0 * (minx + maxx)
+ range12 = 0.50d0 * (maxx - minx)
+ dint = 0.0d0
+ if(.not.(elemnt .eq. 1))goto 23020
+ do 23022 gp1jxzuh=1,kk
+ atx = midpt + range12 * ahl0onwx(gp1jxzuh)
+ call gleg11(atx, i9mwnvqt, mymu, sigma, kpzavbj3mat,
+ &lenkpzavbj3mat, tint)
+ dint = dint + tint * wts(gp1jxzuh)
23022 continue
goto 23021
23020 continue
- if(.not.(nepms8 .eq. 2))goto 23024
- do 23026 nd6mep=1,kk
- atx = byn1gh + k8ousd * oqie8v(nd6mep)
- call zuqx1p(atx, dwgkz6, sfnva0, fpqrt7, uvf4mp, ws5jcg, dy3ljx)
- tns0gf = tns0gf + dy3ljx * wts(nd6mep)
+ if(.not.(elemnt .eq. 2))goto 23024
+ do 23026 gp1jxzuh=1,kk
+ atx = midpt + range12 * ahl0onwx(gp1jxzuh)
+ call gleg12(atx, i9mwnvqt, mymu, sigma, kpzavbj3mat,
+ &lenkpzavbj3mat, tint)
+ dint = dint + tint * wts(gp1jxzuh)
23026 continue
goto 23025
23024 continue
- if(.not.(nepms8 .eq. 3))goto 23028
- do 23030 nd6mep=1,kk
- atx = byn1gh + k8ousd * oqie8v(nd6mep)
- call gleg13(atx, dwgkz6, sfnva0, fpqrt7, uvf4mp, ws5jcg, dy3ljx)
- tns0gf = tns0gf + dy3ljx * wts(nd6mep)
+ if(.not.(elemnt .eq. 3))goto 23028
+ do 23030 gp1jxzuh=1,kk
+ atx = midpt + range12 * ahl0onwx(gp1jxzuh)
+ call gleg13(atx, i9mwnvqt, mymu, sigma, kpzavbj3mat,
+ &lenkpzavbj3mat, tint)
+ dint = dint + tint * wts(gp1jxzuh)
23030 continue
23028 continue
23025 continue
23021 continue
- ghry8z = ghry8z + k8ousd * tns0gf
+ lfu2qhid = lfu2qhid + range12 * dint
return
end
- subroutine yjngintf(r7zvis, bd8olv, oqie8v, wts, nfiumb4, kk,
- &dwgkz6, sfnva0, fpqrt7, ghry8z, kqoy6w)
+ subroutine yjngintf(minx, maxx, ahl0onwx, wts, kuzxj1lo, kk,
+ &i9mwnvqt, mymu, sigma, lfu2qhid, qaltf0nz)
implicit logical (a-z)
- integer nfiumb4, kk
- double precision r7zvis(nfiumb4), bd8olv(nfiumb4), wts(kk),
- &oqie8v(kk), dwgkz6(nfiumb4), sfnva0(nfiumb4), fpqrt7(nfiumb4),
- &ghry8z(3,nfiumb4), kqoy6w
- integer w3gohz, p1rifj, nd6mep, o2yadh, btip7u, epx9jf, nepms8,
- &uxzze7, itwo2
- double precision mu4ygk, azgts7, xmr7cj
- uxzze7 = 1
+ integer kuzxj1lo, kk
+ double precision minx(kuzxj1lo), maxx(kuzxj1lo), wts(kk),
+ &ahl0onwx(kk), i9mwnvqt(kuzxj1lo), mymu(kuzxj1lo), sigma(kuzxj1lo),
+ & lfu2qhid(3,kuzxj1lo), qaltf0nz
+ integer ayfnwr1v, iii, gp1jxzuh, lencomp, ipzbcvw3, hmayv1xt,
+ &elemnt, hbsl0gto, itwo2
+ double precision xd4mybgj, j4qgxvlk, wiptsjx8
+ hbsl0gto = 1
itwo2 = 2
- o2yadh = 12
- do 23032 w3gohz = 1,nfiumb4
- do 23034 nepms8=1,3
- azgts7 = -10.0d0
- do 23036 p1rifj=2,o2yadh
- btip7u = 2 ** p1rifj
- mu4ygk = (bd8olv(w3gohz) - r7zvis(w3gohz)) / btip7u
- ghry8z(nepms8,w3gohz) = 0.0d0
- do 23038 nd6mep=1,btip7u
- call rnvz5t(r7zvis(w3gohz)+(nd6mep-1)*mu4ygk, r7zvis(w3gohz)+
- &nd6mep*mu4ygk, wts, oqie8v, dwgkz6(w3gohz), sfnva0(w3gohz),
- &fpqrt7(w3gohz), kk, ghry8z(nepms8,w3gohz), nepms8)
+ lencomp = 12
+ do 23032 ayfnwr1v = 1,kuzxj1lo
+ do 23034 elemnt=1,3
+ j4qgxvlk = -10.0d0
+ do 23036 iii=2,lencomp
+ ipzbcvw3 = 2 ** iii
+ xd4mybgj = (maxx(ayfnwr1v) - minx(ayfnwr1v)) / ipzbcvw3
+ lfu2qhid(elemnt,ayfnwr1v) = 0.0d0
+ do 23038 gp1jxzuh=1,ipzbcvw3
+ call gint3(minx(ayfnwr1v)+(gp1jxzuh-1)*xd4mybgj, minx(ayfnwr1v)+
+ &gp1jxzuh*xd4mybgj, wts, ahl0onwx, i9mwnvqt(ayfnwr1v), mymu(
+ &ayfnwr1v), sigma(ayfnwr1v), kk, lfu2qhid(elemnt,ayfnwr1v), elemnt)
23038 continue
- xmr7cj = dabs(ghry8z(nepms8,w3gohz) - azgts7) / (1.0d0 + dabs(
- &ghry8z(nepms8,w3gohz)))
- if(.not.(xmr7cj .lt. kqoy6w))goto 23040
+ wiptsjx8 = dabs(lfu2qhid(elemnt,ayfnwr1v) - j4qgxvlk) / (1.0d0 +
+ &dabs(lfu2qhid(elemnt,ayfnwr1v)))
+ if(.not.(wiptsjx8 .lt. qaltf0nz))goto 23040
goto 234
goto 23041
23040 continue
- azgts7 = ghry8z(nepms8,w3gohz)
+ j4qgxvlk = lfu2qhid(elemnt,ayfnwr1v)
23041 continue
23036 continue
-234 epx9jf = 0
+234 hmayv1xt = 0
23034 continue
23032 continue
return
diff --git a/src/rgam.f b/src/rgam.f
index daf9c94..e004e26 100644
--- a/src/rgam.f
+++ b/src/rgam.f
@@ -1,100 +1,105 @@
- subroutine nvhb7f(egoxa3,atqh0o,xs,ys,ws, nfiumb4,nk, knot,coef,
- &sz,rjcq9o, n9peut,l6xrjt,fpcb2n, sz6ohy, yc1ezl,hts1gp,mk2vyr,
- &thfyl1,la5dcf)
+ subroutine dnaoqj0l(penalt,pjb6wfoq,xs,ys,ws, kuzxj1lo,nk,
+ &ankcghz2,coef,sz,ifys6woa, qcpiaj7f,wbkq9zyi,parms, scrtch,
+ &gp0xjetb,l3zpbstu,e5knafcg,wep0oibc,fbd5yktj)
implicit logical (a-z)
- integer nfiumb4, nk, yc1ezl, hts1gp(3), mk2vyr, thfyl1, la5dcf
- double precision egoxa3, atqh0o, xs(nfiumb4), ys(nfiumb4), ws(
- &nfiumb4), knot(nk+4), coef(nk), sz(nfiumb4), rjcq9o(nfiumb4),
- &n9peut, l6xrjt, fpcb2n(3), sz6ohy(1)
- call gzmfi3(egoxa3,atqh0o,xs,ys,ws, nfiumb4,nk, knot,coef,sz,
- &rjcq9o, n9peut,hts1gp(1),l6xrjt,hts1gp(2), hts1gp(3), fpcb2n(1),
- &fpcb2n(2),fpcb2n(3), yc1ezl, sz6ohy(1), sz6ohy(nk+1),sz6ohy(2*nk+
- &1),sz6ohy(3*nk+1),sz6ohy(4*nk+1), sz6ohy(5*nk+1),sz6ohy(6*nk+1),
- &sz6ohy(7*nk+1),sz6ohy(8*nk+1), sz6ohy(9*nk+1),sz6ohy(9*nk+mk2vyr*
- &nk+1),sz6ohy(9*nk+2*mk2vyr*nk+1), mk2vyr,thfyl1,la5dcf)
+ integer kuzxj1lo, nk, gp0xjetb, l3zpbstu(3), e5knafcg, wep0oibc,
+ &fbd5yktj
+ double precision penalt, pjb6wfoq, xs(kuzxj1lo), ys(kuzxj1lo), ws(
+ &kuzxj1lo), ankcghz2(nk+4), coef(nk), sz(kuzxj1lo), ifys6woa(
+ &kuzxj1lo), qcpiaj7f, wbkq9zyi, parms(3), scrtch(1)
+ call hbzuprs6(penalt,pjb6wfoq,xs,ys,ws, kuzxj1lo,nk, ankcghz2,
+ &coef,sz,ifys6woa, qcpiaj7f,l3zpbstu(1),wbkq9zyi,l3zpbstu(2),
+ &l3zpbstu(3), parms(1),parms(2),parms(3), gp0xjetb, scrtch(1),
+ &scrtch(nk+1),scrtch(2*nk+1),scrtch(3*nk+1),scrtch(4*nk+1), scrtch(
+ &5*nk+1),scrtch(6*nk+1),scrtch(7*nk+1),scrtch(8*nk+1), scrtch(9*nk+
+ &1),scrtch(9*nk+e5knafcg*nk+1),scrtch(9*nk+2*e5knafcg*nk+1),
+ &e5knafcg,wep0oibc,fbd5yktj)
return
end
- subroutine gzmfi3(egoxa3,atqh0o,xs,ys,ws, nfiumb4,nk, knot,coef,
- &sz,rjcq9o, n9peut,rlhz2a,dwgkz6,ispar, pga6nu, lspar,uspar,fjo2dy,
- & yc1ezl, mheq6i, n7cuql,dvpc8x,hdv8br,cbg5ys, vf1jtn,eh6nly,
- &mvx9at,vbxpg4, rlep7v,lunah2,p2ip, mk2vyr,thfyl1,la5dcf)
+ subroutine hbzuprs6(penalt,pjb6wfoq,xs,ys,ws, kuzxj1lo,nk,
+ &ankcghz2,coef,sz,ifys6woa, qcpiaj7f,icrit,i9mwnvqt,ispar,
+ &c5aesxku, mynl7uaq,zustx4fw,tol, gp0xjetb, xwy, zvau2lct,f6lsuzax,
+ &fvh2rwtc,dcfir2no, xecbg0pf,z4grbpiq,d7glzhbj,v2eydbxs, buhyalv4,
+ &fulcp8wa,plj0trqx, e5knafcg,wep0oibc,fbd5yktj)
implicit logical (a-z)
- integer nfiumb4,nk, rlhz2a,ispar, yc1ezl, mk2vyr,thfyl1,la5dcf
- integer pga6nu
- double precision egoxa3,atqh0o,xs(nfiumb4),ys(nfiumb4),ws(nfiumb4)
- &, knot(nk+4), coef(nk),sz(nfiumb4),rjcq9o(nfiumb4), n9peut,dwgkz6,
- &lspar,uspar,fjo2dy, mheq6i(nk), n7cuql(nk),dvpc8x(nk),hdv8br(nk),
- &cbg5ys(nk), vf1jtn(nk),eh6nly(nk),mvx9at(nk),vbxpg4(nk), rlep7v(
- &mk2vyr,nk),lunah2(mk2vyr,nk),p2ip(thfyl1,nk)
- double precision t1,t2,dyb3po, a,b,c,d,e,kqoy6w,xm,p,q,r,fjo2dy1,
- &fjo2dy2,u,v,w, fu,fv,fw,fx,x, ax,bx
- integer w3gohz, vucgi1r
- double precision hz0fmy, epx9jf
- hz0fmy = 8.0d88
- epx9jf = 0.0d0
+ integer kuzxj1lo,nk, icrit,ispar, gp0xjetb, e5knafcg,wep0oibc,
+ &fbd5yktj
+ integer c5aesxku
+ double precision penalt,pjb6wfoq,xs(kuzxj1lo),ys(kuzxj1lo),ws(
+ &kuzxj1lo), ankcghz2(nk+4), coef(nk),sz(kuzxj1lo),ifys6woa(
+ &kuzxj1lo), qcpiaj7f,i9mwnvqt,mynl7uaq,zustx4fw,tol, xwy(nk),
+ &zvau2lct(nk),f6lsuzax(nk),fvh2rwtc(nk),dcfir2no(nk), xecbg0pf(nk),
+ &z4grbpiq(nk),d7glzhbj(nk),v2eydbxs(nk), buhyalv4(e5knafcg,nk),
+ &fulcp8wa(e5knafcg,nk),plj0trqx(wep0oibc,nk)
+ double precision t1,t2,ratio, a,b,c,d,e,qaltf0nz,xm,p,q,r,tol1,
+ &tol2,u,v,w, fu,fv,fw,fx,x, ax,bx
+ integer ayfnwr1v, viter
+ double precision yjpnro8d, hmayv1xt
+ yjpnro8d = 8.0d88
+ hmayv1xt = 0.0d0
d = 0.5d0
u = 0.5d0
- dyb3po = 0.5d0
- w3gohz = 1
-23000 if(.not.(w3gohz.le.nfiumb4))goto 23002
- if(.not.(ws(w3gohz).gt.0.0d0))goto 23003
- ws(w3gohz) = dsqrt(ws(w3gohz))
+ ratio = 0.5d0
+ ayfnwr1v = 1
+23000 if(.not.(ayfnwr1v.le.kuzxj1lo))goto 23002
+ if(.not.(ws(ayfnwr1v).gt.0.0d0))goto 23003
+ ws(ayfnwr1v) = dsqrt(ws(ayfnwr1v))
23003 continue
- w3gohz = w3gohz+1
+ ayfnwr1v = ayfnwr1v+1
goto 23000
23002 continue
- if(.not.(yc1ezl .eq. 0))goto 23005
- call poqy8c(vf1jtn,eh6nly,mvx9at,vbxpg4,knot,nk)
- call ak9vxi(xs,ys,ws,knot, nfiumb4,nk, mheq6i,n7cuql,dvpc8x,
- &hdv8br,cbg5ys)
+ if(.not.(gp0xjetb .eq. 0))goto 23005
+ call zosq7hub(xecbg0pf,z4grbpiq,d7glzhbj,v2eydbxs,ankcghz2,nk)
+ call gt9iulbf(xs,ys,ws,ankcghz2, kuzxj1lo,nk, xwy,zvau2lct,
+ &f6lsuzax,fvh2rwtc,dcfir2no)
t1 = 0.0d0
t2 = 0.0d0
- do 23007 w3gohz = 3,nk-3
- t1 = t1 + n7cuql(w3gohz)
+ do 23007 ayfnwr1v = 3,nk-3
+ t1 = t1 + zvau2lct(ayfnwr1v)
23007 continue
- do 23009 w3gohz = 3,nk-3
- t2 = t2 + vf1jtn(w3gohz)
+ do 23009 ayfnwr1v = 3,nk-3
+ t2 = t2 + xecbg0pf(ayfnwr1v)
23009 continue
- dyb3po = t1/t2
- yc1ezl = 1
+ ratio = t1/t2
+ gp0xjetb = 1
23005 continue
if(.not.(ispar .eq. 1))goto 23011
- call oipu6h(egoxa3,atqh0o,xs,ys,ws, nfiumb4,nk,rlhz2a, knot,coef,
- &sz,rjcq9o,n9peut, dwgkz6, mheq6i, n7cuql,dvpc8x,hdv8br,cbg5ys,
- &vf1jtn,eh6nly,mvx9at,vbxpg4, rlep7v,lunah2,p2ip,mk2vyr,thfyl1,
- &la5dcf)
+ call wmhctl9x(penalt,pjb6wfoq,xs,ys,ws, kuzxj1lo,nk,icrit,
+ &ankcghz2,coef,sz,ifys6woa,qcpiaj7f, i9mwnvqt, xwy, zvau2lct,
+ &f6lsuzax,fvh2rwtc,dcfir2no, xecbg0pf,z4grbpiq,d7glzhbj,v2eydbxs,
+ &buhyalv4,fulcp8wa,plj0trqx,e5knafcg,wep0oibc,fbd5yktj)
return
23011 continue
- ax = lspar
- bx = uspar
+ ax = mynl7uaq
+ bx = zustx4fw
c = 0.381966011250105097d0
- kqoy6w = 2.0d-5
- vucgi1r = 0
+ qaltf0nz = 2.0d-5
+ viter = 0
a = ax
b = bx
v = a + c*(b - a)
w = v
x = v
e = 0.0d0
- dwgkz6 = dyb3po * dexp((-2.0d0 + x*6.0d0) * dlog(16.0d0))
- call oipu6h(egoxa3,atqh0o,xs,ys,ws, nfiumb4,nk,rlhz2a, knot,coef,
- &sz,rjcq9o,n9peut, dwgkz6, mheq6i, n7cuql,dvpc8x,hdv8br,cbg5ys,
- &vf1jtn,eh6nly,mvx9at,vbxpg4, rlep7v,lunah2,p2ip,mk2vyr,thfyl1,
- &la5dcf)
- fx = n9peut
+ i9mwnvqt = ratio * dexp((-2.0d0 + x*6.0d0) * dlog(16.0d0))
+ call wmhctl9x(penalt,pjb6wfoq,xs,ys,ws, kuzxj1lo,nk,icrit,
+ &ankcghz2,coef,sz,ifys6woa,qcpiaj7f, i9mwnvqt, xwy, zvau2lct,
+ &f6lsuzax,fvh2rwtc,dcfir2no, xecbg0pf,z4grbpiq,d7glzhbj,v2eydbxs,
+ &buhyalv4,fulcp8wa,plj0trqx,e5knafcg,wep0oibc,fbd5yktj)
+ fx = qcpiaj7f
fv = fx
fw = fx
-23013 if(.not.(la5dcf .eq. 0))goto 23014
- vucgi1r = vucgi1r + 1
+23013 if(.not.(fbd5yktj .eq. 0))goto 23014
+ viter = viter + 1
xm = 0.5d0*(a + b)
- fjo2dy1 = kqoy6w*dabs(x) + fjo2dy/3.0d0
- fjo2dy2 = 2.0d0*fjo2dy1
- if(.not.((dabs(x - xm) .le. (fjo2dy2 - 0.5d0*(b - a))) .or.(
- &vucgi1r .gt. pga6nu)))goto 23015
+ tol1 = qaltf0nz*dabs(x) + tol/3.0d0
+ tol2 = 2.0d0*tol1
+ if(.not.((dabs(x - xm) .le. (tol2 - 0.5d0*(b - a))) .or.(viter
+ &.gt. c5aesxku)))goto 23015
go to 90
23015 continue
- if(.not.((dabs(e) .le. fjo2dy1) .or.(fx .ge. hz0fmy) .or.(fv .ge.
- &hz0fmy) .or.(fw .ge. hz0fmy)))goto 23017
+ if(.not.((dabs(e) .le. tol1) .or.(fx .ge. yjpnro8d) .or.(fv .ge.
+ &yjpnro8d) .or.(fw .ge. yjpnro8d)))goto 23017
go to 40
23017 continue
r = (x - w)*(fx - fv)
@@ -116,11 +121,11 @@
23023 continue
d = p/q
u = x + d
- if(.not.((u - a) .lt. fjo2dy2))goto 23025
- d = dsign(fjo2dy1, xm - x)
+ if(.not.((u - a) .lt. tol2))goto 23025
+ d = dsign(tol1, xm - x)
23025 continue
- if(.not.((b - u) .lt. fjo2dy2))goto 23027
- d = dsign(fjo2dy1, xm - x)
+ if(.not.((b - u) .lt. tol2))goto 23027
+ d = dsign(tol1, xm - x)
23027 continue
go to 50
40 if(.not.(x .ge. xm))goto 23029
@@ -130,20 +135,20 @@
e = b - x
23030 continue
d = c*e
-50 if(.not.(dabs(d) .ge. fjo2dy1))goto 23031
+50 if(.not.(dabs(d) .ge. tol1))goto 23031
u = x + d
goto 23032
23031 continue
- u = x + dsign(fjo2dy1, d)
+ u = x + dsign(tol1, d)
23032 continue
- dwgkz6 = dyb3po * dexp((-2.0d0 + u*6.0) * dlog(16.0d0))
- call oipu6h(egoxa3,atqh0o,xs,ys,ws, nfiumb4,nk,rlhz2a, knot,coef,
- &sz,rjcq9o,n9peut, dwgkz6, mheq6i, n7cuql,dvpc8x,hdv8br,cbg5ys,
- &vf1jtn,eh6nly,mvx9at,vbxpg4, rlep7v,lunah2,p2ip,mk2vyr,thfyl1,
- &la5dcf)
- fu = n9peut
- if(.not.(fu .gt. hz0fmy))goto 23033
- fu = 2.0d0 * hz0fmy
+ i9mwnvqt = ratio * dexp((-2.0d0 + u*6.0) * dlog(16.0d0))
+ call wmhctl9x(penalt,pjb6wfoq,xs,ys,ws, kuzxj1lo,nk,icrit,
+ &ankcghz2,coef,sz,ifys6woa,qcpiaj7f, i9mwnvqt, xwy, zvau2lct,
+ &f6lsuzax,fvh2rwtc,dcfir2no, xecbg0pf,z4grbpiq,d7glzhbj,v2eydbxs,
+ &buhyalv4,fulcp8wa,plj0trqx,e5knafcg,wep0oibc,fbd5yktj)
+ fu = qcpiaj7f
+ if(.not.(fu .gt. yjpnro8d))goto 23033
+ fu = 2.0d0 * yjpnro8d
23033 continue
if(.not.(fu .le. fx))goto 23035
if(.not.(u .ge. x))goto 23037
@@ -181,117 +186,118 @@
23036 continue
goto 23013
23014 continue
-90 epx9jf = 0.0d0
- dwgkz6 = dyb3po * dexp((-2.0d0 + x*6.0d0) * dlog(16.0d0))
- n9peut = fx
+90 hmayv1xt = 0.0d0
+ i9mwnvqt = ratio * dexp((-2.0d0 + x*6.0d0) * dlog(16.0d0))
+ qcpiaj7f = fx
return
return
end
- subroutine poqy8c(vf1jtn,eh6nly,mvx9at,vbxpg4,tb,nb)
+ subroutine zosq7hub(xecbg0pf,z4grbpiq,d7glzhbj,v2eydbxs,tb,nb)
implicit logical (a-z)
integer nb
- double precision vf1jtn(nb),eh6nly(nb),mvx9at(nb),vbxpg4(nb),tb(
- &nb+4)
- integer m5xudf,ilo,i6ndbu, ynmzp6, def4wn, nbp1
- integer w3gohz,p1rifj,d9rjek
- integer tlpr2hal
- double precision uq9jtc(4,3),bgu6fw(16),avoe4y(4),yw2(4), wpt
- double precision uoqx2m
- uoqx2m = 1.0d0 / 3.0d0
- ynmzp6 = 3
- def4wn = 4
+ double precision xecbg0pf(nb),z4grbpiq(nb),d7glzhbj(nb),v2eydbxs(
+ &nb),tb(nb+4)
+ integer dqlr5bse,ilo,pqzfxw4i, three3, ifour4, nbp1
+ integer ayfnwr1v,iii,yq6lorbx
+ integer i2svdbx3tk
+ double precision g9fvdrbw(4,3),work(16),yw1(4),yw2(4), wpt
+ double precision othird
+ othird = 1.0d0 / 3.0d0
+ three3 = 3
+ ifour4 = 4
nbp1 = nb + 1
- do 23045 w3gohz = 1,nb
- vf1jtn(w3gohz) = 0.0d0
- eh6nly(w3gohz) = 0.0d0
- mvx9at(w3gohz) = 0.0d0
- vbxpg4(w3gohz) = 0.0d0
+ do 23045 ayfnwr1v = 1,nb
+ xecbg0pf(ayfnwr1v) = 0.0d0
+ z4grbpiq(ayfnwr1v) = 0.0d0
+ d7glzhbj(ayfnwr1v) = 0.0d0
+ v2eydbxs(ayfnwr1v) = 0.0d0
23045 continue
ilo = 1
- do 23047 w3gohz = 1,nb
- call vinterv(tb(1), nbp1 ,tb(w3gohz),m5xudf,i6ndbu)
- call vbsplvd(tb,def4wn,tb(w3gohz),m5xudf,bgu6fw,uq9jtc,ynmzp6)
- do 23049 p1rifj = 1,4
- avoe4y(p1rifj) = uq9jtc(p1rifj,3)
+ do 23047 ayfnwr1v = 1,nb
+ call vinterv(tb(1), nbp1 ,tb(ayfnwr1v),dqlr5bse,pqzfxw4i)
+ call vbsplvd(tb,ifour4,tb(ayfnwr1v),dqlr5bse,work,g9fvdrbw,three3)
+ do 23049 iii = 1,4
+ yw1(iii) = g9fvdrbw(iii,3)
23049 continue
- call vbsplvd(tb,def4wn,tb(w3gohz+1),m5xudf,bgu6fw,uq9jtc,ynmzp6)
- do 23051 p1rifj = 1,4
- yw2(p1rifj) = uq9jtc(p1rifj,3) - avoe4y(p1rifj)
+ call vbsplvd(tb,ifour4,tb(ayfnwr1v+1),dqlr5bse,work,g9fvdrbw,
+ &three3)
+ do 23051 iii = 1,4
+ yw2(iii) = g9fvdrbw(iii,3) - yw1(iii)
23051 continue
- wpt = tb(w3gohz+1) - tb(w3gohz)
- if(.not.(m5xudf .ge. 4))goto 23053
- do 23055 p1rifj = 1,4
- d9rjek = p1rifj
- tlpr2hal = m5xudf-4+p1rifj
- vf1jtn(tlpr2hal) = vf1jtn(tlpr2hal) + wpt * (avoe4y(p1rifj)*
- &avoe4y(d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(
- &p1rifj))*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
- d9rjek = p1rifj+1
- if(.not.(d9rjek .le. 4))goto 23057
- eh6nly(tlpr2hal) = eh6nly(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
+ wpt = tb(ayfnwr1v+1) - tb(ayfnwr1v)
+ if(.not.(dqlr5bse .ge. 4))goto 23053
+ do 23055 iii = 1,4
+ yq6lorbx = iii
+ i2svdbx3tk = dqlr5bse-4+iii
+ xecbg0pf(i2svdbx3tk) = xecbg0pf(i2svdbx3tk) + wpt * (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
+ yq6lorbx = iii+1
+ if(.not.(yq6lorbx .le. 4))goto 23057
+ z4grbpiq(i2svdbx3tk) = z4grbpiq(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
23057 continue
- d9rjek = p1rifj+2
- if(.not.(d9rjek .le. 4))goto 23059
- mvx9at(tlpr2hal) = mvx9at(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
+ yq6lorbx = iii+2
+ if(.not.(yq6lorbx .le. 4))goto 23059
+ d7glzhbj(i2svdbx3tk) = d7glzhbj(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
23059 continue
- d9rjek = p1rifj+3
- if(.not.(d9rjek .le. 4))goto 23061
- vbxpg4(tlpr2hal) = vbxpg4(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
+ yq6lorbx = iii+3
+ if(.not.(yq6lorbx .le. 4))goto 23061
+ v2eydbxs(i2svdbx3tk) = v2eydbxs(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
23061 continue
23055 continue
goto 23054
23053 continue
- if(.not.(m5xudf .eq. 3))goto 23063
- do 23065 p1rifj = 1,3
- d9rjek = p1rifj
- tlpr2hal = m5xudf-3+p1rifj
- vf1jtn(tlpr2hal) = vf1jtn(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
- d9rjek = p1rifj+1
- if(.not.(d9rjek .le. 3))goto 23067
- eh6nly(tlpr2hal) = eh6nly(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
+ if(.not.(dqlr5bse .eq. 3))goto 23063
+ do 23065 iii = 1,3
+ yq6lorbx = iii
+ i2svdbx3tk = dqlr5bse-3+iii
+ xecbg0pf(i2svdbx3tk) = xecbg0pf(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
+ yq6lorbx = iii+1
+ if(.not.(yq6lorbx .le. 3))goto 23067
+ z4grbpiq(i2svdbx3tk) = z4grbpiq(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
23067 continue
- d9rjek = p1rifj+2
- if(.not.(d9rjek .le. 3))goto 23069
- mvx9at(tlpr2hal) = mvx9at(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
+ yq6lorbx = iii+2
+ if(.not.(yq6lorbx .le. 3))goto 23069
+ d7glzhbj(i2svdbx3tk) = d7glzhbj(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
23069 continue
23065 continue
goto 23064
23063 continue
- if(.not.(m5xudf .eq. 2))goto 23071
- do 23073 p1rifj = 1,2
- d9rjek = p1rifj
- tlpr2hal = m5xudf-2+p1rifj
- vf1jtn(tlpr2hal) = vf1jtn(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
- d9rjek = p1rifj+1
- if(.not.(d9rjek .le. 2))goto 23075
- eh6nly(tlpr2hal) = eh6nly(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
+ if(.not.(dqlr5bse .eq. 2))goto 23071
+ do 23073 iii = 1,2
+ yq6lorbx = iii
+ i2svdbx3tk = dqlr5bse-2+iii
+ xecbg0pf(i2svdbx3tk) = xecbg0pf(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
+ yq6lorbx = iii+1
+ if(.not.(yq6lorbx .le. 2))goto 23075
+ z4grbpiq(i2svdbx3tk) = z4grbpiq(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
23075 continue
23073 continue
goto 23072
23071 continue
- if(.not.(m5xudf .eq. 1))goto 23077
- do 23079 p1rifj = 1,1
- d9rjek = p1rifj
- tlpr2hal = m5xudf-1+p1rifj
- vf1jtn(tlpr2hal) = vf1jtn(tlpr2hal) + wpt* (avoe4y(p1rifj)*avoe4y(
- &d9rjek) + (yw2(p1rifj)*avoe4y(d9rjek) + yw2(d9rjek)*avoe4y(p1rifj)
- &)*0.50 + yw2(p1rifj)*yw2(d9rjek)*uoqx2m)
+ if(.not.(dqlr5bse .eq. 1))goto 23077
+ do 23079 iii = 1,1
+ yq6lorbx = iii
+ i2svdbx3tk = dqlr5bse-1+iii
+ xecbg0pf(i2svdbx3tk) = xecbg0pf(i2svdbx3tk) + wpt* (yw1(iii)*yw1(
+ &yq6lorbx) + (yw2(iii)*yw1(yq6lorbx) + yw2(yq6lorbx)*yw1(iii))*0.
+ &50 + yw2(iii)*yw2(yq6lorbx)*othird)
23079 continue
23077 continue
23072 continue
@@ -300,46 +306,47 @@
23047 continue
return
end
- subroutine gayot2(rlep7v,lunah2,p2ip, mk2vyr,nk,thfyl1,isbkvx6)
+ subroutine vmnweiy2(buhyalv4,fulcp8wa,plj0trqx, e5knafcg,nk,
+ &wep0oibc,iflag)
implicit logical (a-z)
- integer mk2vyr,nk,thfyl1,isbkvx6
- double precision rlep7v(mk2vyr,nk), lunah2(mk2vyr,nk), p2ip(
- &thfyl1,nk)
- integer w3gohz, d9rjek, nd6mep
- double precision yrbij3(3),vef2gk(2),cfko0l(1),c0,c1,c2,c3
- double precision wxj6p6, k6nvd6, s6w6ny, ijk1l1, ya6c6v, vj6e6b,
- &rm44is, pe0ko0, by99io
+ integer e5knafcg,nk,wep0oibc,iflag
+ double precision buhyalv4(e5knafcg,nk), fulcp8wa(e5knafcg,nk),
+ &plj0trqx(wep0oibc,nk)
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh
+ double precision wjm3(3),wjm2(2),wjm1(1),c0,c1,c2,c3
+ double precision pcsuow9k, qdbgu6oi, upwkh5xz, rul5fnyd, ueydbrg6,
+ & plce2srm, k3yvomnh, bfdjhu7l, ctfvwdu0
c1 = 0.0d0
c2 = 0.0d0
c3 = 0.0d0
- yrbij3(1) = 0.0d0
- yrbij3(2) = 0.0d0
- yrbij3(3) = 0.0d0
- vef2gk(1) = 0.0d0
- vef2gk(2) = 0.0d0
- cfko0l(1) = 0.0d0
- do 23081 w3gohz = 1,nk
- d9rjek = nk-w3gohz+1
- c0 = 1.0d0 / rlep7v(4,d9rjek)
- if(.not.(d9rjek .le. (nk-3)))goto 23083
- c1 = rlep7v(1,d9rjek+3)*c0
- c2 = rlep7v(2,d9rjek+2)*c0
- c3 = rlep7v(3,d9rjek+1)*c0
+ wjm3(1) = 0.0d0
+ wjm3(2) = 0.0d0
+ wjm3(3) = 0.0d0
+ wjm2(1) = 0.0d0
+ wjm2(2) = 0.0d0
+ wjm1(1) = 0.0d0
+ do 23081 ayfnwr1v = 1,nk
+ yq6lorbx = nk-ayfnwr1v+1
+ c0 = 1.0d0 / buhyalv4(4,yq6lorbx)
+ if(.not.(yq6lorbx .le. (nk-3)))goto 23083
+ c1 = buhyalv4(1,yq6lorbx+3)*c0
+ c2 = buhyalv4(2,yq6lorbx+2)*c0
+ c3 = buhyalv4(3,yq6lorbx+1)*c0
goto 23084
23083 continue
- if(.not.(d9rjek .eq. (nk-2)))goto 23085
+ if(.not.(yq6lorbx .eq. (nk-2)))goto 23085
c1 = 0.0d0
- c2 = rlep7v(2,d9rjek+2)*c0
- c3 = rlep7v(3,d9rjek+1)*c0
+ c2 = buhyalv4(2,yq6lorbx+2)*c0
+ c3 = buhyalv4(3,yq6lorbx+1)*c0
goto 23086
23085 continue
- if(.not.(d9rjek .eq. (nk-1)))goto 23087
+ if(.not.(yq6lorbx .eq. (nk-1)))goto 23087
c1 = 0.0d0
c2 = 0.0d0
- c3 = rlep7v(3,d9rjek+1)*c0
+ c3 = buhyalv4(3,yq6lorbx+1)*c0
goto 23088
23087 continue
- if(.not.(d9rjek .eq. nk))goto 23089
+ if(.not.(yq6lorbx .eq. nk))goto 23089
c1 = 0.0d0
c2 = 0.0d0
c3 = 0.0d0
@@ -347,223 +354,251 @@
23088 continue
23086 continue
23084 continue
- wxj6p6 = c1*yrbij3(1)
- k6nvd6 = c2*yrbij3(2)
- s6w6ny = c3*yrbij3(3)
- ijk1l1 = c1*yrbij3(2)
- ya6c6v = c2*vef2gk(1)
- vj6e6b = c3*vef2gk(2)
- rm44is = c1*yrbij3(3)
- pe0ko0 = c2*vef2gk(2)
- by99io = c3*cfko0l(1)
- lunah2(1,d9rjek) = 0.0d0 - (wxj6p6+k6nvd6+s6w6ny)
- lunah2(2,d9rjek) = 0.0d0 - (ijk1l1+ya6c6v+vj6e6b)
- lunah2(3,d9rjek) = 0.0d0 - (rm44is+pe0ko0+by99io)
- lunah2(4,d9rjek) = c0**2 + c1*(wxj6p6 + 2.0d0*(k6nvd6 + s6w6ny)) +
- & c2*(ya6c6v + 2.0d0* vj6e6b) + c3*by99io
- yrbij3(1) = vef2gk(1)
- yrbij3(2) = vef2gk(2)
- yrbij3(3) = lunah2(2,d9rjek)
- vef2gk(1) = cfko0l(1)
- vef2gk(2) = lunah2(3,d9rjek)
- cfko0l(1) = lunah2(4,d9rjek)
+ pcsuow9k = c1*wjm3(1)
+ qdbgu6oi = c2*wjm3(2)
+ upwkh5xz = c3*wjm3(3)
+ rul5fnyd = c1*wjm3(2)
+ ueydbrg6 = c2*wjm2(1)
+ plce2srm = c3*wjm2(2)
+ k3yvomnh = c1*wjm3(3)
+ bfdjhu7l = c2*wjm2(2)
+ ctfvwdu0 = c3*wjm1(1)
+ fulcp8wa(1,yq6lorbx) = 0.0d0 - (pcsuow9k+qdbgu6oi+upwkh5xz)
+ fulcp8wa(2,yq6lorbx) = 0.0d0 - (rul5fnyd+ueydbrg6+plce2srm)
+ fulcp8wa(3,yq6lorbx) = 0.0d0 - (k3yvomnh+bfdjhu7l+ctfvwdu0)
+ fulcp8wa(4,yq6lorbx) = c0**2 + c1*(pcsuow9k + 2.0d0*(qdbgu6oi +
+ &upwkh5xz)) + c2*(ueydbrg6 + 2.0d0* plce2srm) + c3*ctfvwdu0
+ wjm3(1) = wjm2(1)
+ wjm3(2) = wjm2(2)
+ wjm3(3) = fulcp8wa(2,yq6lorbx)
+ wjm2(1) = wjm1(1)
+ wjm2(2) = fulcp8wa(3,yq6lorbx)
+ wjm1(1) = fulcp8wa(4,yq6lorbx)
23081 continue
- if(.not.(isbkvx6 .eq. 0))goto 23091
+ if(.not.(iflag .eq. 0))goto 23091
return
23091 continue
- do 23093 w3gohz = 1,nk
- d9rjek = nk-w3gohz+1
- nd6mep = 1
-23095 if(.not.(nd6mep.le.4.and.d9rjek+nd6mep-1.le.nk))goto 23097
- p2ip(d9rjek,d9rjek+nd6mep-1) = lunah2(5-nd6mep,d9rjek)
- nd6mep = nd6mep+1
+ do 23093 ayfnwr1v = 1,nk
+ yq6lorbx = nk-ayfnwr1v+1
+ gp1jxzuh = 1
+23095 if(.not.(gp1jxzuh.le.4.and.yq6lorbx+gp1jxzuh-1.le.nk))goto 23097
+ plj0trqx(yq6lorbx,yq6lorbx+gp1jxzuh-1) = fulcp8wa(5-gp1jxzuh,
+ &yq6lorbx)
+ gp1jxzuh = gp1jxzuh+1
goto 23095
23097 continue
23093 continue
- do 23098 w3gohz = 1,nk
- d9rjek = nk-w3gohz+1
- nd6mep = d9rjek-4
-23100 if(.not.(nd6mep.ge.1))goto 23102
- c0 = 1.0 / rlep7v(4,nd6mep)
- c1 = rlep7v(1,nd6mep+3)*c0
- c2 = rlep7v(2,nd6mep+2)*c0
- c3 = rlep7v(3,nd6mep+1)*c0
- p2ip(nd6mep,d9rjek) = 0.0d0- ( c1*p2ip(nd6mep+3,d9rjek) + c2*p2ip(
- &nd6mep+2,d9rjek) + c3*p2ip(nd6mep+1,d9rjek) )
- nd6mep = nd6mep-1
+ do 23098 ayfnwr1v = 1,nk
+ yq6lorbx = nk-ayfnwr1v+1
+ gp1jxzuh = yq6lorbx-4
+23100 if(.not.(gp1jxzuh.ge.1))goto 23102
+ c0 = 1.0 / buhyalv4(4,gp1jxzuh)
+ c1 = buhyalv4(1,gp1jxzuh+3)*c0
+ c2 = buhyalv4(2,gp1jxzuh+2)*c0
+ c3 = buhyalv4(3,gp1jxzuh+1)*c0
+ plj0trqx(gp1jxzuh,yq6lorbx) = 0.0d0- ( c1*plj0trqx(gp1jxzuh+3,
+ &yq6lorbx) + c2*plj0trqx(gp1jxzuh+2,yq6lorbx) + c3*plj0trqx(
+ &gp1jxzuh+1,yq6lorbx) )
+ gp1jxzuh = gp1jxzuh-1
goto 23100
23102 continue
23098 continue
return
end
- subroutine oipu6h(egoxa3,atqh0o,x,y,w, nfiumb4,nk,rlhz2a, knot,
- &coef,sz,rjcq9o, n9peut, dwgkz6, mheq6i, n7cuql,dvpc8x,hdv8br,
- &cbg5ys, vf1jtn,eh6nly,mvx9at,vbxpg4, rlep7v,lunah2,p2ip, mk2vyr,
- &thfyl1,fjg0qv)
+ subroutine wmhctl9x(penalt,pjb6wfoq,x,y,w, kuzxj1lo,nk,icrit,
+ &ankcghz2,coef,sz,ifys6woa, qcpiaj7f, i9mwnvqt, xwy, zvau2lct,
+ &f6lsuzax,fvh2rwtc,dcfir2no, xecbg0pf,z4grbpiq,d7glzhbj,v2eydbxs,
+ &buhyalv4,fulcp8wa,plj0trqx, e5knafcg,wep0oibc,info)
implicit logical (a-z)
- integer nfiumb4,nk,rlhz2a, mk2vyr,thfyl1,fjg0qv
- double precision egoxa3,atqh0o,x(nfiumb4),y(nfiumb4),w(nfiumb4)
- double precision knot(nk+4), coef(nk),sz(nfiumb4),rjcq9o(nfiumb4),
- & n9peut, dwgkz6, mheq6i(nk)
- double precision n7cuql(nk),dvpc8x(nk),hdv8br(nk),cbg5ys(nk)
- double precision vf1jtn(nk),eh6nly(nk),mvx9at(nk),vbxpg4(nk),
- &rlep7v(mk2vyr,nk),lunah2(mk2vyr,nk),p2ip(thfyl1,nk)
- double precision das4bx, bgu6fw(16), b0,b1,b2,b3,kqoy6w, uq9jtc(4,
- &1), xv,eqdf
- double precision zh0bs0
- double precision risyv0
- integer oht3ga, ynmzp6, ilo, i6ndbu, d9rjek, w3gohz
- integer px1yhr, m5xudf, def4wn, uxzze7, nkp1
+ integer kuzxj1lo,nk,icrit, e5knafcg,wep0oibc,info
+ double precision penalt,pjb6wfoq,x(kuzxj1lo),y(kuzxj1lo),w(
+ &kuzxj1lo)
+ double precision ankcghz2(nk+4), coef(nk),sz(kuzxj1lo),ifys6woa(
+ &kuzxj1lo), qcpiaj7f, i9mwnvqt, xwy(nk)
+ double precision zvau2lct(nk),f6lsuzax(nk),fvh2rwtc(nk),dcfir2no(
+ &nk)
+ double precision xecbg0pf(nk),z4grbpiq(nk),d7glzhbj(nk),v2eydbxs(
+ &nk), buhyalv4(e5knafcg,nk),fulcp8wa(e5knafcg,nk),plj0trqx(
+ &wep0oibc,nk)
+ double precision resss, work(16), b0,b1,b2,b3,qaltf0nz, g9fvdrbw(
+ &4,1), xv,eqdf
+ double precision qtce8hzo
+ double precision rxeqjn0y
+ integer izero0, three3, ilo, pqzfxw4i, yq6lorbx, ayfnwr1v
+ integer icoef, dqlr5bse, ifour4, hbsl0gto, nkp1
ilo = 1
- kqoy6w = 0.1d-10
- oht3ga = 0
- ynmzp6 = 3
- def4wn = 4
- uxzze7 = 1
+ qaltf0nz = 0.1d-10
+ izero0 = 0
+ three3 = 3
+ ifour4 = 4
+ hbsl0gto = 1
nkp1 = nk + 1
- do 23103 w3gohz = 1,nk
- coef(w3gohz) = mheq6i(w3gohz)
+ do 23103 ayfnwr1v = 1,nk
+ coef(ayfnwr1v) = xwy(ayfnwr1v)
23103 continue
- do 23105 w3gohz = 1,nk
- rlep7v(4,w3gohz) = n7cuql(w3gohz)+dwgkz6*vf1jtn(w3gohz)
+ do 23105 ayfnwr1v = 1,nk
+ buhyalv4(4,ayfnwr1v) = zvau2lct(ayfnwr1v)+i9mwnvqt*xecbg0pf(
+ &ayfnwr1v)
23105 continue
- do 23107 w3gohz = 1,(nk-1)
- rlep7v(3,w3gohz+1) = dvpc8x(w3gohz)+dwgkz6*eh6nly(w3gohz)
+ do 23107 ayfnwr1v = 1,(nk-1)
+ buhyalv4(3,ayfnwr1v+1) = f6lsuzax(ayfnwr1v)+i9mwnvqt*z4grbpiq(
+ &ayfnwr1v)
23107 continue
- do 23109 w3gohz = 1,(nk-2)
- rlep7v(2,w3gohz+2) = hdv8br(w3gohz)+dwgkz6*mvx9at(w3gohz)
+ do 23109 ayfnwr1v = 1,(nk-2)
+ buhyalv4(2,ayfnwr1v+2) = fvh2rwtc(ayfnwr1v)+i9mwnvqt*d7glzhbj(
+ &ayfnwr1v)
23109 continue
- do 23111 w3gohz = 1,(nk-3)
- rlep7v(1,w3gohz+3) = cbg5ys(w3gohz)+dwgkz6*vbxpg4(w3gohz)
+ do 23111 ayfnwr1v = 1,(nk-3)
+ buhyalv4(1,ayfnwr1v+3) = dcfir2no(ayfnwr1v)+i9mwnvqt*v2eydbxs(
+ &ayfnwr1v)
23111 continue
- call dpbfa8(rlep7v,mk2vyr,nk,ynmzp6,fjg0qv)
- if(.not.(fjg0qv .ne. 0))goto 23113
+ call dpbfa8(buhyalv4,e5knafcg,nk,three3,info)
+ if(.not.(info .ne. 0))goto 23113
return
23113 continue
- call dpbsl8(rlep7v,mk2vyr,nk,ynmzp6,coef)
- px1yhr = 1
- do 23115 w3gohz = 1,nfiumb4
- xv = x(w3gohz)
- call wbvalue(knot,coef, nk,def4wn,xv,oht3ga, sz(w3gohz))
+ call dpbsl8(buhyalv4,e5knafcg,nk,three3,coef)
+ icoef = 1
+ do 23115 ayfnwr1v = 1,kuzxj1lo
+ xv = x(ayfnwr1v)
+ call wbvalue(ankcghz2,coef, nk,ifour4,xv,izero0, sz(ayfnwr1v))
23115 continue
- if(.not.(rlhz2a .eq. 0))goto 23117
+ if(.not.(icrit .eq. 0))goto 23117
return
23117 continue
- call gayot2(rlep7v,lunah2,p2ip, mk2vyr,nk,thfyl1,oht3ga)
- do 23119 w3gohz = 1,nfiumb4
- xv = x(w3gohz)
- call vinterv(knot(1), nkp1 ,xv,m5xudf,i6ndbu)
- if(.not.(i6ndbu .eq. -1))goto 23121
- m5xudf = 4
- xv = knot(4) + kqoy6w
+ call vmnweiy2(buhyalv4,fulcp8wa,plj0trqx, e5knafcg,nk,wep0oibc,
+ &izero0)
+ do 23119 ayfnwr1v = 1,kuzxj1lo
+ xv = x(ayfnwr1v)
+ call vinterv(ankcghz2(1), nkp1 ,xv,dqlr5bse,pqzfxw4i)
+ if(.not.(pqzfxw4i .eq. -1))goto 23121
+ dqlr5bse = 4
+ xv = ankcghz2(4) + qaltf0nz
23121 continue
- if(.not.(i6ndbu .eq. 1))goto 23123
- m5xudf = nk
- xv = knot(nk+1) - kqoy6w
+ if(.not.(pqzfxw4i .eq. 1))goto 23123
+ dqlr5bse = nk
+ xv = ankcghz2(nk+1) - qaltf0nz
23123 continue
- d9rjek = m5xudf-3
- call vbsplvd(knot,def4wn,xv,m5xudf,bgu6fw,uq9jtc,uxzze7)
- b0 = uq9jtc(1,1)
- b1 = uq9jtc(2,1)
- b2 = uq9jtc(3,1)
- b3 = uq9jtc(4,1)
- zh0bs0 = (b0 *(lunah2(4,d9rjek)*b0 + 2.0d0*(lunah2(3,d9rjek)*b1 +
- &lunah2(2,d9rjek)*b2 + lunah2(1,d9rjek)*b3)) + b1 *(lunah2(4,
- &d9rjek+1)*b1 + 2.0d0*(lunah2(3,d9rjek+1)*b2 + lunah2(2,d9rjek+1)*
- &b3)) + b2 *(lunah2(4,d9rjek+2)*b2 + 2.0d0* lunah2(3,d9rjek+2)*b3 )
- &+ b3**2* lunah2(4,d9rjek+3)) * w(w3gohz)**2
- rjcq9o(w3gohz) = zh0bs0
+ yq6lorbx = dqlr5bse-3
+ call vbsplvd(ankcghz2,ifour4,xv,dqlr5bse,work,g9fvdrbw,hbsl0gto)
+ b0 = g9fvdrbw(1,1)
+ b1 = g9fvdrbw(2,1)
+ b2 = g9fvdrbw(3,1)
+ b3 = g9fvdrbw(4,1)
+ qtce8hzo = (b0 *(fulcp8wa(4,yq6lorbx)*b0 + 2.0d0*(fulcp8wa(3,
+ &yq6lorbx)*b1 + fulcp8wa(2,yq6lorbx)*b2 + fulcp8wa(1,yq6lorbx)*b3))
+ & + b1 *(fulcp8wa(4,yq6lorbx+1)*b1 + 2.0d0*(fulcp8wa(3,yq6lorbx+1)*
+ &b2 + fulcp8wa(2,yq6lorbx+1)*b3)) + b2 *(fulcp8wa(4,yq6lorbx+2)*b2
+ &+ 2.0d0* fulcp8wa(3,yq6lorbx+2)*b3 )+ b3**2* fulcp8wa(4,yq6lorbx+
+ &3)) * w(ayfnwr1v)**2
+ ifys6woa(ayfnwr1v) = qtce8hzo
23119 continue
- if(.not.(rlhz2a .eq. 1))goto 23125
- das4bx = 0.0d0
+ if(.not.(icrit .eq. 1))goto 23125
+ resss = 0.0d0
eqdf = 0.0d0
- risyv0 = 0.0d0
- do 23127 w3gohz = 1,nfiumb4
- das4bx = das4bx + ((y(w3gohz)-sz(w3gohz))*w(w3gohz))**2
- eqdf = eqdf + rjcq9o(w3gohz)
- risyv0 = risyv0 + w(w3gohz)*w(w3gohz)
+ rxeqjn0y = 0.0d0
+ do 23127 ayfnwr1v = 1,kuzxj1lo
+ resss = resss + ((y(ayfnwr1v)-sz(ayfnwr1v))*w(ayfnwr1v))**2
+ eqdf = eqdf + ifys6woa(ayfnwr1v)
+ rxeqjn0y = rxeqjn0y + w(ayfnwr1v)*w(ayfnwr1v)
23127 continue
- n9peut = (das4bx/risyv0)/((1.0d0-(atqh0o+egoxa3*eqdf)/risyv0)**2)
+ qcpiaj7f = (resss/rxeqjn0y)/((1.0d0-(pjb6wfoq+penalt*eqdf)/
+ &rxeqjn0y)**2)
goto 23126
23125 continue
- if(.not.(rlhz2a .eq. 2))goto 23129
- n9peut = 0.0d0
- risyv0 = 0.0d0
- do 23131 w3gohz = 1,nfiumb4
- n9peut = n9peut + (((y(w3gohz)-sz(w3gohz))*w(w3gohz))/(1.0d0-
- &rjcq9o(w3gohz)))**2
- risyv0 = risyv0 + w(w3gohz)*w(w3gohz)
+ if(.not.(icrit .eq. 2))goto 23129
+ qcpiaj7f = 0.0d0
+ rxeqjn0y = 0.0d0
+ do 23131 ayfnwr1v = 1,kuzxj1lo
+ qcpiaj7f = qcpiaj7f + (((y(ayfnwr1v)-sz(ayfnwr1v))*w(ayfnwr1v))/(
+ &1.0d0-ifys6woa(ayfnwr1v)))**2
+ rxeqjn0y = rxeqjn0y + w(ayfnwr1v)*w(ayfnwr1v)
23131 continue
- n9peut = n9peut / risyv0
+ qcpiaj7f = qcpiaj7f / rxeqjn0y
goto 23130
23129 continue
- n9peut = 0.0d0
- do 23133 w3gohz = 1,nfiumb4
- n9peut = n9peut+rjcq9o(w3gohz)
+ qcpiaj7f = 0.0d0
+ do 23133 ayfnwr1v = 1,kuzxj1lo
+ qcpiaj7f = qcpiaj7f+ifys6woa(ayfnwr1v)
23133 continue
- n9peut = 3.0d0 + (atqh0o-n9peut)**2
+ qcpiaj7f = 3.0d0 + (pjb6wfoq-qcpiaj7f)**2
23130 continue
23126 continue
return
end
- subroutine ak9vxi(p3vlea,hr83e,w,onyz6j, xl6qgm,nfiumb4, wevr5o,
- &n7cuql,dvpc8x,hdv8br,cbg5ys)
+ subroutine gt9iulbf(he7mqnvy,ghz9vuba,w,gkdx5jal, rvy1fpli,
+ &kuzxj1lo, bhcji9glto,zvau2lct,f6lsuzax,fvh2rwtc,dcfir2no)
implicit logical (a-z)
- integer xl6qgm,nfiumb4
- double precision p3vlea(xl6qgm),hr83e(xl6qgm),w(xl6qgm),onyz6j(
- &nfiumb4+4), wevr5o(nfiumb4), n7cuql(nfiumb4),dvpc8x(nfiumb4),
- &hdv8br(nfiumb4),cbg5ys(nfiumb4)
- double precision kqoy6w,uq9jtc(4,1),bgu6fw(16)
- double precision gyn0o0, sce5d5
- integer d9rjek,w3gohz,ilo,m5xudf,i6ndbu, nhwi2tb1
- integer def4wn, uxzze7
- uxzze7 = 1
- def4wn = 4
- nhwi2tb1 = nfiumb4 + 1
- do 23135 w3gohz = 1,nfiumb4
- wevr5o(w3gohz) = 0.0d0
- n7cuql(w3gohz) = 0.0d0
- dvpc8x(w3gohz) = 0.0d0
- hdv8br(w3gohz) = 0.0d0
- cbg5ys(w3gohz) = 0.0d0
+ integer rvy1fpli,kuzxj1lo
+ double precision he7mqnvy(rvy1fpli),ghz9vuba(rvy1fpli),w(rvy1fpli)
+ &,gkdx5jal(kuzxj1lo+4), bhcji9glto(kuzxj1lo), zvau2lct(kuzxj1lo),
+ &f6lsuzax(kuzxj1lo),fvh2rwtc(kuzxj1lo),dcfir2no(kuzxj1lo)
+ double precision qaltf0nz,g9fvdrbw(4,1),work(16)
+ double precision w2svdbx3tk, wv2svdbx3tk
+ integer yq6lorbx,ayfnwr1v,ilo,dqlr5bse,pqzfxw4i, nhnpt1zym1
+ integer ifour4, hbsl0gto
+ hbsl0gto = 1
+ ifour4 = 4
+ nhnpt1zym1 = kuzxj1lo + 1
+ do 23135 ayfnwr1v = 1,kuzxj1lo
+ bhcji9glto(ayfnwr1v) = 0.0d0
+ zvau2lct(ayfnwr1v) = 0.0d0
+ f6lsuzax(ayfnwr1v) = 0.0d0
+ fvh2rwtc(ayfnwr1v) = 0.0d0
+ dcfir2no(ayfnwr1v) = 0.0d0
23135 continue
ilo = 1
- kqoy6w = 0.1d-9
- do 23137 w3gohz = 1,xl6qgm
- call vinterv(onyz6j(1), nhwi2tb1 ,p3vlea(w3gohz),m5xudf,i6ndbu)
- if(.not.(i6ndbu .eq. 1))goto 23139
- if(.not.(p3vlea(w3gohz) .le. (onyz6j(m5xudf)+kqoy6w)))goto 23141
- m5xudf = m5xudf-1
+ qaltf0nz = 0.1d-9
+ do 23137 ayfnwr1v = 1,rvy1fpli
+ call vinterv(gkdx5jal(1), nhnpt1zym1 ,he7mqnvy(ayfnwr1v),dqlr5bse,
+ &pqzfxw4i)
+ if(.not.(pqzfxw4i .eq. 1))goto 23139
+ if(.not.(he7mqnvy(ayfnwr1v) .le. (gkdx5jal(dqlr5bse)+qaltf0nz)))
+ &goto 23141
+ dqlr5bse = dqlr5bse-1
goto 23142
23141 continue
return
23142 continue
23139 continue
- call vbsplvd(onyz6j,def4wn,p3vlea(w3gohz),m5xudf,bgu6fw,uq9jtc,
- &uxzze7)
- d9rjek = m5xudf-4+1
- gyn0o0 = w(w3gohz)**2
- sce5d5 = gyn0o0 * uq9jtc(1,1)
- wevr5o(d9rjek) = wevr5o(d9rjek) + sce5d5*hr83e(w3gohz)
- n7cuql(d9rjek) = n7cuql(d9rjek) + sce5d5*uq9jtc(1,1)
- dvpc8x(d9rjek) = dvpc8x(d9rjek) + sce5d5*uq9jtc(2,1)
- hdv8br(d9rjek) = hdv8br(d9rjek) + sce5d5*uq9jtc(3,1)
- cbg5ys(d9rjek) = cbg5ys(d9rjek) + sce5d5*uq9jtc(4,1)
- d9rjek = m5xudf-4+2
- sce5d5 = gyn0o0 * uq9jtc(2,1)
- wevr5o(d9rjek) = wevr5o(d9rjek) + sce5d5*hr83e(w3gohz)
- n7cuql(d9rjek) = n7cuql(d9rjek) + sce5d5*uq9jtc(2,1)
- dvpc8x(d9rjek) = dvpc8x(d9rjek) + sce5d5*uq9jtc(3,1)
- hdv8br(d9rjek) = hdv8br(d9rjek) + sce5d5*uq9jtc(4,1)
- d9rjek = m5xudf-4+3
- sce5d5 = gyn0o0 * uq9jtc(3,1)
- wevr5o(d9rjek) = wevr5o(d9rjek) + sce5d5*hr83e(w3gohz)
- n7cuql(d9rjek) = n7cuql(d9rjek) + sce5d5*uq9jtc(3,1)
- dvpc8x(d9rjek) = dvpc8x(d9rjek) + sce5d5*uq9jtc(4,1)
- d9rjek = m5xudf
- sce5d5 = gyn0o0 * uq9jtc(4,1)
- wevr5o(d9rjek) = wevr5o(d9rjek) + sce5d5*hr83e(w3gohz)
- n7cuql(d9rjek) = n7cuql(d9rjek) + sce5d5*uq9jtc(4,1)
+ call vbsplvd(gkdx5jal,ifour4,he7mqnvy(ayfnwr1v),dqlr5bse,work,
+ &g9fvdrbw,hbsl0gto)
+ yq6lorbx = dqlr5bse-4+1
+ w2svdbx3tk = w(ayfnwr1v)**2
+ wv2svdbx3tk = w2svdbx3tk * g9fvdrbw(1,1)
+ bhcji9glto(yq6lorbx) = bhcji9glto(yq6lorbx) + wv2svdbx3tk*
+ &ghz9vuba(ayfnwr1v)
+ zvau2lct(yq6lorbx) = zvau2lct(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(1,
+ &1)
+ f6lsuzax(yq6lorbx) = f6lsuzax(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(2,
+ &1)
+ fvh2rwtc(yq6lorbx) = fvh2rwtc(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(3,
+ &1)
+ dcfir2no(yq6lorbx) = dcfir2no(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(4,
+ &1)
+ yq6lorbx = dqlr5bse-4+2
+ wv2svdbx3tk = w2svdbx3tk * g9fvdrbw(2,1)
+ bhcji9glto(yq6lorbx) = bhcji9glto(yq6lorbx) + wv2svdbx3tk*
+ &ghz9vuba(ayfnwr1v)
+ zvau2lct(yq6lorbx) = zvau2lct(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(2,
+ &1)
+ f6lsuzax(yq6lorbx) = f6lsuzax(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(3,
+ &1)
+ fvh2rwtc(yq6lorbx) = fvh2rwtc(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(4,
+ &1)
+ yq6lorbx = dqlr5bse-4+3
+ wv2svdbx3tk = w2svdbx3tk * g9fvdrbw(3,1)
+ bhcji9glto(yq6lorbx) = bhcji9glto(yq6lorbx) + wv2svdbx3tk*
+ &ghz9vuba(ayfnwr1v)
+ zvau2lct(yq6lorbx) = zvau2lct(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(3,
+ &1)
+ f6lsuzax(yq6lorbx) = f6lsuzax(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(4,
+ &1)
+ yq6lorbx = dqlr5bse
+ wv2svdbx3tk = w2svdbx3tk * g9fvdrbw(4,1)
+ bhcji9glto(yq6lorbx) = bhcji9glto(yq6lorbx) + wv2svdbx3tk*
+ &ghz9vuba(ayfnwr1v)
+ zvau2lct(yq6lorbx) = zvau2lct(yq6lorbx) + wv2svdbx3tk*g9fvdrbw(4,
+ &1)
23137 continue
return
end
diff --git a/src/rgam3.c b/src/rgam3.c
new file mode 100644
index 0000000..9c0be8b
--- /dev/null
+++ b/src/rgam3.c
@@ -0,0 +1,746 @@
+
+
+
+
+
+#include<math.h>
+#include<stdio.h>
+#include<stdlib.h>
+#include<R.h>
+#include<Rmath.h>
+
+
+void n5aioudkdnaoqj0l(double *qgnl3toc,
+ double sjwyig9t[], double bhcji9gl[], double po8rwsmy[],
+ int *kuzxj1lo, int *acpios9q,
+ double gkdx5jal[], double rpyis2kc[], double imdvf4hx[],
+ double ifys6woa[],
+ double *wbkq9zyi, double jstx4uwe[4],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double *tt2,
+ int *cvnjhg2u, int l3zpbstu[3],
+ int *xtov9rbf, int *wep0oibc, int *fbd5yktj);
+void n5aioudkhbzuprs6(double *qgnl3toc,
+ double sjwyig9t[], double bhcji9gl[], double po8rwsmy[],
+ int *kuzxj1lo, int *acpios9q, double gkdx5jal[],
+ double *rpyis2kc, double *imdvf4hx, double *ifys6woa,
+ double *i9mwnvqt, int *pn9eowxc, int *ic5aesxku,
+ double *mynl7uaq, double *zustx4fw, double *nbe4gvpq, double *qaltf0nz,
+ int *cvnjhg2u,
+ double xwy[],
+ double zvau2lct[], double f6lsuzax[], double fvh2rwtc[], double dcfir2no[],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double *tt2,
+ double buhyalv4[],
+ double fulcp8wa[], double plj0trqx[],
+ int *xtov9rbf, int *wep0oibc, int *fbd5yktj);
+void n5aioudkzosq7hub(double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double gkdx5jal[], int *acpios9q);
+void n5aioudkvmnweiy2(double buhyalv4[], double fulcp8wa[], double plj0trqx[], int *xtov9rbf,
+ int *acpios9q, int *wep0oibc, int *iflag);
+void n5aioudkwmhctl9x( double *qgnl3toc, double sjwyig9t[],
+ double po8rwsmy[], int *kuzxj1lo, int *acpios9q,
+ int *pn9eowxc, // int *icrit,
+ double gkdx5jal[], double rpyis2kc[], double imdvf4hx[],
+ double ifys6woa[], double *i9mwnvqt, double xwy[],
+ double *qcpiaj7f,
+ double zvau2lct[], double f6lsuzax[], double fvh2rwtc[], double dcfir2no[],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double buhyalv4[], double fulcp8wa[], double plj0trqx[],
+ int *xtov9rbf, int *wep0oibc, int *algpft4y);
+void n5aioudkgt9iulbf(double sjwyig9t[], double ghz9vuba[], double po8rwsmy[],
+ double gkdx5jal[], int *rvy1fpli, int *kuzxj1lo, double zyupcmk6[],
+ double zvau2lct[], double f6lsuzax[], double fvh2rwtc[], double dcfir2no[]);
+
+void F77_NAME(vinterv)(double*, int*, double*, int*, int*);
+void F77_NAME(vbsplvd)(double*, int*, double*, int*, double*, double*,
+ int*);
+void F77_NAME(dpbfa8)(double*, int*, int*, int*, int*);
+void F77_NAME(dpbsl8)(double*, int*, int*, int*, double*);
+void F77_NAME(wbvalue)(double*, double*, int*, int*, double*, int*,
+ double*);
+
+
+void n5aioudkdnaoqj0l(double *qgnl3toc,
+ double sjwyig9t[], double bhcji9gl[], double po8rwsmy[],
+ int *kuzxj1lo, int *acpios9q,
+ double gkdx5jal[], double rpyis2kc[], double imdvf4hx[],
+ double ifys6woa[],
+ double *wbkq9zyi, double jstx4uwe[4],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double *tt2,
+ int *cvnjhg2u, int l3zpbstu[3],
+ int *xtov9rbf, int *wep0oibc, int *fbd5yktj) {
+
+
+
+
+ double *wkumc9idxwy, *wkumc9idbuhyalv4,
+ *wkumc9idzvau2lct, *wkumc9idf6lsuzax, *wkumc9idfvh2rwtc, *wkumc9iddcfir2no,
+ *wkumc9idfulcp8wa, *wkumc9idplj0trqx;
+
+ wkumc9idxwy = Calloc(*acpios9q, double);
+ wkumc9idzvau2lct = Calloc(*acpios9q, double);
+ wkumc9idf6lsuzax = Calloc(*acpios9q, double);
+ wkumc9idfvh2rwtc = Calloc(*acpios9q, double);
+ wkumc9iddcfir2no = Calloc(*acpios9q, double);
+ wkumc9idbuhyalv4 = Calloc(*xtov9rbf * *acpios9q, double);
+ wkumc9idfulcp8wa = Calloc(*xtov9rbf * *acpios9q, double);
+ wkumc9idplj0trqx = Calloc( (int) 1 , double);
+
+ n5aioudkhbzuprs6(qgnl3toc, sjwyig9t, bhcji9gl,
+ po8rwsmy, kuzxj1lo, acpios9q, gkdx5jal,
+ rpyis2kc, imdvf4hx, ifys6woa,
+ wbkq9zyi, l3zpbstu + 1, l3zpbstu + 2,
+ jstx4uwe, jstx4uwe + 1, jstx4uwe + 2, jstx4uwe + 3,
+ cvnjhg2u,
+ wkumc9idxwy,
+ wkumc9idzvau2lct, wkumc9idf6lsuzax, wkumc9idfvh2rwtc, wkumc9iddcfir2no,
+ xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs,
+ tt2,
+ wkumc9idbuhyalv4,
+ wkumc9idfulcp8wa, wkumc9idplj0trqx,
+ xtov9rbf, wep0oibc, fbd5yktj);
+
+ Free(wkumc9idxwy); Free(wkumc9idbuhyalv4);
+ Free(wkumc9idzvau2lct); Free(wkumc9idf6lsuzax); Free(wkumc9idfvh2rwtc); Free(wkumc9iddcfir2no);
+ Free(wkumc9idfulcp8wa); Free(wkumc9idplj0trqx);
+}
+
+
+void n5aioudkhbzuprs6(double *qgnl3toc,
+ double sjwyig9t[], double bhcji9gl[], double po8rwsmy[],
+ int *kuzxj1lo, int *acpios9q, double gkdx5jal[],
+ double *rpyis2kc, double *imdvf4hx, double *ifys6woa,
+ double *wbkq9zyi, int *pn9eowxc, int *ic5aesxku,
+ double *mynl7uaq, double *zustx4fw, double *nbe4gvpq, double *qaltf0nz,
+ int *cvnjhg2u,
+ double xwy[],
+ double zvau2lct[], double f6lsuzax[], double fvh2rwtc[], double dcfir2no[],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double *tt2,
+ double buhyalv4[],
+ double fulcp8wa[], double plj0trqx[],
+ int *xtov9rbf, int *wep0oibc, int *fbd5yktj) {
+
+
+
+ static const double c_Gold = 0.381966011250105151795413165634;
+ double tt1 = 0.0, g2dnwteb,
+ wkumc9ida, wkumc9idb, wkumc9idd, wkumc9ide,
+ wkumc9idxm, wkumc9idp, wkumc9idq, wkumc9idr, // qaltf0nz,
+ Tol1, Tol2, wkumc9idu, wkumc9idv, wkumc9idw,
+ wkumc9idfu, wkumc9idfv, wkumc9idfw, wkumc9idfx, wkumc9idx, wkumc9idax, wkumc9idbx;
+ int ayfnwr1v, viter = 0;
+ double yjpnro8d = 8.0e88, bk3ymcih = 0.0e0,
+ *qcpiaj7f, qcpiaj7f0 = 0.0;
+
+ qcpiaj7f = &qcpiaj7f0,
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ wkumc9idd = 0.0; wkumc9idfu = 0.0e0; wkumc9idu = 0.0e0;
+
+
+ if (*cvnjhg2u == 0) {
+ n5aioudkzosq7hub(xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs, gkdx5jal, acpios9q);
+
+ *tt2 = 0.0;
+ for (ayfnwr1v = 3; ayfnwr1v <= (*acpios9q - 3); ayfnwr1v++) {
+ *tt2 += xecbg0pf[ayfnwr1v-1];
+ }
+
+ *cvnjhg2u = 1;
+ } else {
+ }
+
+ n5aioudkgt9iulbf(sjwyig9t, bhcji9gl, po8rwsmy,
+ gkdx5jal, kuzxj1lo, acpios9q, xwy,
+ zvau2lct, f6lsuzax, fvh2rwtc, dcfir2no);
+
+ for (ayfnwr1v = 3; ayfnwr1v <= (*acpios9q - 3); ayfnwr1v++) {
+ tt1 += zvau2lct[ayfnwr1v-1];
+ }
+ g2dnwteb = tt1 / *tt2;
+
+ if (*pn9eowxc == 1) {
+
+ *mynl7uaq = g2dnwteb * pow(16.0, *wbkq9zyi * 6.0 - 2.0);
+ n5aioudkwmhctl9x(qgnl3toc, sjwyig9t,
+ po8rwsmy, kuzxj1lo, acpios9q,
+ pn9eowxc, // icrit, (icrit used to be used solely)
+ gkdx5jal, rpyis2kc, imdvf4hx,
+ ifys6woa, mynl7uaq, xwy,
+ qcpiaj7f, // Not used here
+ zvau2lct, f6lsuzax, fvh2rwtc, dcfir2no,
+ xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs,
+ buhyalv4, fulcp8wa, plj0trqx,
+ xtov9rbf, wep0oibc, fbd5yktj);
+ return;
+ }
+
+
+
+ wkumc9idax = *mynl7uaq;
+ wkumc9idbx = *zustx4fw;
+
+
+
+
+
+
+
+
+
+
+
+
+ /* Initialization. */
+ wkumc9ida = wkumc9idax;
+ wkumc9idb = wkumc9idbx;
+ wkumc9idv = wkumc9ida + c_Gold * (wkumc9idb - wkumc9ida);
+ wkumc9idw =
+ wkumc9idx = wkumc9idv;
+ wkumc9ide = 0.0e0;
+
+ *wbkq9zyi = wkumc9idx;
+ *mynl7uaq = g2dnwteb * pow((double) 16.0, (double) *wbkq9zyi * 6.0 - 2.0);
+ n5aioudkwmhctl9x(qgnl3toc, sjwyig9t,
+ po8rwsmy, kuzxj1lo, acpios9q,
+ pn9eowxc, // icrit,
+ gkdx5jal, rpyis2kc, imdvf4hx,
+ ifys6woa, mynl7uaq, xwy,
+ qcpiaj7f,
+ zvau2lct, f6lsuzax, fvh2rwtc, dcfir2no,
+ xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs,
+ buhyalv4, fulcp8wa, plj0trqx,
+ xtov9rbf, wep0oibc, fbd5yktj);
+
+
+ wkumc9idfx = *qcpiaj7f;
+ wkumc9idfv =
+ wkumc9idfw = wkumc9idfx;
+
+
+ while (*fbd5yktj == 0) {
+ viter++;
+ wkumc9idxm = 0.5e0 * (wkumc9ida + wkumc9idb);
+ Tol1 = *qaltf0nz * fabs(wkumc9idx) + *nbe4gvpq / 3.0e0;
+ Tol2 = 2.0e0 * Tol1;
+
+ if ((fabs(wkumc9idx - wkumc9idxm) <= (Tol2 - 0.5 * (wkumc9idb - wkumc9ida)))
+ || (viter > *ic5aesxku))
+ goto L_End;
+
+ if ((fabs(wkumc9ide) <= Tol1) ||
+ (wkumc9idfx >= yjpnro8d) ||
+ (wkumc9idfv >= yjpnro8d) ||
+ (wkumc9idfw >= yjpnro8d)) goto a3bdsirf;
+
+ wkumc9idr = (wkumc9idx - wkumc9idw) * (wkumc9idfx - wkumc9idfv);
+ wkumc9idq = (wkumc9idx - wkumc9idv) * (wkumc9idfx - wkumc9idfw);
+ wkumc9idp = (wkumc9idx - wkumc9idv) * wkumc9idq - (wkumc9idx - wkumc9idw) * wkumc9idr;
+ wkumc9idq = 2.0e0 * (wkumc9idq - wkumc9idr);
+ if (wkumc9idq > 0.0e0) wkumc9idp = -wkumc9idp;
+ wkumc9idq = fabs(wkumc9idq);
+ wkumc9idr = wkumc9ide;
+ wkumc9ide = wkumc9idd;
+
+ if (fabs(wkumc9idp) >= fabs(0.5 * wkumc9idq * wkumc9idr) ||
+ wkumc9idq == 0.0e0) {
+ goto a3bdsirf;
+ }
+ if (wkumc9idp <= wkumc9idq * (wkumc9ida - wkumc9idx) ||
+ wkumc9idp >= wkumc9idq * (wkumc9idb - wkumc9idx)) goto a3bdsirf;
+
+ wkumc9idd = wkumc9idp / wkumc9idq;
+ if(!R_FINITE(wkumc9idd))
+ Rprintf("Error in n5aioudkhbzuprs6: wkumc9idd is not finite.\n");
+
+ wkumc9idu = wkumc9idx + wkumc9idd;
+
+ if (wkumc9idu - wkumc9ida < Tol2 ||
+ wkumc9idb - wkumc9idu < Tol2) wkumc9idd = fsign(Tol1, wkumc9idxm - wkumc9idx);
+
+ goto ceqzd1hi50;
+
+a3bdsirf:
+ wkumc9ide = (wkumc9idx >= wkumc9idxm) ? wkumc9ida - wkumc9idx : wkumc9idb - wkumc9idx;
+ wkumc9idd = c_Gold * wkumc9ide;
+
+ceqzd1hi50: wkumc9idu = wkumc9idx +
+ ((fabs(wkumc9idd) >= Tol1) ? wkumc9idd : fsign(Tol1, wkumc9idd));
+
+ *wbkq9zyi = wkumc9idu;
+ *mynl7uaq = g2dnwteb * pow((double) 16.0, (double) *wbkq9zyi * 6.0 - 2.0);
+ n5aioudkwmhctl9x(qgnl3toc, sjwyig9t,
+ po8rwsmy, kuzxj1lo, acpios9q,
+ pn9eowxc, // icrit,
+ gkdx5jal, rpyis2kc, imdvf4hx,
+ ifys6woa, mynl7uaq, xwy,
+ qcpiaj7f,
+ zvau2lct, f6lsuzax, fvh2rwtc, dcfir2no,
+ xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs,
+ buhyalv4, fulcp8wa, plj0trqx,
+ xtov9rbf, wep0oibc, fbd5yktj);
+
+ wkumc9idfu = *qcpiaj7f;
+
+ if (wkumc9idfu > yjpnro8d)
+ wkumc9idfu = 2.0e0 * yjpnro8d;
+
+ if (wkumc9idfu <= wkumc9idfx) {
+ if (wkumc9idu >= wkumc9idx) wkumc9ida = wkumc9idx; else wkumc9idb = wkumc9idx;
+ wkumc9idv = wkumc9idw; wkumc9idfv = wkumc9idfw;
+ wkumc9idw = wkumc9idx; wkumc9idfw = wkumc9idfx;
+ wkumc9idx = wkumc9idu; wkumc9idfx = wkumc9idfu;
+ } else {
+ if (wkumc9idu < wkumc9idx) wkumc9ida = wkumc9idu; else wkumc9idb = wkumc9idu;
+ if (wkumc9idfu <= wkumc9idfw || wkumc9idw == wkumc9idx) {
+ wkumc9idv = wkumc9idw; wkumc9idfv = wkumc9idfw;
+ wkumc9idw = wkumc9idu; wkumc9idfw = wkumc9idfu;
+ } else
+ if (wkumc9idfu <= wkumc9idfv || wkumc9idv == wkumc9idx || wkumc9idv == wkumc9idw){
+ wkumc9idv = wkumc9idu; wkumc9idfv = wkumc9idfu;
+ }
+ }
+ }
+ L_End: bk3ymcih = 0.0e0;
+
+ *wbkq9zyi = wkumc9idx;
+ *qcpiaj7f = wkumc9idfx;
+ return;
+}
+
+
+
+
+void n5aioudkzosq7hub(double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double gkdx5jal[], int *acpios9q) {
+
+
+ int dqlr5bse, pqzfxw4i, bvsquk3z = 3, h2dpsbkr = 4, nkplus1 = *acpios9q + 1;
+ int ayfnwr1v, gp1jxzuh, yq6lorbx;
+ int urohxe6t;
+ double g9fvdrbw[12], ms0qypiw[16], yw1[4], yw2[4], wrk1, othird = 1.0 / 3.0,
+ *qnwamo0e0, *qnwamo0e1, *qnwamo0e2, *qnwamo0e3;
+
+
+
+
+
+ qnwamo0e0 = xecbg0pf; qnwamo0e1 = z4grbpiq; qnwamo0e2 = d7glzhbj; qnwamo0e3 = v2eydbxs;
+ for (ayfnwr1v = 0; ayfnwr1v < *acpios9q; ayfnwr1v++) {
+ *qnwamo0e0++ = *qnwamo0e1++ = *qnwamo0e2++ = *qnwamo0e3++ = 0.0e0;
+ }
+
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+
+
+ F77_CALL(vinterv)(gkdx5jal, &nkplus1, gkdx5jal + ayfnwr1v-1, &dqlr5bse, &pqzfxw4i);
+
+ F77_CALL(vbsplvd)(gkdx5jal, &h2dpsbkr, gkdx5jal + ayfnwr1v - 1, &dqlr5bse, ms0qypiw,
+ g9fvdrbw, &bvsquk3z);
+
+ for (gp1jxzuh = 1; gp1jxzuh <= 4; gp1jxzuh++) {
+ yw1[gp1jxzuh-1] = g9fvdrbw[gp1jxzuh-1 + 2*4];
+ }
+
+ F77_CALL(vbsplvd)(gkdx5jal, &h2dpsbkr, gkdx5jal + ayfnwr1v, &dqlr5bse, ms0qypiw,
+ g9fvdrbw, &bvsquk3z);
+
+ for (gp1jxzuh = 1; gp1jxzuh <= 4; gp1jxzuh++) {
+ yw2[gp1jxzuh-1] = g9fvdrbw[gp1jxzuh-1 + 2*4] - yw1[gp1jxzuh-1];
+ }
+ wrk1 = gkdx5jal[ayfnwr1v] - gkdx5jal[ayfnwr1v-1];
+
+ if (dqlr5bse >= 4) {
+ for (gp1jxzuh = 1; gp1jxzuh <= 4; gp1jxzuh++) {
+ yq6lorbx = gp1jxzuh;
+ urohxe6t = dqlr5bse - 4 + gp1jxzuh;
+ xecbg0pf[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ yq6lorbx = gp1jxzuh + 1;
+ if (yq6lorbx <= 4) {
+ z4grbpiq[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ }
+ yq6lorbx = gp1jxzuh + 2;
+ if (yq6lorbx <= 4) {
+ d7glzhbj[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ }
+ yq6lorbx = gp1jxzuh + 3;
+ if (yq6lorbx <= 4) {
+ v2eydbxs[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ }
+ }
+ } else if (dqlr5bse == 3) {
+ for (gp1jxzuh = 1; gp1jxzuh <= 3; gp1jxzuh++) {
+ yq6lorbx = gp1jxzuh;
+ urohxe6t = dqlr5bse - 3 + gp1jxzuh;
+ xecbg0pf[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ yq6lorbx = gp1jxzuh + 1;
+ if (yq6lorbx <= 3) {
+ z4grbpiq[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ }
+ yq6lorbx = gp1jxzuh + 2;
+ if (yq6lorbx <= 3) {
+ d7glzhbj[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ }
+ }
+ } else if (dqlr5bse == 2) {
+ for (gp1jxzuh = 1; gp1jxzuh <= 2; gp1jxzuh++) {
+ yq6lorbx = gp1jxzuh;
+ urohxe6t = dqlr5bse - 2 + gp1jxzuh;
+ xecbg0pf[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ yq6lorbx = gp1jxzuh + 1;
+ if (yq6lorbx <= 2) {
+ z4grbpiq[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ }
+ }
+ } else if (dqlr5bse == 1) {
+ for (gp1jxzuh = 1; gp1jxzuh <= 1; gp1jxzuh++) {
+ yq6lorbx = gp1jxzuh;
+ urohxe6t = dqlr5bse - 1 + gp1jxzuh;
+ xecbg0pf[urohxe6t-1] +=
+ wrk1 * (yw1[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ (yw2[gp1jxzuh-1]*yw1[yq6lorbx-1] +
+ yw2[yq6lorbx-1]*yw1[gp1jxzuh-1]) * 0.50 +
+ yw2[gp1jxzuh-1]*yw2[yq6lorbx-1] * othird);
+ }
+ }
+ }
+}
+
+
+void n5aioudkvmnweiy2(double buhyalv4[], double fulcp8wa[], double plj0trqx[], int *xtov9rbf,
+ int *acpios9q, int *wep0oibc, int *iflag) {
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh;
+ double wjm3[3], wjm2[2], wjm1[1], c0, c1, c2, c3;
+ double pcsuow9k, qdbgu6oi, upwkh5xz, rul5fnyd, ueydbrg6,
+ plce2srm, k3yvomnh, bfdjhu7l, ctfvwdu0;
+
+ c1 = c2 = c3 = 0.0e0;
+
+
+
+
+
+
+
+ wjm3[0] = wjm3[1] = wjm3[2] =
+ wjm2[0] = wjm2[1] =
+ wjm1[0] = 0.0e0;
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+ yq6lorbx = *acpios9q - ayfnwr1v + 1;
+ c0 = 1.0e0 / buhyalv4[3 + (yq6lorbx-1) * *xtov9rbf];
+ if (yq6lorbx <= (*acpios9q-3)) {
+ c1 = buhyalv4[0 + (yq6lorbx+2) * *xtov9rbf] * c0;
+ c2 = buhyalv4[1 + (yq6lorbx+1) * *xtov9rbf] * c0;
+ c3 = buhyalv4[2 + (yq6lorbx+0) * *xtov9rbf] * c0;
+ } else if (yq6lorbx == (*acpios9q - 2)) {
+ c1 = 0.0e0;
+ c2 = buhyalv4[1 + (yq6lorbx+1) * *xtov9rbf] * c0;
+ c3 = buhyalv4[2 + yq6lorbx * *xtov9rbf] * c0;
+ } else if (yq6lorbx == (*acpios9q - 1)) {
+ c1 =
+ c2 = 0.0e0;
+ c3 = buhyalv4[2 + yq6lorbx * *xtov9rbf] * c0;
+ } else if (yq6lorbx == *acpios9q) {
+ c1 =
+ c2 =
+ c3 = 0.0e0;
+ }
+
+ pcsuow9k = c1 * wjm3[0];
+ qdbgu6oi = c2 * wjm3[1];
+ upwkh5xz = c3 * wjm3[2];
+ rul5fnyd = c1 * wjm3[1];
+ ueydbrg6 = c2 * wjm2[0];
+ plce2srm = c3 * wjm2[1];
+ k3yvomnh = c1 * wjm3[2];
+ bfdjhu7l = c2 * wjm2[1];
+ ctfvwdu0 = c3 * wjm1[0];
+ fulcp8wa[0 + (yq6lorbx-1) * *xtov9rbf] = 0.0 - (pcsuow9k+qdbgu6oi+upwkh5xz);
+ fulcp8wa[1 + (yq6lorbx-1) * *xtov9rbf] = 0.0 - (rul5fnyd+ueydbrg6+plce2srm);
+ fulcp8wa[2 + (yq6lorbx-1) * *xtov9rbf] = 0.0 - (k3yvomnh+bfdjhu7l+ctfvwdu0);
+
+ fulcp8wa[3 + (yq6lorbx-1) * *xtov9rbf] = pow(c0, (double) 2.0) +
+ c1 * (pcsuow9k + 2.0e0 * (qdbgu6oi + upwkh5xz)) +
+ c2 * (ueydbrg6 + 2.0e0 * plce2srm) +
+ c3 * ctfvwdu0;
+
+
+ wjm3[0] = wjm2[0];
+ wjm3[1] = wjm2[1];
+ wjm3[2] = fulcp8wa[1 + (yq6lorbx-1) * *xtov9rbf];
+ wjm2[0] = wjm1[0];
+ wjm2[1] = fulcp8wa[2 + (yq6lorbx-1) * *xtov9rbf];
+ wjm1[0] = fulcp8wa[3 + (yq6lorbx-1) * *xtov9rbf];
+ }
+
+
+ if (*iflag == 0) {
+ return;
+ }
+ Rprintf("plj0trqx must not be a double of length one!\n");
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+ yq6lorbx = *acpios9q - ayfnwr1v + 1;
+ for (gp1jxzuh = 1; gp1jxzuh <= 4 &&
+ yq6lorbx + gp1jxzuh-1 <= *acpios9q; gp1jxzuh++) {
+ plj0trqx[yq6lorbx-1 + (yq6lorbx+gp1jxzuh-2) * *wep0oibc] =
+ fulcp8wa[4-gp1jxzuh + (yq6lorbx-1) * *xtov9rbf];
+ }
+ }
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+ yq6lorbx = *acpios9q - ayfnwr1v + 1;
+ for (gp1jxzuh = yq6lorbx-4; gp1jxzuh >= 1; gp1jxzuh--) {
+ c0 = 1.0 / buhyalv4[3 + (gp1jxzuh-1) * *xtov9rbf];
+ c1 = buhyalv4[0 + (gp1jxzuh+2) * *xtov9rbf] * c0;
+ c2 = buhyalv4[1 + (gp1jxzuh+1) * *xtov9rbf] * c0;
+ c3 = buhyalv4[2 + gp1jxzuh * *xtov9rbf] * c0;
+ plj0trqx[gp1jxzuh-1 + (yq6lorbx-1) * *wep0oibc] = 0.0e0 -
+ ( c1 * plj0trqx[gp1jxzuh+2 + (yq6lorbx-1) * *wep0oibc] +
+ c2 * plj0trqx[gp1jxzuh+1 + (yq6lorbx-1) * *wep0oibc] +
+ c3 * plj0trqx[gp1jxzuh + (yq6lorbx-1) * *wep0oibc] );
+ }
+ }
+}
+
+
+void n5aioudkwmhctl9x(double *qgnl3toc, double sjwyig9t[],
+ double po8rwsmy[], int *kuzxj1lo, int *acpios9q,
+ int *pn9eowxc, // int *icrit,
+ double gkdx5jal[], double rpyis2kc[], double imdvf4hx[],
+ double ifys6woa[], double *i9mwnvqt, double xwy[],
+ double *qcpiaj7f,
+ double zvau2lct[], double f6lsuzax[], double fvh2rwtc[], double dcfir2no[],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double buhyalv4[], double fulcp8wa[], double plj0trqx[],
+ int *xtov9rbf, int *wep0oibc, int *algpft4y) {
+
+
+ double ms0qypiw[16], b0, b1, b2, b3, qaltf0nz = 0.1e-10,
+ g9fvdrbw[4], qtce8hzo, *chw8lzty, egwbdua212 = 0.0e0;
+ int yu6izdrc = 0, pqneb2ra = 1, bvsquk3z = 3, h2dpsbkr = 4,
+ pqzfxw4i, ayfnwr1v, yq6lorbx, dqlr5bse, nkp1 = *acpios9q + 1;
+ double *qnwamo0e1, *qnwamo0e2;
+
+
+
+
+
+ qnwamo0e1 = rpyis2kc; qnwamo0e2 = xwy;
+ for (ayfnwr1v = 0; ayfnwr1v < *acpios9q; ayfnwr1v++) {
+ *qnwamo0e1++ = *qnwamo0e2++;
+ }
+
+ qnwamo0e1 = zvau2lct; qnwamo0e2 = xecbg0pf;
+ for (ayfnwr1v = 0; ayfnwr1v < *acpios9q; ayfnwr1v++) {
+ buhyalv4[3 + ayfnwr1v * *xtov9rbf] = *qnwamo0e1++ + *i9mwnvqt * *qnwamo0e2++;
+ }
+
+ qnwamo0e1 = f6lsuzax; qnwamo0e2 = z4grbpiq;
+ for (ayfnwr1v = 1; ayfnwr1v <= (*acpios9q-1); ayfnwr1v++) {
+ buhyalv4[2 + ayfnwr1v * *xtov9rbf] = *qnwamo0e1++ + *i9mwnvqt * *qnwamo0e2++;
+ }
+
+ qnwamo0e1 = fvh2rwtc; qnwamo0e2 = d7glzhbj;
+ for (ayfnwr1v = 1; ayfnwr1v <= (*acpios9q-2); ayfnwr1v++) {
+ buhyalv4[1 + (ayfnwr1v+1) * *xtov9rbf] = *qnwamo0e1++ + *i9mwnvqt * *qnwamo0e2++;
+ }
+
+ qnwamo0e1 = dcfir2no; qnwamo0e2 = v2eydbxs;
+ for (ayfnwr1v = 1; ayfnwr1v <= (*acpios9q-3); ayfnwr1v++) {
+ buhyalv4[ (ayfnwr1v+2) * *xtov9rbf] = *qnwamo0e1++ + *i9mwnvqt * *qnwamo0e2++;
+ }
+
+ F77_CALL(dpbfa8)(buhyalv4, xtov9rbf, acpios9q, &bvsquk3z, algpft4y);
+ if (*algpft4y != 0) {
+ Rprintf("In C function wmhctl9x; Error:\n");
+ Rprintf("Leading minor of order %d is not pos-def\n", *algpft4y);
+ return;
+ }
+ F77_CALL(dpbsl8)(buhyalv4, xtov9rbf, acpios9q, &bvsquk3z, rpyis2kc);
+
+ chw8lzty = sjwyig9t; qnwamo0e1 = imdvf4hx;
+ for (ayfnwr1v = 1; ayfnwr1v <= *kuzxj1lo; ayfnwr1v++) {
+ F77_CALL(wbvalue)(gkdx5jal, rpyis2kc, acpios9q, &h2dpsbkr,
+ chw8lzty++, &yu6izdrc, qnwamo0e1++);
+ }
+
+
+ n5aioudkvmnweiy2(buhyalv4, fulcp8wa, plj0trqx, xtov9rbf, acpios9q, wep0oibc, &yu6izdrc);
+
+ //Rprintf("first one n5aioudkwmhctl9x pow(po8rwsmy[0], (double) 1.0) = ");
+ //Rprintf("%9.5e\n", pow(po8rwsmy[0], (double) 1.0));
+
+ chw8lzty = sjwyig9t;
+ for (ayfnwr1v = 1; ayfnwr1v <= *kuzxj1lo; ayfnwr1v++) {
+
+ F77_CALL(vinterv)(gkdx5jal, &nkp1, chw8lzty, &dqlr5bse, &pqzfxw4i);
+
+ if (pqzfxw4i == -1) {
+ dqlr5bse = 4;
+ *chw8lzty = gkdx5jal[3] + qaltf0nz;
+ } else
+ if (pqzfxw4i == 1) {
+ dqlr5bse = *acpios9q;
+ *chw8lzty = gkdx5jal[*acpios9q] - qaltf0nz;
+ }
+ yq6lorbx = dqlr5bse-3;
+
+ F77_CALL(vbsplvd)(gkdx5jal, &h2dpsbkr, chw8lzty++, &dqlr5bse,
+ ms0qypiw, g9fvdrbw, &pqneb2ra);
+
+ b0 = g9fvdrbw[0]; b1 = g9fvdrbw[1]; b2 = g9fvdrbw[2]; b3 = g9fvdrbw[3];
+
+ qtce8hzo = (b0 * (fulcp8wa[3 + (yq6lorbx-1) * *xtov9rbf] * b0 +
+ 2.0e0* (fulcp8wa[2 + (yq6lorbx-1) * *xtov9rbf] * b1 +
+ fulcp8wa[1 + (yq6lorbx-1) * *xtov9rbf] * b2 +
+ fulcp8wa[0 + (yq6lorbx-1) * *xtov9rbf] * b3)) +
+ b1 * (fulcp8wa[3 + yq6lorbx * *xtov9rbf] * b1 +
+ 2.0e0* (fulcp8wa[2 + yq6lorbx * *xtov9rbf] * b2 +
+ fulcp8wa[1 + yq6lorbx * *xtov9rbf] * b3)) +
+ b2 * (fulcp8wa[3 + (yq6lorbx+1) * *xtov9rbf] * b2 +
+ 2.0e0* fulcp8wa[2 + (yq6lorbx+1) * *xtov9rbf] * b3) +
+ fulcp8wa[3 + (yq6lorbx+2) * *xtov9rbf] *
+ pow(b3, (double) 2.0)) *
+ po8rwsmy[ayfnwr1v-1];
+ ifys6woa[ayfnwr1v-1] = qtce8hzo;
+ }
+
+ if (*pn9eowxc == 1) {
+ return;
+ }
+
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *kuzxj1lo; ayfnwr1v++) {
+ egwbdua212 += ifys6woa[ayfnwr1v-1];
+ }
+ *qcpiaj7f = pow(*qgnl3toc - egwbdua212, (double) 2.0);
+}
+
+
+void n5aioudkgt9iulbf(double sjwyig9t[], double ghz9vuba[], double po8rwsmy[],
+ double gkdx5jal[], int *rvy1fpli, int *kuzxj1lo, double zyupcmk6[],
+ double zvau2lct[], double f6lsuzax[], double fvh2rwtc[], double dcfir2no[]) {
+
+
+
+ double g9fvdrbw[4], ms0qypiw[16], wsvdbx3tk, wv2svdbx3tk, qaltf0nz = 0.1e-9;
+ int ayfnwr1v, yq6lorbx, dqlr5bse, pqzfxw4i, nhnpt1zym1 = *kuzxj1lo + 1,
+ pqneb2ra = 1, h2dpsbkr = 4;
+ double *qnwamo0e0, *qnwamo0e1, *qnwamo0e2, *qnwamo0e3, *qnwamo0e4;
+
+ qnwamo0e0 = zvau2lct; qnwamo0e1 = f6lsuzax; qnwamo0e2 = fvh2rwtc; qnwamo0e3 = dcfir2no; qnwamo0e4 = zyupcmk6;
+ for (ayfnwr1v = 0; ayfnwr1v < *kuzxj1lo; ayfnwr1v++) {
+ *qnwamo0e0++ = *qnwamo0e1++ = *qnwamo0e2++ = *qnwamo0e3++ = *qnwamo0e4++ = 0.0e0;
+ }
+
+ //Rprintf("first one n5aioudkgt9iulbf pow(po8rwsmy[0], (double) 1.0) = ");
+ //Rprintf("%9.5e\n", pow(po8rwsmy[0], (double) 1.0));
+
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *rvy1fpli; ayfnwr1v++) {
+
+ F77_CALL(vinterv)(gkdx5jal, &nhnpt1zym1, sjwyig9t + ayfnwr1v - 1, &dqlr5bse, &pqzfxw4i);
+
+ if (pqzfxw4i == 1) {
+ if (sjwyig9t[ayfnwr1v-1] <= (gkdx5jal[dqlr5bse-1] + qaltf0nz)) {
+ dqlr5bse--;
+ } else {
+ return;
+ }
+ }
+
+ F77_CALL(vbsplvd)(gkdx5jal, &h2dpsbkr, sjwyig9t + ayfnwr1v - 1, &dqlr5bse,
+ ms0qypiw, g9fvdrbw, &pqneb2ra);
+
+
+ yq6lorbx = dqlr5bse - 4 + 1;
+ wsvdbx3tk = po8rwsmy[ayfnwr1v-1];
+ wv2svdbx3tk = wsvdbx3tk * g9fvdrbw[0];
+ zyupcmk6[yq6lorbx-1] += wv2svdbx3tk * ghz9vuba[ayfnwr1v-1];
+ zvau2lct[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[0];
+ f6lsuzax[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[1];
+ fvh2rwtc[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[2];
+ dcfir2no[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[3];
+
+ yq6lorbx = dqlr5bse - 4 + 2;
+ wv2svdbx3tk = wsvdbx3tk * g9fvdrbw[1];
+ zyupcmk6[yq6lorbx-1] += wv2svdbx3tk * ghz9vuba[ayfnwr1v-1];
+ zvau2lct[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[1];
+ f6lsuzax[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[2];
+ fvh2rwtc[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[3];
+
+ yq6lorbx = dqlr5bse - 4 + 3;
+ wv2svdbx3tk = wsvdbx3tk * g9fvdrbw[2];
+ zyupcmk6[yq6lorbx-1] += wv2svdbx3tk * ghz9vuba[ayfnwr1v-1];
+ zvau2lct[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[2];
+ f6lsuzax[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[3];
+ yq6lorbx = dqlr5bse;
+ wv2svdbx3tk = wsvdbx3tk * g9fvdrbw[3];
+ zyupcmk6[yq6lorbx-1] += wv2svdbx3tk * ghz9vuba[ayfnwr1v-1];
+ zvau2lct[yq6lorbx-1] += wv2svdbx3tk * g9fvdrbw[3];
+ }
+}
+
diff --git a/src/testf90.f90 b/src/testf90.f90
deleted file mode 100644
index f85a83d..0000000
--- a/src/testf90.f90
+++ /dev/null
@@ -1,96 +0,0 @@
-
-
-
-subroutine vgamf90fill9(vec, veclen, ansvec)
-implicit none
-
-integer :: veclen
-double precision :: vec(veclen), ansvec(veclen)
-double precision, allocatable :: workspace1(:)
-
-integer :: iii
-
-allocate(workspace1(veclen))
-do iii = 1, veclen
- workspace1(iii) = iii
- ansvec(iii) = vec(iii) + workspace1(iii)
-end do
-deallocate(workspace1)
-
-end subroutine vgamf90fill9
-
-
-
-
-
-
-
-
-subroutine vgamf90mux34(xmat, Dmat, nrowx, ncolx, symmetric, ansvec)
-implicit none
-
-
-integer :: nrowx, ncolx, symmetric
-double precision :: xmat(nrowx,ncolx), Dmat(ncolx,ncolx), ansvec(nrowx)
-
-integer :: iii, jay, kay
-
-if(ncolx .eq. 1) then
- do iii = 1, nrowx
- ansvec(iii) = Dmat(1,1) * xmat(iii, 1)**2
- end do
- return
-end if
-
-if(symmetric .eq. 1) then
- do iii = 1, nrowx
- ansvec(iii) = 0.0d0
- do jay = 1, ncolx
- ansvec(iii) = ansvec(iii) + Dmat(jay,jay) * xmat(iii, jay)**2
- end do
- if(ncolx .gt. 1) then
- do jay = 1, ncolx
- do kay = jay+1, ncolx
- ansvec(iii) = ansvec(iii) + 2.0 * Dmat(jay,kay) * &
- xmat(iii, jay) * xmat(iii, kay)
- end do
- end do
- end if
- end do
-else
- do iii = 1, nrowx
- ansvec(iii) = 0.0d0
- do jay = 1, ncolx
- do kay = 1, ncolx
- ansvec(iii) = ansvec(iii) + &
- Dmat(jay,kay) * xmat(iii, jay) * xmat(iii, kay)
- end do
- end do
- end do
-end if
-
-return
-end subroutine vgamf90mux34
-
-
-
-
-
-subroutine vgamf90memalloc(m, n)
-implicit none
-
-integer :: m, n
-real(kind(0.0d0)), allocatable :: A(:,:)
-integer :: errno
-
-allocate(A(m,n), stat=errno)
-if(errno /= 0) then ! allocation failed
- call INTPR("in vgamf90memalloc; errno: ",-1, errno, 1)
- stop
-end if
-
-return
-end subroutine vgamf90memalloc
-
-
-
diff --git a/src/tyeepolygamma.f b/src/tyeepolygamma.f
deleted file mode 100644
index 1f90e43..0000000
--- a/src/tyeepolygamma.f
+++ /dev/null
@@ -1,151 +0,0 @@
- subroutine vdgam1(x, ghry8z, c4uxow)
- implicit logical (a-z)
- double precision x, ghry8z
- integer c4uxow
- double precision w, sqap4b, temp
- c4uxow = 1
- if(.not.(x .le. 0.0d0))goto 23000
- c4uxow = 0
- return
-23000 continue
- if(.not.(x .lt. 6.0d0))goto 23002
- call vdgam2(x + 6.0d0, temp, c4uxow)
- ghry8z = temp - 1.0d0/x - 1.0d0/(x + 1.0d0) - 1.0d0/(x + 2.0d0) -
- &1.0d0/(x + 3.0d0) - 1.0d0/(x + 4.0d0) - 1.0d0/(x + 5.0d0)
- return
-23002 continue
- w = 1.0d0 / (x * x)
- sqap4b = ((w * (-1.0d0/12.0d0 + ((w * (1.0d0/120.0d0 + ((w * (-1.
- &0d0/252.0d0 + ((w * (1.0d0/240.0d0 + ((w * (-1.0d0/132.0d0 + ((w *
- & (691.0d0/32760.0d0 + ((w * (-1.0d0/12.0d0 + (3617.0d0 * w)/8160.
- &0d0)))))))))))))))))))))
- ghry8z = ( dlog(x) - 0.5d0/x + sqap4b )
- return
- end
- subroutine vdgam2(x, ghry8z, c4uxow)
- implicit logical (a-z)
- double precision x, ghry8z
- integer c4uxow
- double precision w, sqap4b, temp
- c4uxow = 1
- if(.not.(x .le. 0.0d0))goto 23004
- c4uxow = 0
- return
-23004 continue
- if(.not.(x .lt. 6.0d0))goto 23006
- call vdgam1(x + 6.0d0, temp, c4uxow)
- ghry8z = temp - 1.0d0/x - 1.0d0/(x + 1.0d0) - 1.0d0/(x + 2.0d0) -
- &1.0d0/(x + 3.0d0) - 1.0d0/(x + 4.0d0) - 1.0d0/(x + 5.0d0)
- return
-23006 continue
- w = 1.0d0 / (x * x)
- sqap4b = ((w * (-1.0d0/12.0d0 + ((w * (1.0d0/120.0d0 + ((w * (-1.
- &0d0/252.0d0 + ((w * (1.0d0/240.0d0 + ((w * (-1.0d0/132.0d0 + ((w *
- & (691.0d0/32760.0d0 + ((w * (-1.0d0/12.0d0 + (3617.0d0 * w)/8160.
- &0d0)))))))))))))))))))))
- ghry8z = ( dlog(x) - 0.5d0/x + sqap4b )
- return
- end
- subroutine vtgam1(x, ghry8z, c4uxow)
- implicit logical (a-z)
- double precision x, ghry8z
- integer c4uxow
- double precision w, sqap4b, temp
- c4uxow = 1
- if(.not.(x .le. 0.0d0))goto 23008
- c4uxow = 0
- return
-23008 continue
- if(.not.(x .lt. 6.0d0))goto 23010
- call vtgam2(x + 6.0d0, temp, c4uxow)
- ghry8z = temp + 1.0d0/x**2 + 1.0d0/(x + 1.0d0)**2 + 1.0d0/(x + 2.
- &0d0)**2 + 1.0d0/(x + 3.0d0)**2 + 1.0d0/(x + 4.0d0)**2 + 1.0d0/(x +
- & 5.0d0)**2
- return
-23010 continue
- w = 1.0d0 / (x * x)
- sqap4b = 1.0d0 + (w * (1.0d0/6.0d0 + (w * (-1.0d0/30.0d0 + (w * (
- &1.0d0/42.0d0 + (w * (-1.0d0/30.0d0 + (w * (5.0d0/66.0d0 + (w * (-
- &691.0d0/2370.0d0 + (w * (7.0d0/6.0d0 - (3617.0d0 * w)/510.0d0)))))
- &)))))))))
- ghry8z = 0.5d0 * w + sqap4b / x
- return
- end
- subroutine vtgam2(x, ghry8z, c4uxow)
- implicit logical (a-z)
- double precision x, ghry8z
- integer c4uxow
- double precision w, sqap4b, temp
- c4uxow = 1
- if(.not.(x .le. 0.0d0))goto 23012
- c4uxow = 0
- return
-23012 continue
- if(.not.(x .lt. 6.0d0))goto 23014
- call vtgam1(x + 6.0d0, temp, c4uxow)
- ghry8z = temp + 1.0d0/x**2 + 1.0d0/(x + 1.0d0)**2 + 1.0d0/(x + 2.
- &0d0)**2 + 1.0d0/(x + 3.0d0)**2 + 1.0d0/(x + 4.0d0)**2 + 1.0d0/(x +
- & 5.0d0)**2
- return
-23014 continue
- w = 1.0d0 / (x * x)
- sqap4b = 1.0d0 + (w * (1.0d0/6.0d0 + (w * (-1.0d0/30.0d0 + (w * (
- &1.0d0/42.0d0 + (w * (-1.0d0/30.0d0 + (w * (5.0d0/66.0d0 + (w * (-
- &691.0d0/2370.0d0 + (w * (7.0d0/6.0d0 - (3617.0d0 * w)/510.0d0)))))
- &)))))))))
- ghry8z = 0.5d0 * w + sqap4b / x
- return
- end
- subroutine dgam1w(x, ghry8z, n, c4uxow)
- implicit logical (a-z)
- integer n, c4uxow
- double precision x(n), ghry8z(n)
- integer i, lqhm2g
- c4uxow = 1
- do 23016 i=1,n
- call vdgam1(x(i), ghry8z(i), lqhm2g)
- if(.not.(lqhm2g .ne. 1))goto 23018
- c4uxow = lqhm2g
-23018 continue
-23016 continue
- return
- end
- subroutine tgam1w(x, ghry8z, n, c4uxow)
- implicit logical (a-z)
- integer n, c4uxow
- double precision x(n), ghry8z(n)
- integer i, lqhm2g
- c4uxow = 1
- do 23020 i=1,n
- call vtgam1(x(i), ghry8z(i), lqhm2g)
- if(.not.(lqhm2g .ne. 1))goto 23022
- c4uxow = lqhm2g
-23022 continue
-23020 continue
- return
- end
- subroutine cum8sum(bz4gufr, ghry8z, nghry8z, valong, ntot,
- ¬c4uxow)
- implicit logical (a-z)
- integer nghry8z, ntot, notc4uxow
- double precision bz4gufr(ntot), ghry8z(nghry8z), valong(ntot)
- integer w3gohz, p1rifj
- p1rifj = 1
- ghry8z(p1rifj) = bz4gufr(p1rifj)
- do 23024 w3gohz=2,ntot
- if(.not.(valong(w3gohz) .gt. valong(w3gohz-1)))goto 23026
- ghry8z(p1rifj) = ghry8z(p1rifj) + bz4gufr(w3gohz)
- goto 23027
-23026 continue
- p1rifj = p1rifj + 1
- ghry8z(p1rifj) = bz4gufr(w3gohz)
-23027 continue
-23024 continue
- if(.not.(p1rifj .eq. nghry8z))goto 23028
- notc4uxow = 0
- goto 23029
-23028 continue
- notc4uxow = 1
-23029 continue
- return
- end
diff --git a/src/tyeepolygamma3.c b/src/tyeepolygamma3.c
new file mode 100644
index 0000000..62a1665
--- /dev/null
+++ b/src/tyeepolygamma3.c
@@ -0,0 +1,137 @@
+
+
+
+#include<math.h>
+#include<stdio.h>
+#include<stdlib.h>
+#include<R.h>
+#include<Rmath.h>
+
+void tyee_C_vdgam1(double *xval, double *lfu2qhid, int *dvhw1ulq);
+void tyee_C_vtgam1(double *xval, double *lfu2qhid, int *dvhw1ulq);
+void tyee_C_dgam1w(double sjwyig9t[], double lfu2qhid[], int *f8yswcat, int *dvhw1ulq);
+void tyee_C_tgam1w(double sjwyig9t[], double lfu2qhid[], int *f8yswcat, int *dvhw1ulq);
+void tyee_C_cum8sum(double ci1oyxas[], double lfu2qhid[], int *nlfu2qhid,
+ double valong[], int *ntot, int *notdvhw1ulq);
+
+void tyee_C_vdgam1(double *xval, double *lfu2qhid, int *dvhw1ulq) {
+
+
+ double wval, series, obr6tcex, tmp1;
+
+ *dvhw1ulq = 1;
+ if (*xval <= 0.0e0) {
+ *dvhw1ulq = 0;
+ return;
+ }
+
+ if (*xval < 6.0e0) {
+ tmp1 = *xval + 6.0e0;
+ tyee_C_vdgam1(&tmp1, &obr6tcex, dvhw1ulq);
+ *lfu2qhid = obr6tcex - 1.0e0 / *xval - 1.0e0 / (*xval + 1.0e0) -
+ 1.0e0 / (*xval + 2.0e0) - 1.0e0 / (*xval + 3.0e0) -
+ 1.0e0 / (*xval + 4.0e0) - 1.0e0 / (*xval + 5.0e0);
+ return;
+ }
+ wval = 1.0e0 / (*xval * *xval);
+ series = ((wval * ( -1.0e0 / 12.0e0 +
+ ((wval * ( 1.0e0 / 120.0e0 +
+ ((wval * ( -1.0e0 / 252.0e0 +
+ ((wval * ( 1.0e0 / 240.0e0 +
+ ((wval * ( -1.0e0 / 132.0e0 +
+ ((wval * (691.0e0 /32760.0e0 +
+ ((wval * ( -1.0e0 / 12.0e0 +
+ (wval * 3617.0e0)/ 8160.0e0)))))))))))))))))))));
+ *lfu2qhid = log(*xval) - 0.5e0 / *xval + series;
+}
+
+
+
+void tyee_C_vtgam1(double *xval, double *lfu2qhid, int *dvhw1ulq) {
+
+
+ double wval, series, obr6tcex, tmp1;
+ *dvhw1ulq = 1;
+
+ if (*xval <= 0.0e0) {
+ *dvhw1ulq = 0;
+ return;
+ }
+
+ if (*xval < 6.0e0) {
+ tmp1 = *xval + 6.0e0;
+ tyee_C_vtgam1(&tmp1, &obr6tcex, dvhw1ulq);
+ *lfu2qhid = obr6tcex +
+ 1.0e0 / pow( (double) *xval, (double) 2.0) +
+ 1.0e0 / pow( (double) (*xval + 1.0e0), (double) 2.0) +
+ 1.0e0 / pow( (double) (*xval + 2.0e0), (double) 2.0) +
+ 1.0e0 / pow( (double) (*xval + 3.0e0), (double) 2.0) +
+ 1.0e0 / pow( (double) (*xval + 4.0e0), (double) 2.0) +
+ 1.0e0 / pow( (double) (*xval + 5.0e0), (double) 2.0);
+ return;
+ }
+ wval = 1.0e0 / (*xval * *xval);
+ series = 1.0e0 +
+ (wval * ( 1.0e0 / 6.0e0 +
+ (wval * ( -1.0e0 / 30.0e0 +
+ (wval * ( 1.0e0 / 42.0e0 +
+ (wval * ( -1.0e0 / 30.0e0 +
+ (wval * ( 5.0e0 / 66.0e0 +
+ (wval * (-691.0e0 /2370.0e0 +
+ (wval * ( 7.0e0 / 6.0e0 -
+ (wval * 3617.0e0)/ 510.0e0))))))))))))));
+ *lfu2qhid = 0.5e0 * wval + series / *xval;
+}
+
+
+
+void tyee_C_dgam1w(double sjwyig9t[], double lfu2qhid[], int *f8yswcat, int *dvhw1ulq) {
+
+ int ayfnwr1v, okobr6tcex;
+ double *qnwamo0e1, *qnwamo0e2;
+
+ *dvhw1ulq = 1;
+
+ qnwamo0e1 = sjwyig9t; qnwamo0e2 = lfu2qhid;
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ tyee_C_vdgam1(qnwamo0e1++, qnwamo0e2++, &okobr6tcex);
+ if (okobr6tcex != 1) *dvhw1ulq = okobr6tcex;
+ }
+}
+
+
+void tyee_C_tgam1w(double sjwyig9t[], double lfu2qhid[], int *f8yswcat, int *dvhw1ulq) {
+
+ int ayfnwr1v, okobr6tcex;
+ double *qnwamo0e1, *qnwamo0e2;
+
+ *dvhw1ulq = 1;
+
+ qnwamo0e1 = sjwyig9t; qnwamo0e2 = lfu2qhid;
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ tyee_C_vtgam1(qnwamo0e1++, qnwamo0e2++, &okobr6tcex);
+ if (okobr6tcex != 1) *dvhw1ulq = okobr6tcex;
+ }
+}
+
+
+
+void tyee_C_cum8sum(double ci1oyxas[], double lfu2qhid[], int *nlfu2qhid,
+ double valong[], int *ntot, int *notdvhw1ulq) {
+
+
+ int ayfnwr1v, iii = 1;
+
+ lfu2qhid[iii-1] = ci1oyxas[iii-1];
+ for (ayfnwr1v = 2; ayfnwr1v <= *ntot; ayfnwr1v++) {
+ if (valong[ayfnwr1v-1] > valong[ayfnwr1v-2]) {
+ lfu2qhid[iii-1] += ci1oyxas[ayfnwr1v-1];
+ } else {
+ iii++;
+ lfu2qhid[iii-1] = ci1oyxas[ayfnwr1v-1];
+ }
+ }
+
+ *notdvhw1ulq = (iii == *nlfu2qhid) ? 0 : 1;
+}
+
diff --git a/src/vgam.f b/src/vgam.f
index 057c22b..25bbe1c 100644
--- a/src/vgam.f
+++ b/src/vgam.f
@@ -1,1265 +1,1322 @@
- subroutine vbvs(nfiumb4,knot,j1l0o1,nk,p3vlea,ocaxi1,ikscn4,
- &lku8xq)
- integer nfiumb4, nk, ikscn4, lku8xq
- double precision knot(nk+4), j1l0o1(nk,lku8xq), p3vlea(nfiumb4),
- &ocaxi1(nfiumb4,lku8xq)
- double precision xvalue
- integer w3gohz, d9rjek, def4wn
- def4wn = 4
- do 23000 d9rjek=1,lku8xq
- do 23002 w3gohz=1,nfiumb4
- xvalue = p3vlea(w3gohz)
- call wbvalue(knot, j1l0o1(1,d9rjek), nk, def4wn, xvalue, ikscn4,
- &ocaxi1(w3gohz,d9rjek))
+ subroutine vbvs(kuzxj1lo,ankcghz2,rpyis2kc,nk,he7mqnvy,smat,order,
+ &wy1vqfzu)
+ integer kuzxj1lo, nk, order, wy1vqfzu
+ double precision ankcghz2(nk+4), rpyis2kc(nk,wy1vqfzu), he7mqnvy(
+ &kuzxj1lo), smat(kuzxj1lo,wy1vqfzu)
+ double precision chw8lzty
+ integer ayfnwr1v, yq6lorbx, ifour4
+ ifour4 = 4
+ do 23000 yq6lorbx=1,wy1vqfzu
+ do 23002 ayfnwr1v=1,kuzxj1lo
+ chw8lzty = he7mqnvy(ayfnwr1v)
+ call wbvalue(ankcghz2, rpyis2kc(1,yq6lorbx), nk, ifour4, chw8lzty,
+ & order, smat(ayfnwr1v,yq6lorbx))
23002 continue
23000 continue
return
end
- subroutine j3navf(nkzg2p, nk, lku8xq, a51l0o, l6xrjt, nf8brk)
+ subroutine tfeswo7c(osiz4fxy, nk, wy1vqfzu, ldk, wbkq9zyi, sgmat)
implicit logical (a-z)
- integer nk, lku8xq, a51l0o
- double precision nkzg2p(a51l0o,nk*lku8xq), l6xrjt(lku8xq), nf8brk(
- &nk,4)
- integer w3gohz, d9rjek
- do 23004 w3gohz=1,nk
- do 23006 d9rjek=1,lku8xq
- nkzg2p(a51l0o,(w3gohz-1)*lku8xq+d9rjek) = nkzg2p(a51l0o,(w3gohz-1)
- &*lku8xq+d9rjek) + l6xrjt(d9rjek) * nf8brk(w3gohz,1)
+ integer nk, wy1vqfzu, ldk
+ double precision osiz4fxy(ldk,nk*wy1vqfzu), wbkq9zyi(wy1vqfzu),
+ &sgmat(nk,4)
+ integer ayfnwr1v, yq6lorbx
+ do 23004 ayfnwr1v=1,nk
+ do 23006 yq6lorbx=1,wy1vqfzu
+ osiz4fxy(ldk,(ayfnwr1v-1)*wy1vqfzu+yq6lorbx) = osiz4fxy(ldk,(
+ &ayfnwr1v-1)*wy1vqfzu+yq6lorbx) + wbkq9zyi(yq6lorbx) * sgmat(
+ &ayfnwr1v,1)
23006 continue
23004 continue
- do 23008 w3gohz=1,(nk-1)
- do 23010 d9rjek=1,lku8xq
- nkzg2p(a51l0o-lku8xq,(w3gohz-0)*lku8xq+d9rjek) = nkzg2p(a51l0o-
- &lku8xq,(w3gohz-0)*lku8xq+d9rjek) + l6xrjt(d9rjek) * nf8brk(w3gohz,
- &2)
+ do 23008 ayfnwr1v=1,(nk-1)
+ do 23010 yq6lorbx=1,wy1vqfzu
+ osiz4fxy(ldk-wy1vqfzu,(ayfnwr1v-0)*wy1vqfzu+yq6lorbx) = osiz4fxy(
+ &ldk-wy1vqfzu,(ayfnwr1v-0)*wy1vqfzu+yq6lorbx) + wbkq9zyi(yq6lorbx)
+ &* sgmat(ayfnwr1v,2)
23010 continue
23008 continue
- do 23012 w3gohz=1,(nk-2)
- do 23014 d9rjek=1,lku8xq
- nkzg2p(a51l0o-2*lku8xq,(w3gohz+1)*lku8xq+d9rjek) = nkzg2p(a51l0o-
- &2*lku8xq,(w3gohz+1)*lku8xq+d9rjek) + l6xrjt(d9rjek) * nf8brk(
- &w3gohz,3)
+ do 23012 ayfnwr1v=1,(nk-2)
+ do 23014 yq6lorbx=1,wy1vqfzu
+ osiz4fxy(ldk-2*wy1vqfzu,(ayfnwr1v+1)*wy1vqfzu+yq6lorbx) =
+ &osiz4fxy(ldk-2*wy1vqfzu,(ayfnwr1v+1)*wy1vqfzu+yq6lorbx) +
+ &wbkq9zyi(yq6lorbx) * sgmat(ayfnwr1v,3)
23014 continue
23012 continue
- do 23016 w3gohz=1,(nk-3)
- do 23018 d9rjek=1,lku8xq
- nkzg2p(a51l0o-3*lku8xq,(w3gohz+2)*lku8xq+d9rjek) = nkzg2p(a51l0o-
- &3*lku8xq,(w3gohz+2)*lku8xq+d9rjek) + l6xrjt(d9rjek) * nf8brk(
- &w3gohz,4)
+ do 23016 ayfnwr1v=1,(nk-3)
+ do 23018 yq6lorbx=1,wy1vqfzu
+ osiz4fxy(ldk-3*wy1vqfzu,(ayfnwr1v+2)*wy1vqfzu+yq6lorbx) =
+ &osiz4fxy(ldk-3*wy1vqfzu,(ayfnwr1v+2)*wy1vqfzu+yq6lorbx) +
+ &wbkq9zyi(yq6lorbx) * sgmat(ayfnwr1v,4)
23018 continue
23016 continue
return
end
- subroutine wgy5ta(p1rifj, s17te9, nbbad, uq9jtc, nkzg2p, w8xfic,
- &evgfu3, anke8p, lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l,
- &vvl1li)
+ subroutine ybnagt8k(iii, cz8qdfyj, tesdm5kv, g9fvdrbw, osiz4fxy,
+ &wmat, kxvq6sfw, nyfu9rod, wy1vqfzu, ldk, dimw, kuzxj1lo, nk,
+ &tgiyxdw1, dufozmt7)
implicit logical (a-z)
- integer p1rifj, s17te9, nbbad, evgfu3, anke8p, lku8xq, a51l0o,
- &xhe4cg, nfiumb4, nk, zqve1l(1), vvl1li(1)
- double precision uq9jtc(4,1), nkzg2p(a51l0o, nk*lku8xq), w8xfic(
- &nfiumb4,xhe4cg)
- double precision temp
- integer xi1mqb, j3ymns, bcol, brow, y9eilo, pazyk8
- bcol = s17te9 + nbbad
- brow = s17te9
- do 23020 xi1mqb=1,xhe4cg
- temp = w8xfic(p1rifj,xi1mqb) * uq9jtc(evgfu3,1) * uq9jtc(anke8p,1)
- y9eilo = (brow-1)*lku8xq + zqve1l(xi1mqb)
- pazyk8 = (bcol-1)*lku8xq + vvl1li(xi1mqb)
- j3ymns = pazyk8 - y9eilo
- nkzg2p(a51l0o-j3ymns, pazyk8) = nkzg2p(a51l0o-j3ymns, pazyk8) +
- &temp
- if(.not.(nbbad .gt. 0 .and. vvl1li(xi1mqb) .ne. zqve1l(xi1mqb)))
- &goto 23022
- y9eilo = (brow-1)*lku8xq + vvl1li(xi1mqb)
- pazyk8 = (bcol-1)*lku8xq + zqve1l(xi1mqb)
- j3ymns = pazyk8 - y9eilo
- nkzg2p(a51l0o-j3ymns, pazyk8) = nkzg2p(a51l0o-j3ymns, pazyk8) +
- &temp
+ integer iii, cz8qdfyj, tesdm5kv, kxvq6sfw, nyfu9rod, wy1vqfzu,
+ &ldk, dimw, kuzxj1lo, nk, tgiyxdw1(1), dufozmt7(1)
+ double precision g9fvdrbw(4,1), osiz4fxy(ldk, nk*wy1vqfzu), wmat(
+ &kuzxj1lo,dimw)
+ double precision obr6tcex
+ integer urohxe6t, nead, bcol, brow, biuvowq2, nbj8tdsk
+ bcol = cz8qdfyj + tesdm5kv
+ brow = cz8qdfyj
+ do 23020 urohxe6t=1,dimw
+ obr6tcex = wmat(iii,urohxe6t) * g9fvdrbw(kxvq6sfw,1) * g9fvdrbw(
+ &nyfu9rod,1)
+ biuvowq2 = (brow-1)*wy1vqfzu + tgiyxdw1(urohxe6t)
+ nbj8tdsk = (bcol-1)*wy1vqfzu + dufozmt7(urohxe6t)
+ nead = nbj8tdsk - biuvowq2
+ osiz4fxy(ldk-nead, nbj8tdsk) = osiz4fxy(ldk-nead, nbj8tdsk) +
+ &obr6tcex
+ if(.not.(tesdm5kv .gt. 0 .and. dufozmt7(urohxe6t) .ne. tgiyxdw1(
+ &urohxe6t)))goto 23022
+ biuvowq2 = (brow-1)*wy1vqfzu + dufozmt7(urohxe6t)
+ nbj8tdsk = (bcol-1)*wy1vqfzu + tgiyxdw1(urohxe6t)
+ nead = nbj8tdsk - biuvowq2
+ osiz4fxy(ldk-nead, nbj8tdsk) = osiz4fxy(ldk-nead, nbj8tdsk) +
+ &obr6tcex
23022 continue
23020 continue
return
end
- subroutine vsplin(p3vlea,lj4dph,w8xfic,nfiumb4,onyz6j, nk,a51l0o,
- &lku8xq,xhe4cg, zqve1l,vvl1li, zxao0o, l6xrjt, fjg0qv, w5poyv,
- &j1l0o1, nkzg2p, cy3dhl, vb81l0, l8dgox, y6jcvk, bmb, rjcq9o, dof,
- &sz6ohy, la5dcf, e5jrsg)
+ subroutine vsplin(he7mqnvy,rbne6ouj,wmat,kuzxj1lo,gkdx5jal, nk,
+ &ldk,wy1vqfzu,dimw, tgiyxdw1,dufozmt7, wkmm, wbkq9zyi, info,
+ &t8hwvalr, rpyis2kc, osiz4fxy, btwy, sgdub, ui8ysltq, yzoe1rsp,
+ &bmb, ifys6woa, dof, scrtch, fbd5yktj, truen)
implicit logical (a-z)
- integer nfiumb4, nk, a51l0o, lku8xq, xhe4cg, zqve1l(1), vvl1li(1),
- & fjg0qv, la5dcf, e5jrsg
- integer y6jcvk
- double precision p3vlea(nfiumb4), lj4dph(nfiumb4,lku8xq), w8xfic(
- &nfiumb4,xhe4cg), onyz6j(nk+4), zxao0o(lku8xq,lku8xq,16), l6xrjt(
- &lku8xq), w5poyv(nfiumb4,lku8xq), j1l0o1(nk,lku8xq), nkzg2p(a51l0o,
- &nk*lku8xq), cy3dhl(lku8xq,nk)
- double precision vb81l0(nk,lku8xq), l8dgox(e5jrsg,lku8xq), bmb(
- &lku8xq,lku8xq), rjcq9o(nfiumb4,lku8xq), dof(lku8xq), sz6ohy(1)
- integer d9rjek, w3gohz, m5xudf, i6ndbu, xi1mqb, rlhz2a
- integer yc1ezl, mk2vyr, thfyl1, hts1gp(3), ispar, opf6cv
- double precision kqoy6w, uq9jtc(4,1), z2djpt(16), egoxa3, n9peut,
- &bt9lgm, v2isnf, fjo2dydf, fpcb2n(3)
- do 23024 d9rjek=1,lku8xq
- if(.not.(l6xrjt(d9rjek) .eq. 0.0d0))goto 23026
+ integer kuzxj1lo, nk, ldk, wy1vqfzu, dimw, tgiyxdw1(1), dufozmt7(
+ &1), info, fbd5yktj, truen
+ integer yzoe1rsp
+ double precision he7mqnvy(kuzxj1lo), rbne6ouj(kuzxj1lo,wy1vqfzu),
+ &wmat(kuzxj1lo,dimw), gkdx5jal(nk+4), wkmm(wy1vqfzu,wy1vqfzu,16),
+ &wbkq9zyi(wy1vqfzu), t8hwvalr(kuzxj1lo,wy1vqfzu), rpyis2kc(nk,
+ &wy1vqfzu), osiz4fxy(ldk,nk*wy1vqfzu), btwy(wy1vqfzu,nk)
+ double precision sgdub(nk,wy1vqfzu), ui8ysltq(truen,wy1vqfzu),
+ &bmb(wy1vqfzu,wy1vqfzu), ifys6woa(kuzxj1lo,wy1vqfzu), dof(wy1vqfzu)
+ &, scrtch(1)
+ integer yq6lorbx, ayfnwr1v, dqlr5bse, pqzfxw4i, urohxe6t, icrit
+ integer gp0xjetb, e5knafcg, wep0oibc, l3zpbstu(3), ispar, i1loc
+ double precision qaltf0nz, g9fvdrbw(4,1), ms0qypiw(16), penalt,
+ &qcpiaj7f, fp6nozvx, waiez6nt, toldf, parms(3)
+ do 23024 yq6lorbx=1,wy1vqfzu
+ if(.not.(wbkq9zyi(yq6lorbx) .eq. 0.0d0))goto 23026
ispar=0
- rlhz2a=3
+ icrit=3
goto 23027
23026 continue
ispar=1
- rlhz2a=1
+ icrit=1
23027 continue
- if(.not.((lku8xq .eq. 1) .or. (xhe4cg.eq.lku8xq) .or. (ispar .eq.
- &0)))goto 23028
- mk2vyr = 4
- bt9lgm = 1.50d0
- v2isnf = 0.00d0
- thfyl1 = 1
- fjo2dydf=0.001d0
- if(.not.(lku8xq.eq.1))goto 23030
- fjo2dydf=0.005d0
+ if(.not.((wy1vqfzu .eq. 1) .or. (dimw.eq.wy1vqfzu) .or. (ispar
+ &.eq. 0)))goto 23028
+ e5knafcg = 4
+ fp6nozvx = 1.50d0
+ waiez6nt = 0.00d0
+ wep0oibc = 1
+ toldf=0.001d0
+ if(.not.(wy1vqfzu.eq.1))goto 23030
+ toldf=0.005d0
goto 23031
23030 continue
- if(.not.(lku8xq.eq.2))goto 23032
- fjo2dydf=0.015d0
+ if(.not.(wy1vqfzu.eq.2))goto 23032
+ toldf=0.015d0
goto 23033
23032 continue
- if(.not.(lku8xq.eq.3))goto 23034
- fjo2dydf=0.025d0
+ if(.not.(wy1vqfzu.eq.3))goto 23034
+ toldf=0.025d0
goto 23035
23034 continue
- fjo2dydf=0.045d0
+ toldf=0.045d0
23035 continue
23033 continue
23031 continue
- hts1gp(1) = rlhz2a
- hts1gp(2) = ispar
- hts1gp(3) = 300
- fpcb2n(1) = v2isnf
- fpcb2n(2) = bt9lgm
- fpcb2n(3) = fjo2dydf
- yc1ezl=0
- if(.not.((lku8xq .eq. 1) .or. (xhe4cg.eq.lku8xq)))goto 23036
- do 23038 w3gohz=1,nfiumb4
- lj4dph(w3gohz,d9rjek) = lj4dph(w3gohz,d9rjek) / w8xfic(w3gohz,
- &d9rjek)
+ l3zpbstu(1) = icrit
+ l3zpbstu(2) = ispar
+ l3zpbstu(3) = 300
+ parms(1) = waiez6nt
+ parms(2) = fp6nozvx
+ parms(3) = toldf
+ gp0xjetb=0
+ if(.not.((wy1vqfzu .eq. 1) .or. (dimw.eq.wy1vqfzu)))goto 23036
+ do 23038 ayfnwr1v=1,kuzxj1lo
+ rbne6ouj(ayfnwr1v,yq6lorbx) = rbne6ouj(ayfnwr1v,yq6lorbx) / wmat(
+ &ayfnwr1v,yq6lorbx)
23038 continue
- call nvhb7f(egoxa3, dof(d9rjek), p3vlea, lj4dph(1,d9rjek), w8xfic(
- &1,d9rjek), nfiumb4,nk, onyz6j,j1l0o1(1,d9rjek), w5poyv(1,d9rjek),
- &rjcq9o(1,d9rjek), n9peut,l6xrjt(d9rjek),fpcb2n, sz6ohy, yc1ezl,
- &hts1gp, mk2vyr,thfyl1,la5dcf)
- if(.not.(la5dcf .ne. 0))goto 23040
+ call dnaoqj0l(penalt, dof(yq6lorbx), he7mqnvy, rbne6ouj(1,
+ &yq6lorbx), wmat(1,yq6lorbx), kuzxj1lo,nk, gkdx5jal,rpyis2kc(1,
+ &yq6lorbx), t8hwvalr(1,yq6lorbx), ifys6woa(1,yq6lorbx), qcpiaj7f,
+ &wbkq9zyi(yq6lorbx),parms, scrtch, gp0xjetb,l3zpbstu, e5knafcg,
+ &wep0oibc,fbd5yktj)
+ if(.not.(fbd5yktj .ne. 0))goto 23040
return
23040 continue
- do 23042 w3gohz=1,nfiumb4
- w8xfic(w3gohz,d9rjek) = w8xfic(w3gohz,d9rjek) * w8xfic(w3gohz,
- &d9rjek)
+ do 23042 ayfnwr1v=1,kuzxj1lo
+ wmat(ayfnwr1v,yq6lorbx) = wmat(ayfnwr1v,yq6lorbx) * wmat(ayfnwr1v,
+ &yq6lorbx)
23042 continue
- if(.not.(y6jcvk .ne. 0))goto 23044
- do 23046 w3gohz=1,nfiumb4
- l8dgox(w3gohz,d9rjek) = rjcq9o(w3gohz,d9rjek) / w8xfic(w3gohz,
- &d9rjek)
+ if(.not.(yzoe1rsp .ne. 0))goto 23044
+ do 23046 ayfnwr1v=1,kuzxj1lo
+ ui8ysltq(ayfnwr1v,yq6lorbx) = ifys6woa(ayfnwr1v,yq6lorbx) / wmat(
+ &ayfnwr1v,yq6lorbx)
23046 continue
23044 continue
goto 23037
23036 continue
- call nvhb7f(egoxa3, dof(d9rjek), p3vlea, cy3dhl(1,d9rjek), w8xfic(
- &1,d9rjek), nfiumb4,nk, onyz6j,j1l0o1(1,d9rjek),w5poyv(1,d9rjek),
- &rjcq9o(1,d9rjek), n9peut,l6xrjt(d9rjek),fpcb2n, sz6ohy, yc1ezl,
- &hts1gp, mk2vyr,thfyl1,la5dcf)
- if(.not.(la5dcf .ne. 0))goto 23048
+ call dnaoqj0l(penalt, dof(yq6lorbx), he7mqnvy, btwy(1,yq6lorbx),
+ &wmat(1,yq6lorbx), kuzxj1lo,nk, gkdx5jal,rpyis2kc(1,yq6lorbx),
+ &t8hwvalr(1,yq6lorbx), ifys6woa(1,yq6lorbx), qcpiaj7f,wbkq9zyi(
+ &yq6lorbx),parms, scrtch, gp0xjetb,l3zpbstu, e5knafcg,wep0oibc,
+ &fbd5yktj)
+ if(.not.(fbd5yktj .ne. 0))goto 23048
return
23048 continue
- do 23050 w3gohz=1,nfiumb4
- w8xfic(w3gohz,d9rjek) = w8xfic(w3gohz,d9rjek) * w8xfic(w3gohz,
- &d9rjek)
+ do 23050 ayfnwr1v=1,kuzxj1lo
+ wmat(ayfnwr1v,yq6lorbx) = wmat(ayfnwr1v,yq6lorbx) * wmat(ayfnwr1v,
+ &yq6lorbx)
23050 continue
23037 continue
- if(.not.(la5dcf .ne. 0))goto 23052
+ if(.not.(fbd5yktj .ne. 0))goto 23052
return
23052 continue
23028 continue
23024 continue
- if(.not.((lku8xq .eq. 1) .or. (xhe4cg .eq. lku8xq)))goto 23054
+ if(.not.((wy1vqfzu .eq. 1) .or. (dimw .eq. wy1vqfzu)))goto 23054
return
23054 continue
- do 23056 w3gohz=1,nk
- do 23058 d9rjek=1,lku8xq
- cy3dhl(d9rjek,w3gohz)=0.0d0
+ do 23056 ayfnwr1v=1,nk
+ do 23058 yq6lorbx=1,wy1vqfzu
+ btwy(yq6lorbx,ayfnwr1v)=0.0d0
23058 continue
23056 continue
- do 23060 w3gohz=1,(nk*lku8xq)
- do 23062 d9rjek=1,a51l0o
- nkzg2p(d9rjek,w3gohz) = 0.0d0
+ do 23060 ayfnwr1v=1,(nk*wy1vqfzu)
+ do 23062 yq6lorbx=1,ldk
+ osiz4fxy(yq6lorbx,ayfnwr1v) = 0.0d0
23062 continue
23060 continue
- kqoy6w = 0.1d-9
- do 23064 w3gohz=1,nfiumb4
- call vinterv(onyz6j(1),(nk+1),p3vlea(w3gohz),m5xudf,i6ndbu)
- if(.not.(i6ndbu .eq. 1))goto 23066
- if(.not.(p3vlea(w3gohz) .le. (onyz6j(m5xudf)+kqoy6w)))goto 23068
- m5xudf=m5xudf-1
+ qaltf0nz = 0.1d-9
+ do 23064 ayfnwr1v=1,kuzxj1lo
+ call vinterv(gkdx5jal(1),(nk+1),he7mqnvy(ayfnwr1v),dqlr5bse,
+ &pqzfxw4i)
+ if(.not.(pqzfxw4i .eq. 1))goto 23066
+ if(.not.(he7mqnvy(ayfnwr1v) .le. (gkdx5jal(dqlr5bse)+qaltf0nz)))
+ &goto 23068
+ dqlr5bse=dqlr5bse-1
goto 23069
23068 continue
return
23069 continue
23066 continue
- call vbsplvd(onyz6j,4,p3vlea(w3gohz),m5xudf,z2djpt,uq9jtc,1)
- d9rjek= m5xudf-4+1
- do 23070 xi1mqb=1,lku8xq
- cy3dhl(xi1mqb,d9rjek)=cy3dhl(xi1mqb,d9rjek) + lj4dph(w3gohz,
- &xi1mqb) * uq9jtc(1,1)
+ call vbsplvd(gkdx5jal,4,he7mqnvy(ayfnwr1v),dqlr5bse,ms0qypiw,
+ &g9fvdrbw,1)
+ yq6lorbx= dqlr5bse-4+1
+ do 23070 urohxe6t=1,wy1vqfzu
+ btwy(urohxe6t,yq6lorbx)=btwy(urohxe6t,yq6lorbx) + rbne6ouj(
+ &ayfnwr1v,urohxe6t) * g9fvdrbw(1,1)
23070 continue
- call wgy5ta(w3gohz, d9rjek, 0, uq9jtc, nkzg2p, w8xfic, 1, 1,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- call wgy5ta(w3gohz, d9rjek, 1, uq9jtc, nkzg2p, w8xfic, 1, 2,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- call wgy5ta(w3gohz, d9rjek, 2, uq9jtc, nkzg2p, w8xfic, 1, 3,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- call wgy5ta(w3gohz, d9rjek, 3, uq9jtc, nkzg2p, w8xfic, 1, 4,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- d9rjek= m5xudf-4+2
- do 23072 xi1mqb=1,lku8xq
- cy3dhl(xi1mqb,d9rjek)=cy3dhl(xi1mqb,d9rjek) + lj4dph(w3gohz,
- &xi1mqb) * uq9jtc(2,1)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 0, g9fvdrbw, osiz4fxy, wmat, 1,
+ &1, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 1, g9fvdrbw, osiz4fxy, wmat, 1,
+ &2, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 2, g9fvdrbw, osiz4fxy, wmat, 1,
+ &3, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 3, g9fvdrbw, osiz4fxy, wmat, 1,
+ &4, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ yq6lorbx= dqlr5bse-4+2
+ do 23072 urohxe6t=1,wy1vqfzu
+ btwy(urohxe6t,yq6lorbx)=btwy(urohxe6t,yq6lorbx) + rbne6ouj(
+ &ayfnwr1v,urohxe6t) * g9fvdrbw(2,1)
23072 continue
- call wgy5ta(w3gohz, d9rjek, 0, uq9jtc, nkzg2p, w8xfic, 2, 2,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- call wgy5ta(w3gohz, d9rjek, 1, uq9jtc, nkzg2p, w8xfic, 2, 3,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- call wgy5ta(w3gohz, d9rjek, 2, uq9jtc, nkzg2p, w8xfic, 2, 4,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- d9rjek= m5xudf-4+3
- do 23074 xi1mqb=1,lku8xq
- cy3dhl(xi1mqb,d9rjek)=cy3dhl(xi1mqb,d9rjek) + lj4dph(w3gohz,
- &xi1mqb) * uq9jtc(3,1)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 0, g9fvdrbw, osiz4fxy, wmat, 2,
+ &2, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 1, g9fvdrbw, osiz4fxy, wmat, 2,
+ &3, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 2, g9fvdrbw, osiz4fxy, wmat, 2,
+ &4, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ yq6lorbx= dqlr5bse-4+3
+ do 23074 urohxe6t=1,wy1vqfzu
+ btwy(urohxe6t,yq6lorbx)=btwy(urohxe6t,yq6lorbx) + rbne6ouj(
+ &ayfnwr1v,urohxe6t) * g9fvdrbw(3,1)
23074 continue
- call wgy5ta(w3gohz, d9rjek, 0, uq9jtc, nkzg2p, w8xfic, 3, 3,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- call wgy5ta(w3gohz, d9rjek, 1, uq9jtc, nkzg2p, w8xfic, 3, 4,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
- d9rjek= m5xudf-4+4
- do 23076 xi1mqb=1,lku8xq
- cy3dhl(xi1mqb,d9rjek)=cy3dhl(xi1mqb,d9rjek) + lj4dph(w3gohz,
- &xi1mqb) * uq9jtc(4,1)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 0, g9fvdrbw, osiz4fxy, wmat, 3,
+ &3, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 1, g9fvdrbw, osiz4fxy, wmat, 3,
+ &4, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
+ yq6lorbx= dqlr5bse-4+4
+ do 23076 urohxe6t=1,wy1vqfzu
+ btwy(urohxe6t,yq6lorbx)=btwy(urohxe6t,yq6lorbx) + rbne6ouj(
+ &ayfnwr1v,urohxe6t) * g9fvdrbw(4,1)
23076 continue
- call wgy5ta(w3gohz, d9rjek, 0, uq9jtc, nkzg2p, w8xfic, 4, 4,
- &lku8xq, a51l0o, xhe4cg, nfiumb4, nk, zqve1l, vvl1li)
+ call ybnagt8k(ayfnwr1v, yq6lorbx, 0, g9fvdrbw, osiz4fxy, wmat, 4,
+ &4, wy1vqfzu, ldk, dimw, kuzxj1lo, nk, tgiyxdw1, dufozmt7)
23064 continue
- call poqy8c(vb81l0(1,1), vb81l0(1,2), vb81l0(1,3), vb81l0(1,4),
- &onyz6j, nk)
- call j3navf(nkzg2p, nk, lku8xq, a51l0o, l6xrjt, vb81l0)
- call vdpbfa7(nkzg2p, a51l0o, nk*lku8xq, a51l0o-1, fjg0qv, vb81l0)
- if(.not.(fjg0qv .ne. 0))goto 23078
+ call zosq7hub(sgdub(1,1), sgdub(1,2), sgdub(1,3), sgdub(1,4),
+ &gkdx5jal, nk)
+ call tfeswo7c(osiz4fxy, nk, wy1vqfzu, ldk, wbkq9zyi, sgdub)
+ call vdpbfa7(osiz4fxy, ldk, nk*wy1vqfzu, ldk-1, info, sgdub)
+ if(.not.(info .ne. 0))goto 23078
return
23078 continue
- call vdpbsl7(nkzg2p, a51l0o, nk*lku8xq, a51l0o-1, cy3dhl, vb81l0)
- opf6cv = 0
- do 23080 w3gohz=1,nk
- do 23082 d9rjek=1,lku8xq
- opf6cv = opf6cv + 1
- j1l0o1(w3gohz,d9rjek) = cy3dhl(d9rjek,w3gohz)
+ call vdpbsl7(osiz4fxy, ldk, nk*wy1vqfzu, ldk-1, btwy, sgdub)
+ i1loc = 0
+ do 23080 ayfnwr1v=1,nk
+ do 23082 yq6lorbx=1,wy1vqfzu
+ i1loc = i1loc + 1
+ rpyis2kc(ayfnwr1v,yq6lorbx) = btwy(yq6lorbx,ayfnwr1v)
23082 continue
23080 continue
- call ye3zvn(onyz6j, p3vlea, j1l0o1, nfiumb4, nk, lku8xq, w5poyv)
- call gyzcj5(nkzg2p, nkzg2p, vb81l0, zxao0o, a51l0o-1, nk*lku8xq)
- call jiyw4z(nkzg2p, p3vlea, onyz6j, l8dgox, a51l0o, nfiumb4, nk,
- &lku8xq, y6jcvk, bmb, zxao0o, w8xfic, rjcq9o, xhe4cg, zqve1l,
- &vvl1li, e5jrsg)
+ call cn8kzpab(gkdx5jal, he7mqnvy, rpyis2kc, kuzxj1lo, nk,
+ &wy1vqfzu, t8hwvalr)
+ call vicb2(osiz4fxy, osiz4fxy, sgdub, wkmm, ldk-1, nk*wy1vqfzu)
+ call icpd0omv(osiz4fxy, he7mqnvy, gkdx5jal, ui8ysltq, ldk,
+ &kuzxj1lo, nk, wy1vqfzu, yzoe1rsp, bmb, wkmm, wmat, ifys6woa, dimw,
+ & tgiyxdw1, dufozmt7, truen)
return
end
- subroutine ye3zvn(knot, p3vlea, j1l0o1, nfiumb4, nk, lku8xq,
- &w5poyv)
+ subroutine cn8kzpab(ankcghz2, he7mqnvy, rpyis2kc, kuzxj1lo, nk,
+ &wy1vqfzu, t8hwvalr)
implicit logical (a-z)
- integer nfiumb4, nk, lku8xq
- double precision knot(nk+4), p3vlea(nfiumb4), j1l0o1(nk,lku8xq),
- &w5poyv(nfiumb4,lku8xq)
- double precision xvalue
- integer w3gohz, d9rjek, oht3ga, def4wn
- oht3ga = 0
- def4wn = 4
- do 23084 w3gohz=1,nfiumb4
- xvalue = p3vlea(w3gohz)
- do 23086 d9rjek=1,lku8xq
- call wbvalue(knot, j1l0o1(1,d9rjek), nk, def4wn, xvalue, oht3ga,
- &w5poyv(w3gohz,d9rjek))
+ integer kuzxj1lo, nk, wy1vqfzu
+ double precision ankcghz2(nk+4), he7mqnvy(kuzxj1lo), rpyis2kc(nk,
+ &wy1vqfzu), t8hwvalr(kuzxj1lo,wy1vqfzu)
+ double precision chw8lzty
+ integer ayfnwr1v, yq6lorbx, izero0, ifour4
+ izero0 = 0
+ ifour4 = 4
+ do 23084 ayfnwr1v=1,kuzxj1lo
+ chw8lzty = he7mqnvy(ayfnwr1v)
+ do 23086 yq6lorbx=1,wy1vqfzu
+ call wbvalue(ankcghz2, rpyis2kc(1,yq6lorbx), nk, ifour4, chw8lzty,
+ & izero0, t8hwvalr(ayfnwr1v,yq6lorbx))
23086 continue
23084 continue
return
end
- subroutine vsuff9(nfiumb4,uxs1iq,ynk9ah, p3vlea,jmwo0z,w8xfic,
- &qxy6aj,bz3pyo,ax1cdp,f0pzmy,lg3zhr, lku8xq, xhe4cg, zkjqhi,
- &zqve1l, vvl1li, bgu6fw, ve2mqu, ifo4ew, du8jbv, wj5shg, x6rito,
- &c4uxow)
+ subroutine vsuff9(kuzxj1lo,nef,ezlgm2up, he7mqnvy,tlgduey8,wmat,
+ &pygsw6ko,pasjmo8g,wbar,uwbar,wpasjmo8g, wy1vqfzu, dimw, dimu,
+ &tgiyxdw1, dufozmt7, work, work2, hjm2ktyr, kgwmz4ip, iz2nbfjc,
+ &wuwbar, dvhw1ulq)
implicit logical (a-z)
- integer nfiumb4, uxs1iq, ynk9ah(nfiumb4), lku8xq, xhe4cg, zkjqhi,
- &zqve1l(1),vvl1li(1), du8jbv, wj5shg, x6rito, c4uxow
- double precision p3vlea(nfiumb4), jmwo0z(nfiumb4,lku8xq), w8xfic(
- &nfiumb4,xhe4cg), qxy6aj(uxs1iq), bz3pyo(uxs1iq,lku8xq), ax1cdp(
- &uxs1iq,1), f0pzmy(zkjqhi,uxs1iq), lg3zhr(uxs1iq,lku8xq), bgu6fw(
- &lku8xq,lku8xq+1), ve2mqu(du8jbv,du8jbv+1), ifo4ew(lku8xq,du8jbv)
- integer w3gohz, d9rjek, nd6mep, xi1mqb, i1nkrb, j0qwtz
+ integer kuzxj1lo, nef, ezlgm2up(kuzxj1lo), wy1vqfzu, dimw, dimu,
+ &tgiyxdw1(1),dufozmt7(1), kgwmz4ip, iz2nbfjc, wuwbar, dvhw1ulq
+ double precision he7mqnvy(kuzxj1lo), tlgduey8(kuzxj1lo,wy1vqfzu),
+ &wmat(kuzxj1lo,dimw), pygsw6ko(nef), pasjmo8g(nef,wy1vqfzu), wbar(
+ &nef,1), uwbar(dimu,nef), wpasjmo8g(nef,wy1vqfzu), work(wy1vqfzu,
+ &wy1vqfzu+1), work2(kgwmz4ip,kgwmz4ip+1), hjm2ktyr(wy1vqfzu,
+ &kgwmz4ip)
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh, urohxe6t, bpvaqm5z,
+ &imk5wjxg
integer oneint
oneint = 1
- if(.not.(wj5shg .eq. 1))goto 23088
- if(.not.((zkjqhi .ne. xhe4cg) .or. (du8jbv .ne. lku8xq)))goto 2309
+ if(.not.(iz2nbfjc .eq. 1))goto 23088
+ if(.not.((dimu .ne. dimw) .or. (kgwmz4ip .ne. wy1vqfzu)))goto 2309
&0
- c4uxow = 0
+ dvhw1ulq = 0
return
23090 continue
23088 continue
- j0qwtz = lku8xq * (lku8xq+1) / 2
- if(.not.(xhe4cg .gt. j0qwtz))goto 23092
+ imk5wjxg = wy1vqfzu * (wy1vqfzu+1) / 2
+ if(.not.(dimw .gt. imk5wjxg))goto 23092
23092 continue
- call qh4ulb(zqve1l, vvl1li, lku8xq)
- do 23094 w3gohz=1,nfiumb4
- qxy6aj(ynk9ah(w3gohz))=p3vlea(w3gohz)
+ call qpsedg8xf(tgiyxdw1, dufozmt7, wy1vqfzu)
+ do 23094 ayfnwr1v=1,kuzxj1lo
+ pygsw6ko(ezlgm2up(ayfnwr1v))=he7mqnvy(ayfnwr1v)
23094 continue
- do 23096 d9rjek=1,lku8xq
- do 23098 w3gohz=1,uxs1iq
- lg3zhr(w3gohz,d9rjek) = 0.0d0
+ do 23096 yq6lorbx=1,wy1vqfzu
+ do 23098 ayfnwr1v=1,nef
+ wpasjmo8g(ayfnwr1v,yq6lorbx) = 0.0d0
23098 continue
23096 continue
- do 23100 d9rjek=1,xhe4cg
- do 23102 w3gohz=1,uxs1iq
- ax1cdp(w3gohz,d9rjek) = 0.0d0
+ do 23100 yq6lorbx=1,dimw
+ do 23102 ayfnwr1v=1,nef
+ wbar(ayfnwr1v,yq6lorbx) = 0.0d0
23102 continue
23100 continue
- if(.not.(xhe4cg .ne. j0qwtz))goto 23104
- do 23106 nd6mep=1,lku8xq
- do 23108 d9rjek=1,lku8xq
- bgu6fw(d9rjek,nd6mep) = 0.0d0
+ if(.not.(dimw .ne. imk5wjxg))goto 23104
+ do 23106 gp1jxzuh=1,wy1vqfzu
+ do 23108 yq6lorbx=1,wy1vqfzu
+ work(yq6lorbx,gp1jxzuh) = 0.0d0
23108 continue
23106 continue
23104 continue
- do 23110 w3gohz=1,nfiumb4
- do 23112 d9rjek=1,xhe4cg
- bgu6fw(zqve1l(d9rjek),vvl1li(d9rjek)) = w8xfic(w3gohz,d9rjek)
- bgu6fw(vvl1li(d9rjek),zqve1l(d9rjek)) = bgu6fw(zqve1l(d9rjek),
- &vvl1li(d9rjek))
+ do 23110 ayfnwr1v=1,kuzxj1lo
+ do 23112 yq6lorbx=1,dimw
+ work(tgiyxdw1(yq6lorbx),dufozmt7(yq6lorbx)) = wmat(ayfnwr1v,
+ &yq6lorbx)
+ work(dufozmt7(yq6lorbx),tgiyxdw1(yq6lorbx)) = work(tgiyxdw1(
+ &yq6lorbx),dufozmt7(yq6lorbx))
23112 continue
- do 23114 d9rjek=1,lku8xq
- do 23116 nd6mep=1,lku8xq
- lg3zhr(ynk9ah(w3gohz),d9rjek) = lg3zhr(ynk9ah(w3gohz),d9rjek) +
- &bgu6fw(d9rjek,nd6mep)*jmwo0z(w3gohz,nd6mep)
+ do 23114 yq6lorbx=1,wy1vqfzu
+ do 23116 gp1jxzuh=1,wy1vqfzu
+ wpasjmo8g(ezlgm2up(ayfnwr1v),yq6lorbx) = wpasjmo8g(ezlgm2up(
+ &ayfnwr1v),yq6lorbx) + work(yq6lorbx,gp1jxzuh)*tlgduey8(ayfnwr1v,
+ &gp1jxzuh)
23116 continue
23114 continue
- do 23118 d9rjek=1,xhe4cg
- ax1cdp(ynk9ah(w3gohz),d9rjek) = ax1cdp(ynk9ah(w3gohz),d9rjek) +
- &w8xfic(w3gohz,d9rjek)
+ do 23118 yq6lorbx=1,dimw
+ wbar(ezlgm2up(ayfnwr1v),yq6lorbx) = wbar(ezlgm2up(ayfnwr1v),
+ &yq6lorbx) + wmat(ayfnwr1v,yq6lorbx)
23118 continue
23110 continue
- c4uxow = 1
- if(.not.(wj5shg .eq. 1))goto 23120
- do 23122 w3gohz=1,uxs1iq
- do 23124 d9rjek=1,xhe4cg
- bgu6fw(zqve1l(d9rjek),vvl1li(d9rjek)) = ax1cdp(w3gohz,d9rjek)
- bgu6fw(vvl1li(d9rjek),zqve1l(d9rjek)) = bgu6fw(zqve1l(d9rjek),
- &vvl1li(d9rjek))
+ dvhw1ulq = 1
+ if(.not.(iz2nbfjc .eq. 1))goto 23120
+ do 23122 ayfnwr1v=1,nef
+ do 23124 yq6lorbx=1,dimw
+ work(tgiyxdw1(yq6lorbx),dufozmt7(yq6lorbx)) = wbar(ayfnwr1v,
+ &yq6lorbx)
+ work(dufozmt7(yq6lorbx),tgiyxdw1(yq6lorbx)) = work(tgiyxdw1(
+ &yq6lorbx),dufozmt7(yq6lorbx))
23124 continue
- do 23126 d9rjek=1,lku8xq
- bgu6fw(d9rjek,lku8xq+1)=lg3zhr(w3gohz,d9rjek)
+ do 23126 yq6lorbx=1,wy1vqfzu
+ work(yq6lorbx,wy1vqfzu+1)=wpasjmo8g(ayfnwr1v,yq6lorbx)
23126 continue
- call vcholf(bgu6fw, bgu6fw(1,lku8xq+1), lku8xq, c4uxow, oneint)
- if(.not.(c4uxow .ne. 1))goto 23128
+ call vcholf(work, work(1,wy1vqfzu+1), wy1vqfzu, dvhw1ulq, oneint)
+ if(.not.(dvhw1ulq .ne. 1))goto 23128
return
23128 continue
- if(.not.(x6rito .ne. 0))goto 23130
- do 23132 d9rjek=1,xhe4cg
- f0pzmy(d9rjek,w3gohz) = bgu6fw(zqve1l(d9rjek),vvl1li(d9rjek))
+ if(.not.(wuwbar .ne. 0))goto 23130
+ do 23132 yq6lorbx=1,dimw
+ uwbar(yq6lorbx,ayfnwr1v) = work(tgiyxdw1(yq6lorbx),dufozmt7(
+ &yq6lorbx))
23132 continue
23130 continue
- do 23134 d9rjek=1,lku8xq
- bz3pyo(w3gohz,d9rjek)=bgu6fw(d9rjek,lku8xq+1)
+ do 23134 yq6lorbx=1,wy1vqfzu
+ pasjmo8g(ayfnwr1v,yq6lorbx)=work(yq6lorbx,wy1vqfzu+1)
23134 continue
23122 continue
goto 23121
23120 continue
- if(.not.(xhe4cg .ne. j0qwtz))goto 23136
- do 23138 d9rjek=1,lku8xq
- do 23140 nd6mep=1,lku8xq
- bgu6fw(d9rjek,nd6mep) = 0.0d0
+ if(.not.(dimw .ne. imk5wjxg))goto 23136
+ do 23138 yq6lorbx=1,wy1vqfzu
+ do 23140 gp1jxzuh=1,wy1vqfzu
+ work(yq6lorbx,gp1jxzuh) = 0.0d0
23140 continue
23138 continue
23136 continue
- do 23142 w3gohz=1,uxs1iq
- call qh4ulb(zqve1l, vvl1li, lku8xq)
- do 23144 d9rjek=1,xhe4cg
- bgu6fw(zqve1l(d9rjek),vvl1li(d9rjek)) = ax1cdp(w3gohz,d9rjek)
- bgu6fw(vvl1li(d9rjek),zqve1l(d9rjek)) = bgu6fw(zqve1l(d9rjek),
- &vvl1li(d9rjek))
+ do 23142 ayfnwr1v=1,nef
+ call qpsedg8xf(tgiyxdw1, dufozmt7, wy1vqfzu)
+ do 23144 yq6lorbx=1,dimw
+ work(tgiyxdw1(yq6lorbx),dufozmt7(yq6lorbx)) = wbar(ayfnwr1v,
+ &yq6lorbx)
+ work(dufozmt7(yq6lorbx),tgiyxdw1(yq6lorbx)) = work(tgiyxdw1(
+ &yq6lorbx),dufozmt7(yq6lorbx))
23144 continue
- do 23146 d9rjek=1,lku8xq
- bgu6fw(d9rjek,lku8xq+1)=lg3zhr(w3gohz,d9rjek)
+ do 23146 yq6lorbx=1,wy1vqfzu
+ work(yq6lorbx,wy1vqfzu+1)=wpasjmo8g(ayfnwr1v,yq6lorbx)
23146 continue
- do 23148 d9rjek=1,du8jbv
- do 23150 nd6mep=d9rjek,du8jbv
- ve2mqu(d9rjek,nd6mep) = 0.0d0
- do 23152 xi1mqb=1,lku8xq
- do 23154 i1nkrb=1,lku8xq
- ve2mqu(d9rjek,nd6mep) = ve2mqu(d9rjek,nd6mep) + ifo4ew(xi1mqb,
- &d9rjek) * bgu6fw(xi1mqb,i1nkrb) * ifo4ew(i1nkrb,nd6mep)
+ do 23148 yq6lorbx=1,kgwmz4ip
+ do 23150 gp1jxzuh=yq6lorbx,kgwmz4ip
+ work2(yq6lorbx,gp1jxzuh) = 0.0d0
+ do 23152 urohxe6t=1,wy1vqfzu
+ do 23154 bpvaqm5z=1,wy1vqfzu
+ work2(yq6lorbx,gp1jxzuh) = work2(yq6lorbx,gp1jxzuh) + hjm2ktyr(
+ &urohxe6t,yq6lorbx) * work(urohxe6t,bpvaqm5z) * hjm2ktyr(bpvaqm5z,
+ &gp1jxzuh)
23154 continue
23152 continue
23150 continue
23148 continue
- call qh4ulb(zqve1l, vvl1li, du8jbv)
- do 23156 d9rjek=1,zkjqhi
- ax1cdp(w3gohz,d9rjek) = ve2mqu(zqve1l(d9rjek),vvl1li(d9rjek))
+ call qpsedg8xf(tgiyxdw1, dufozmt7, kgwmz4ip)
+ do 23156 yq6lorbx=1,dimu
+ wbar(ayfnwr1v,yq6lorbx) = work2(tgiyxdw1(yq6lorbx),dufozmt7(
+ &yq6lorbx))
23156 continue
- do 23158 d9rjek=1,du8jbv
- ve2mqu(d9rjek,du8jbv+1) = 0.0d0
- do 23160 xi1mqb=1,lku8xq
- ve2mqu(d9rjek,du8jbv+1) = ve2mqu(d9rjek,du8jbv+1) + ifo4ew(xi1mqb,
- &d9rjek) * bgu6fw(xi1mqb,lku8xq+1)
+ do 23158 yq6lorbx=1,kgwmz4ip
+ work2(yq6lorbx,kgwmz4ip+1) = 0.0d0
+ do 23160 urohxe6t=1,wy1vqfzu
+ work2(yq6lorbx,kgwmz4ip+1) = work2(yq6lorbx,kgwmz4ip+1) +
+ &hjm2ktyr(urohxe6t,yq6lorbx) * work(urohxe6t,wy1vqfzu+1)
23160 continue
23158 continue
- do 23162 d9rjek=1,du8jbv
- lg3zhr(w3gohz,d9rjek) = ve2mqu(d9rjek,du8jbv+1)
+ do 23162 yq6lorbx=1,kgwmz4ip
+ wpasjmo8g(ayfnwr1v,yq6lorbx) = work2(yq6lorbx,kgwmz4ip+1)
23162 continue
- call vcholf(ve2mqu, ve2mqu(1,du8jbv+1), du8jbv, c4uxow, oneint)
- if(.not.(c4uxow .ne. 1))goto 23164
+ call vcholf(work2, work2(1,kgwmz4ip+1), kgwmz4ip, dvhw1ulq,
+ &oneint)
+ if(.not.(dvhw1ulq .ne. 1))goto 23164
return
23164 continue
- if(.not.(x6rito .ne. 0))goto 23166
- do 23168 d9rjek=1,zkjqhi
- f0pzmy(d9rjek,w3gohz) = ve2mqu(zqve1l(d9rjek),vvl1li(d9rjek))
+ if(.not.(wuwbar .ne. 0))goto 23166
+ do 23168 yq6lorbx=1,dimu
+ uwbar(yq6lorbx,ayfnwr1v) = work2(tgiyxdw1(yq6lorbx),dufozmt7(
+ &yq6lorbx))
23168 continue
23166 continue
- do 23170 d9rjek=1,du8jbv
- bz3pyo(w3gohz,d9rjek) = ve2mqu(d9rjek,du8jbv+1)
+ do 23170 yq6lorbx=1,kgwmz4ip
+ pasjmo8g(ayfnwr1v,yq6lorbx) = work2(yq6lorbx,kgwmz4ip+1)
23170 continue
23142 continue
23121 continue
return
end
- subroutine jiyw4z(n5fkml, p3vlea, onyz6j, svpr1i, a51l0o, nfiumb4,
- & nk, lku8xq, ifvar, bmb, bgu6fw, w8xfic, rjcq9o, xhe4cg, zqve1l,
- &vvl1li, e5jrsg)
+ subroutine icpd0omv(enaqpzk9, he7mqnvy, gkdx5jal, grmuyvx9, ldk,
+ &kuzxj1lo, nk, wy1vqfzu, jzwsy6tp, bmb, work, wmat, ifys6woa, dimw,
+ & tgiyxdw1, dufozmt7, truen)
implicit logical (a-z)
- integer a51l0o, nfiumb4, nk, lku8xq, ifvar, xhe4cg, zqve1l(1),
- &vvl1li(1), e5jrsg
- double precision n5fkml(a51l0o,nk*lku8xq), p3vlea(nfiumb4),
- &onyz6j(nk+4), svpr1i(e5jrsg,lku8xq), bmb(lku8xq,lku8xq), bgu6fw(
- &lku8xq,lku8xq), w8xfic(nfiumb4,xhe4cg), rjcq9o(nfiumb4,lku8xq)
- integer w3gohz, d9rjek, nd6mep, m5xudf, i6ndbu, xi1mqb, i1nkrb
- double precision kqoy6w, z2djpt(16), uq9jtc(4,1)
- if(.not.(ifvar .ne. 0))goto 23172
- do 23174 nd6mep=1,lku8xq
- do 23176 w3gohz=1,nfiumb4
- svpr1i(w3gohz,nd6mep) = 0.0d0
+ integer ldk, kuzxj1lo, nk, wy1vqfzu, jzwsy6tp, dimw, tgiyxdw1(1),
+ &dufozmt7(1), truen
+ double precision enaqpzk9(ldk,nk*wy1vqfzu), he7mqnvy(kuzxj1lo),
+ &gkdx5jal(nk+4), grmuyvx9(truen,wy1vqfzu), bmb(wy1vqfzu,wy1vqfzu),
+ &work(wy1vqfzu,wy1vqfzu), wmat(kuzxj1lo,dimw), ifys6woa(kuzxj1lo,
+ &wy1vqfzu)
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh, dqlr5bse, pqzfxw4i,
+ &urohxe6t, bpvaqm5z
+ double precision qaltf0nz, ms0qypiw(16), g9fvdrbw(4,1)
+ if(.not.(jzwsy6tp .ne. 0))goto 23172
+ do 23174 gp1jxzuh=1,wy1vqfzu
+ do 23176 ayfnwr1v=1,kuzxj1lo
+ grmuyvx9(ayfnwr1v,gp1jxzuh) = 0.0d0
23176 continue
23174 continue
23172 continue
- kqoy6w = 0.10d-9
- call qh4ulb(zqve1l, vvl1li, lku8xq)
- do 23178 w3gohz=1,nfiumb4
- do 23180 d9rjek=1,lku8xq
- do 23182 nd6mep=1,lku8xq
- bmb(d9rjek,nd6mep)=0.0d0
+ qaltf0nz = 0.10d-9
+ call qpsedg8xf(tgiyxdw1, dufozmt7, wy1vqfzu)
+ do 23178 ayfnwr1v=1,kuzxj1lo
+ do 23180 yq6lorbx=1,wy1vqfzu
+ do 23182 gp1jxzuh=1,wy1vqfzu
+ bmb(yq6lorbx,gp1jxzuh)=0.0d0
23182 continue
23180 continue
- call vinterv(onyz6j(1), (nk+1), p3vlea(w3gohz), m5xudf, i6ndbu)
- if(.not.(i6ndbu.eq. 1))goto 23184
- if(.not.(p3vlea(w3gohz) .le. (onyz6j(m5xudf)+kqoy6w)))goto 23186
- m5xudf=m5xudf-1
+ call vinterv(gkdx5jal(1), (nk+1), he7mqnvy(ayfnwr1v), dqlr5bse,
+ &pqzfxw4i)
+ if(.not.(pqzfxw4i.eq. 1))goto 23184
+ if(.not.(he7mqnvy(ayfnwr1v) .le. (gkdx5jal(dqlr5bse)+qaltf0nz)))
+ &goto 23186
+ dqlr5bse=dqlr5bse-1
goto 23187
23186 continue
return
23187 continue
23184 continue
- call vbsplvd(onyz6j, 4, p3vlea(w3gohz), m5xudf, z2djpt, uq9jtc, 1)
- d9rjek= m5xudf-4+1
- do 23188 xi1mqb=d9rjek,d9rjek+3
- call vsel(xi1mqb, xi1mqb, lku8xq, nk, a51l0o, n5fkml, bgu6fw)
- call bf7qci(lku8xq, uq9jtc(xi1mqb-d9rjek+1,1) * uq9jtc(xi1mqb-
- &d9rjek+1,1), bgu6fw, bmb)
+ call vbsplvd(gkdx5jal, 4, he7mqnvy(ayfnwr1v), dqlr5bse, ms0qypiw,
+ &g9fvdrbw, 1)
+ yq6lorbx= dqlr5bse-4+1
+ do 23188 urohxe6t=yq6lorbx,yq6lorbx+3
+ call vsel(urohxe6t, urohxe6t, wy1vqfzu, nk, ldk, enaqpzk9, work)
+ call o0xlszqr(wy1vqfzu, g9fvdrbw(urohxe6t-yq6lorbx+1,1) *
+ &g9fvdrbw(urohxe6t-yq6lorbx+1,1), work, bmb)
23188 continue
- do 23190 xi1mqb=d9rjek,d9rjek+3
- do 23192 i1nkrb=xi1mqb+1,d9rjek+3
- call vsel(xi1mqb, i1nkrb, lku8xq, nk, a51l0o, n5fkml, bgu6fw)
- call bf7qci(lku8xq, 2.0d0 * uq9jtc(xi1mqb-d9rjek+1,1) * uq9jtc(
- &i1nkrb-d9rjek+1,1), bgu6fw, bmb)
+ do 23190 urohxe6t=yq6lorbx,yq6lorbx+3
+ do 23192 bpvaqm5z=urohxe6t+1,yq6lorbx+3
+ call vsel(urohxe6t, bpvaqm5z, wy1vqfzu, nk, ldk, enaqpzk9, work)
+ call o0xlszqr(wy1vqfzu, 2.0d0 * g9fvdrbw(urohxe6t-yq6lorbx+1,1) *
+ &g9fvdrbw(bpvaqm5z-yq6lorbx+1,1), work, bmb)
23192 continue
23190 continue
- if(.not.(ifvar .ne. 0))goto 23194
- do 23196 d9rjek=1,lku8xq
- svpr1i(w3gohz,d9rjek) = bmb(d9rjek,d9rjek)
+ if(.not.(jzwsy6tp .ne. 0))goto 23194
+ do 23196 yq6lorbx=1,wy1vqfzu
+ grmuyvx9(ayfnwr1v,yq6lorbx) = bmb(yq6lorbx,yq6lorbx)
23196 continue
23194 continue
- call dp2zwv(bmb, w8xfic, bgu6fw, rjcq9o, lku8xq, nfiumb4, xhe4cg,
- &zqve1l, vvl1li, w3gohz)
+ call ovjnsmt2(bmb, wmat, work, ifys6woa, wy1vqfzu, kuzxj1lo, dimw,
+ & tgiyxdw1, dufozmt7, ayfnwr1v)
23178 continue
return
end
- subroutine bf7qci(lku8xq, uq9jtc, bgu6fw, bmb)
+ subroutine o0xlszqr(wy1vqfzu, g9fvdrbw, work, bmb)
implicit logical (a-z)
- integer lku8xq
- double precision uq9jtc, bgu6fw(lku8xq,lku8xq), bmb(lku8xq,lku8xq)
- integer d9rjek, nd6mep
- do 23198 d9rjek=1,lku8xq
- do 23200 nd6mep=1,lku8xq
- bgu6fw(d9rjek,nd6mep) = bgu6fw(d9rjek,nd6mep) * uq9jtc
+ integer wy1vqfzu
+ double precision g9fvdrbw, work(wy1vqfzu,wy1vqfzu), bmb(wy1vqfzu,
+ &wy1vqfzu)
+ integer yq6lorbx, gp1jxzuh
+ do 23198 yq6lorbx=1,wy1vqfzu
+ do 23200 gp1jxzuh=1,wy1vqfzu
+ work(yq6lorbx,gp1jxzuh) = work(yq6lorbx,gp1jxzuh) * g9fvdrbw
23200 continue
23198 continue
- do 23202 d9rjek=1,lku8xq
- do 23204 nd6mep=1,lku8xq
- bmb(nd6mep,d9rjek) = bmb(nd6mep,d9rjek) + bgu6fw(nd6mep,d9rjek)
+ do 23202 yq6lorbx=1,wy1vqfzu
+ do 23204 gp1jxzuh=1,wy1vqfzu
+ bmb(gp1jxzuh,yq6lorbx) = bmb(gp1jxzuh,yq6lorbx) + work(gp1jxzuh,
+ &yq6lorbx)
23204 continue
23202 continue
return
end
- subroutine vsel(s, t, lku8xq, nk, a51l0o, minv, bgu6fw)
+ subroutine vsel(s, t, wy1vqfzu, nk, ldk, minv, work)
implicit logical (a-z)
- integer s, t, lku8xq, nk, a51l0o
- double precision minv(a51l0o,nk*lku8xq), bgu6fw(lku8xq,lku8xq)
- integer w3gohz, d9rjek, y9eilo, pazyk8
- do 23206 w3gohz=1,lku8xq
- do 23208 d9rjek=1,lku8xq
- bgu6fw(w3gohz,d9rjek) = 0.0d0
+ integer s, t, wy1vqfzu, nk, ldk
+ double precision minv(ldk,nk*wy1vqfzu), work(wy1vqfzu,wy1vqfzu)
+ integer ayfnwr1v, yq6lorbx, biuvowq2, nbj8tdsk
+ do 23206 ayfnwr1v=1,wy1vqfzu
+ do 23208 yq6lorbx=1,wy1vqfzu
+ work(ayfnwr1v,yq6lorbx) = 0.0d0
23208 continue
23206 continue
if(.not.(s .ne. t))goto 23210
- do 23212 w3gohz=1,lku8xq
- y9eilo = (s-1)*lku8xq + w3gohz
- do 23214 d9rjek=1,lku8xq
- pazyk8 = (t-1)*lku8xq + d9rjek
- bgu6fw(w3gohz,d9rjek) = minv(a51l0o-(pazyk8-y9eilo), pazyk8)
+ do 23212 ayfnwr1v=1,wy1vqfzu
+ biuvowq2 = (s-1)*wy1vqfzu + ayfnwr1v
+ do 23214 yq6lorbx=1,wy1vqfzu
+ nbj8tdsk = (t-1)*wy1vqfzu + yq6lorbx
+ work(ayfnwr1v,yq6lorbx) = minv(ldk-(nbj8tdsk-biuvowq2), nbj8tdsk)
23214 continue
23212 continue
goto 23211
23210 continue
- do 23216 w3gohz=1,lku8xq
- y9eilo = (s-1)*lku8xq + w3gohz
- do 23218 d9rjek=w3gohz,lku8xq
- pazyk8 = (t-1)*lku8xq + d9rjek
- bgu6fw(w3gohz,d9rjek) = minv(a51l0o-(pazyk8-y9eilo), pazyk8)
+ do 23216 ayfnwr1v=1,wy1vqfzu
+ biuvowq2 = (s-1)*wy1vqfzu + ayfnwr1v
+ do 23218 yq6lorbx=ayfnwr1v,wy1vqfzu
+ nbj8tdsk = (t-1)*wy1vqfzu + yq6lorbx
+ work(ayfnwr1v,yq6lorbx) = minv(ldk-(nbj8tdsk-biuvowq2), nbj8tdsk)
23218 continue
23216 continue
- do 23220 w3gohz=1,lku8xq
- do 23222 d9rjek=w3gohz+1,lku8xq
- bgu6fw(d9rjek,w3gohz) = bgu6fw(w3gohz,d9rjek)
+ do 23220 ayfnwr1v=1,wy1vqfzu
+ do 23222 yq6lorbx=ayfnwr1v+1,wy1vqfzu
+ work(yq6lorbx,ayfnwr1v) = work(ayfnwr1v,yq6lorbx)
23222 continue
23220 continue
23211 continue
return
end
- subroutine dp2zwv(bmb, w8xfic, bgu6fw, rjcq9o, lku8xq, nfiumb4,
- &xhe4cg, zqve1l, vvl1li, p1rifj)
+ subroutine ovjnsmt2(bmb, wmat, work, ifys6woa, wy1vqfzu, kuzxj1lo,
+ & dimw, tgiyxdw1, dufozmt7, iii)
implicit logical (a-z)
- integer lku8xq, nfiumb4, xhe4cg, zqve1l(1), vvl1li(1), p1rifj
- double precision bmb(lku8xq,lku8xq), w8xfic(nfiumb4,xhe4cg),
- &bgu6fw(lku8xq,lku8xq), rjcq9o(nfiumb4,lku8xq)
- double precision qnk4zf, temp
- integer d9rjek, nd6mep, xi1mqb, i1nkrb
- do 23224 i1nkrb=1,lku8xq
- do 23226 d9rjek=1,lku8xq
- do 23228 nd6mep=1,lku8xq
- bgu6fw(nd6mep,d9rjek) = 0.0d0
+ integer wy1vqfzu, kuzxj1lo, dimw, tgiyxdw1(1), dufozmt7(1), iii
+ double precision bmb(wy1vqfzu,wy1vqfzu), wmat(kuzxj1lo,dimw),
+ &work(wy1vqfzu,wy1vqfzu), ifys6woa(kuzxj1lo,wy1vqfzu)
+ double precision q6zdcwxk, obr6tcex
+ integer yq6lorbx, gp1jxzuh, urohxe6t, bpvaqm5z
+ do 23224 bpvaqm5z=1,wy1vqfzu
+ do 23226 yq6lorbx=1,wy1vqfzu
+ do 23228 gp1jxzuh=1,wy1vqfzu
+ work(gp1jxzuh,yq6lorbx) = 0.0d0
23228 continue
23226 continue
- do 23230 xi1mqb=1,xhe4cg
- temp = w8xfic(p1rifj,xi1mqb)
- bgu6fw(zqve1l(xi1mqb),vvl1li(xi1mqb)) = temp
- bgu6fw(vvl1li(xi1mqb),zqve1l(xi1mqb)) = temp
+ do 23230 urohxe6t=1,dimw
+ obr6tcex = wmat(iii,urohxe6t)
+ work(tgiyxdw1(urohxe6t),dufozmt7(urohxe6t)) = obr6tcex
+ work(dufozmt7(urohxe6t),tgiyxdw1(urohxe6t)) = obr6tcex
23230 continue
- qnk4zf = 0.0d0
- do 23232 d9rjek=1,lku8xq
- qnk4zf = qnk4zf + bmb(i1nkrb,d9rjek) * bgu6fw(d9rjek,i1nkrb)
+ q6zdcwxk = 0.0d0
+ do 23232 yq6lorbx=1,wy1vqfzu
+ q6zdcwxk = q6zdcwxk + bmb(bpvaqm5z,yq6lorbx) * work(yq6lorbx,
+ &bpvaqm5z)
23232 continue
- rjcq9o(p1rifj,i1nkrb) = qnk4zf
+ ifys6woa(iii,bpvaqm5z) = q6zdcwxk
23224 continue
return
end
- subroutine gyzcj5(n5fkml, jrxg6l, d, uu, lku8xq, nfiumb4)
+ subroutine vicb2(enaqpzk9, wpuarq2m, d, uu, wy1vqfzu, kuzxj1lo)
implicit logical (a-z)
- integer lku8xq, nfiumb4
- double precision n5fkml(lku8xq+1,nfiumb4), jrxg6l(lku8xq+1,
- &nfiumb4), d(nfiumb4), uu(lku8xq+1,lku8xq+1)
- integer w3gohz, nd6mep, dibm1x, p4gdax, c3qxjo, j0izmn, myx3od
- n5fkml(lku8xq+1,nfiumb4) = 1.0d0 / d(nfiumb4)
- j0izmn = lku8xq+1
- c3qxjo = nfiumb4+1 - j0izmn
- do 23234 myx3od=c3qxjo,nfiumb4
- do 23236 w3gohz=1,j0izmn
- uu(w3gohz, myx3od-c3qxjo+1) = jrxg6l(w3gohz, myx3od)
+ integer wy1vqfzu, kuzxj1lo
+ double precision enaqpzk9(wy1vqfzu+1,kuzxj1lo), wpuarq2m(wy1vqfzu+
+ &1,kuzxj1lo), d(kuzxj1lo), uu(wy1vqfzu+1,wy1vqfzu+1)
+ integer ayfnwr1v, gp1jxzuh, lsvdbx3tk, uplim, sedf7mxb, hofjnx2e,
+ &kij0gwer
+ enaqpzk9(wy1vqfzu+1,kuzxj1lo) = 1.0d0 / d(kuzxj1lo)
+ hofjnx2e = wy1vqfzu+1
+ sedf7mxb = kuzxj1lo+1 - hofjnx2e
+ do 23234 kij0gwer=sedf7mxb,kuzxj1lo
+ do 23236 ayfnwr1v=1,hofjnx2e
+ uu(ayfnwr1v, kij0gwer-sedf7mxb+1) = wpuarq2m(ayfnwr1v, kij0gwer)
23236 continue
23234 continue
- w3gohz = nfiumb4-1
-23238 if(.not.(w3gohz.ge.1))goto 23240
- if(.not.(lku8xq .lt. nfiumb4-w3gohz))goto 23241
- p4gdax = lku8xq
+ ayfnwr1v = kuzxj1lo-1
+23238 if(.not.(ayfnwr1v.ge.1))goto 23240
+ if(.not.(wy1vqfzu .lt. kuzxj1lo-ayfnwr1v))goto 23241
+ uplim = wy1vqfzu
goto 23242
23241 continue
- p4gdax = nfiumb4-w3gohz
+ uplim = kuzxj1lo-ayfnwr1v
23242 continue
- dibm1x=1
-23243 if(.not.(dibm1x.le.p4gdax))goto 23245
- n5fkml(-dibm1x+lku8xq+1,w3gohz+dibm1x) = 0.0d0
- nd6mep=1
-23246 if(.not.(nd6mep.le.dibm1x))goto 23248
- n5fkml(-dibm1x+lku8xq+1,w3gohz+dibm1x) = n5fkml(-dibm1x+lku8xq+1,
- &w3gohz+dibm1x) - uu(-nd6mep+lku8xq+1,w3gohz+nd6mep -c3qxjo+1) *
- &n5fkml(nd6mep-dibm1x+lku8xq+1,w3gohz+dibm1x)
- nd6mep=nd6mep+1
+ lsvdbx3tk=1
+23243 if(.not.(lsvdbx3tk.le.uplim))goto 23245
+ enaqpzk9(-lsvdbx3tk+wy1vqfzu+1,ayfnwr1v+lsvdbx3tk) = 0.0d0
+ gp1jxzuh=1
+23246 if(.not.(gp1jxzuh.le.lsvdbx3tk))goto 23248
+ enaqpzk9(-lsvdbx3tk+wy1vqfzu+1,ayfnwr1v+lsvdbx3tk) = enaqpzk9(-
+ &lsvdbx3tk+wy1vqfzu+1,ayfnwr1v+lsvdbx3tk) - uu(-gp1jxzuh+wy1vqfzu+
+ &1,ayfnwr1v+gp1jxzuh -sedf7mxb+1) * enaqpzk9(gp1jxzuh-lsvdbx3tk+
+ &wy1vqfzu+1,ayfnwr1v+lsvdbx3tk)
+ gp1jxzuh=gp1jxzuh+1
goto 23246
23248 continue
-23249 if(.not.(nd6mep.le.p4gdax))goto 23251
- n5fkml(-dibm1x+lku8xq+1,w3gohz+dibm1x) = n5fkml(-dibm1x+lku8xq+1,
- &w3gohz+dibm1x) - uu(-nd6mep+lku8xq+1,w3gohz+nd6mep -c3qxjo+1) *
- &n5fkml(dibm1x-nd6mep+lku8xq+1,w3gohz+nd6mep)
- nd6mep=nd6mep+1
+23249 if(.not.(gp1jxzuh.le.uplim))goto 23251
+ enaqpzk9(-lsvdbx3tk+wy1vqfzu+1,ayfnwr1v+lsvdbx3tk) = enaqpzk9(-
+ &lsvdbx3tk+wy1vqfzu+1,ayfnwr1v+lsvdbx3tk) - uu(-gp1jxzuh+wy1vqfzu+
+ &1,ayfnwr1v+gp1jxzuh -sedf7mxb+1) * enaqpzk9(lsvdbx3tk-gp1jxzuh+
+ &wy1vqfzu+1,ayfnwr1v+gp1jxzuh)
+ gp1jxzuh=gp1jxzuh+1
goto 23249
23251 continue
- dibm1x=dibm1x+1
+ lsvdbx3tk=lsvdbx3tk+1
goto 23243
23245 continue
- n5fkml(lku8xq+1,w3gohz) = 1.0d0 / d(w3gohz)
- dibm1x = 1
-23252 if(.not.(dibm1x.le.p4gdax))goto 23254
- n5fkml(lku8xq+1,w3gohz) = n5fkml(lku8xq+1,w3gohz) - uu(-dibm1x+
- &lku8xq+1,w3gohz+dibm1x -c3qxjo+1) * n5fkml(-dibm1x+lku8xq+1,
- &w3gohz+dibm1x)
- dibm1x=dibm1x+1
+ enaqpzk9(wy1vqfzu+1,ayfnwr1v) = 1.0d0 / d(ayfnwr1v)
+ lsvdbx3tk = 1
+23252 if(.not.(lsvdbx3tk.le.uplim))goto 23254
+ enaqpzk9(wy1vqfzu+1,ayfnwr1v) = enaqpzk9(wy1vqfzu+1,ayfnwr1v) -
+ &uu(-lsvdbx3tk+wy1vqfzu+1,ayfnwr1v+lsvdbx3tk -sedf7mxb+1) *
+ &enaqpzk9(-lsvdbx3tk+wy1vqfzu+1,ayfnwr1v+lsvdbx3tk)
+ lsvdbx3tk=lsvdbx3tk+1
goto 23252
23254 continue
- if(.not.(w3gohz .eq. c3qxjo))goto 23255
- c3qxjo = c3qxjo-1
- if(.not.(c3qxjo .lt. 1))goto 23257
- c3qxjo = 1
+ if(.not.(ayfnwr1v .eq. sedf7mxb))goto 23255
+ sedf7mxb = sedf7mxb-1
+ if(.not.(sedf7mxb .lt. 1))goto 23257
+ sedf7mxb = 1
goto 23258
23257 continue
- myx3od=j0izmn-1
-23259 if(.not.(myx3od.ge.1))goto 23261
- nd6mep=1
-23262 if(.not.(nd6mep.le.j0izmn))goto 23264
- uu(nd6mep,myx3od+1) = uu(nd6mep,myx3od)
- nd6mep=nd6mep+1
+ kij0gwer=hofjnx2e-1
+23259 if(.not.(kij0gwer.ge.1))goto 23261
+ gp1jxzuh=1
+23262 if(.not.(gp1jxzuh.le.hofjnx2e))goto 23264
+ uu(gp1jxzuh,kij0gwer+1) = uu(gp1jxzuh,kij0gwer)
+ gp1jxzuh=gp1jxzuh+1
goto 23262
23264 continue
- myx3od=myx3od-1
+ kij0gwer=kij0gwer-1
goto 23259
23261 continue
- nd6mep=1
-23265 if(.not.(nd6mep.le.j0izmn))goto 23267
- uu(nd6mep,1) = jrxg6l(nd6mep,c3qxjo)
- nd6mep=nd6mep+1
+ gp1jxzuh=1
+23265 if(.not.(gp1jxzuh.le.hofjnx2e))goto 23267
+ uu(gp1jxzuh,1) = wpuarq2m(gp1jxzuh,sedf7mxb)
+ gp1jxzuh=gp1jxzuh+1
goto 23265
23267 continue
23258 continue
23255 continue
- w3gohz = w3gohz-1
+ ayfnwr1v = ayfnwr1v-1
goto 23238
23240 continue
return
end
- subroutine ntju9b(bz4guf,jmwo0z,w8xfic, nfiumb4,lku8xq,ynk9ah,
- &uxs1iq, l6xrjt,dof,smo,zo5jyl, s0, vy5hmo,yin,lj4dph,win, ykdc2t,
- &phqco4, xhe4cg, la5dcf, a51l0o, fjg0qv, y6jcvk, vb81l0, j1l0o1,
- &qc7zyb, jko0o1,zqve1l,vvl1li, bmb, rjcq9o, zxao0o, wj5shg,du8jbv,
- &i83h1, ifo4ew, lq8reh, i0qvzl, jq8lra, kn7qya, vfd2pw, blq5vu,
- &dfsom3)
+ subroutine ewg7qruh(sjwyig9tto,tlgduey8,wmat, kuzxj1lo,wy1vqfzu,
+ &ezlgm2up,nef, wbkq9zyi,dof,smo,cov, s0, xin,yin,rbne6ouj,win,
+ &work1,work3, dimw, fbd5yktj, ldk, info, yzoe1rsp, sgdub, rpyis2kc,
+ & zv2xfhei, acpios9q,tgiyxdw1,dufozmt7, bmb, ifys6woa, wkmm,
+ &iz2nbfjc,kgwmz4ip,ges1xpkr, hjm2ktyr, beta, fasrkub3, sout,
+ &r0oydcxb, ub4xioar, effect, uwin)
implicit logical (a-z)
- integer nfiumb4,lku8xq,ynk9ah(nfiumb4),uxs1iq, xhe4cg, la5dcf,
- &a51l0o, fjg0qv, y6jcvk, jko0o1,zqve1l(1),vvl1li(1), wj5shg,
- &du8jbv, i83h1(du8jbv*2)
- double precision bz4guf(nfiumb4), jmwo0z(nfiumb4,lku8xq), w8xfic(
- &nfiumb4,xhe4cg), l6xrjt(du8jbv), dof(du8jbv), smo(nfiumb4,du8jbv),
- & zo5jyl(nfiumb4,du8jbv)
- double precision s0(2*du8jbv, 2*du8jbv,2)
- double precision ykdc2t(1), phqco4(1), vb81l0(1), j1l0o1(1),
- &qc7zyb(jko0o1+4)
- double precision vy5hmo(uxs1iq), yin(uxs1iq,lku8xq), lj4dph(
- &uxs1iq,lku8xq), win(uxs1iq,1), bmb(1), rjcq9o(uxs1iq,du8jbv),
- &zxao0o(lku8xq,lku8xq,16), ifo4ew(lku8xq,du8jbv)
- double precision lq8reh(2*du8jbv), i0qvzl(2*du8jbv), jq8lra(
- &uxs1iq,du8jbv), kn7qya(du8jbv,uxs1iq), vfd2pw(du8jbv,uxs1iq),
- &blq5vu(uxs1iq*du8jbv), dfsom3(1)
- integer ybfr6z
- integer w3gohz, d9rjek, nd6mep, c4bdmu, o9ljyn, tvyd2b, zx1610,
- &c4uxow
+ integer kuzxj1lo,wy1vqfzu,ezlgm2up(kuzxj1lo),nef, dimw, fbd5yktj,
+ &ldk, info, yzoe1rsp, acpios9q,tgiyxdw1(1),dufozmt7(1), iz2nbfjc,
+ &kgwmz4ip, ges1xpkr(kgwmz4ip*2)
+ double precision sjwyig9tto(kuzxj1lo), tlgduey8(kuzxj1lo,wy1vqfzu)
+ &, wmat(kuzxj1lo,dimw), wbkq9zyi(kgwmz4ip), dof(kgwmz4ip), smo(
+ &kuzxj1lo,kgwmz4ip), cov(kuzxj1lo,kgwmz4ip)
+ double precision s0(2*kgwmz4ip, 2*kgwmz4ip,2)
+ double precision work1(1), work3(1), sgdub(1), rpyis2kc(1),
+ &zv2xfhei(acpios9q+4)
+ double precision xin(nef), yin(nef,wy1vqfzu), rbne6ouj(nef,
+ &wy1vqfzu), win(nef,1), bmb(1), ifys6woa(nef,kgwmz4ip), wkmm(
+ &wy1vqfzu,wy1vqfzu,16), hjm2ktyr(wy1vqfzu,kgwmz4ip)
+ double precision beta(2*kgwmz4ip), fasrkub3(2*kgwmz4ip), sout(nef,
+ &kgwmz4ip), r0oydcxb(kgwmz4ip,nef), ub4xioar(kgwmz4ip,nef), effect(
+ &nef*kgwmz4ip), uwin(1)
+ integer dimwin
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh, rutyk8mg, xjc4ywlh, job,
+ &qemj9asg, dvhw1ulq
integer oneint
- double precision kogeb2, tap0km, t7sbea
+ double precision xmin, xrange, pvofyg8z
oneint = 1
- if(.not.(wj5shg .eq. 1))goto 23268
- ybfr6z = xhe4cg
+ if(.not.(iz2nbfjc .eq. 1))goto 23268
+ dimwin = dimw
goto 23269
23268 continue
- ybfr6z = du8jbv*(du8jbv+1)/2
+ dimwin = kgwmz4ip*(kgwmz4ip+1)/2
23269 continue
- call qh4ulb(zqve1l, vvl1li, lku8xq)
- call vsuff9(nfiumb4,uxs1iq,ynk9ah, bz4guf,jmwo0z,w8xfic, vy5hmo,
- &yin,win,dfsom3,lj4dph, lku8xq, xhe4cg, ybfr6z, zqve1l, vvl1li,
- &zxao0o, zxao0o(1,1,3), ifo4ew, du8jbv, wj5shg, oneint, c4uxow)
- if(.not.(c4uxow .ne. 1))goto 23270
+ call qpsedg8xf(tgiyxdw1, dufozmt7, wy1vqfzu)
+ call vsuff9(kuzxj1lo,nef,ezlgm2up, sjwyig9tto,tlgduey8,wmat, xin,
+ &yin,win,uwin,rbne6ouj, wy1vqfzu, dimw, dimwin, tgiyxdw1, dufozmt7,
+ & wkmm, wkmm(1,1,3), hjm2ktyr, kgwmz4ip, iz2nbfjc, oneint,
+ &dvhw1ulq)
+ if(.not.(dvhw1ulq .ne. 1))goto 23270
return
23270 continue
- kogeb2 = vy5hmo(1)
- tap0km = vy5hmo(uxs1iq)-vy5hmo(1)
- do 23272 w3gohz=1,uxs1iq
- vy5hmo(w3gohz) = (vy5hmo(w3gohz)-kogeb2)/tap0km
+ xmin = xin(1)
+ xrange = xin(nef)-xin(1)
+ do 23272 ayfnwr1v=1,nef
+ xin(ayfnwr1v) = (xin(ayfnwr1v)-xmin)/xrange
23272 continue
- a51l0o = 4*du8jbv
- la5dcf = 0
- do 23274 d9rjek=1,du8jbv
- if(.not.(l6xrjt(d9rjek) .eq. 0.0d0))goto 23276
- dof(d9rjek) = dof(d9rjek) + 1.0d0
+ ldk = 4*kgwmz4ip
+ fbd5yktj = 0
+ do 23274 yq6lorbx=1,kgwmz4ip
+ if(.not.(wbkq9zyi(yq6lorbx) .eq. 0.0d0))goto 23276
+ dof(yq6lorbx) = dof(yq6lorbx) + 1.0d0
23276 continue
23274 continue
- call qh4ulb(zqve1l, vvl1li, du8jbv)
- call vsplin(vy5hmo,lj4dph,win,uxs1iq,qc7zyb, jko0o1,a51l0o,du8jbv,
- &ybfr6z, zqve1l,vvl1li, zxao0o, l6xrjt, fjg0qv, jq8lra, j1l0o1,
- &phqco4(1), phqco4(1+jko0o1*du8jbv*a51l0o), vb81l0, zo5jyl, y6jcvk,
- & bmb, rjcq9o, dof, ykdc2t, la5dcf, nfiumb4)
- do 23278 d9rjek=1,du8jbv
- dof(d9rjek) = -1.0d0
- do 23280 w3gohz=1,uxs1iq
- dof(d9rjek)=dof(d9rjek)+rjcq9o(w3gohz,d9rjek)
+ call qpsedg8xf(tgiyxdw1, dufozmt7, kgwmz4ip)
+ call vsplin(xin,rbne6ouj,win,nef,zv2xfhei, acpios9q,ldk,kgwmz4ip,
+ &dimwin, tgiyxdw1,dufozmt7, wkmm, wbkq9zyi, info, sout, rpyis2kc,
+ &work3(1), work3(1+acpios9q*kgwmz4ip*ldk), sgdub, cov, yzoe1rsp,
+ &bmb, ifys6woa, dof, work1, fbd5yktj, kuzxj1lo)
+ do 23278 yq6lorbx=1,kgwmz4ip
+ dof(yq6lorbx) = -1.0d0
+ do 23280 ayfnwr1v=1,nef
+ dof(yq6lorbx)=dof(yq6lorbx)+ifys6woa(ayfnwr1v,yq6lorbx)
23280 continue
23278 continue
- if(.not.(du8jbv .ge. 1))goto 23282
- t7sbea = 1.0d-7
- c4bdmu = uxs1iq*du8jbv
- o9ljyn = 2*du8jbv
- tvyd2b = 101
- fjg0qv = 1
- call kgevo5(vy5hmo, phqco4, uxs1iq, du8jbv)
- call qh4ulb(zqve1l, vvl1li, du8jbv)
- call mux17f(dfsom3, phqco4, du8jbv, o9ljyn, uxs1iq, zxao0o(1,1,1),
- & zxao0o(1,1,2), zqve1l, vvl1li, ybfr6z, c4bdmu)
- do 23284 nd6mep=1,o9ljyn
- i83h1(nd6mep) = nd6mep
+ if(.not.(kgwmz4ip .ge. 1))goto 23282
+ pvofyg8z = 1.0d-7
+ rutyk8mg = nef*kgwmz4ip
+ xjc4ywlh = 2*kgwmz4ip
+ job = 101
+ info = 1
+ call x6kanjdh(xin, work3, nef, kgwmz4ip)
+ call qpsedg8xf(tgiyxdw1, dufozmt7, kgwmz4ip)
+ call mxrbkut0f(uwin, work3, kgwmz4ip, xjc4ywlh, nef, wkmm(1,1,1),
+ &wkmm(1,1,2), tgiyxdw1, dufozmt7, dimwin, rutyk8mg)
+ do 23284 gp1jxzuh=1,xjc4ywlh
+ ges1xpkr(gp1jxzuh) = gp1jxzuh
23284 continue
- call dhkt9w(phqco4,c4bdmu,c4bdmu,o9ljyn,i0qvzl,i83h1,ykdc2t,
- &zx1610,t7sbea)
- call qh4ulb(zqve1l, vvl1li, du8jbv)
- call mux22f(dfsom3,jq8lra,kn7qya,ybfr6z,zqve1l,vvl1li,uxs1iq,
- &du8jbv,zxao0o)
- call vdqrsl(phqco4,c4bdmu,c4bdmu,zx1610,i0qvzl,kn7qya,ykdc2t(1),
- &blq5vu,lq8reh, ykdc2t(1),vfd2pw,tvyd2b,fjg0qv)
- call vbksf(dfsom3,vfd2pw,du8jbv,uxs1iq,zxao0o,zqve1l,vvl1li,
- &ybfr6z)
- if(.not.(y6jcvk .ne. 0))goto 23286
- call vrinvf9(phqco4, c4bdmu, o9ljyn, c4uxow, s0(1,1,1), s0(1,1,2))
- if(.not.(c4uxow .ne. 1))goto 23288
+ call vqrdca(work3,rutyk8mg,rutyk8mg,xjc4ywlh,fasrkub3,ges1xpkr,
+ &work1,qemj9asg,pvofyg8z)
+ call qpsedg8xf(tgiyxdw1, dufozmt7, kgwmz4ip)
+ call nudh6szqf(uwin,sout,r0oydcxb,dimwin,tgiyxdw1,dufozmt7,nef,
+ &kgwmz4ip,wkmm)
+ call vdqrsl(work3,rutyk8mg,rutyk8mg,qemj9asg,fasrkub3,r0oydcxb,
+ &work1(1),effect,beta, work1(1),ub4xioar,job,info)
+ call vbksf(uwin,ub4xioar,kgwmz4ip,nef,wkmm,tgiyxdw1,dufozmt7,
+ &dimwin)
+ if(.not.(yzoe1rsp .ne. 0))goto 23286
+ call vrinvf9(work3, rutyk8mg, xjc4ywlh, dvhw1ulq, s0(1,1,1), s0(1,
+ &1,2))
+ if(.not.(dvhw1ulq .ne. 1))goto 23288
return
23288 continue
- do 23290 d9rjek=1,du8jbv
- do 23292 w3gohz=1,uxs1iq
- zo5jyl(w3gohz,d9rjek) = zo5jyl(w3gohz,d9rjek) - s0(d9rjek,d9rjek,
- &1) - vy5hmo(w3gohz) * (2.0d0 * s0(d9rjek,d9rjek+du8jbv,1) +
- &vy5hmo(w3gohz) * s0(d9rjek+du8jbv,d9rjek+du8jbv,1))
+ do 23290 yq6lorbx=1,kgwmz4ip
+ do 23292 ayfnwr1v=1,nef
+ cov(ayfnwr1v,yq6lorbx) = cov(ayfnwr1v,yq6lorbx) - s0(yq6lorbx,
+ &yq6lorbx,1) - xin(ayfnwr1v) * (2.0d0 * s0(yq6lorbx,yq6lorbx+
+ &kgwmz4ip,1) + xin(ayfnwr1v) * s0(yq6lorbx+kgwmz4ip,yq6lorbx+
+ &kgwmz4ip,1))
23292 continue
23290 continue
23286 continue
goto 23283
23282 continue
- call rpfnk6(uxs1iq, vy5hmo, win, jq8lra, vfd2pw, zo5jyl, y6jcvk)
+ call dsrt0gem(nef, xin, win, sout, ub4xioar, cov, yzoe1rsp)
23283 continue
- do 23294 w3gohz=1,uxs1iq
- do 23296 d9rjek=1,du8jbv
- jq8lra(w3gohz,d9rjek) = jq8lra(w3gohz,d9rjek) - vfd2pw(d9rjek,
- &w3gohz)
+ do 23294 ayfnwr1v=1,nef
+ do 23296 yq6lorbx=1,kgwmz4ip
+ sout(ayfnwr1v,yq6lorbx) = sout(ayfnwr1v,yq6lorbx) - ub4xioar(
+ &yq6lorbx,ayfnwr1v)
23296 continue
23294 continue
- do 23298 d9rjek=1,du8jbv
- call uwye7d(nfiumb4, uxs1iq, ynk9ah, jq8lra(1,d9rjek), smo(1,
- &d9rjek))
+ do 23298 yq6lorbx=1,kgwmz4ip
+ call shm8ynte(kuzxj1lo, nef, ezlgm2up, sout(1,yq6lorbx), smo(1,
+ &yq6lorbx))
23298 continue
return
end
- subroutine vbfa( n,lku8xq,gqai81, p3vlea,jmwo0z,w8xfic,l6xrjt,dof,
- & ynk9ah,uxs1iq,vliac4, vfd2pw,sazp9g,go0l1q,s0, lq8reh,zo5jyl,
- &h4fgoy, ioqzvb,i0qvzl, i83h1, xbig, jrxg6l, ifo4ew, ozuw3p,
- &hwi2tb, nbd5rl, wj5shg, ykdc2t, wk2, zxao0o, phqco4, vb81l0, bmb,
- &rjcq9o, mwk, t5vlzq, j1l0o1, qc7zyb, das4bx, vlni8d, jko0o1,
- &mnh3up, fg3pxq)
+ subroutine vbfa( n,wy1vqfzu,psdvgce3, he7mqnvy,tlgduey8,wmat,
+ &wbkq9zyi,dof, ezlgm2up,nef,which, ub4xioar,kispwgx3,m0ibglfx,s0,
+ &beta,cov,zpcqv3uj, vc6hatuj,fasrkub3, ges1xpkr, xbig, wpuarq2m,
+ &hjm2ktyr, jnxpuym2, hnpt1zym, fzm1ihwj, iz2nbfjc, work1, wk2,
+ &wkmm, work3, sgdub, bmb, ifys6woa, mwk, twk, rpyis2kc, zv2xfhei,
+ &resss, nbzjkpi3, acpios9q, itwk, jwbkl9fp)
implicit logical (a-z)
- integer d8gwha, n, lku8xq, gqai81(15), ynk9ah(1),uxs1iq(1),vliac4(
- &1), i83h1(1)
- integer ozuw3p(1), hwi2tb(1), nbd5rl(1), wj5shg(1), vlni8d(1),
- &jko0o1(1), mnh3up(1), fg3pxq(1)
- double precision p3vlea(1),jmwo0z(1),w8xfic(1),l6xrjt(1),dof(1),
- &vfd2pw(1),sazp9g(1), go0l1q(1), s0(lku8xq), lq8reh(1),zo5jyl(1),
- &h4fgoy, ioqzvb(1),i0qvzl(1)
- double precision xbig(1), jrxg6l(1), ifo4ew(1), ykdc2t(1), wk2(n,
- &lku8xq,3), zxao0o(lku8xq,lku8xq,16), phqco4(1), vb81l0(1), bmb(1),
- & rjcq9o(1), mwk(1), t5vlzq(1), j1l0o1(1), qc7zyb(1), das4bx
- integer p,q,y6jcvk,nucgi1r,no2fik, c4bdmu, o9ljyn, tiav4e, xhe4cg,
- & zkjqhi, la5dcf,a51l0o
- integer ucgi1r
- integer sehz7y
- integer w3gohz, j0qwtz, zx1610
- d8gwha = 0
- j0qwtz = lku8xq*(lku8xq+1)/2
- p=gqai81(2)
- q=gqai81(3)
- y6jcvk= 0
- if(.not.(gqai81(4) .eq. 1))goto 23300
- y6jcvk = 1
+ integer irhm4cfa, n, wy1vqfzu, psdvgce3(15), ezlgm2up(1),nef(1),
+ &which(1), ges1xpkr(1)
+ integer jnxpuym2(1), hnpt1zym(1), fzm1ihwj(1), iz2nbfjc(1),
+ &nbzjkpi3(1), acpios9q(1), itwk(1), jwbkl9fp(1)
+ double precision he7mqnvy(1),tlgduey8(1),wmat(1),wbkq9zyi(1),dof(
+ &1), ub4xioar(1),kispwgx3(1), m0ibglfx(1), s0(wy1vqfzu), beta(1),
+ &cov(1),zpcqv3uj, vc6hatuj(1),fasrkub3(1)
+ double precision xbig(1), wpuarq2m(1), hjm2ktyr(1), work1(1), wk2(
+ &n,wy1vqfzu,3), wkmm(wy1vqfzu,wy1vqfzu,16), work3(1), sgdub(1),
+ &bmb(1), ifys6woa(1), mwk(1), twk(1), rpyis2kc(1), zv2xfhei(1),
+ &resss
+ integer p,q,yzoe1rsp,niter,gtrlbz3e, rutyk8mg, xjc4ywlh, lyma1kwc,
+ & dimw, dimu, fbd5yktj,ldk
+ integer iter
+ integer xs4wtvlg
+ integer ayfnwr1v, imk5wjxg, qemj9asg
+ irhm4cfa = 0
+ imk5wjxg = wy1vqfzu*(wy1vqfzu+1)/2
+ p=psdvgce3(2)
+ q=psdvgce3(3)
+ yzoe1rsp= 0
+ if(.not.(psdvgce3(4) .eq. 1))goto 23300
+ yzoe1rsp = 1
23300 continue
- no2fik=gqai81(6)
- zx1610=gqai81(7)
- c4bdmu=gqai81(9)
- o9ljyn=gqai81(10)
- tiav4e=gqai81(11)
- xhe4cg=gqai81(12)
- zkjqhi=gqai81(13)
- la5dcf = 0
- a51l0o=gqai81(15)
- sehz7y = 1
- if(.not.(tiav4e .gt. 0))goto 23302
- do 23304 w3gohz=1,tiav4e
- ykdc2t(w3gohz) = dof(w3gohz)
- ykdc2t(w3gohz+tiav4e) = l6xrjt(w3gohz)
- ykdc2t(w3gohz+2*tiav4e) = dof(w3gohz)
+ gtrlbz3e=psdvgce3(6)
+ qemj9asg=psdvgce3(7)
+ rutyk8mg=psdvgce3(9)
+ xjc4ywlh=psdvgce3(10)
+ lyma1kwc=psdvgce3(11)
+ dimw=psdvgce3(12)
+ dimu=psdvgce3(13)
+ fbd5yktj = 0
+ ldk=psdvgce3(15)
+ xs4wtvlg = 1
+ if(.not.(lyma1kwc .gt. 0))goto 23302
+ do 23304 ayfnwr1v=1,lyma1kwc
+ work1(ayfnwr1v) = dof(ayfnwr1v)
+ work1(ayfnwr1v+lyma1kwc) = wbkq9zyi(ayfnwr1v)
+ work1(ayfnwr1v+2*lyma1kwc) = dof(ayfnwr1v)
23304 continue
23302 continue
- ucgi1r = 0
-23306 if(.not.(sehz7y .ne. 0))goto 23307
- ucgi1r = ucgi1r+1
- if(.not.(ucgi1r .gt. 1))goto 23308
- if(.not.(tiav4e .gt. 0))goto 23310
- do 23312 w3gohz=1,tiav4e
- if(.not.(ykdc2t(w3gohz+tiav4e).eq.0.0d0 .and.(dabs(ykdc2t(w3gohz+
- &2*tiav4e)-dof(w3gohz))/dof(w3gohz).gt.0.05d0)))goto 23314
- ykdc2t(w3gohz+2*tiav4e) = dof(w3gohz)
- dof(w3gohz)=ykdc2t(w3gohz)
- l6xrjt(w3gohz)=0.0d0
+ iter = 0
+23306 if(.not.(xs4wtvlg .ne. 0))goto 23307
+ iter = iter+1
+ if(.not.(iter .gt. 1))goto 23308
+ if(.not.(lyma1kwc .gt. 0))goto 23310
+ do 23312 ayfnwr1v=1,lyma1kwc
+ if(.not.(work1(ayfnwr1v+lyma1kwc).eq.0.0d0 .and.(dabs(work1(
+ &ayfnwr1v+2*lyma1kwc)-dof(ayfnwr1v))/dof(ayfnwr1v).gt.0.05d0)))
+ &goto 23314
+ work1(ayfnwr1v+2*lyma1kwc) = dof(ayfnwr1v)
+ dof(ayfnwr1v)=work1(ayfnwr1v)
+ wbkq9zyi(ayfnwr1v)=0.0d0
goto 23315
23314 continue
- ykdc2t(w3gohz+2*tiav4e) = dof(w3gohz)
+ work1(ayfnwr1v+2*lyma1kwc) = dof(ayfnwr1v)
23315 continue
23312 continue
23310 continue
23308 continue
- call xqasw0(d8gwha,n,lku8xq, p3vlea,jmwo0z,w8xfic,l6xrjt,dof,
- &ynk9ah,uxs1iq,vliac4, vfd2pw,sazp9g,go0l1q,s0, lq8reh,zo5jyl,
- &h4fgoy, ioqzvb,i0qvzl, zx1610,i83h1, xbig, jrxg6l, ifo4ew, ozuw3p,
- & hwi2tb, nbd5rl(1), nbd5rl(1 + j0qwtz), wj5shg, ykdc2t(1+3*tiav4e)
- &, zxao0o, phqco4, vb81l0, bmb, rjcq9o, mwk, t5vlzq, j1l0o1,
- &qc7zyb, das4bx, vlni8d, jko0o1, mnh3up, fg3pxq, p,q,y6jcvk,
- &nucgi1r,no2fik, wk2(1,1,1), wk2(1,1,2), wk2(1,1,3), c4bdmu,
- &o9ljyn, tiav4e, xhe4cg, zkjqhi, la5dcf, a51l0o)
- if(.not.(d8gwha .ne. 0))goto 23316
- call vcall2(sehz7y,w,y,go0l1q,lq8reh,jrxg6l)
+ call vbfa1(irhm4cfa,n,wy1vqfzu, he7mqnvy,tlgduey8,wmat,wbkq9zyi,
+ &dof, ezlgm2up,nef,which, ub4xioar,kispwgx3,m0ibglfx,s0, beta,cov,
+ &zpcqv3uj, vc6hatuj,fasrkub3, qemj9asg,ges1xpkr, xbig, wpuarq2m,
+ &hjm2ktyr, jnxpuym2, hnpt1zym, fzm1ihwj(1), fzm1ihwj(1 + imk5wjxg),
+ & iz2nbfjc, work1(1+3*lyma1kwc), wkmm, work3, sgdub, bmb, ifys6woa,
+ & mwk, twk, rpyis2kc, zv2xfhei, resss, nbzjkpi3, acpios9q, itwk,
+ &jwbkl9fp, p,q,yzoe1rsp,niter,gtrlbz3e, wk2(1,1,1), wk2(1,1,2),
+ &wk2(1,1,3), rutyk8mg, xjc4ywlh, lyma1kwc, dimw, dimu, fbd5yktj,
+ &ldk)
+ if(.not.(irhm4cfa .ne. 0))goto 23316
+ call vcall2(xs4wtvlg,w,y,m0ibglfx,beta,wpuarq2m)
goto 23317
23316 continue
- sehz7y = 0
+ xs4wtvlg = 0
23317 continue
- if(.not.(sehz7y .ne. 0))goto 23318
- zx1610=0
+ if(.not.(xs4wtvlg .ne. 0))goto 23318
+ qemj9asg=0
23318 continue
goto 23306
23307 continue
- gqai81(7) = zx1610
- gqai81(5) = nucgi1r
- gqai81(14) = la5dcf
+ psdvgce3(7) = qemj9asg
+ psdvgce3(5) = niter
+ psdvgce3(14) = fbd5yktj
return
end
- subroutine xqasw0(d8gwha,nfiumb4,lku8xq, p3vlea,jmwo0z,w8xfic,
- &l6xrjt,dof, ynk9ah,uxs1iq,vliac4, vfd2pw,sazp9g,go0l1q,s0, lq8reh,
- &zo5jyl,h4fgoy, ioqzvb,i0qvzl, zx1610,i83h1, xbig, jrxg6l, ifo4ew,
- &ozuw3p, hwi2tb, zqve1l, vvl1li, wj5shg, ykdc2t, zxao0o, phqco4,
- &vb81l0, bmb, rjcq9o, mwk, t5vlzq, j1l0o1, qc7zyb, das4bx, vlni8d,
- &jko0o1, mnh3up, fg3pxq, p, q, y6jcvk, nucgi1r, no2fik, hr83e,
- &x7aort, wk2, c4bdmu, o9ljyn, tiav4e, xhe4cg, zkjqhi, la5dcf,
- &a51l0o)
+ subroutine vbfa1(irhm4cfa,kuzxj1lo,wy1vqfzu, he7mqnvy,tlgduey8,
+ &wmat,wbkq9zyi,dof, ezlgm2up,nef,which, ub4xioar,kispwgx3,m0ibglfx,
+ &s0, beta,cov,zpcqv3uj, vc6hatuj,fasrkub3, qemj9asg,ges1xpkr, xbig,
+ & wpuarq2m, hjm2ktyr, jnxpuym2, hnpt1zym, tgiyxdw1, dufozmt7,
+ &iz2nbfjc, work1, wkmm, work3, sgdub, bmb, ifys6woa, mwk, twk,
+ &rpyis2kc, zv2xfhei, resss, nbzjkpi3, acpios9q, itwk, jwbkl9fp, p,
+ &q, yzoe1rsp, niter, gtrlbz3e, ghz9vuba, oldmat, wk2, rutyk8mg,
+ &xjc4ywlh, lyma1kwc, dimw, dimu, fbd5yktj, ldk)
implicit logical (a-z)
- integer zx1610
- integer vvl1li(1), zqve1l(1)
- integer p, q, y6jcvk, nucgi1r, no2fik, c4bdmu, o9ljyn, tiav4e,
- &xhe4cg, zkjqhi, la5dcf, a51l0o
- integer d8gwha, nfiumb4, lku8xq, ynk9ah(nfiumb4,q),uxs1iq(q),
- &vliac4(q), i83h1(o9ljyn)
- integer ozuw3p(q), hwi2tb(q), wj5shg(q), vlni8d(q+1), jko0o1(q),
- &mnh3up(1), fg3pxq(q+1)
- double precision p3vlea(nfiumb4,p), jmwo0z(nfiumb4,lku8xq),
- &w8xfic(nfiumb4,xhe4cg), l6xrjt(tiav4e), dof(tiav4e)
- double precision vfd2pw(lku8xq,nfiumb4), sazp9g(nfiumb4,tiav4e),
- &go0l1q(lku8xq,nfiumb4), s0(lku8xq), lq8reh(o9ljyn), zo5jyl(
- &nfiumb4,tiav4e), h4fgoy, ioqzvb(c4bdmu,o9ljyn), i0qvzl(o9ljyn)
- double precision xbig(c4bdmu,o9ljyn), jrxg6l(zkjqhi,nfiumb4),
- &ifo4ew(lku8xq,tiav4e), ykdc2t(1), wk2(nfiumb4,lku8xq), zxao0o(
- &lku8xq,lku8xq,16), phqco4(1), vb81l0(1), bmb(1), rjcq9o(1), mwk(1)
- &, t5vlzq(1), j1l0o1(1), qc7zyb(1), das4bx
- double precision hr83e(nfiumb4,lku8xq), x7aort(nfiumb4,lku8xq)
- integer tvyd2b,fjg0qv,rbwx6v
- integer w3gohz, d9rjek, nd6mep, jbyv3q
- double precision gwu72m, jcp1ti,dyb3po, njdgw8, gcjn3k,t7sbea
- t7sbea = 1.0d-7
- tvyd2b = 101
- fjg0qv = 1
+ integer qemj9asg
+ integer dufozmt7(1), tgiyxdw1(1)
+ integer p, q, yzoe1rsp, niter, gtrlbz3e, rutyk8mg, xjc4ywlh,
+ &lyma1kwc, dimw, dimu, fbd5yktj, ldk
+ integer irhm4cfa, kuzxj1lo, wy1vqfzu, ezlgm2up(kuzxj1lo,q),nef(q),
+ &which(q), ges1xpkr(xjc4ywlh)
+ integer jnxpuym2(q), hnpt1zym(q), iz2nbfjc(q), nbzjkpi3(q+1),
+ &acpios9q(q), itwk(1), jwbkl9fp(q+1)
+ double precision he7mqnvy(kuzxj1lo,p), tlgduey8(kuzxj1lo,wy1vqfzu)
+ &, wmat(kuzxj1lo,dimw), wbkq9zyi(lyma1kwc), dof(lyma1kwc)
+ double precision ub4xioar(wy1vqfzu,kuzxj1lo), kispwgx3(kuzxj1lo,
+ &lyma1kwc), m0ibglfx(wy1vqfzu,kuzxj1lo), s0(wy1vqfzu), beta(
+ &xjc4ywlh), cov(kuzxj1lo,lyma1kwc), zpcqv3uj, vc6hatuj(rutyk8mg,
+ &xjc4ywlh), fasrkub3(xjc4ywlh)
+ double precision xbig(rutyk8mg,xjc4ywlh), wpuarq2m(dimu,kuzxj1lo),
+ & hjm2ktyr(wy1vqfzu,lyma1kwc), work1(1), wk2(kuzxj1lo,wy1vqfzu),
+ &wkmm(wy1vqfzu,wy1vqfzu,16), work3(1), sgdub(1), bmb(1), ifys6woa(
+ &1), mwk(1), twk(1), rpyis2kc(1), zv2xfhei(1), resss
+ double precision ghz9vuba(kuzxj1lo,wy1vqfzu), oldmat(kuzxj1lo,
+ &wy1vqfzu)
+ integer job,info,nefk
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh, wg1xifdy
+ double precision vo4mtexk, rd9beyfk,ratio, deltaf, z4vrscot,
+ &pvofyg8z
+ pvofyg8z = 1.0d-7
+ job = 101
+ info = 1
if(.not.(q .eq. 0))goto 23320
- no2fik = 1
+ gtrlbz3e = 1
23320 continue
- if(.not.(d8gwha .ne. 0))goto 23322
- do 23324 d9rjek=1,o9ljyn
- do 23326 w3gohz=1,c4bdmu
- ioqzvb(w3gohz,d9rjek)=xbig(w3gohz,d9rjek)
+ if(.not.(irhm4cfa .ne. 0))goto 23322
+ do 23324 yq6lorbx=1,xjc4ywlh
+ do 23326 ayfnwr1v=1,rutyk8mg
+ vc6hatuj(ayfnwr1v,yq6lorbx)=xbig(ayfnwr1v,yq6lorbx)
23326 continue
23324 continue
23322 continue
- if(.not.(zx1610.eq.0))goto 23328
- call qh4ulb(zqve1l,vvl1li,lku8xq)
- call mux17f(jrxg6l, ioqzvb, lku8xq, o9ljyn, nfiumb4, zxao0o(1,1,1)
- &, zxao0o(1,1,2), zqve1l, vvl1li, zkjqhi, c4bdmu)
- do 23330 nd6mep=1,o9ljyn
- i83h1(nd6mep) = nd6mep
+ if(.not.(qemj9asg.eq.0))goto 23328
+ call qpsedg8xf(tgiyxdw1,dufozmt7,wy1vqfzu)
+ call mxrbkut0f(wpuarq2m, vc6hatuj, wy1vqfzu, xjc4ywlh, kuzxj1lo,
+ &wkmm(1,1,1), wkmm(1,1,2), tgiyxdw1, dufozmt7, dimu, rutyk8mg)
+ do 23330 gp1jxzuh=1,xjc4ywlh
+ ges1xpkr(gp1jxzuh) = gp1jxzuh
23330 continue
- call dhkt9w(ioqzvb,c4bdmu,c4bdmu,o9ljyn,i0qvzl,i83h1,t5vlzq,
- &zx1610,t7sbea)
+ call vqrdca(vc6hatuj,rutyk8mg,rutyk8mg,xjc4ywlh,fasrkub3,ges1xpkr,
+ &twk,qemj9asg,pvofyg8z)
23328 continue
- do 23332 d9rjek=1,lku8xq
- do 23334 w3gohz=1,nfiumb4
- go0l1q(d9rjek,w3gohz)=0.0d0
+ do 23332 yq6lorbx=1,wy1vqfzu
+ do 23334 ayfnwr1v=1,kuzxj1lo
+ m0ibglfx(yq6lorbx,ayfnwr1v)=0.0d0
23334 continue
if(.not.(q .gt. 0))goto 23336
- do 23338 nd6mep=1,q
- if(.not.(wj5shg(nd6mep).eq.1))goto 23340
- do 23342 w3gohz=1,nfiumb4
- go0l1q(d9rjek,w3gohz) = go0l1q(d9rjek,w3gohz) + sazp9g(w3gohz,
- &hwi2tb(nd6mep)+d9rjek-1)
+ do 23338 gp1jxzuh=1,q
+ if(.not.(iz2nbfjc(gp1jxzuh).eq.1))goto 23340
+ do 23342 ayfnwr1v=1,kuzxj1lo
+ m0ibglfx(yq6lorbx,ayfnwr1v) = m0ibglfx(yq6lorbx,ayfnwr1v) +
+ &kispwgx3(ayfnwr1v,hnpt1zym(gp1jxzuh)+yq6lorbx-1)
23342 continue
goto 23341
23340 continue
- do 23344 jbyv3q=1,ozuw3p(nd6mep)
- do 23346 w3gohz=1,nfiumb4
- go0l1q(d9rjek,w3gohz) = go0l1q(d9rjek,w3gohz) + ifo4ew(d9rjek,
- &hwi2tb(nd6mep)+jbyv3q-1) * sazp9g(w3gohz,hwi2tb(nd6mep)+jbyv3q-1)
+ do 23344 wg1xifdy=1,jnxpuym2(gp1jxzuh)
+ do 23346 ayfnwr1v=1,kuzxj1lo
+ m0ibglfx(yq6lorbx,ayfnwr1v) = m0ibglfx(yq6lorbx,ayfnwr1v) +
+ &hjm2ktyr(yq6lorbx,hnpt1zym(gp1jxzuh)+wg1xifdy-1) * kispwgx3(
+ &ayfnwr1v,hnpt1zym(gp1jxzuh)+wg1xifdy-1)
23346 continue
23344 continue
23341 continue
23338 continue
23336 continue
23332 continue
- nucgi1r = 0
- dyb3po = 1.0d0
-23348 if(.not.((dyb3po .gt. h4fgoy ) .and. (nucgi1r .lt. no2fik)))goto 2
- &3349
- nucgi1r = nucgi1r + 1
- njdgw8 = 0.0d0
- do 23350 d9rjek=1,lku8xq
- do 23352 w3gohz=1,nfiumb4
- hr83e(w3gohz,d9rjek)=jmwo0z(w3gohz,d9rjek)-go0l1q(d9rjek,w3gohz)
+ niter = 0
+ ratio = 1.0d0
+23348 if(.not.((ratio .gt. zpcqv3uj ) .and. (niter .lt. gtrlbz3e)))
+ &goto 23349
+ niter = niter + 1
+ deltaf = 0.0d0
+ do 23350 yq6lorbx=1,wy1vqfzu
+ do 23352 ayfnwr1v=1,kuzxj1lo
+ ghz9vuba(ayfnwr1v,yq6lorbx)=tlgduey8(ayfnwr1v,yq6lorbx)-m0ibglfx(
+ &yq6lorbx,ayfnwr1v)
23352 continue
23350 continue
- call qh4ulb(zqve1l,vvl1li,lku8xq)
- call mux22f(jrxg6l,hr83e, t5vlzq, zkjqhi,zqve1l,vvl1li,nfiumb4,
- &lku8xq,zxao0o)
- call vdqrsl(ioqzvb,c4bdmu,c4bdmu,zx1610,i0qvzl, t5vlzq, wk2,wk2,
- &lq8reh, wk2,vfd2pw,tvyd2b,fjg0qv)
- das4bx=0.0d0
- do 23354 w3gohz=1,nfiumb4
- do 23356 d9rjek=1,lku8xq
- gwu72m = t5vlzq((w3gohz-1)*lku8xq+d9rjek) - vfd2pw(d9rjek,w3gohz)
- das4bx = das4bx + gwu72m * gwu72m
+ call qpsedg8xf(tgiyxdw1,dufozmt7,wy1vqfzu)
+ call nudh6szqf(wpuarq2m,ghz9vuba, twk, dimu,tgiyxdw1,dufozmt7,
+ &kuzxj1lo,wy1vqfzu,wkmm)
+ call vdqrsl(vc6hatuj,rutyk8mg,rutyk8mg,qemj9asg,fasrkub3, twk,
+ &wk2,wk2, beta, wk2,ub4xioar,job,info)
+ resss=0.0d0
+ do 23354 ayfnwr1v=1,kuzxj1lo
+ do 23356 yq6lorbx=1,wy1vqfzu
+ vo4mtexk = twk((ayfnwr1v-1)*wy1vqfzu+yq6lorbx) - ub4xioar(
+ &yq6lorbx,ayfnwr1v)
+ resss = resss + vo4mtexk * vo4mtexk
23356 continue
23354 continue
- call vbksf(jrxg6l,vfd2pw,lku8xq,nfiumb4,zxao0o,zqve1l,vvl1li,
- &zkjqhi)
+ call vbksf(wpuarq2m,ub4xioar,wy1vqfzu,kuzxj1lo,wkmm,tgiyxdw1,
+ &dufozmt7,dimu)
if(.not.(q .gt. 0))goto 23358
- do 23360 nd6mep=1,q
- do 23362 d9rjek=1,lku8xq
- if(.not.(wj5shg(nd6mep).eq.1))goto 23364
- do 23366 w3gohz=1,nfiumb4
- x7aort(w3gohz,d9rjek)=sazp9g(w3gohz,hwi2tb(nd6mep)+d9rjek-1)
- hr83e(w3gohz,d9rjek) = jmwo0z(w3gohz,d9rjek) - vfd2pw(d9rjek,
- &w3gohz) - go0l1q(d9rjek,w3gohz) + x7aort(w3gohz,d9rjek)
+ do 23360 gp1jxzuh=1,q
+ do 23362 yq6lorbx=1,wy1vqfzu
+ if(.not.(iz2nbfjc(gp1jxzuh).eq.1))goto 23364
+ do 23366 ayfnwr1v=1,kuzxj1lo
+ oldmat(ayfnwr1v,yq6lorbx)=kispwgx3(ayfnwr1v,hnpt1zym(gp1jxzuh)+
+ &yq6lorbx-1)
+ ghz9vuba(ayfnwr1v,yq6lorbx) = tlgduey8(ayfnwr1v,yq6lorbx) -
+ &ub4xioar(yq6lorbx,ayfnwr1v) - m0ibglfx(yq6lorbx,ayfnwr1v) +
+ &oldmat(ayfnwr1v,yq6lorbx)
23366 continue
goto 23365
23364 continue
- do 23368 w3gohz=1,nfiumb4
- x7aort(w3gohz,d9rjek)=0.0d0
- do 23370 jbyv3q=1,ozuw3p(nd6mep)
- x7aort(w3gohz,d9rjek)=x7aort(w3gohz,d9rjek) + ifo4ew(d9rjek,
- &hwi2tb(nd6mep)+jbyv3q-1) * sazp9g(w3gohz,hwi2tb(nd6mep)+jbyv3q-1)
+ do 23368 ayfnwr1v=1,kuzxj1lo
+ oldmat(ayfnwr1v,yq6lorbx)=0.0d0
+ do 23370 wg1xifdy=1,jnxpuym2(gp1jxzuh)
+ oldmat(ayfnwr1v,yq6lorbx)=oldmat(ayfnwr1v,yq6lorbx) + hjm2ktyr(
+ &yq6lorbx,hnpt1zym(gp1jxzuh)+wg1xifdy-1) * kispwgx3(ayfnwr1v,
+ &hnpt1zym(gp1jxzuh)+wg1xifdy-1)
23370 continue
- hr83e(w3gohz,d9rjek) = jmwo0z(w3gohz,d9rjek) - vfd2pw(d9rjek,
- &w3gohz) - go0l1q(d9rjek,w3gohz) + x7aort(w3gohz,d9rjek)
+ ghz9vuba(ayfnwr1v,yq6lorbx) = tlgduey8(ayfnwr1v,yq6lorbx) -
+ &ub4xioar(yq6lorbx,ayfnwr1v) - m0ibglfx(yq6lorbx,ayfnwr1v) +
+ &oldmat(ayfnwr1v,yq6lorbx)
23368 continue
23365 continue
23362 continue
- rbwx6v = uxs1iq(nd6mep)
- call ntju9b(p3vlea(1,vliac4(nd6mep)),hr83e,w8xfic, nfiumb4,lku8xq,
- &ynk9ah(1,nd6mep),rbwx6v, l6xrjt(hwi2tb(nd6mep)), dof(hwi2tb(
- &nd6mep)), sazp9g(1,hwi2tb(nd6mep)), zo5jyl(1,hwi2tb(nd6mep)), s0,
- &mwk(1), mwk(1+rbwx6v), mwk(1+rbwx6v*(lku8xq+1)), mwk(1+rbwx6v*(2*
- &lku8xq+1)), ykdc2t, phqco4, xhe4cg, la5dcf, a51l0o, fjg0qv,
- &y6jcvk, vb81l0, j1l0o1(vlni8d(nd6mep)), qc7zyb(fg3pxq(nd6mep)),
- &jko0o1(nd6mep),zqve1l, vvl1li, bmb, rjcq9o, zxao0o, wj5shg(nd6mep)
- &,ozuw3p(nd6mep),mnh3up, ifo4ew(1,hwi2tb(nd6mep)), t5vlzq(1),
- &t5vlzq(1+2*ozuw3p(nd6mep)), t5vlzq(1+4*ozuw3p(nd6mep)), t5vlzq(1+(
- &4+rbwx6v)*ozuw3p(nd6mep)), t5vlzq(1+(4+2*rbwx6v)*ozuw3p(nd6mep)),
- &t5vlzq(1+(4+3*rbwx6v)*ozuw3p(nd6mep)), t5vlzq(1+(4+4*rbwx6v)*
- &ozuw3p(nd6mep)))
- do 23372 d9rjek=1,lku8xq
- if(.not.(wj5shg(nd6mep).eq.1))goto 23374
- do 23376 w3gohz=1,nfiumb4
- go0l1q(d9rjek,w3gohz) = go0l1q(d9rjek,w3gohz) + sazp9g(w3gohz,
- &hwi2tb(nd6mep)+d9rjek-1)
+ nefk = nef(gp1jxzuh)
+ call ewg7qruh(he7mqnvy(1,which(gp1jxzuh)),ghz9vuba,wmat, kuzxj1lo,
+ &wy1vqfzu,ezlgm2up(1,gp1jxzuh),nefk, wbkq9zyi(hnpt1zym(gp1jxzuh)),
+ &dof(hnpt1zym(gp1jxzuh)), kispwgx3(1,hnpt1zym(gp1jxzuh)), cov(1,
+ &hnpt1zym(gp1jxzuh)), s0, mwk(1), mwk(1+nefk), mwk(1+nefk*(
+ &wy1vqfzu+1)), mwk(1+nefk*(2*wy1vqfzu+1)), work1, work3, dimw,
+ &fbd5yktj, ldk, info, yzoe1rsp, sgdub, rpyis2kc(nbzjkpi3(gp1jxzuh))
+ &, zv2xfhei(jwbkl9fp(gp1jxzuh)), acpios9q(gp1jxzuh),tgiyxdw1,
+ &dufozmt7, bmb, ifys6woa, wkmm, iz2nbfjc(gp1jxzuh),jnxpuym2(
+ &gp1jxzuh),itwk, hjm2ktyr(1,hnpt1zym(gp1jxzuh)), twk(1), twk(1+2*
+ &jnxpuym2(gp1jxzuh)), twk(1+4*jnxpuym2(gp1jxzuh)), twk(1+(4+nefk)*
+ &jnxpuym2(gp1jxzuh)), twk(1+(4+2*nefk)*jnxpuym2(gp1jxzuh)), twk(1+(
+ &4+3*nefk)*jnxpuym2(gp1jxzuh)), twk(1+(4+4*nefk)*jnxpuym2(gp1jxzuh)
+ &))
+ do 23372 yq6lorbx=1,wy1vqfzu
+ if(.not.(iz2nbfjc(gp1jxzuh).eq.1))goto 23374
+ do 23376 ayfnwr1v=1,kuzxj1lo
+ m0ibglfx(yq6lorbx,ayfnwr1v) = m0ibglfx(yq6lorbx,ayfnwr1v) +
+ &kispwgx3(ayfnwr1v,hnpt1zym(gp1jxzuh)+yq6lorbx-1)
23376 continue
goto 23375
23374 continue
- do 23378 jbyv3q=1,ozuw3p(nd6mep)
- do 23380 w3gohz=1,nfiumb4
- go0l1q(d9rjek,w3gohz)=go0l1q(d9rjek,w3gohz) + ifo4ew(d9rjek,
- &hwi2tb(nd6mep)+jbyv3q-1) * sazp9g(w3gohz,hwi2tb(nd6mep)+jbyv3q-1)
+ do 23378 wg1xifdy=1,jnxpuym2(gp1jxzuh)
+ do 23380 ayfnwr1v=1,kuzxj1lo
+ m0ibglfx(yq6lorbx,ayfnwr1v)=m0ibglfx(yq6lorbx,ayfnwr1v) +
+ &hjm2ktyr(yq6lorbx,hnpt1zym(gp1jxzuh)+wg1xifdy-1) * kispwgx3(
+ &ayfnwr1v,hnpt1zym(gp1jxzuh)+wg1xifdy-1)
23380 continue
23378 continue
23375 continue
- do 23382 w3gohz=1,nfiumb4
- go0l1q(d9rjek,w3gohz) = go0l1q(d9rjek,w3gohz) - x7aort(w3gohz,
- &d9rjek)
+ do 23382 ayfnwr1v=1,kuzxj1lo
+ m0ibglfx(yq6lorbx,ayfnwr1v) = m0ibglfx(yq6lorbx,ayfnwr1v) -
+ &oldmat(ayfnwr1v,yq6lorbx)
23382 continue
23372 continue
- do 23384 d9rjek=1,lku8xq
- if(.not.(wj5shg(nd6mep) .eq. 1))goto 23386
- njdgw8 = njdgw8 + jcp1ti(nfiumb4,x7aort(1,d9rjek),sazp9g(1,hwi2tb(
- &nd6mep)+d9rjek-1), w8xfic(1,d9rjek))
+ do 23384 yq6lorbx=1,wy1vqfzu
+ if(.not.(iz2nbfjc(gp1jxzuh) .eq. 1))goto 23386
+ deltaf = deltaf + rd9beyfk(kuzxj1lo,oldmat(1,yq6lorbx),kispwgx3(1,
+ &hnpt1zym(gp1jxzuh)+yq6lorbx-1), wmat(1,yq6lorbx))
goto 23387
23386 continue
- do 23388 w3gohz=1,nfiumb4
- t5vlzq(w3gohz) = 0.0d0
- do 23390 jbyv3q=1,ozuw3p(nd6mep)
- t5vlzq(w3gohz) = t5vlzq(w3gohz) + ifo4ew(d9rjek,hwi2tb(nd6mep)+
- &jbyv3q-1) * sazp9g(w3gohz,hwi2tb(nd6mep)+jbyv3q-1)
+ do 23388 ayfnwr1v=1,kuzxj1lo
+ twk(ayfnwr1v) = 0.0d0
+ do 23390 wg1xifdy=1,jnxpuym2(gp1jxzuh)
+ twk(ayfnwr1v) = twk(ayfnwr1v) + hjm2ktyr(yq6lorbx,hnpt1zym(
+ &gp1jxzuh)+wg1xifdy-1) * kispwgx3(ayfnwr1v,hnpt1zym(gp1jxzuh)+
+ &wg1xifdy-1)
23390 continue
23388 continue
- njdgw8 = njdgw8 + jcp1ti(nfiumb4, x7aort(1,d9rjek), t5vlzq,
- &w8xfic(1,d9rjek))
+ deltaf = deltaf + rd9beyfk(kuzxj1lo, oldmat(1,yq6lorbx), twk,
+ &wmat(1,yq6lorbx))
23387 continue
23384 continue
- do 23392 d9rjek=1,lku8xq
- do 23394 w3gohz=1,nfiumb4
- hr83e(w3gohz,d9rjek)=jmwo0z(w3gohz,d9rjek)-go0l1q(d9rjek,w3gohz)
+ do 23392 yq6lorbx=1,wy1vqfzu
+ do 23394 ayfnwr1v=1,kuzxj1lo
+ ghz9vuba(ayfnwr1v,yq6lorbx)=tlgduey8(ayfnwr1v,yq6lorbx)-m0ibglfx(
+ &yq6lorbx,ayfnwr1v)
23394 continue
23392 continue
- call qh4ulb(zqve1l,vvl1li,lku8xq)
- call mux22f(jrxg6l,hr83e, t5vlzq, zkjqhi,zqve1l,vvl1li,nfiumb4,
- &lku8xq,zxao0o)
- call vdqrsl(ioqzvb,c4bdmu,c4bdmu,zx1610,i0qvzl, t5vlzq, wk2,wk2,
- &lq8reh, wk2,vfd2pw,tvyd2b,fjg0qv)
- call vbksf(jrxg6l,vfd2pw,lku8xq,nfiumb4,zxao0o,zqve1l,vvl1li,
- &zkjqhi)
+ call qpsedg8xf(tgiyxdw1,dufozmt7,wy1vqfzu)
+ call nudh6szqf(wpuarq2m,ghz9vuba, twk, dimu,tgiyxdw1,dufozmt7,
+ &kuzxj1lo,wy1vqfzu,wkmm)
+ call vdqrsl(vc6hatuj,rutyk8mg,rutyk8mg,qemj9asg,fasrkub3, twk,
+ &wk2,wk2, beta, wk2,ub4xioar,job,info)
+ call vbksf(wpuarq2m,ub4xioar,wy1vqfzu,kuzxj1lo,wkmm,tgiyxdw1,
+ &dufozmt7,dimu)
23360 continue
23358 continue
if(.not.(q .gt. 0))goto 23396
- gcjn3k=0.0d0
- do 23398 d9rjek=1,lku8xq
- do 23400 w3gohz=1,nfiumb4
- gcjn3k = gcjn3k + w8xfic(w3gohz,d9rjek) * go0l1q(d9rjek,w3gohz)**
- &2
+ z4vrscot=0.0d0
+ do 23398 yq6lorbx=1,wy1vqfzu
+ do 23400 ayfnwr1v=1,kuzxj1lo
+ z4vrscot = z4vrscot + wmat(ayfnwr1v,yq6lorbx) * m0ibglfx(yq6lorbx,
+ &ayfnwr1v)**2
23400 continue
23398 continue
- if(.not.(gcjn3k .gt. 0.0d0))goto 23402
- dyb3po = dsqrt(njdgw8/gcjn3k)
+ if(.not.(z4vrscot .gt. 0.0d0))goto 23402
+ ratio = dsqrt(deltaf/z4vrscot)
goto 23403
23402 continue
- dyb3po = 0.0d0
+ ratio = 0.0d0
23403 continue
23396 continue
- if(.not.(nucgi1r .eq. 1))goto 23404
- dyb3po = 1.0d0
+ if(.not.(niter .eq. 1))goto 23404
+ ratio = 1.0d0
23404 continue
goto 23348
23349 continue
- do 23406 d9rjek=1,o9ljyn
- t5vlzq(d9rjek)=lq8reh(d9rjek)
+ do 23406 yq6lorbx=1,xjc4ywlh
+ twk(yq6lorbx)=beta(yq6lorbx)
23406 continue
- do 23408 d9rjek=1,o9ljyn
- lq8reh(i83h1(d9rjek))=t5vlzq(d9rjek)
+ do 23408 yq6lorbx=1,xjc4ywlh
+ beta(ges1xpkr(yq6lorbx))=twk(yq6lorbx)
23408 continue
- do 23410 w3gohz=1,nfiumb4
- do 23412 d9rjek=1,lku8xq
- go0l1q(d9rjek,w3gohz) = go0l1q(d9rjek,w3gohz) + vfd2pw(d9rjek,
- &w3gohz)
+ do 23410 ayfnwr1v=1,kuzxj1lo
+ do 23412 yq6lorbx=1,wy1vqfzu
+ m0ibglfx(yq6lorbx,ayfnwr1v) = m0ibglfx(yq6lorbx,ayfnwr1v) +
+ &ub4xioar(yq6lorbx,ayfnwr1v)
23412 continue
23410 continue
- if(.not.((y6jcvk .ne. 0) .and. (q .gt. 0)))goto 23414
- do 23416 nd6mep=1,q
- do 23418 jbyv3q=1,ozuw3p(nd6mep)
- call uwye7d(nfiumb4,uxs1iq(nd6mep),ynk9ah(1,nd6mep), zo5jyl(1,
- &hwi2tb(nd6mep)+jbyv3q-1),x7aort)
- do 23420 w3gohz=1,nfiumb4
- zo5jyl(w3gohz,hwi2tb(nd6mep)+jbyv3q-1) = x7aort(w3gohz,1)
+ if(.not.((yzoe1rsp .ne. 0) .and. (q .gt. 0)))goto 23414
+ do 23416 gp1jxzuh=1,q
+ do 23418 wg1xifdy=1,jnxpuym2(gp1jxzuh)
+ call shm8ynte(kuzxj1lo,nef(gp1jxzuh),ezlgm2up(1,gp1jxzuh), cov(1,
+ &hnpt1zym(gp1jxzuh)+wg1xifdy-1),oldmat)
+ do 23420 ayfnwr1v=1,kuzxj1lo
+ cov(ayfnwr1v,hnpt1zym(gp1jxzuh)+wg1xifdy-1) = oldmat(ayfnwr1v,1)
23420 continue
23418 continue
23416 continue
23414 continue
return
end
- subroutine kgevo5(p3vlea, xout, nfiumb4, lku8xq)
+ subroutine x6kanjdh(he7mqnvy, xout, kuzxj1lo, wy1vqfzu)
implicit logical (a-z)
- integer nfiumb4, lku8xq
- double precision p3vlea(nfiumb4), xout(1)
- integer w3gohz, d9rjek, nd6mep, xtiel4
- xtiel4=1
- do 23422 d9rjek=1,lku8xq
- do 23424 w3gohz=1,nfiumb4
- do 23426 nd6mep=1,lku8xq
- if(.not.(d9rjek .eq. nd6mep))goto 23428
- xout(xtiel4) = 1.0d0
+ integer kuzxj1lo, wy1vqfzu
+ double precision he7mqnvy(kuzxj1lo), xout(1)
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh, iptr
+ iptr=1
+ do 23422 yq6lorbx=1,wy1vqfzu
+ do 23424 ayfnwr1v=1,kuzxj1lo
+ do 23426 gp1jxzuh=1,wy1vqfzu
+ if(.not.(yq6lorbx .eq. gp1jxzuh))goto 23428
+ xout(iptr) = 1.0d0
goto 23429
23428 continue
- xout(xtiel4) = 0.0d0
+ xout(iptr) = 0.0d0
23429 continue
- xtiel4=xtiel4+1
+ iptr=iptr+1
23426 continue
23424 continue
23422 continue
- do 23430 d9rjek=1,lku8xq
- do 23432 w3gohz=1,nfiumb4
- do 23434 nd6mep=1,lku8xq
- if(.not.(d9rjek .eq. nd6mep))goto 23436
- xout(xtiel4) = p3vlea(w3gohz)
+ do 23430 yq6lorbx=1,wy1vqfzu
+ do 23432 ayfnwr1v=1,kuzxj1lo
+ do 23434 gp1jxzuh=1,wy1vqfzu
+ if(.not.(yq6lorbx .eq. gp1jxzuh))goto 23436
+ xout(iptr) = he7mqnvy(ayfnwr1v)
goto 23437
23436 continue
- xout(xtiel4) = 0.0d0
+ xout(iptr) = 0.0d0
23437 continue
- xtiel4=xtiel4+1
+ iptr=iptr+1
23434 continue
23432 continue
23430 continue
return
end
- double precision function jcp1ti(nfiumb4, yvec, go0l1q, wvec)
- integer nfiumb4
- double precision yvec(nfiumb4), go0l1q(nfiumb4), wvec(nfiumb4)
- integer w3gohz
- double precision wtot, risyv0, bgu6fw
- risyv0 = 0.0d0
- wtot = 0.0d0
- do 23438 w3gohz=1,nfiumb4
- bgu6fw = yvec(w3gohz) - go0l1q(w3gohz)
- risyv0 = risyv0 + wvec(w3gohz)*bgu6fw*bgu6fw
- wtot = wtot + wvec(w3gohz)
+ double precision function rd9beyfk(kuzxj1lo, bhcji9gl, m0ibglfx,
+ &po8rwsmy)
+ integer kuzxj1lo
+ double precision bhcji9gl(kuzxj1lo), m0ibglfx(kuzxj1lo), po8rwsmy(
+ &kuzxj1lo)
+ integer ayfnwr1v
+ double precision lm9vcjob, rxeqjn0y, work
+ rxeqjn0y = 0.0d0
+ lm9vcjob = 0.0d0
+ do 23438 ayfnwr1v=1,kuzxj1lo
+ work = bhcji9gl(ayfnwr1v) - m0ibglfx(ayfnwr1v)
+ rxeqjn0y = rxeqjn0y + po8rwsmy(ayfnwr1v)*work*work
+ lm9vcjob = lm9vcjob + po8rwsmy(ayfnwr1v)
23438 continue
- if(.not.(wtot .gt. 0.0d0))goto 23440
- jcp1ti=risyv0/wtot
+ if(.not.(lm9vcjob .gt. 0.0d0))goto 23440
+ rd9beyfk=rxeqjn0y/lm9vcjob
goto 23441
23440 continue
- jcp1ti=0.0d0
+ rd9beyfk=0.0d0
23441 continue
return
end
- subroutine usytl1(nfiumb4, yvec, wvec, ghry8z, wtot)
+ subroutine pitmeh0q(kuzxj1lo, bhcji9gl, po8rwsmy, lfu2qhid,
+ &lm9vcjob)
implicit logical (a-z)
- integer nfiumb4
- double precision yvec(nfiumb4), wvec(nfiumb4), ghry8z, wtot
- double precision risyv0
- integer w3gohz
- wtot = 0.0d0
- risyv0 = 0.0d0
- do 23442 w3gohz=1,nfiumb4
- risyv0 = risyv0 + yvec(w3gohz) * wvec(w3gohz)
- wtot = wtot + wvec(w3gohz)
+ integer kuzxj1lo
+ double precision bhcji9gl(kuzxj1lo), po8rwsmy(kuzxj1lo), lfu2qhid,
+ & lm9vcjob
+ double precision rxeqjn0y
+ integer ayfnwr1v
+ lm9vcjob = 0.0d0
+ rxeqjn0y = 0.0d0
+ do 23442 ayfnwr1v=1,kuzxj1lo
+ rxeqjn0y = rxeqjn0y + bhcji9gl(ayfnwr1v) * po8rwsmy(ayfnwr1v)
+ lm9vcjob = lm9vcjob + po8rwsmy(ayfnwr1v)
23442 continue
- if(.not.(wtot .gt. 0.0d0))goto 23444
- ghry8z = risyv0 / wtot
+ if(.not.(lm9vcjob .gt. 0.0d0))goto 23444
+ lfu2qhid = rxeqjn0y / lm9vcjob
goto 23445
23444 continue
- ghry8z = 0.0d0
+ lfu2qhid = 0.0d0
23445 continue
return
end
- subroutine rpfnk6(nfiumb4, x, w, yvec, vfd2pw, zo5jyl, y6jcvk)
+ subroutine dsrt0gem(kuzxj1lo, x, w, bhcji9gl, ub4xioar, cov,
+ &yzoe1rsp)
implicit logical (a-z)
- integer nfiumb4
- integer y6jcvk
- double precision x(nfiumb4), w(nfiumb4), yvec(nfiumb4), vfd2pw(
- &nfiumb4)
- double precision zo5jyl(nfiumb4,1)
- integer w3gohz
- double precision bz3pyo, qxy6aj, qnk4zf, vgh4cp, u7hbqo, agfy3b,
- &qe3jcd, j0izmn, wtot
- call usytl1(nfiumb4,yvec,w,bz3pyo, wtot)
- call usytl1(nfiumb4,x,w,qxy6aj, wtot)
- vgh4cp = 0.0d0
- qnk4zf = 0.0d0
- do 23446 w3gohz=1,nfiumb4
- j0izmn = x(w3gohz)-qxy6aj
- vgh4cp = vgh4cp + j0izmn * (yvec(w3gohz)-bz3pyo) * w(w3gohz)
- j0izmn = j0izmn * j0izmn
- qnk4zf = qnk4zf + j0izmn * w(w3gohz)
+ integer kuzxj1lo
+ integer yzoe1rsp
+ double precision x(kuzxj1lo), w(kuzxj1lo), bhcji9gl(kuzxj1lo),
+ &ub4xioar(kuzxj1lo)
+ double precision cov(kuzxj1lo,1)
+ integer ayfnwr1v
+ double precision pasjmo8g, pygsw6ko, q6zdcwxk, nsum, eck8vubt,
+ &interc, bzmd6ftv, hofjnx2e, lm9vcjob
+ call pitmeh0q(kuzxj1lo,bhcji9gl,w,pasjmo8g, lm9vcjob)
+ call pitmeh0q(kuzxj1lo,x,w,pygsw6ko, lm9vcjob)
+ nsum = 0.0d0
+ q6zdcwxk = 0.0d0
+ do 23446 ayfnwr1v=1,kuzxj1lo
+ hofjnx2e = x(ayfnwr1v)-pygsw6ko
+ nsum = nsum + hofjnx2e * (bhcji9gl(ayfnwr1v)-pasjmo8g) * w(
+ &ayfnwr1v)
+ hofjnx2e = hofjnx2e * hofjnx2e
+ q6zdcwxk = q6zdcwxk + hofjnx2e * w(ayfnwr1v)
23446 continue
- u7hbqo = vgh4cp/qnk4zf
- agfy3b = bz3pyo - u7hbqo * qxy6aj
- do 23448 w3gohz=1,nfiumb4
- vfd2pw(w3gohz) = agfy3b + u7hbqo * x(w3gohz)
+ eck8vubt = nsum/q6zdcwxk
+ interc = pasjmo8g - eck8vubt * pygsw6ko
+ do 23448 ayfnwr1v=1,kuzxj1lo
+ ub4xioar(ayfnwr1v) = interc + eck8vubt * x(ayfnwr1v)
23448 continue
- qe3jcd = agfy3b + u7hbqo * x(1)
- if(.not.(y6jcvk .ne. 0))goto 23450
- do 23452 w3gohz=1,nfiumb4
- j0izmn = x(w3gohz)-qxy6aj
- if(.not.(w(w3gohz) .gt. 0.0d0))goto 23454
- zo5jyl(w3gohz,1) = zo5jyl(w3gohz,1) - 1.0d0/wtot - j0izmn *
- &j0izmn / qnk4zf
+ bzmd6ftv = interc + eck8vubt * x(1)
+ if(.not.(yzoe1rsp .ne. 0))goto 23450
+ do 23452 ayfnwr1v=1,kuzxj1lo
+ hofjnx2e = x(ayfnwr1v)-pygsw6ko
+ if(.not.(w(ayfnwr1v) .gt. 0.0d0))goto 23454
+ cov(ayfnwr1v,1) = cov(ayfnwr1v,1) - 1.0d0/lm9vcjob - hofjnx2e *
+ &hofjnx2e / q6zdcwxk
goto 23455
23454 continue
- zo5jyl(w3gohz,1) = 0.0d0
+ cov(ayfnwr1v,1) = 0.0d0
23455 continue
23452 continue
23450 continue
return
end
- subroutine uwye7d(nfiumb4, p, ynk9ah, qxy6aj, x)
+ subroutine shm8ynte(kuzxj1lo, p, ezlgm2up, pygsw6ko, x)
implicit logical (a-z)
- integer nfiumb4, p, ynk9ah(nfiumb4)
- double precision qxy6aj(p), x(nfiumb4)
- integer w3gohz
- do 23456 w3gohz=1,nfiumb4
- x(w3gohz) = qxy6aj(ynk9ah(w3gohz))
+ integer kuzxj1lo, p, ezlgm2up(kuzxj1lo)
+ double precision pygsw6ko(p), x(kuzxj1lo)
+ integer ayfnwr1v
+ do 23456 ayfnwr1v=1,kuzxj1lo
+ x(ayfnwr1v) = pygsw6ko(ezlgm2up(ayfnwr1v))
23456 continue
return
end
- subroutine vknotl2(x, nfiumb4, knot, xl6qgm, q9wyop)
+ subroutine vankcghz2l2(x, kuzxj1lo, ankcghz2, rvy1fpli, ukgwt7na)
implicit logical (a-z)
- integer nfiumb4, xl6qgm, q9wyop
- double precision x(nfiumb4), knot(nfiumb4)
- integer ndk, d9rjek
- if(.not.(q9wyop .eq. 0))goto 23458
- if(.not.(nfiumb4 .le. 40))goto 23460
- ndk = nfiumb4
+ integer kuzxj1lo, rvy1fpli, ukgwt7na
+ double precision x(kuzxj1lo), ankcghz2(kuzxj1lo)
+ integer ndk, yq6lorbx
+ if(.not.(ukgwt7na .eq. 0))goto 23458
+ if(.not.(kuzxj1lo .le. 40))goto 23460
+ ndk = kuzxj1lo
goto 23461
23460 continue
- ndk = 40 + dexp(0.25d0 * dlog(nfiumb4-40.0d0))
+ ndk = 40 + dexp(0.25d0 * dlog(kuzxj1lo-40.0d0))
23461 continue
goto 23459
23458 continue
- ndk = xl6qgm - 6
+ ndk = rvy1fpli - 6
23459 continue
- xl6qgm = ndk + 6
- do 23462 d9rjek = 1,3
- knot(d9rjek) = x(1)
+ rvy1fpli = ndk + 6
+ do 23462 yq6lorbx = 1,3
+ ankcghz2(yq6lorbx) = x(1)
23462 continue
- do 23464 d9rjek = 1,ndk
- knot(d9rjek+3) = x( 1 + (d9rjek-1)*(nfiumb4-1)/(ndk-1) )
+ do 23464 yq6lorbx = 1,ndk
+ ankcghz2(yq6lorbx+3) = x( 1 + (yq6lorbx-1)*(kuzxj1lo-1)/(ndk-1) )
23464 continue
- do 23466 d9rjek = 1,3
- knot(ndk+3+d9rjek) = x(nfiumb4)
+ do 23466 yq6lorbx = 1,3
+ ankcghz2(ndk+3+yq6lorbx) = x(kuzxj1lo)
23466 continue
return
end
- subroutine pknotl2(knot, nfiumb4, keep, fjo2dy)
+ subroutine pankcghz2l2(ankcghz2, kuzxj1lo, zo8wpibx, tol)
implicit logical (a-z)
- integer nfiumb4, keep(nfiumb4)
- double precision knot(nfiumb4), fjo2dy
- integer w3gohz, ilower
- do 23468 w3gohz=1,4
- keep(w3gohz) = 1
+ integer kuzxj1lo, zo8wpibx(kuzxj1lo)
+ double precision ankcghz2(kuzxj1lo), tol
+ integer ayfnwr1v, cjop5bwm
+ do 23468 ayfnwr1v=1,4
+ zo8wpibx(ayfnwr1v) = 1
23468 continue
- ilower = 4
- do 23470 w3gohz=5,(nfiumb4-4)
- if(.not.((knot(w3gohz) - knot(ilower) .ge. fjo2dy) .and.(knot(
- &nfiumb4) - knot(w3gohz) .ge. fjo2dy)))goto 23472
- keep(w3gohz) = 1
- ilower = w3gohz
+ cjop5bwm = 4
+ do 23470 ayfnwr1v=5,(kuzxj1lo-4)
+ if(.not.((ankcghz2(ayfnwr1v) - ankcghz2(cjop5bwm) .ge. tol) .and.(
+ &ankcghz2(kuzxj1lo) - ankcghz2(ayfnwr1v) .ge. tol)))goto 23472
+ zo8wpibx(ayfnwr1v) = 1
+ cjop5bwm = ayfnwr1v
goto 23473
23472 continue
- keep(w3gohz) = 0
+ zo8wpibx(ayfnwr1v) = 0
23473 continue
23470 continue
- do 23474 w3gohz=(nfiumb4-3),nfiumb4
- keep(w3gohz) = 1
+ do 23474 ayfnwr1v=(kuzxj1lo-3),kuzxj1lo
+ zo8wpibx(ayfnwr1v) = 1
23474 continue
return
end
diff --git a/src/vgam3.c b/src/vgam3.c
new file mode 100644
index 0000000..41a7e59
--- /dev/null
+++ b/src/vgam3.c
@@ -0,0 +1,2003 @@
+
+
+
+
+
+
+#include<math.h>
+#include<stdio.h>
+#include<stdlib.h>
+#include<R.h>
+#include<Rmath.h>
+
+void Yee_vbvs(int *f8yswcat, double gkdx5jal[], double rpyis2kc[],
+ double sjwyig9t[], double kispwgx3[],
+ int *acpios9q, int *order, int *wy1vqfzu);
+void fapc0tnbtfeswo7c(double osiz4fxy[], int *acpios9q, int *wy1vqfzu, int *ldk,
+ double wbkq9zyi[],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[]);
+void fapc0tnbybnagt8k(int *iii, int *cz8qdfyj, int *tesdm5kv,
+ double g9fvdrbw[], double osiz4fxy[], double rbne6ouj[],
+ int *kxvq6sfw, int *nyfu9rod, int *wy1vqfzu, int *ldk,
+ int *kvowz9ht, int *kuzxj1lo,
+ int tgiyxdw1[], int dufozmt7[]);
+void Yee_spline(double *sjwyig9t, double *tlgduey8, double *rbne6ouj, double *gkdx5jal,
+ int *lqsahu0r, int *acpios9q, int *ldk, int *wy1vqfzu, int *kvowz9ht,
+ double wbkq9zyi[], double lamvec[],
+ int *aalgpft4y, double t8hwvalr[],
+ double rpyis2kc[], double ui8ysltq[],
+ double ifys6woa[], double hdnw2fts[],
+ int *yzoe1rsp, int *fbd5yktj, int *ftnjamu2,
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double tt2[], int *cvnjhg2u,
+ int itdcb8ilk[], // Added 20100313
+ double tdcb8ilk[] // Added 20100313
+ );
+void fapc0tnbcn8kzpab(double gkdx5jal[], double sjwyig9t[], double rpyis2kc[],
+ int *lqsahu0r, int *acpios9q, int *wy1vqfzu, double t8hwvalr[]);
+void vsuff9(int *ftnjamu2, int *lqsahu0r, int ezlgm2up[],
+ double sjwyig9t[], double tlgduey8[], double rbne6ouj[],
+ double pygsw6ko[], double pasjmo8g[], double eshvo2ic[],
+ double ueshvo2ic[], double onxjvw8u[], int *dvhw1ulq,
+ int *wy1vqfzu, int *kvowz9ht, int *npjlv3mr,
+ double conmat[], int *kgwmz4ip,
+ int *iz2nbfjc, int *wueshvo2ic,
+ int *npjlv3mreshvo2ic, int *dim2eshvo2ic);
+void fapc0tnbicpd0omv(double enaqpzk9[], double sjwyig9t[], double gkdx5jal[],
+ double grmuyvx9[],
+ int *ldk, int *lqsahu0r, int *acpios9q, int *wy1vqfzu, int *jzwsy6tp,
+ double rbne6ouj[], double ifys6woa[],
+ int *kvowz9ht, int *ftnjamu2);
+void fapc0tnbo0xlszqr(int *wy1vqfzu, double *g9fvdrbw, double *quc6khaf, double *bmb);
+void fapc0tnbvsel(int *nurohxe6t, int *nbpvaqm5z, int *wy1vqfzu, int *ldk,
+ double minv[], double quc6khaf[]);
+void fapc0tnbovjnsmt2(double bmb[], double rbne6ouj[],
+ double ifys6woa[],
+ int *wy1vqfzu, int *kuzxj1lo, int *dimw, int *iii,
+ int tgiyxdw1_[], int dufozmt7_[]);
+void fapc0tnbvicb2(double enaqpzk9[], double wpuarq2m[], double Dvector[],
+ int *wy1vqfzu, int *f8yswcat);
+
+void fapc0tnbewg7qruh(double ci1oyxas[], double tlgduey8[], double rbne6ouj[],
+ int *ftnjamu2, int *wy1vqfzu, int ezlgm2up[], int *lqsahu0r,
+ double wbkq9zyi[], double lamvec[], double hdnw2fts[],
+ double kispwgx3[], double ui8ysltq[],
+ int *kvowz9ht, int *fbd5yktj, int *ldk, int *aalgpft4y, int *yzoe1rsp,
+ double rpyis2kc[], double gkdx5jals[], double ifys6woa[], double conmat[],
+
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double *tt2, int *cvnjhg2u,
+
+ int *acpios9q, int *iz2nbfjc, int *kgwmz4ip,
+ int *npjlv3mr,
+ int itdcb8ilk[], // Added 20100313
+ double tdcb8ilk[] // Added 20100313
+ );
+void Yee_vbfa(
+ int psdvgce3[], double *doubvec, double he7mqnvy[], double tlgduey8[],
+ double rbne6ouj[], double hdnw2fts[], double lamvec[], double wbkq9zyi[],
+ int ezlgm2up[], int lqsahu0r[], int which[],
+ double kispwgx3[], double m0ibglfx[],
+ double zshtfg8c[], double ui8ysltq[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+
+
+ double wpuarq2m[], double hjm2ktyr[], int ulm3dvzg[],
+ int hnpt1zym[],
+ int iz2nbfjc[],
+
+
+ double ifys6woa[],
+
+
+ double rpyis2kc[], double gkdx5jals[],
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[]);
+void fapc0tnbvbfa1(int *ftnjamu2, int *wy1vqfzu, int ezlgm2up[], int lqsahu0r[], int which[],
+ double he7mqnvy[], double tlgduey8[], double rbne6ouj[],
+ double wbkq9zyi[], double lamvec[], double hdnw2fts[],
+ double kispwgx3[], double m0ibglfx[], double zshtfg8c[],
+ double ui8ysltq[], double *zpcqv3uj, double vc6hatuj[], double fasrkub3[],
+ int *qemj9asg, int ges1xpkr[], double wpuarq2m[], double hjm2ktyr[],
+ int ulm3dvzg[], int hnpt1zym[], int iz2nbfjc[],
+ double ifys6woa[],
+ double rpyis2kc[], double gkdx5jals[], double *ghdetj8v,
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[],
+ int *nhja0izq, int *yzoe1rsp, int *ueb8hndv, int *gtrlbz3e,
+ int *rutyk8mg, int *xjc4ywlh,
+ int *kvowz9ht, int *npjlv3mr, int *fbd5yktj, int *ldk, int *algpft4y,
+ int itdcb8ilk[],
+ double tdcb8ilk[]);
+void fapc0tnbx6kanjdh(double sjwyig9t[], double xout[], int *f8yswcat, int *wy1vqfzu);
+double fapc0tnbrd9beyfk(int *f8yswcat, double bhcji9gl[], double po8rwsmy[],
+ double m0ibglfx[]);
+void fapc0tnbpitmeh0q(int *f8yswcat, double bhcji9gl[], double po8rwsmy[],
+ double *lfu2qhid, double *lm9vcjob);
+void fapc0tnbdsrt0gem(int *f8yswcat, double sjwyig9t[], double po8rwsmy[], double bhcji9gl[],
+ double ub4xioar[], double ui8ysltq[], int *yzoe1rsp);
+void fapc0tnbshm8ynte(int *ftnjamu2,
+ int ezlgm2up[], double pygsw6ko[], double sjwyig9t[]);
+void vknootl2(double x[], int *f8yswcat, double gkdx5jal[], int *rvy1fpli,
+ int *ukgwt7na);
+void Yee_pknootl2(double *gkdx5jal, int *f8yswcat, int *zo8wpibx, double *Toler_ankcghz2);
+void F77_NAME(wbvalue)(double*, double*, int*, int*, double*, int*,
+ double*);
+void F77_NAME(vinterv)(double*, int*, double*, int*, int*);
+void F77_NAME(vbsplvd)(double*, int*, double*, int*, double*, double*,int*);
+void F77_NAME(vdpbfa7)(double*, int*, int*, int*, int*, double*);
+void F77_NAME(vdpbsl7)(double*, int*, int*, int*, double*, double*);
+void F77_NAME(vdqrsl)(double*, int*, int*, int*, double*, double*, double*,
+ double*, double*, double*, double*, int*, int*);
+void F77_NAME(vqrdca)(double*, int*, int*, int*, double*, int*, double*,
+ int*, double*);
+
+void Free_fapc0tnbvsplin(double *wkumc9idosiz4fxy, double *wkumc9idenaqpzk9,
+ double *wkumc9idbtwy, double *wkumc9idwk0, double *wkumc9idbk3ymcih,
+ int *wkumc9idtgiyxdw1, int *wkumc9iddufozmt7);
+void Free_fapc0tnbewg7qruh(double *wkumc9idWrk1,
+ int *wkumc9idges1xpkr,
+ double *wkumc9idbeta, double *wkumc9idfasrkub3,
+ double *wkumc9idsout, double *wkumc9idr0oydcxb,
+ double *wkumc9idub4xioar, double *wkumc9ideffect,
+ double *wkumc9idueshvo2ic, double *wkumc9ids0,
+ double *wkumc9idpygsw6ko, double *wkumc9idpasjmo8g,
+ double *wkumc9ideshvo2ic, double *wkumc9idonxjvw8u,
+ double *wkumc9idwk4);
+
+
+extern
+void n5aioudkdnaoqj0l(double *pjb6wfoq, double *xs, double *ys,
+ double ws[], int *kuzxj1lo, int *nk, double gkdx5jal[],
+ double coef[], double sz[], double ifys6woa[],
+ double *wbkq9zyi, double parms[],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double *tt2,
+ int *cvnjhg2u, int l3zpbstu[],
+ int *xtov9rbf, int *wep0oibc, int *fbd5yktj);
+
+extern
+void n5aioudkzosq7hub(double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double tb[], int *nb);
+
+extern
+void fvlmz9iyC_qpsedg8x(int tgiyxdw1[], int dufozmt7[], int *wy1vqfzu);
+
+extern
+void fvlmz9iyjdbomp0g(double rbne6ouj[], double unvxka0m[], int *wy1vqfzu, int *dvhw1ulq,
+ int *isolve);
+
+extern
+void fvlmz9iyjdbomp0g(double rbne6ouj[], double unvxka0m[], int *wy1vqfzu, int *dvhw1ulq,
+ int *isolve);
+
+extern
+void fvlmz9iyC_nudh6szq(double wpuarq2m[], double tlgduey8[], double lfu2qhid[],
+ int *dimu, int *f8yswcat, int *wy1vqfzu);
+
+extern
+void fvlmz9iyC_vbks(double wpuarq2m[], double unvxka0m[], int *wy1vqfzu, int *f8yswcat,
+ int *dimu);
+
+extern
+void fvlmz9iyC_lkhnw9yq(double wpuarq2m[], double ks3wejcv[],
+ int *npjlv3mr, int *wy1vqfzu, int *dvhw1ulq);
+
+extern
+void fvlmz9iyC_mxrbkut0(double wpuarq2m[], double he7mqnvy[], int *wy1vqfzu, int *xjc4ywlh,
+ int *f8yswcat, int *dimu, int *rutyk8mg);
+
+
+
+
+void Yee_vbvs(int *f8yswcat, double gkdx5jal[], double rpyis2kc[],
+ double sjwyig9t[], double kispwgx3[],
+ int *acpios9q, int *order, int *wy1vqfzu) {
+
+
+ double *chw8lzty;
+ int ayfnwr1v, yq6lorbx, h2dpsbkr = 4;
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ chw8lzty = sjwyig9t;
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ F77_CALL(wbvalue)(gkdx5jal, rpyis2kc, acpios9q, &h2dpsbkr,
+ chw8lzty++, order, kispwgx3++);
+ }
+ rpyis2kc += *acpios9q;
+ }
+}
+
+
+void fapc0tnbtfeswo7c(double osiz4fxy[], int *acpios9q, int *wy1vqfzu, int *ldk,
+ double wbkq9zyi[],
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[]) {
+
+
+ int ayfnwr1v, yq6lorbx;
+ double *fpdlcqk9wbkq9zyi, *fpdlcqk9xecbg0pf, *fpdlcqk9z4grbpiq, *fpdlcqk9d7glzhbj, *fpdlcqk9v2eydbxs,
+ *fpdlcqk9osiz4fxy;
+
+
+ fpdlcqk9osiz4fxy = osiz4fxy + *ldk - 1;
+ fpdlcqk9xecbg0pf = xecbg0pf;
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+ fpdlcqk9wbkq9zyi = wbkq9zyi;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9osiz4fxy += *fpdlcqk9wbkq9zyi++ * *fpdlcqk9xecbg0pf;
+ fpdlcqk9osiz4fxy += *ldk;
+ }
+ fpdlcqk9xecbg0pf++;
+ }
+
+ fpdlcqk9osiz4fxy = osiz4fxy + *wy1vqfzu * *ldk;
+ fpdlcqk9osiz4fxy = fpdlcqk9osiz4fxy + *ldk - *wy1vqfzu - 1;
+ fpdlcqk9z4grbpiq = z4grbpiq;
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+ fpdlcqk9wbkq9zyi = wbkq9zyi;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9osiz4fxy += *fpdlcqk9wbkq9zyi++ * *fpdlcqk9z4grbpiq;
+ fpdlcqk9osiz4fxy += *ldk;
+ }
+ fpdlcqk9z4grbpiq++;
+ }
+
+ fpdlcqk9osiz4fxy = osiz4fxy + *ldk + 2 * *wy1vqfzu * *ldk;
+ fpdlcqk9osiz4fxy = fpdlcqk9osiz4fxy - 2 * *wy1vqfzu - 1;
+ fpdlcqk9d7glzhbj = d7glzhbj;
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+ fpdlcqk9wbkq9zyi = wbkq9zyi;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9osiz4fxy += *fpdlcqk9wbkq9zyi++ * *fpdlcqk9d7glzhbj;
+ fpdlcqk9osiz4fxy += *ldk;
+ }
+ fpdlcqk9d7glzhbj++;
+ }
+
+ fpdlcqk9osiz4fxy = osiz4fxy + *ldk + 3 * *wy1vqfzu * *ldk;
+ fpdlcqk9osiz4fxy = fpdlcqk9osiz4fxy - 3 * *wy1vqfzu - 1;
+ fpdlcqk9v2eydbxs = v2eydbxs;
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+ fpdlcqk9wbkq9zyi = wbkq9zyi;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9osiz4fxy += *fpdlcqk9wbkq9zyi++ * *fpdlcqk9v2eydbxs;
+ fpdlcqk9osiz4fxy += *ldk;
+ }
+ fpdlcqk9v2eydbxs++;
+ }
+}
+
+
+void fapc0tnbybnagt8k(int *iii, int *cz8qdfyj, int *tesdm5kv,
+ double g9fvdrbw[], double osiz4fxy[], double rbne6ouj[],
+ int *kxvq6sfw, int *nyfu9rod, int *wy1vqfzu, int *ldk,
+ int *kvowz9ht, int *kuzxj1lo, int tgiyxdw1[], int dufozmt7[]) {
+
+
+ double tmp_wrk;
+ int urohxe6t, nead, bcol, brow, biuvowq2, nbj8tdsk;
+
+
+
+ bcol = *cz8qdfyj + *tesdm5kv;
+ brow = *cz8qdfyj;
+ for (urohxe6t = 1; urohxe6t <= *kvowz9ht; urohxe6t++) {
+ tmp_wrk = rbne6ouj[*iii -1 + (urohxe6t-1) * *kuzxj1lo] *
+ g9fvdrbw[*kxvq6sfw-1] * g9fvdrbw[*nyfu9rod-1];
+
+ biuvowq2 = (brow-1) * *wy1vqfzu + tgiyxdw1[urohxe6t-1];
+ nbj8tdsk = (bcol-1) * *wy1vqfzu + dufozmt7[urohxe6t-1];
+ nead = nbj8tdsk - biuvowq2;
+ osiz4fxy[*ldk - nead - 1 + (nbj8tdsk-1) * *ldk] += tmp_wrk;
+
+ if (*tesdm5kv > 0 && dufozmt7[urohxe6t-1] != tgiyxdw1[urohxe6t-1]) {
+ biuvowq2 = (brow-1) * *wy1vqfzu + dufozmt7[urohxe6t-1];
+ nbj8tdsk = (bcol-1) * *wy1vqfzu + tgiyxdw1[urohxe6t-1];
+ nead = nbj8tdsk - biuvowq2;
+ osiz4fxy[*ldk - nead - 1 + (nbj8tdsk-1) * *ldk] += tmp_wrk;
+ }
+ }
+
+}
+
+
+void Free_fapc0tnbvsplin(double *wkumc9idosiz4fxy, double *wkumc9idenaqpzk9,
+ double *wkumc9idbtwy, double *wkumc9idwk0, double *wkumc9idbk3ymcih,
+ int *wkumc9idtgiyxdw1, int *wkumc9iddufozmt7) {
+ Free(wkumc9idosiz4fxy); Free(wkumc9idenaqpzk9);
+ Free(wkumc9idbtwy); Free(wkumc9idwk0); Free(wkumc9idbk3ymcih);
+ Free(wkumc9idtgiyxdw1); Free(wkumc9iddufozmt7);
+}
+
+
+void Yee_spline(double *sjwyig9t, double *tlgduey8, double *rbne6ouj, double *gkdx5jal,
+ int *lqsahu0r, int *acpios9q, int *ldk, int *wy1vqfzu, int *kvowz9ht,
+ double wbkq9zyi[], double lamvec[],
+ int *aalgpft4y, double t8hwvalr[],
+ double rpyis2kc[], double ui8ysltq[], double ifys6woa[], double hdnw2fts[],
+ int *yzoe1rsp, int *fbd5yktj, int *ftnjamu2,
+
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double *tt2, int *cvnjhg2u,
+
+ int itdcb8ilk[], // Added 20100313
+ double tdcb8ilk[] // Added 20100313
+ ) {
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, urohxe6t, bpvaqm5z,
+ dqlr5bse, pqzfxw4i, wep0oibc;
+
+
+ int junkicrit = -1,
+ xtov9rbf = 4,
+ l3zpbstu[3], pn9eowxc;
+ double jstx4uwe[4], g9fvdrbw[4], qaltf0nz = 0.1e-9,
+ ms0qypiw[16], *fpdlcqk9btwy;
+
+ int yu6izdrc = 0, pqneb2ra = 1, qhzja4ny = 2, bvsquk3z = 3, h2dpsbkr = 4;
+ int arm0lkbg1, arm0lkbg2;
+
+ double *wkumc9idosiz4fxy, *wkumc9idenaqpzk9,
+ *wkumc9idbtwy, *wkumc9idwk0, *wkumc9idbk3ymcih;
+
+ int *wkumc9idtgiyxdw1, *wkumc9iddufozmt7;
+ int imk5wjxg = *wy1vqfzu * (*wy1vqfzu + 1) / 2;
+
+ double kpftdm0jmynl7uaq = tdcb8ilk[0],
+ kpftdm0jzustx4fw = tdcb8ilk[1],
+ kpftdm0jtol = tdcb8ilk[2],
+ kpftdm0jeps = tdcb8ilk[3];
+
+
+ wkumc9idtgiyxdw1 = Calloc(imk5wjxg, int);
+ wkumc9iddufozmt7 = Calloc(imk5wjxg, int);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw1, wkumc9iddufozmt7, wy1vqfzu);
+
+ wkumc9idosiz4fxy = Calloc(*ldk * (*wy1vqfzu * *acpios9q), double);
+ wkumc9idenaqpzk9 = Calloc(*ldk * (*acpios9q * *wy1vqfzu), double);
+ wkumc9idbtwy = Calloc(*wy1vqfzu * *acpios9q , double);
+ wkumc9idbk3ymcih = Calloc( *acpios9q , double);
+ wkumc9idwk0 = Calloc(*acpios9q * *wy1vqfzu , double);
+
+
+
+
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+
+
+ if (wbkq9zyi[yq6lorbx-1] == 0.0) {
+ pn9eowxc = 0;
+ } else {
+ pn9eowxc = 1;
+ }
+
+
+ if (*wy1vqfzu == 1 || *kvowz9ht == *wy1vqfzu || pn9eowxc == 0) { // ggg
+
+ wep0oibc = 1;
+
+ l3zpbstu[0] = junkicrit;
+ l3zpbstu[1] = pn9eowxc;
+ l3zpbstu[2] = itdcb8ilk[0];
+ jstx4uwe[0] = kpftdm0jmynl7uaq; // Prior to 20100313: was waiez6nt;
+ jstx4uwe[1] = kpftdm0jzustx4fw; // Prior to 20100313: was fp6nozvx;
+ jstx4uwe[2] = kpftdm0jtol; // Prior to 20100313: was Toler_df;
+ jstx4uwe[3] = kpftdm0jeps; // Introduced as an arg, 20100313
+
+
+ if (*wy1vqfzu == 1 || *kvowz9ht == *wy1vqfzu) { // hhh
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r] /=
+ rbne6ouj[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r];
+ }
+
+
+ n5aioudkdnaoqj0l(hdnw2fts + yq6lorbx-1,
+ sjwyig9t, tlgduey8 + (yq6lorbx-1) * *lqsahu0r,
+ rbne6ouj + (yq6lorbx-1) * *lqsahu0r,
+ lqsahu0r, acpios9q,
+ gkdx5jal, rpyis2kc + (yq6lorbx-1) * *acpios9q,
+ t8hwvalr + (yq6lorbx-1) * *lqsahu0r,
+ ifys6woa + (yq6lorbx-1) * *ftnjamu2,
+ wbkq9zyi + yq6lorbx-1, jstx4uwe,
+ xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs,
+ tt2,
+ cvnjhg2u, l3zpbstu,
+ &xtov9rbf, &wep0oibc, fbd5yktj);
+ lamvec[yq6lorbx-1] = jstx4uwe[0];
+
+ if (*fbd5yktj) {
+ Rprintf("Error in n5aioudkdnaoqj0l; inside Yee_spline\n");
+ Free_fapc0tnbvsplin(wkumc9idosiz4fxy, wkumc9idenaqpzk9,
+ wkumc9idbtwy, wkumc9idwk0, wkumc9idbk3ymcih,
+ wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ return;
+ }
+
+ if (*yzoe1rsp) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ gp1jxzuh = ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2;
+ bpvaqm5z = ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r;
+ ui8ysltq[gp1jxzuh] = ifys6woa[gp1jxzuh] / rbne6ouj[bpvaqm5z];
+ }
+ }
+ } else { // hhh and uuu
+ n5aioudkdnaoqj0l(hdnw2fts + yq6lorbx-1,
+ sjwyig9t, wkumc9idbk3ymcih, rbne6ouj + (yq6lorbx-1) * *lqsahu0r,
+ lqsahu0r, acpios9q,
+ gkdx5jal, rpyis2kc + (yq6lorbx-1) * *acpios9q,
+ t8hwvalr + (yq6lorbx-1) * *lqsahu0r,
+ ifys6woa + (yq6lorbx-1) * *ftnjamu2,
+ wbkq9zyi + yq6lorbx-1, jstx4uwe,
+ xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs,
+ tt2,
+ cvnjhg2u, l3zpbstu,
+ &xtov9rbf, &wep0oibc, fbd5yktj);
+
+ lamvec[yq6lorbx-1] = jstx4uwe[0];
+
+ if (*fbd5yktj) {
+ Rprintf("Error in Rgam_dnaoqj0l; inside Yee_spline\n");
+ Free_fapc0tnbvsplin(wkumc9idosiz4fxy, wkumc9idenaqpzk9,
+ wkumc9idbtwy, wkumc9idwk0, wkumc9idbk3ymcih,
+ wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ return;
+ }
+ } // uuu
+
+ if (*fbd5yktj) {
+ Rprintf("Error in n5aioudkdnaoqj0l: fbd5yktj = %3d.\n", *fbd5yktj);
+ Rprintf("Called within Yee_spline.\n");
+ Free_fapc0tnbvsplin(wkumc9idosiz4fxy, wkumc9idenaqpzk9,
+ wkumc9idbtwy, wkumc9idwk0, wkumc9idbk3ymcih,
+ wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ return;
+ }
+ } // ggg
+ }
+
+ if (*wy1vqfzu == 1 || *kvowz9ht == *wy1vqfzu) {
+ Free_fapc0tnbvsplin(wkumc9idosiz4fxy, wkumc9idenaqpzk9,
+ wkumc9idbtwy, wkumc9idwk0, wkumc9idbk3ymcih,
+ wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ return;
+ }
+
+
+
+
+
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ arm0lkbg1 = *acpios9q + 1;
+ F77_CALL(vinterv)(gkdx5jal, &arm0lkbg1, sjwyig9t + ayfnwr1v-1,
+ &dqlr5bse, &pqzfxw4i);
+
+ if (pqzfxw4i == 1) {
+ if (sjwyig9t[ayfnwr1v-1] <= (gkdx5jal[dqlr5bse-1] + qaltf0nz)) {
+ dqlr5bse--;
+ } else {
+ Rprintf("Freeing memory in Yee_spline and returning.\n");
+ Free_fapc0tnbvsplin(wkumc9idosiz4fxy, wkumc9idenaqpzk9,
+ wkumc9idbtwy, wkumc9idwk0, wkumc9idbk3ymcih,
+ wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ return;
+ }
+ }
+
+ F77_CALL(vbsplvd)(gkdx5jal, &h2dpsbkr, sjwyig9t + ayfnwr1v-1, &dqlr5bse, ms0qypiw,
+ g9fvdrbw, &pqneb2ra);
+
+ yq6lorbx= dqlr5bse - 4 + 1;
+ fpdlcqk9btwy = wkumc9idbtwy + (yq6lorbx-1) * *wy1vqfzu;
+ for (urohxe6t = 1; urohxe6t <= *wy1vqfzu; urohxe6t++) {
+ *fpdlcqk9btwy += tlgduey8[ayfnwr1v-1 + (urohxe6t-1) * *lqsahu0r] * g9fvdrbw[0];
+ fpdlcqk9btwy++;
+ }
+
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &yu6izdrc,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &pqneb2ra, &pqneb2ra, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &pqneb2ra,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &pqneb2ra, &qhzja4ny, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &qhzja4ny,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &pqneb2ra, &bvsquk3z, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &bvsquk3z,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &pqneb2ra, &h2dpsbkr, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+
+ yq6lorbx = dqlr5bse - 4 + 2;
+ fpdlcqk9btwy = wkumc9idbtwy + (yq6lorbx-1) * *wy1vqfzu;
+ for (urohxe6t = 1; urohxe6t <= *wy1vqfzu; urohxe6t++) {
+ *fpdlcqk9btwy += tlgduey8[ayfnwr1v-1 + (urohxe6t-1) * *lqsahu0r] * g9fvdrbw[1];
+ fpdlcqk9btwy++;
+ }
+
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &yu6izdrc,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &qhzja4ny, &qhzja4ny, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &pqneb2ra,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &qhzja4ny, &bvsquk3z, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &qhzja4ny,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &qhzja4ny, &h2dpsbkr, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+
+ yq6lorbx = dqlr5bse - 4 + 3;
+ fpdlcqk9btwy = wkumc9idbtwy + (yq6lorbx-1) * *wy1vqfzu;
+ for (urohxe6t = 1; urohxe6t <= *wy1vqfzu; urohxe6t++) {
+ *fpdlcqk9btwy += tlgduey8[ayfnwr1v-1 + (urohxe6t-1) * *lqsahu0r] * g9fvdrbw[2];
+ fpdlcqk9btwy++;
+ }
+
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &yu6izdrc,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &bvsquk3z, &bvsquk3z, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &pqneb2ra,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &bvsquk3z, &h2dpsbkr, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+
+ yq6lorbx = dqlr5bse - 4 + 4;
+ fpdlcqk9btwy = wkumc9idbtwy + (yq6lorbx-1) * *wy1vqfzu;
+ for (urohxe6t = 1; urohxe6t <= *wy1vqfzu; urohxe6t++) {
+ *fpdlcqk9btwy += tlgduey8[ayfnwr1v-1 + (urohxe6t-1) * *lqsahu0r] * g9fvdrbw[3];
+ fpdlcqk9btwy++;
+ }
+
+ fapc0tnbybnagt8k(&ayfnwr1v, &yq6lorbx, &yu6izdrc,
+ g9fvdrbw, wkumc9idosiz4fxy, rbne6ouj,
+ &h2dpsbkr, &h2dpsbkr, wy1vqfzu, ldk,
+ kvowz9ht, lqsahu0r, wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ }
+
+
+
+ fapc0tnbtfeswo7c(wkumc9idosiz4fxy, acpios9q, wy1vqfzu, ldk, lamvec,
+ xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs);
+
+ arm0lkbg1 = *acpios9q * *wy1vqfzu;
+ arm0lkbg2 = *ldk - 1;
+ F77_CALL(vdpbfa7)(wkumc9idosiz4fxy, ldk, &arm0lkbg1, &arm0lkbg2,
+ aalgpft4y, wkumc9idwk0);
+
+
+ if (*aalgpft4y) {
+ Rprintf("Error in subroutine vdpbfa7; inside Yee_spline.\n");
+ Rprintf("*aalgpft4y = %3d\n", *aalgpft4y);
+ Free_fapc0tnbvsplin(wkumc9idosiz4fxy, wkumc9idenaqpzk9,
+ wkumc9idbtwy, wkumc9idwk0, wkumc9idbk3ymcih,
+ wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+ return;
+ }
+
+ arm0lkbg1 = *acpios9q * *wy1vqfzu;
+ arm0lkbg2 = *ldk - 1;
+ F77_CALL(vdpbsl7)(wkumc9idosiz4fxy, ldk, &arm0lkbg1, &arm0lkbg2,
+ wkumc9idbtwy, wkumc9idwk0);
+
+
+ fpdlcqk9btwy = wkumc9idbtwy;
+ for (ayfnwr1v = 1; ayfnwr1v <= *acpios9q; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ rpyis2kc[ ayfnwr1v-1 + (yq6lorbx-1) * *acpios9q] = *fpdlcqk9btwy++;
+ }
+ }
+
+ fapc0tnbcn8kzpab(gkdx5jal, sjwyig9t, rpyis2kc,
+ lqsahu0r, acpios9q, wy1vqfzu, t8hwvalr);
+
+
+
+ arm0lkbg1 = *acpios9q * *wy1vqfzu;
+ arm0lkbg2 = *ldk - 1;
+ fapc0tnbvicb2(wkumc9idenaqpzk9, wkumc9idosiz4fxy, wkumc9idwk0,
+ &arm0lkbg2, &arm0lkbg1);
+
+ fapc0tnbicpd0omv(wkumc9idenaqpzk9, sjwyig9t, gkdx5jal, ui8ysltq,
+ ldk, lqsahu0r, acpios9q, wy1vqfzu, yzoe1rsp,
+ rbne6ouj, ifys6woa, kvowz9ht, ftnjamu2);
+
+
+ Free_fapc0tnbvsplin(wkumc9idosiz4fxy, wkumc9idenaqpzk9,
+ wkumc9idbtwy, wkumc9idwk0, wkumc9idbk3ymcih,
+ wkumc9idtgiyxdw1, wkumc9iddufozmt7);
+}
+
+
+
+void fapc0tnbcn8kzpab(double gkdx5jals[], double sjwyig9t[], double rpyis2kc[],
+ int *lqsahu0r, int *acpios9q, int *wy1vqfzu, double t8hwvalr[]) {
+
+
+ int ayfnwr1v, yq6lorbx, yu6izdrc = 0, h2dpsbkr = 4;
+ double *chw8lzty;
+
+
+ for (yq6lorbx = 0; yq6lorbx < *wy1vqfzu; yq6lorbx++) {
+ chw8lzty = sjwyig9t;
+ for (ayfnwr1v = 0; ayfnwr1v < *lqsahu0r; ayfnwr1v++) {
+ F77_CALL(wbvalue)(gkdx5jals, rpyis2kc, acpios9q, &h2dpsbkr,
+ chw8lzty++, &yu6izdrc, t8hwvalr++);
+ }
+ rpyis2kc += *acpios9q;
+ }
+}
+
+
+void Free_fapc0tnbvsuff9(double *wkumc9idwk1a, double *wkumc9idwk1b,
+ double *wkumc9idwk2a, double *wkumc9idwk2b,
+ double *wkumc9ideshvo2ic, double *wkumc9idonxjvw8u,
+ int *wkumc9idtgiyxdw11, int *wkumc9iddufozmt71,
+ int *wkumc9idtgiyxdw12, int *wkumc9iddufozmt72,
+ int *iz2nbfjc) {
+ Free(wkumc9idwk1a); Free(wkumc9idwk1b);
+ Free(wkumc9idwk2a); Free(wkumc9idwk2b);
+ if (! *iz2nbfjc) {
+ Free(wkumc9ideshvo2ic);
+ Free(wkumc9idonxjvw8u);
+ }
+ Free(wkumc9idtgiyxdw11); Free(wkumc9iddufozmt71);
+ Free(wkumc9idtgiyxdw12); Free(wkumc9iddufozmt72);
+}
+
+
+void vsuff9(int *ftnjamu2, int *lqsahu0r, int ezlgm2up[],
+ double sjwyig9t[], double tlgduey8[], double rbne6ouj[],
+ double pygsw6ko[], double pasjmo8g[], double eshvo2ic[],
+ double ueshvo2ic[], double onxjvw8u[], int *dvhw1ulq,
+ int *wy1vqfzu, int *kvowz9ht, int *npjlv3mr,
+ double conmat[], int *kgwmz4ip,
+ int *iz2nbfjc, int *wueshvo2ic,
+ int *npjlv3mreshvo2ic, int *dim2eshvo2ic) {
+
+
+
+
+
+ double *qnwamo0e, *qnwamo0e1, *qnwamo0e2;
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, urohxe6t, bpvaqm5z, *ptri;
+ int pqneb2ra = 1;
+
+
+
+
+ double *wkumc9idwk1a, *wkumc9idwk1b, *wkumc9idwk2a, *wkumc9idwk2b,
+ *wkumc9ideshvo2ic, *wkumc9idonxjvw8u;
+ int *wkumc9idtgiyxdw11, *wkumc9iddufozmt71,
+ *wkumc9idtgiyxdw12, *wkumc9iddufozmt72;
+ int zyojx5hw = *wy1vqfzu * *wy1vqfzu,
+ imk5wjxg = *wy1vqfzu * (*wy1vqfzu + 1) / 2,
+ n2colb = *kgwmz4ip * *kgwmz4ip,
+ n3colb = *kgwmz4ip * (*kgwmz4ip + 1) / 2;
+
+ wkumc9idwk1a = Calloc(zyojx5hw , double);
+ wkumc9idwk1b = Calloc(*wy1vqfzu , double);
+ wkumc9idwk2a = Calloc(n2colb , double);
+ wkumc9idwk2b = Calloc(*kgwmz4ip , double);
+ wkumc9idtgiyxdw11 = Calloc(imk5wjxg , int);
+ wkumc9iddufozmt71 = Calloc(imk5wjxg , int);
+ wkumc9idtgiyxdw12 = Calloc(n3colb , int);
+ wkumc9iddufozmt72 = Calloc(n3colb , int);
+
+ if (*iz2nbfjc) {
+ if (*npjlv3mr < *kvowz9ht || *kgwmz4ip != *wy1vqfzu) {
+ Rprintf("Error in fapc0tnbvsuff9: ");
+ Rprintf("must have npjlv3mr >= kvowz9ht & kgwmz4ip = M\n");
+ Free_fapc0tnbvsuff9(wkumc9idwk1a, wkumc9idwk1b,
+ wkumc9idwk2a, wkumc9idwk2b,
+ wkumc9ideshvo2ic, wkumc9idonxjvw8u,
+ wkumc9idtgiyxdw11, wkumc9iddufozmt71,
+ wkumc9idtgiyxdw12, wkumc9iddufozmt72,
+ iz2nbfjc);
+ *dvhw1ulq = 0;
+ return;
+ }
+ } else {
+ if (*npjlv3mreshvo2ic < n3colb || *dim2eshvo2ic < n3colb) {
+ Rprintf("Error in fapc0tnbvsuff9 with nontrivial constraints:\n");
+ Rprintf("must have npjlv3mreshvo2ic and dim2eshvo2ic both >= n3colb\n");
+ Free_fapc0tnbvsuff9(wkumc9idwk1a, wkumc9idwk1b,
+ wkumc9idwk2a, wkumc9idwk2b,
+ wkumc9ideshvo2ic, wkumc9idonxjvw8u,
+ wkumc9idtgiyxdw11, wkumc9iddufozmt71,
+ wkumc9idtgiyxdw12, wkumc9iddufozmt72,
+ iz2nbfjc);
+ *dvhw1ulq = 0;
+ return;
+ }
+
+ wkumc9ideshvo2ic = Calloc(*lqsahu0r * zyojx5hw , double);
+ wkumc9idonxjvw8u = Calloc(*lqsahu0r * *wy1vqfzu , double);
+ }
+
+
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw11, wkumc9iddufozmt71, wy1vqfzu);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw12, wkumc9iddufozmt72, kgwmz4ip);
+
+ ptri = ezlgm2up; qnwamo0e = sjwyig9t;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ pygsw6ko[(*ptri++) - 1] = *qnwamo0e++;
+ }
+
+ if (*iz2nbfjc) {
+ qnwamo0e = onxjvw8u;
+ for (yq6lorbx = 0; yq6lorbx < *wy1vqfzu; yq6lorbx++) {
+ for (ayfnwr1v = 0; ayfnwr1v < *lqsahu0r; ayfnwr1v++) {
+ *qnwamo0e++ = 0.0e0;
+ }
+ }
+ }
+
+ if (*iz2nbfjc) {
+ qnwamo0e = eshvo2ic;
+ for (yq6lorbx = 1; yq6lorbx <= *dim2eshvo2ic; yq6lorbx++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ *qnwamo0e++ = 0.0e0;
+ }
+ }
+ }
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *kvowz9ht; yq6lorbx++) {
+ wkumc9idwk1a[wkumc9idtgiyxdw11[yq6lorbx-1]-1 +
+ (wkumc9iddufozmt71[yq6lorbx-1]-1) * *wy1vqfzu] =
+ wkumc9idwk1a[wkumc9iddufozmt71[yq6lorbx-1]-1 +
+ (wkumc9idtgiyxdw11[yq6lorbx-1]-1) * *wy1vqfzu] =
+ rbne6ouj[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2];
+ }
+
+ qnwamo0e1 = (*iz2nbfjc) ? eshvo2ic : wkumc9ideshvo2ic;
+ qnwamo0e2 = (*iz2nbfjc) ? onxjvw8u : wkumc9idonxjvw8u;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ for (gp1jxzuh = 1; gp1jxzuh <= *wy1vqfzu; gp1jxzuh++) {
+ qnwamo0e2[ezlgm2up[ayfnwr1v-1]-1 + (yq6lorbx-1) * *lqsahu0r] +=
+ wkumc9idwk1a[yq6lorbx -1 + (gp1jxzuh-1) * *wy1vqfzu] *
+ tlgduey8[ayfnwr1v -1 + (gp1jxzuh-1) * *ftnjamu2];
+ }
+ }
+ for (yq6lorbx = 1; yq6lorbx <= *kvowz9ht; yq6lorbx++) {
+ qnwamo0e1[ezlgm2up[ayfnwr1v-1]-1 + (yq6lorbx-1) * *lqsahu0r] +=
+ rbne6ouj[ayfnwr1v -1 + (yq6lorbx-1) * *ftnjamu2];
+ }
+ }
+
+ *dvhw1ulq = 1;
+ if (*iz2nbfjc) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *kvowz9ht; yq6lorbx++) {
+ wkumc9idwk1a[wkumc9idtgiyxdw11[yq6lorbx-1]-1 +
+ (wkumc9iddufozmt71[yq6lorbx-1]-1) * *wy1vqfzu] =
+ wkumc9idwk1a[wkumc9iddufozmt71[yq6lorbx-1]-1 +
+ (wkumc9idtgiyxdw11[yq6lorbx-1]-1) * *wy1vqfzu] =
+ eshvo2ic[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r];
+ }
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ wkumc9idwk1b[yq6lorbx-1] = onxjvw8u[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r];
+ }
+
+ fvlmz9iyjdbomp0g(wkumc9idwk1a, wkumc9idwk1b, wy1vqfzu, dvhw1ulq, &pqneb2ra);
+ if (*dvhw1ulq != 1) {
+ Rprintf("*dvhw1ulq != 1 after fvlmz9iyjdbomp0g in vsuff9.\n");
+ Free_fapc0tnbvsuff9(wkumc9idwk1a, wkumc9idwk1b,
+ wkumc9idwk2a, wkumc9idwk2b,
+ wkumc9ideshvo2ic, wkumc9idonxjvw8u,
+ wkumc9idtgiyxdw11, wkumc9iddufozmt71,
+ wkumc9idtgiyxdw12, wkumc9iddufozmt72,
+ iz2nbfjc);
+ return;
+ }
+ if (*wueshvo2ic) {
+ for (yq6lorbx = 1; yq6lorbx <= *npjlv3mreshvo2ic; yq6lorbx++) {
+ ueshvo2ic[yq6lorbx-1 + (ayfnwr1v-1) * *npjlv3mreshvo2ic] =
+ wkumc9idwk1a[wkumc9idtgiyxdw11[yq6lorbx-1]-1 +
+ (wkumc9iddufozmt71[yq6lorbx-1]-1) * *wy1vqfzu];
+ }
+ }
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ pasjmo8g[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r] = wkumc9idwk1b[yq6lorbx-1];
+ }
+ }
+ } else {
+ qnwamo0e = wkumc9idwk1a;
+ for (yq6lorbx = 1; yq6lorbx <= zyojx5hw; yq6lorbx++) {
+ *qnwamo0e++ = 0.0e0;
+ }
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+
+ for (yq6lorbx = 1; yq6lorbx <= *kvowz9ht; yq6lorbx++) {
+ wkumc9idwk1a[wkumc9idtgiyxdw11[yq6lorbx-1]-1 +
+ (wkumc9iddufozmt71[yq6lorbx-1]-1) * *wy1vqfzu] =
+ wkumc9idwk1a[wkumc9iddufozmt71[yq6lorbx-1]-1 +
+ (wkumc9idtgiyxdw11[yq6lorbx-1]-1) * *wy1vqfzu] =
+ wkumc9ideshvo2ic[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r];
+ }
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ wkumc9idwk1b[yq6lorbx-1] = wkumc9idonxjvw8u[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r];
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ for (gp1jxzuh = yq6lorbx; gp1jxzuh <= *kgwmz4ip; gp1jxzuh++) {
+ wkumc9idwk2a[yq6lorbx-1 + (gp1jxzuh-1) * *kgwmz4ip] = 0.0e0;
+ for (urohxe6t = 1; urohxe6t <= *wy1vqfzu; urohxe6t++) {
+ for (bpvaqm5z = 1; bpvaqm5z <= *wy1vqfzu; bpvaqm5z++) {
+ wkumc9idwk2a[yq6lorbx-1 + (gp1jxzuh-1) * *kgwmz4ip] +=
+ conmat[urohxe6t-1 + (yq6lorbx-1) * *wy1vqfzu] *
+ wkumc9idwk1a[urohxe6t-1 + (bpvaqm5z-1) * *wy1vqfzu] *
+ conmat[bpvaqm5z-1 + (gp1jxzuh-1) * *wy1vqfzu];
+ }
+ }
+ }
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *dim2eshvo2ic; yq6lorbx++) {
+ eshvo2ic[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r] =
+ wkumc9idwk2a[wkumc9idtgiyxdw12[yq6lorbx-1]-1 +
+ (wkumc9iddufozmt72[yq6lorbx-1]-1) * *kgwmz4ip];
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ wkumc9idwk2b[yq6lorbx-1] = 0.0e0;
+ for (urohxe6t = 1; urohxe6t <= *wy1vqfzu; urohxe6t++) {
+ wkumc9idwk2b[yq6lorbx-1] += conmat[urohxe6t-1 + (yq6lorbx-1) * *wy1vqfzu] *
+ wkumc9idwk1b[urohxe6t-1];
+ }
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ onxjvw8u[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r] = wkumc9idwk2b[yq6lorbx-1];
+ }
+
+ fvlmz9iyjdbomp0g(wkumc9idwk2a, wkumc9idwk2b, kgwmz4ip, dvhw1ulq, &pqneb2ra);
+ if (*dvhw1ulq != 1) {
+ Rprintf("*dvhw1ulq!=1 in vchol-vsuff9. Something gone wrong\n");
+ Free_fapc0tnbvsuff9(wkumc9idwk1a, wkumc9idwk1b,
+ wkumc9idwk2a, wkumc9idwk2b,
+ wkumc9ideshvo2ic, wkumc9idonxjvw8u,
+ wkumc9idtgiyxdw11, wkumc9iddufozmt71,
+ wkumc9idtgiyxdw12, wkumc9iddufozmt72,
+ iz2nbfjc);
+ return;
+ }
+
+ if (*wueshvo2ic) {
+ for (yq6lorbx = 1; yq6lorbx <= *npjlv3mreshvo2ic; yq6lorbx++) {
+ ueshvo2ic[yq6lorbx-1 + (ayfnwr1v-1) * *npjlv3mreshvo2ic] =
+ wkumc9idwk2a[wkumc9idtgiyxdw12[yq6lorbx-1]-1 +
+ (wkumc9iddufozmt72[yq6lorbx-1]-1) * *kgwmz4ip];
+ }
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ pasjmo8g[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r] = wkumc9idwk2b[yq6lorbx-1];
+ }
+ }
+ }
+
+ Free_fapc0tnbvsuff9(wkumc9idwk1a, wkumc9idwk1b,
+ wkumc9idwk2a, wkumc9idwk2b,
+ wkumc9ideshvo2ic, wkumc9idonxjvw8u,
+ wkumc9idtgiyxdw11, wkumc9iddufozmt71,
+ wkumc9idtgiyxdw12, wkumc9iddufozmt72,
+ iz2nbfjc);
+}
+
+
+void fapc0tnbicpd0omv(double enaqpzk9[], double sjwyig9t[], double gkdx5jals[],
+ double grmuyvx9[],
+ int *ldk, int *lqsahu0r, int *acpios9q, int *wy1vqfzu, int *jzwsy6tp,
+ double rbne6ouj[], double ifys6woa[], int *kvowz9ht, int *ftnjamu2) {
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, urohxe6t, bpvaqm5z, dqlr5bse, pqzfxw4i;
+ double ms0qypiw[16], g9fvdrbw[4], qaltf0nz = 0.10e-9;
+
+ int arm0lkbg1, arm0lkbg4, *ptri1, *ptri2;
+ double tmp_var4, tmp_var5, *qnwamo0e;
+ double *wkumc9idwrk, *wkumc9idbmb;
+ int *wkumc9idtgiyxdw1_, *wkumc9iddufozmt7_,
+ imk5wjxg = *wy1vqfzu * (*wy1vqfzu + 1) / 2,
+ zyojx5hw = *wy1vqfzu * *wy1vqfzu;
+ wkumc9idtgiyxdw1_ = Calloc(imk5wjxg, int);
+ wkumc9iddufozmt7_ = Calloc(imk5wjxg, int);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw1_, wkumc9iddufozmt7_, wy1vqfzu);
+ ptri1 = wkumc9idtgiyxdw1_; ptri2 = wkumc9iddufozmt7_;
+ for (ayfnwr1v = 0; ayfnwr1v < imk5wjxg; ayfnwr1v++) {
+ (*ptri1++)--; (*ptri2++)--;
+ }
+
+ wkumc9idwrk = Calloc(zyojx5hw, double);
+ wkumc9idbmb = Calloc(zyojx5hw, double);
+
+
+
+
+
+
+ if (*jzwsy6tp) {
+ qnwamo0e = grmuyvx9;
+ for (gp1jxzuh = 1; gp1jxzuh <= *wy1vqfzu; gp1jxzuh++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *qnwamo0e++ = 0.0e0;
+ }
+ }
+ }
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+
+ qnwamo0e = wkumc9idbmb;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ for (gp1jxzuh = 1; gp1jxzuh <= *wy1vqfzu; gp1jxzuh++) {
+ *qnwamo0e++ = 0.0e0;
+ }
+ }
+
+ arm0lkbg1 = *acpios9q + 1;
+ F77_CALL(vinterv)(gkdx5jals, &arm0lkbg1, sjwyig9t + ayfnwr1v-1,
+ &dqlr5bse, &pqzfxw4i);
+
+ if (pqzfxw4i == 1) {
+ if (sjwyig9t[ayfnwr1v-1] <= (gkdx5jals[dqlr5bse-1] + qaltf0nz)) {
+ dqlr5bse--;
+ } else {
+ Rprintf("pqzfxw4i!=1 after vinterv called in fapc0tnbicpd0omv\n");
+ Free(wkumc9idtgiyxdw1_); Free(wkumc9iddufozmt7_);
+ Free(wkumc9idwrk);
+ return;
+ }
+ }
+ arm0lkbg1 = 1;
+ arm0lkbg4 = 4;
+ F77_CALL(vbsplvd)(gkdx5jals, &arm0lkbg4, sjwyig9t + ayfnwr1v-1, &dqlr5bse,
+ ms0qypiw, g9fvdrbw, &arm0lkbg1);
+
+ yq6lorbx = dqlr5bse - 4 + 1;
+
+
+ for (urohxe6t = yq6lorbx; urohxe6t <= (yq6lorbx + 3); urohxe6t++) {
+ fapc0tnbvsel(&urohxe6t, &urohxe6t, wy1vqfzu, ldk,
+ enaqpzk9, wkumc9idwrk);
+
+ tmp_var4 = pow(g9fvdrbw[urohxe6t-yq6lorbx], (double) 2.0);
+ fapc0tnbo0xlszqr(wy1vqfzu, &tmp_var4, wkumc9idwrk, wkumc9idbmb);
+ }
+
+ for (urohxe6t = yq6lorbx; urohxe6t <= (yq6lorbx+3); urohxe6t++) {
+ for (bpvaqm5z = urohxe6t+1; bpvaqm5z <= (yq6lorbx+3); bpvaqm5z++) {
+ fapc0tnbvsel(&urohxe6t, &bpvaqm5z, wy1vqfzu, ldk,
+ enaqpzk9, wkumc9idwrk);
+ tmp_var5 = 2.0 * g9fvdrbw[urohxe6t-yq6lorbx] * g9fvdrbw[bpvaqm5z-yq6lorbx];
+ fapc0tnbo0xlszqr(wy1vqfzu, &tmp_var5, wkumc9idwrk, wkumc9idbmb);
+ }
+ }
+
+ if (*jzwsy6tp) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ grmuyvx9[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] =
+ wkumc9idbmb[yq6lorbx-1 + (yq6lorbx-1) * *wy1vqfzu];
+ }
+ }
+
+ fapc0tnbovjnsmt2(wkumc9idbmb, rbne6ouj, ifys6woa,
+ wy1vqfzu, lqsahu0r, kvowz9ht, &ayfnwr1v,
+ wkumc9idtgiyxdw1_, wkumc9iddufozmt7_);
+ }
+
+ Free(wkumc9idtgiyxdw1_); Free(wkumc9iddufozmt7_);
+ Free(wkumc9idwrk);
+ Free(wkumc9idbmb);
+}
+
+
+void fapc0tnbo0xlszqr(int *wy1vqfzu, double *g9fvdrbw, double *quc6khaf, double *bmb) {
+
+
+
+ int yq6lorbx, gp1jxzuh;
+ double *qnwamo0e;
+
+
+
+ qnwamo0e = quc6khaf;
+ for (yq6lorbx = 0; yq6lorbx < *wy1vqfzu; yq6lorbx++) {
+ for (gp1jxzuh = 0; gp1jxzuh < *wy1vqfzu; gp1jxzuh++) {
+ *quc6khaf *= *g9fvdrbw;
+ quc6khaf++;
+ }
+ }
+ quc6khaf = qnwamo0e;
+ for (yq6lorbx = 0; yq6lorbx < *wy1vqfzu; yq6lorbx++) {
+ for (gp1jxzuh = 0; gp1jxzuh < *wy1vqfzu; gp1jxzuh++) {
+ *bmb += *quc6khaf++;
+ bmb++;
+ }
+ }
+}
+
+
+void fapc0tnbvsel(int *nurohxe6t, int *nbpvaqm5z, int *wy1vqfzu, int *ldk,
+ double minv[], double quc6khaf[]) {
+
+
+ int ayfnwr1v, yq6lorbx, biuvowq2, nbj8tdsk;
+ double *qnwamo0e;
+
+
+
+ qnwamo0e = quc6khaf;
+ for (ayfnwr1v = 1; ayfnwr1v <= *wy1vqfzu; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *qnwamo0e++ = 0.0;
+ }
+ }
+
+ if (*nurohxe6t != *nbpvaqm5z) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *wy1vqfzu; ayfnwr1v++) {
+ biuvowq2 = (*nurohxe6t - 1) * *wy1vqfzu + ayfnwr1v;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ nbj8tdsk = (*nbpvaqm5z - 1) * *wy1vqfzu + yq6lorbx;
+ quc6khaf[ayfnwr1v-1 + (yq6lorbx-1) * *wy1vqfzu] =
+ minv[*ldk - (nbj8tdsk-biuvowq2)-1 + (nbj8tdsk-1) * *ldk];
+ }
+ }
+ } else {
+ for (ayfnwr1v = 1; ayfnwr1v <= *wy1vqfzu; ayfnwr1v++) {
+ biuvowq2 = (*nurohxe6t - 1) * *wy1vqfzu + ayfnwr1v;
+ for (yq6lorbx = ayfnwr1v; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ nbj8tdsk = (*nbpvaqm5z - 1) * *wy1vqfzu + yq6lorbx;
+ quc6khaf[ayfnwr1v-1 + (yq6lorbx-1) * *wy1vqfzu] =
+ minv[*ldk - (nbj8tdsk-biuvowq2)-1 + (nbj8tdsk-1) * *ldk];
+ }
+ }
+ for (ayfnwr1v = 1; ayfnwr1v <= *wy1vqfzu; ayfnwr1v++) {
+ for (yq6lorbx = ayfnwr1v+1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ quc6khaf[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] =
+ quc6khaf[ayfnwr1v-1 + (yq6lorbx-1) * *wy1vqfzu];
+ }
+ }
+ }
+}
+
+
+void fapc0tnbovjnsmt2(double bmb[], double rbne6ouj[],
+ double ifys6woa[],
+ int *wy1vqfzu, int *lqsahu0r, int *kvowz9ht, int *iii,
+ int tgiyxdw1_[], int dufozmt7_[]) {
+
+
+
+ int yq6lorbx, gp1jxzuh, urohxe6t, bpvaqm5z;
+ double q6zdcwxk;
+
+ int zyojx5hw = *wy1vqfzu * *wy1vqfzu;
+ double *wkumc9idwrk;
+ wkumc9idwrk = Calloc(zyojx5hw, double);
+
+
+ for (bpvaqm5z = 1; bpvaqm5z <= *wy1vqfzu; bpvaqm5z++) {
+ for (urohxe6t = 1; urohxe6t <= *kvowz9ht; urohxe6t++) {
+ yq6lorbx = tgiyxdw1_[urohxe6t-1] + (dufozmt7_[urohxe6t-1] ) * *wy1vqfzu;
+ gp1jxzuh = dufozmt7_[urohxe6t-1] + (tgiyxdw1_[urohxe6t-1] ) * *wy1vqfzu;
+
+ wkumc9idwrk[yq6lorbx] =
+ wkumc9idwrk[gp1jxzuh] = rbne6ouj[*iii-1 + (urohxe6t-1) * *lqsahu0r];
+ }
+
+ q6zdcwxk = 0.0e0;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ q6zdcwxk += bmb[bpvaqm5z-1 + (yq6lorbx-1) * *wy1vqfzu] *
+ wkumc9idwrk[yq6lorbx-1 + (bpvaqm5z-1) * *wy1vqfzu];
+ }
+ ifys6woa[*iii-1 + (bpvaqm5z-1) * *lqsahu0r] = q6zdcwxk;
+ }
+
+ Free(wkumc9idwrk);
+}
+
+
+void fapc0tnbvicb2(double enaqpzk9[], double wpuarq2m[], double Dvector[],
+ int *wy1vqfzu, int *f8yswcat) {
+
+
+ int ayfnwr1v, gp1jxzuh, urohxe6t, uplim, sedf7mxb, hofjnx2e, kij0gwer;
+
+
+
+
+
+ int Mplus1 = *wy1vqfzu + 1;
+ int Mp1Mp1 = Mplus1 * Mplus1;
+ double *wkumc9iduu;
+ wkumc9iduu = Calloc(Mp1Mp1, double);
+
+ enaqpzk9[*wy1vqfzu + (*f8yswcat-1) * Mplus1] = 1.0e0 / Dvector[*f8yswcat-1];
+
+ hofjnx2e = *wy1vqfzu + 1;
+ sedf7mxb = *f8yswcat + 1 - hofjnx2e;
+ for (kij0gwer = sedf7mxb; kij0gwer <= *f8yswcat; kij0gwer++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= hofjnx2e; ayfnwr1v++) {
+ wkumc9iduu[ayfnwr1v-1 + (kij0gwer-sedf7mxb) * Mplus1] =
+ wpuarq2m[ayfnwr1v-1 + (kij0gwer-1 ) * Mplus1];
+ }
+ }
+
+ for (ayfnwr1v = *f8yswcat-1; ayfnwr1v >= 1; ayfnwr1v--) {
+ uplim = *wy1vqfzu < (*f8yswcat - ayfnwr1v) ? *wy1vqfzu : *f8yswcat - ayfnwr1v;
+
+ for (urohxe6t = 1; urohxe6t <= uplim; urohxe6t++) {
+ enaqpzk9[-urohxe6t+*wy1vqfzu + (ayfnwr1v+urohxe6t-1) * Mplus1] = 0.0e0;
+ for (gp1jxzuh = 1; gp1jxzuh <= urohxe6t; gp1jxzuh++) {
+ enaqpzk9[-urohxe6t + *wy1vqfzu + (ayfnwr1v+urohxe6t-1 ) * Mplus1] -=
+ wkumc9iduu[-gp1jxzuh + *wy1vqfzu + (ayfnwr1v+gp1jxzuh - sedf7mxb) * Mplus1] *
+ enaqpzk9[gp1jxzuh-urohxe6t + *wy1vqfzu + (ayfnwr1v+urohxe6t-1 ) * Mplus1];
+ }
+
+ for ( ; gp1jxzuh <= uplim; gp1jxzuh++) {
+ enaqpzk9[-urohxe6t + *wy1vqfzu + (ayfnwr1v+urohxe6t-1 ) * Mplus1] -=
+ wkumc9iduu[-gp1jxzuh + *wy1vqfzu + (ayfnwr1v+gp1jxzuh - sedf7mxb) * Mplus1] *
+ enaqpzk9[urohxe6t-gp1jxzuh + *wy1vqfzu + (ayfnwr1v+gp1jxzuh-1 ) * Mplus1];
+ }
+ }
+
+ enaqpzk9[*wy1vqfzu + (ayfnwr1v-1) * Mplus1] = 1.0e0 / Dvector[ayfnwr1v-1];
+ for (urohxe6t = 1; urohxe6t <= uplim; urohxe6t++) {
+ enaqpzk9[ *wy1vqfzu + (ayfnwr1v - 1 ) * Mplus1] -=
+ wkumc9iduu[-urohxe6t + *wy1vqfzu + (ayfnwr1v+urohxe6t - sedf7mxb) * Mplus1] *
+ enaqpzk9[-urohxe6t + *wy1vqfzu + (ayfnwr1v+urohxe6t - 1 ) * Mplus1];
+ }
+
+ if (ayfnwr1v == sedf7mxb) {
+ if (--sedf7mxb < 1) {
+ sedf7mxb = 1;
+ } else {
+ for (kij0gwer = hofjnx2e - 1; kij0gwer >= 1; kij0gwer--) {
+ for (gp1jxzuh = 1; gp1jxzuh <= hofjnx2e; gp1jxzuh++) {
+ wkumc9iduu[gp1jxzuh-1 + kij0gwer * Mplus1] =
+ wkumc9iduu[gp1jxzuh-1 + (kij0gwer-1) * Mplus1];
+ }
+ }
+ for (gp1jxzuh = 1; gp1jxzuh <= hofjnx2e; gp1jxzuh++) {
+ wkumc9iduu[gp1jxzuh-1] = wpuarq2m[gp1jxzuh-1 + (sedf7mxb-1) * Mplus1];
+ }
+ }
+ }
+ }
+
+ Free(wkumc9iduu);
+}
+
+
+
+
+
+
+
+
+
+
+
+
+void Free_fapc0tnbewg7qruh(double *wkumc9idWrk1,
+ int *wkumc9idges1xpkr,
+ double *wkumc9idbeta, double *wkumc9idfasrkub3,
+ double *wkumc9idsout, double *wkumc9idr0oydcxb,
+ double *wkumc9idub4xioar, double *wkumc9ideffect,
+ double *wkumc9idueshvo2ic, double *wkumc9ids0,
+ double *wkumc9idpygsw6ko, double *wkumc9idpasjmo8g,
+ double *wkumc9ideshvo2ic, double *wkumc9idonxjvw8u,
+ double *wkumc9idwk4) {
+ Free(wkumc9idWrk1);
+ Free(wkumc9idges1xpkr);
+ Free(wkumc9idbeta); Free(wkumc9idfasrkub3);
+ Free(wkumc9idsout); Free(wkumc9idr0oydcxb);
+ Free(wkumc9idub4xioar); Free(wkumc9ideffect);
+ Free(wkumc9idueshvo2ic); Free(wkumc9ids0);
+ Free(wkumc9idpygsw6ko); Free(wkumc9idpasjmo8g);
+ Free(wkumc9ideshvo2ic); Free(wkumc9idonxjvw8u);
+ Free(wkumc9idwk4);
+}
+
+
+void fapc0tnbewg7qruh(double ci1oyxas[], double tlgduey8[], double rbne6ouj[],
+ int *ftnjamu2, int *wy1vqfzu, int ezlgm2up[], int *lqsahu0r,
+ double wbkq9zyi[], double lamvec[], double hdnw2fts[],
+ double kispwgx3[], double ui8ysltq[],
+ int *kvowz9ht, int *fbd5yktj, int *ldk, int *aalgpft4y, int *yzoe1rsp,
+ double rpyis2kc[], double gkdx5jals[], double ifys6woa[], double conmat[],
+
+ double xecbg0pf[], double z4grbpiq[], double d7glzhbj[], double v2eydbxs[],
+ double *tt2, int *cvnjhg2u,
+
+ int *acpios9q, int *iz2nbfjc, int *kgwmz4ip,
+ int *npjlv3mr,
+ int itdcb8ilk[],
+ double tdcb8ilk[]) {
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, qemj9asg, dvhw1ulq, infoqr_svdbx3tk,
+ rutyk8mg = *lqsahu0r * *kgwmz4ip;
+ int pqneb2ra = 1, ybnsqgo9 = 101;
+ int xjc4ywlh = 2 * *kgwmz4ip,
+ kgwmz4ip2 = 2 * *kgwmz4ip;
+
+ int npjlv3mreshvo2ic = (*iz2nbfjc == 1) ? *npjlv3mr : *kgwmz4ip * (*kgwmz4ip + 1) / 2,
+ dim2eshvo2ic = (*iz2nbfjc == 1) ? *kvowz9ht : *kgwmz4ip * (*kgwmz4ip + 1) / 2;
+
+ double xmin, xrange, *fpdlcqk9ui8ysltq, *fpdlcqk9hdnw2fts, *fpdlcqk9ub4xioar, *fpdlcqk9ifys6woa,
+ *fpdlcqk9pygsw6ko, dtad5vhsu, do3jyipdf, dpq0hfucn, pvofyg8z = 1.0e-7;
+
+ int *wkumc9idges1xpkr, maxrutyk8mgxjc4ywlh;
+ double *wkumc9idWrk1, *wkumc9idwk4;
+ double *wkumc9idbeta, *wkumc9idfasrkub3, *wkumc9idsout,
+ *wkumc9idr0oydcxb, *wkumc9idub4xioar, *wkumc9ideffect,
+ *wkumc9idueshvo2ic, *wkumc9ids0;
+ double *wkumc9idpygsw6ko, *wkumc9idpasjmo8g,
+ *wkumc9ideshvo2ic, *wkumc9idonxjvw8u;
+
+ maxrutyk8mgxjc4ywlh = (rutyk8mg > xjc4ywlh) ? rutyk8mg : xjc4ywlh;
+ wkumc9idWrk1 = Calloc(maxrutyk8mgxjc4ywlh , double);
+ wkumc9idwk4 = Calloc(rutyk8mg * xjc4ywlh , double);
+
+ wkumc9idges1xpkr = Calloc(kgwmz4ip2 , int);
+ wkumc9idbeta = Calloc(kgwmz4ip2 , double);
+ wkumc9idfasrkub3 = Calloc(kgwmz4ip2 , double);
+ wkumc9idsout = Calloc(*lqsahu0r * *kgwmz4ip , double);
+ wkumc9idr0oydcxb = Calloc(*kgwmz4ip * *lqsahu0r , double);
+ wkumc9idub4xioar = Calloc(*kgwmz4ip * *lqsahu0r , double);
+ wkumc9ideffect = Calloc(*lqsahu0r * *kgwmz4ip , double);
+ wkumc9idueshvo2ic = Calloc(npjlv3mreshvo2ic * *lqsahu0r , double);
+ wkumc9ids0 = Calloc(kgwmz4ip2 * kgwmz4ip2 * 2 , double);
+ wkumc9idpygsw6ko = Calloc(*lqsahu0r , double);
+ wkumc9idpasjmo8g = Calloc(*lqsahu0r * *kgwmz4ip , double);
+ wkumc9idonxjvw8u = Calloc(*lqsahu0r * *kgwmz4ip , double);
+ wkumc9ideshvo2ic = Calloc(*lqsahu0r * dim2eshvo2ic , double);
+
+
+
+
+ vsuff9(ftnjamu2, lqsahu0r, ezlgm2up,
+ ci1oyxas, tlgduey8, rbne6ouj,
+ wkumc9idpygsw6ko, wkumc9idpasjmo8g, wkumc9ideshvo2ic,
+ wkumc9idueshvo2ic, wkumc9idonxjvw8u, &dvhw1ulq,
+ wy1vqfzu, kvowz9ht, npjlv3mr,
+ conmat, kgwmz4ip,
+ iz2nbfjc, &pqneb2ra,
+ &npjlv3mreshvo2ic, &dim2eshvo2ic);
+
+ if (dvhw1ulq != 1) {
+ Rprintf("Error in fapc0tnbewg7qruh after calling vsuff9.\n");
+ Free_fapc0tnbewg7qruh(wkumc9idWrk1,
+ wkumc9idges1xpkr,
+ wkumc9idbeta, wkumc9idfasrkub3,
+ wkumc9idsout, wkumc9idr0oydcxb,
+ wkumc9idub4xioar, wkumc9ideffect,
+ wkumc9idueshvo2ic, wkumc9ids0,
+ wkumc9idpygsw6ko, wkumc9idpasjmo8g,
+ wkumc9ideshvo2ic, wkumc9idonxjvw8u,
+ wkumc9idwk4);
+ return;
+ }
+
+ xmin = wkumc9idpygsw6ko[0];
+ xrange = wkumc9idpygsw6ko[*lqsahu0r-1] - wkumc9idpygsw6ko[0];
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ wkumc9idpygsw6ko[ayfnwr1v-1] = (wkumc9idpygsw6ko[ayfnwr1v-1] - xmin) / xrange;
+ }
+
+ *ldk = 4 * *kgwmz4ip;
+ *ldk = 3 * *kgwmz4ip + 1;
+
+ *fbd5yktj = 0;
+
+
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ if (wbkq9zyi[yq6lorbx-1] == 0.0e0) {
+ hdnw2fts[yq6lorbx-1] += 1.0e0;
+ }
+ }
+
+ Yee_spline(wkumc9idpygsw6ko, wkumc9idonxjvw8u, wkumc9ideshvo2ic, gkdx5jals,
+ lqsahu0r, acpios9q, ldk, kgwmz4ip, &dim2eshvo2ic,
+ wbkq9zyi, lamvec, aalgpft4y, wkumc9idsout,
+ rpyis2kc, ui8ysltq, ifys6woa, hdnw2fts,
+ yzoe1rsp, fbd5yktj, ftnjamu2,
+ xecbg0pf, z4grbpiq, d7glzhbj, v2eydbxs,
+ tt2, cvnjhg2u,
+ itdcb8ilk,
+ tdcb8ilk);
+
+
+ fpdlcqk9hdnw2fts = hdnw2fts;
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ *fpdlcqk9hdnw2fts = -1.0e0;
+ fpdlcqk9ifys6woa = ifys6woa + (yq6lorbx-1) * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ *fpdlcqk9hdnw2fts += *fpdlcqk9ifys6woa++;
+ }
+ fpdlcqk9hdnw2fts++;
+ }
+
+
+ if (*kgwmz4ip >= 1) {
+
+ fapc0tnbx6kanjdh(wkumc9idpygsw6ko, wkumc9idwk4, lqsahu0r, kgwmz4ip);
+
+ rutyk8mg = *lqsahu0r * *kgwmz4ip;
+
+ fvlmz9iyC_mxrbkut0(wkumc9idueshvo2ic, wkumc9idwk4,
+ kgwmz4ip, &xjc4ywlh, lqsahu0r, &npjlv3mreshvo2ic, &rutyk8mg);
+
+ for (gp1jxzuh = 1; gp1jxzuh <= xjc4ywlh; gp1jxzuh++) {
+ wkumc9idges1xpkr[gp1jxzuh-1] = gp1jxzuh;
+ }
+ F77_CALL(vqrdca)(wkumc9idwk4, &rutyk8mg, &rutyk8mg, &xjc4ywlh, wkumc9idfasrkub3,
+ wkumc9idges1xpkr, wkumc9idWrk1, &qemj9asg, &pvofyg8z);
+
+ fvlmz9iyC_nudh6szq(wkumc9idueshvo2ic, wkumc9idsout, wkumc9idr0oydcxb,
+ &npjlv3mreshvo2ic, lqsahu0r, kgwmz4ip);
+
+ F77_CALL(vdqrsl)(wkumc9idwk4, &rutyk8mg, &rutyk8mg, &qemj9asg, wkumc9idfasrkub3,
+ wkumc9idr0oydcxb, wkumc9idWrk1, wkumc9ideffect, wkumc9idbeta,
+ wkumc9idWrk1, wkumc9idub4xioar, &ybnsqgo9, &infoqr_svdbx3tk);
+
+
+ fvlmz9iyC_vbks(wkumc9idueshvo2ic, wkumc9idub4xioar, kgwmz4ip, lqsahu0r, &npjlv3mreshvo2ic);
+
+ if (*yzoe1rsp) {
+
+ fvlmz9iyC_lkhnw9yq(wkumc9idwk4, wkumc9ids0, &rutyk8mg, &xjc4ywlh, &dvhw1ulq);
+
+ if (dvhw1ulq != 1) {
+ Rprintf("Error in fapc0tnbewg7qruh calling fvlmz9iyC_lkhnw9yq.\n");
+ Free_fapc0tnbewg7qruh(wkumc9idWrk1,
+ wkumc9idges1xpkr,
+ wkumc9idbeta, wkumc9idfasrkub3,
+ wkumc9idsout, wkumc9idr0oydcxb,
+ wkumc9idub4xioar, wkumc9ideffect,
+ wkumc9idueshvo2ic, wkumc9ids0,
+ wkumc9idpygsw6ko, wkumc9idpasjmo8g,
+ wkumc9ideshvo2ic, wkumc9idonxjvw8u,
+ wkumc9idwk4);
+ return;
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ dtad5vhsu = wkumc9ids0[yq6lorbx-1 + (yq6lorbx-1 ) * kgwmz4ip2];
+ do3jyipdf = wkumc9ids0[yq6lorbx-1 + (yq6lorbx-1 + *kgwmz4ip) * kgwmz4ip2];
+ dpq0hfucn = wkumc9ids0[yq6lorbx-1 + *kgwmz4ip +
+ (yq6lorbx-1 + *kgwmz4ip) * kgwmz4ip2];
+ fpdlcqk9ui8ysltq = ui8ysltq + (yq6lorbx-1) * *ftnjamu2;
+ fpdlcqk9pygsw6ko = wkumc9idpygsw6ko;
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ *fpdlcqk9ui8ysltq -= dtad5vhsu + *fpdlcqk9pygsw6ko *
+ (2.0 * do3jyipdf + *fpdlcqk9pygsw6ko * dpq0hfucn);
+ fpdlcqk9ui8ysltq++;
+ fpdlcqk9pygsw6ko++;
+ }
+ }
+ }
+ } else {
+
+ fapc0tnbdsrt0gem(lqsahu0r, wkumc9idpygsw6ko, wkumc9ideshvo2ic, wkumc9idsout,
+ wkumc9idub4xioar, ui8ysltq, yzoe1rsp);
+ }
+
+
+ fpdlcqk9ub4xioar = wkumc9idub4xioar;
+ for (ayfnwr1v = 1; ayfnwr1v <= *lqsahu0r; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ wkumc9idsout[ayfnwr1v-1 + (yq6lorbx-1) * *lqsahu0r] -= *fpdlcqk9ub4xioar++;
+ }
+ }
+
+
+ for (yq6lorbx = 1; yq6lorbx <= *kgwmz4ip; yq6lorbx++) {
+ fapc0tnbshm8ynte(ftnjamu2, /* lqsahu0r, */
+ ezlgm2up, wkumc9idsout + (yq6lorbx-1) * *lqsahu0r,
+ kispwgx3 + (yq6lorbx-1) * *ftnjamu2);
+ }
+
+ Free_fapc0tnbewg7qruh(wkumc9idWrk1,
+ wkumc9idges1xpkr,
+ wkumc9idbeta, wkumc9idfasrkub3,
+ wkumc9idsout, wkumc9idr0oydcxb,
+ wkumc9idub4xioar, wkumc9ideffect,
+ wkumc9idueshvo2ic, wkumc9ids0,
+ wkumc9idpygsw6ko, wkumc9idpasjmo8g,
+ wkumc9ideshvo2ic, wkumc9idonxjvw8u,
+ wkumc9idwk4);
+}
+
+
+void Yee_vbfa(int psdvgce3[], double *doubvec, double he7mqnvy[], double tlgduey8[],
+ double rbne6ouj[], double hdnw2fts[], double lamvec[], double wbkq9zyi[],
+ int ezlgm2up[], int lqsahu0r[], int which[],
+ double kispwgx3[], double m0ibglfx[],
+ double zshtfg8c[], double ui8ysltq[],
+ double vc6hatuj[], double fasrkub3[], int ges1xpkr[],
+ double wpuarq2m[], double hjm2ktyr[],
+ int ulm3dvzg[], int hnpt1zym[], int iz2nbfjc[],
+ double ifys6woa[],
+ double rpyis2kc[], double gkdx5jals[],
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[]) {
+
+
+ double *ghdetj8v, *zpcqv3uj;
+ int nhja0izq, rutyk8mg, xjc4ywlh, lyma1kwc, lyzoe1rsp, ueb8hndv, gtrlbz3e, algpft4y = 0,
+ qemj9asg, npjlv3mr, kvowz9ht, ldk, fbd5yktj = 0;
+
+
+
+
+
+
+
+
+
+ int *ftnjamu2, *wy1vqfzu;
+ int itdcb8ilk[1];
+ double tdcb8ilk[4];
+
+ itdcb8ilk[0] = psdvgce3[15];
+ tdcb8ilk[0] = doubvec[2];
+ tdcb8ilk[1] = doubvec[3];
+ tdcb8ilk[2] = doubvec[4];
+ tdcb8ilk[3] = doubvec[5];
+
+ wy1vqfzu = psdvgce3 + 7;
+ ftnjamu2 = psdvgce3;
+ nhja0izq = psdvgce3[2];
+ lyzoe1rsp = psdvgce3[3];
+ gtrlbz3e = psdvgce3[5];
+ qemj9asg = psdvgce3[6];
+
+ rutyk8mg = psdvgce3[8];
+ xjc4ywlh = psdvgce3[9];
+ lyma1kwc = psdvgce3[10];
+ kvowz9ht = psdvgce3[11];
+ npjlv3mr = psdvgce3[12];
+ ldk = psdvgce3[14];
+
+ zpcqv3uj = doubvec + 0;;
+ ghdetj8v = doubvec + 1;
+
+ fapc0tnbvbfa1(ftnjamu2, wy1vqfzu, ezlgm2up, lqsahu0r, which,
+ he7mqnvy, tlgduey8, rbne6ouj,
+ wbkq9zyi, lamvec, hdnw2fts,
+ kispwgx3, m0ibglfx, zshtfg8c,
+ ui8ysltq, zpcqv3uj, vc6hatuj, fasrkub3,
+ &qemj9asg, ges1xpkr, wpuarq2m, hjm2ktyr,
+ ulm3dvzg, hnpt1zym, iz2nbfjc,
+ ifys6woa,
+ rpyis2kc, gkdx5jals, ghdetj8v,
+ nbzjkpi3, acpios9q, jwbkl9fp,
+ &nhja0izq, &lyzoe1rsp, &ueb8hndv, >rlbz3e,
+ &rutyk8mg, &xjc4ywlh,
+ &kvowz9ht, &npjlv3mr, &fbd5yktj, &ldk, &algpft4y,
+ itdcb8ilk,
+ tdcb8ilk);
+
+ psdvgce3[6] = qemj9asg;
+ psdvgce3[4] = ueb8hndv;
+ psdvgce3[13] = fbd5yktj;
+ psdvgce3[16] = algpft4y;
+}
+
+
+
+void fapc0tnbvbfa1(int *ftnjamu2, int *wy1vqfzu, int ezlgm2up[], int lqsahu0r[], int which[],
+ double he7mqnvy[], double tlgduey8[], double rbne6ouj[],
+ double wbkq9zyi[], double lamvec[], double hdnw2fts[],
+ double kispwgx3[], double m0ibglfx[], double zshtfg8c[],
+ double ui8ysltq[], double *zpcqv3uj, double vc6hatuj[], double fasrkub3[],
+ int *qemj9asg, int ges1xpkr[], double wpuarq2m[], double hjm2ktyr[],
+ int ulm3dvzg[], int hnpt1zym[], int iz2nbfjc[],
+ double ifys6woa[],
+ double rpyis2kc[], double gkdx5jals[], double *ghdetj8v,
+ int nbzjkpi3[], int acpios9q[], int jwbkl9fp[],
+ int *nhja0izq, int *yzoe1rsp, int *ueb8hndv, int *gtrlbz3e,
+ int *rutyk8mg, int *xjc4ywlh,
+ int *kvowz9ht, int *npjlv3mr, int *fbd5yktj, int *ldk, int *algpft4y,
+ int itdcb8ilk[],
+ double tdcb8ilk[]) {
+
+
+
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, urohxe6t, bpvaqm5z, wg1xifdy, ybnsqgo9 = 101,
+ maxrutyk8mgxjc4ywlh, infoqr_svdbx3tk, sumzv2xfhei = 0;
+ double qtce8hzo, deltaf, z4vrscot, pvofyg8z = 1.0e-7, g2dnwteb = 1.0,
+ *fpdlcqk9m0ibglfx, *fpdlcqk9ub4xioar, *fpdlcqk9tlgduey8, *fpdlcqk9ghz9vuba,
+ *fpdlcqk9hjm2ktyr, *fpdlcqk9kispwgx3, *qnwamo0e1;
+ double *wkumc9idTwk,
+ *wkumc9idwkbzmd6ftv, *wkumc9idwk9;
+ double *wkumc9idghz9vuba, *wkumc9idoldmat,
+ *wkumc9idub4xioar, *wkumc9idwk2;
+ double *wkumc9idall_xecbg0pf, *wkumc9idall_z4grbpiq, *wkumc9idall_d7glzhbj, *wkumc9idall_v2eydbxs,
+ *wkumc9idall_tt2;
+ int cvnjhg2u;
+
+ maxrutyk8mgxjc4ywlh = (*ftnjamu2 * *wy1vqfzu > *xjc4ywlh) ? (*ftnjamu2 * *wy1vqfzu) : *xjc4ywlh;
+ wkumc9idTwk = Calloc(maxrutyk8mgxjc4ywlh , double);
+
+ wkumc9idwkbzmd6ftv = Calloc(*xjc4ywlh * *rutyk8mg, double);
+ wkumc9idwk9 = Calloc(*xjc4ywlh , double);
+
+ wkumc9idghz9vuba = Calloc(*ftnjamu2 * *wy1vqfzu, double);
+ wkumc9idoldmat = Calloc(*ftnjamu2 * *wy1vqfzu, double);
+ wkumc9idub4xioar = Calloc(*wy1vqfzu * *ftnjamu2, double);
+ wkumc9idwk2 = Calloc(*ftnjamu2 * *wy1vqfzu, double);
+
+
+
+
+ if ( *nhja0izq == 0
+ || *nhja0izq == 1
+ ) {
+ *gtrlbz3e = 1;
+ }
+
+ if (*qemj9asg == 0) {
+ fvlmz9iyC_mxrbkut0(wpuarq2m, vc6hatuj, wy1vqfzu, xjc4ywlh, ftnjamu2, npjlv3mr, rutyk8mg);
+
+ for (gp1jxzuh = 1; gp1jxzuh <= *xjc4ywlh; gp1jxzuh++) {
+ ges1xpkr[gp1jxzuh-1] = gp1jxzuh;
+ }
+ F77_CALL(vqrdca)(vc6hatuj, rutyk8mg, rutyk8mg, xjc4ywlh, fasrkub3,
+ ges1xpkr, wkumc9idTwk, qemj9asg, &pvofyg8z);
+ }
+
+ fpdlcqk9m0ibglfx = m0ibglfx;
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 0; yq6lorbx < *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9m0ibglfx++ = 0.0e0;
+ }
+ }
+
+ for (gp1jxzuh = 1; gp1jxzuh <= *nhja0izq; gp1jxzuh++) {
+ if (iz2nbfjc[gp1jxzuh-1] == 1) {
+ fpdlcqk9m0ibglfx = m0ibglfx;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ bpvaqm5z = hnpt1zym[gp1jxzuh-1] - 1;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9m0ibglfx += kispwgx3[ayfnwr1v-1 + bpvaqm5z * *ftnjamu2];
+ fpdlcqk9m0ibglfx++;
+ bpvaqm5z++;
+ }
+ }
+ } else {
+ for (wg1xifdy = 1; wg1xifdy <= ulm3dvzg[gp1jxzuh-1]; wg1xifdy++) {
+ urohxe6t = hnpt1zym[gp1jxzuh-1] + wg1xifdy - 2;
+ fpdlcqk9m0ibglfx = m0ibglfx;
+ fpdlcqk9kispwgx3 = kispwgx3 + urohxe6t * *ftnjamu2;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ fpdlcqk9hjm2ktyr = hjm2ktyr + urohxe6t * *wy1vqfzu;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9hjm2ktyr++ * *fpdlcqk9kispwgx3;
+ fpdlcqk9m0ibglfx++;
+ }
+ fpdlcqk9kispwgx3++;
+ }
+ }
+ }
+ }
+
+
+ sumzv2xfhei = jwbkl9fp[(1 + *nhja0izq) - 1];
+ wkumc9idall_xecbg0pf = Calloc(sumzv2xfhei, double);
+ wkumc9idall_z4grbpiq = Calloc(sumzv2xfhei, double);
+ wkumc9idall_d7glzhbj = Calloc(sumzv2xfhei, double);
+ wkumc9idall_v2eydbxs = Calloc(sumzv2xfhei, double);
+ wkumc9idall_tt2 = Calloc(*nhja0izq , double);
+
+
+ *ueb8hndv = 0;
+
+ while ((g2dnwteb > *zpcqv3uj ) && (*ueb8hndv < *gtrlbz3e)) {
+
+ (*ueb8hndv)++;
+ deltaf = 0.0e0;
+ fpdlcqk9ghz9vuba = wkumc9idghz9vuba; fpdlcqk9tlgduey8 = tlgduey8;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ fpdlcqk9m0ibglfx = m0ibglfx + yq6lorbx-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9ghz9vuba++ = *fpdlcqk9tlgduey8++ - *fpdlcqk9m0ibglfx;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+
+ fvlmz9iyC_nudh6szq(wpuarq2m, wkumc9idghz9vuba, wkumc9idTwk, npjlv3mr, ftnjamu2, wy1vqfzu);
+
+ F77_CALL(vdqrsl)(vc6hatuj, rutyk8mg, rutyk8mg, qemj9asg, fasrkub3,
+ wkumc9idTwk, wkumc9idwk2, wkumc9idwk2, zshtfg8c,
+ wkumc9idwk2, wkumc9idub4xioar, &ybnsqgo9, &infoqr_svdbx3tk);
+
+ *ghdetj8v = 0.0e0;
+ qnwamo0e1 = wkumc9idTwk; fpdlcqk9ub4xioar = wkumc9idub4xioar;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ qtce8hzo = *qnwamo0e1++ - *fpdlcqk9ub4xioar++;
+ *ghdetj8v += pow(qtce8hzo, (double) 2.0);
+ }
+ }
+
+ fvlmz9iyC_vbks(wpuarq2m, wkumc9idub4xioar, wy1vqfzu, ftnjamu2, npjlv3mr);
+
+ for (gp1jxzuh = 1; gp1jxzuh <= *nhja0izq; gp1jxzuh++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ urohxe6t = hnpt1zym[gp1jxzuh-1] + yq6lorbx -2;
+ if (iz2nbfjc[gp1jxzuh-1] == 1) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ wkumc9idoldmat[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] =
+ kispwgx3[ayfnwr1v-1 + urohxe6t * *ftnjamu2];
+
+ wkumc9idghz9vuba[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] =
+ tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] -
+ wkumc9idub4xioar[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] -
+ m0ibglfx[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] +
+ wkumc9idoldmat[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2];
+ }
+ } else {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ wkumc9idoldmat[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] = 0.0e0;
+ for (wg1xifdy = 1; wg1xifdy <= ulm3dvzg[gp1jxzuh-1]; wg1xifdy++) {
+ bpvaqm5z = hnpt1zym[gp1jxzuh-1] + wg1xifdy -2;
+ wkumc9idoldmat[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] +=
+ hjm2ktyr[yq6lorbx-1 + bpvaqm5z * *wy1vqfzu] *
+ kispwgx3[ayfnwr1v-1 + bpvaqm5z * *ftnjamu2];
+ }
+ wkumc9idghz9vuba[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] =
+ tlgduey8[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] -
+ wkumc9idub4xioar[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] -
+ m0ibglfx[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] +
+ wkumc9idoldmat[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2];
+ }
+ }
+ }
+
+ cvnjhg2u = (*ueb8hndv == 1) ? 0 : 1;
+ fapc0tnbewg7qruh(he7mqnvy+(which[gp1jxzuh-1]-1) * *ftnjamu2, wkumc9idghz9vuba, rbne6ouj,
+ ftnjamu2, wy1vqfzu, ezlgm2up + (gp1jxzuh-1) * *ftnjamu2, lqsahu0r + gp1jxzuh-1,
+ wbkq9zyi + hnpt1zym[gp1jxzuh-1]-1,
+ lamvec + hnpt1zym[gp1jxzuh-1]-1,
+ hdnw2fts + hnpt1zym[gp1jxzuh-1]-1,
+ kispwgx3 + (hnpt1zym[gp1jxzuh-1]-1) * *ftnjamu2,
+ ui8ysltq + (hnpt1zym[gp1jxzuh-1]-1) * *ftnjamu2,
+ kvowz9ht, fbd5yktj, ldk, algpft4y, yzoe1rsp,
+ rpyis2kc + nbzjkpi3[gp1jxzuh-1]-1,
+ gkdx5jals + jwbkl9fp[gp1jxzuh-1]-1,
+ ifys6woa + (hnpt1zym[gp1jxzuh-1]-1) * *ftnjamu2,
+ hjm2ktyr + (hnpt1zym[gp1jxzuh-1]-1) * *wy1vqfzu,
+
+ wkumc9idall_xecbg0pf + jwbkl9fp[gp1jxzuh-1]-1,
+ wkumc9idall_z4grbpiq + jwbkl9fp[gp1jxzuh-1]-1,
+ wkumc9idall_d7glzhbj + jwbkl9fp[gp1jxzuh-1]-1,
+ wkumc9idall_v2eydbxs + jwbkl9fp[gp1jxzuh-1]-1,
+ wkumc9idall_tt2 + gp1jxzuh-1 ,
+ // If 0 then compute wkumc9idall_sg[0:3] else already done:
+ &cvnjhg2u,
+
+ acpios9q + gp1jxzuh-1, iz2nbfjc + gp1jxzuh-1, ulm3dvzg + gp1jxzuh-1,
+ npjlv3mr,
+ itdcb8ilk,
+ tdcb8ilk);
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ if (iz2nbfjc[gp1jxzuh-1] == 1) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ m0ibglfx[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] +=
+ kispwgx3[ayfnwr1v-1 + (hnpt1zym[gp1jxzuh-1]+yq6lorbx-2) * *ftnjamu2];
+ }
+ } else {
+ for (wg1xifdy = 1; wg1xifdy <= ulm3dvzg[gp1jxzuh-1]; wg1xifdy++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ m0ibglfx[yq6lorbx-1+ (ayfnwr1v-1) * *wy1vqfzu] +=
+ hjm2ktyr[yq6lorbx-1+ (hnpt1zym[gp1jxzuh-1]+wg1xifdy-2) * *wy1vqfzu] *
+ kispwgx3[ayfnwr1v-1+ (hnpt1zym[gp1jxzuh-1]+wg1xifdy-2) * *ftnjamu2];
+ }
+ }
+ }
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ m0ibglfx[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] -=
+ wkumc9idoldmat[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2];
+ }
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ if (iz2nbfjc[gp1jxzuh-1] == 1) {
+ deltaf += fapc0tnbrd9beyfk(ftnjamu2,
+ wkumc9idoldmat + (yq6lorbx-1) * *ftnjamu2,
+ rbne6ouj + (yq6lorbx-1) * *ftnjamu2,
+ kispwgx3 + (hnpt1zym[gp1jxzuh-1]+yq6lorbx-2) * *ftnjamu2);
+ } else {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ wkumc9idTwk[ayfnwr1v-1] = 0.0e0;
+ for (wg1xifdy=1; wg1xifdy<=ulm3dvzg[gp1jxzuh-1]; wg1xifdy++) {
+ wkumc9idTwk[ayfnwr1v-1] +=
+ hjm2ktyr[yq6lorbx-1 + (hnpt1zym[gp1jxzuh-1]+wg1xifdy-2) * *wy1vqfzu] *
+ kispwgx3[ayfnwr1v-1 + (hnpt1zym[gp1jxzuh-1]+wg1xifdy-2) * *ftnjamu2];
+ }
+ }
+ deltaf += fapc0tnbrd9beyfk(ftnjamu2,
+ wkumc9idoldmat + (yq6lorbx-1) * *ftnjamu2,
+ rbne6ouj + (yq6lorbx-1) * *ftnjamu2,
+ wkumc9idTwk);
+ }
+ }
+
+
+ fpdlcqk9ghz9vuba = wkumc9idghz9vuba; fpdlcqk9tlgduey8 = tlgduey8;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ fpdlcqk9m0ibglfx = m0ibglfx + yq6lorbx-1;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ *fpdlcqk9ghz9vuba++ = *fpdlcqk9tlgduey8++ - *fpdlcqk9m0ibglfx;
+ fpdlcqk9m0ibglfx += *wy1vqfzu;
+ }
+ }
+
+ fvlmz9iyC_nudh6szq(wpuarq2m, wkumc9idghz9vuba, wkumc9idTwk, npjlv3mr, ftnjamu2, wy1vqfzu);
+
+ F77_CALL(vdqrsl)(vc6hatuj, rutyk8mg, rutyk8mg, qemj9asg, fasrkub3,
+ wkumc9idTwk, wkumc9idwk2, wkumc9idwk2, zshtfg8c,
+ wkumc9idwk2, wkumc9idub4xioar, &ybnsqgo9, &infoqr_svdbx3tk);
+
+ fvlmz9iyC_vbks(wpuarq2m, wkumc9idub4xioar, wy1vqfzu, ftnjamu2, npjlv3mr);
+
+ }
+
+ if (*nhja0izq > 0) {
+ z4vrscot = 0.0e0;
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ z4vrscot += rbne6ouj[ayfnwr1v-1 + (yq6lorbx-1) * *ftnjamu2] *
+ pow(m0ibglfx[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu], (double) 2.0);
+ }
+ }
+ g2dnwteb = (z4vrscot > 0.0e0) ? sqrt(deltaf / z4vrscot) : 0.0;
+ }
+
+ if (*ueb8hndv == 1) {
+ g2dnwteb = 1.0e0;
+ }
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *xjc4ywlh; yq6lorbx++) {
+ wkumc9idwk9[yq6lorbx-1] = zshtfg8c[yq6lorbx-1];
+ }
+ for (yq6lorbx = 1; yq6lorbx <= *xjc4ywlh; yq6lorbx++) {
+ zshtfg8c[ges1xpkr[yq6lorbx-1]-1] = wkumc9idwk9[yq6lorbx-1];
+ }
+
+ fpdlcqk9m0ibglfx = m0ibglfx; fpdlcqk9ub4xioar = wkumc9idub4xioar;
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ *fpdlcqk9m0ibglfx += *fpdlcqk9ub4xioar++;
+ fpdlcqk9m0ibglfx++;
+ }
+ }
+
+ if (*yzoe1rsp && (*nhja0izq > 0)) {
+ for (gp1jxzuh = 1; gp1jxzuh <= *nhja0izq; gp1jxzuh++) {
+ for (wg1xifdy = 1; wg1xifdy <= ulm3dvzg[gp1jxzuh-1]; wg1xifdy++) {
+ fapc0tnbshm8ynte(ftnjamu2, /* lqsahu0r + gp1jxzuh-1, */
+ ezlgm2up + (gp1jxzuh-1) * *ftnjamu2,
+ ui8ysltq + (hnpt1zym[ gp1jxzuh-1] + wg1xifdy-2) * *ftnjamu2,
+ wkumc9idoldmat);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ ui8ysltq[ayfnwr1v-1 + (hnpt1zym[gp1jxzuh-1]+wg1xifdy-2) * *ftnjamu2] =
+ wkumc9idoldmat[ayfnwr1v-1];
+ }
+ }
+ }
+
+ for (gp1jxzuh = 1; gp1jxzuh <= *nhja0izq; gp1jxzuh++) {
+ for (wg1xifdy = 1; wg1xifdy <= ulm3dvzg[gp1jxzuh-1]; wg1xifdy++) {
+ fapc0tnbshm8ynte(ftnjamu2, /* lqsahu0r + gp1jxzuh-1, */
+ ezlgm2up + (gp1jxzuh-1) * *ftnjamu2,
+ ifys6woa + (hnpt1zym[ gp1jxzuh-1] + wg1xifdy-2) * *ftnjamu2,
+ wkumc9idoldmat);
+ for (ayfnwr1v = 1; ayfnwr1v <= *ftnjamu2; ayfnwr1v++) {
+ ifys6woa[ayfnwr1v-1 + (hnpt1zym[gp1jxzuh-1]+wg1xifdy-2) * *ftnjamu2] =
+ wkumc9idoldmat[ayfnwr1v-1];
+ }
+
+ }
+ }
+ }
+
+ Free(wkumc9idwkbzmd6ftv); Free(wkumc9idwk9);
+ Free(wkumc9idTwk);
+ Free(wkumc9idghz9vuba); Free(wkumc9idoldmat);
+ Free(wkumc9idub4xioar); Free(wkumc9idwk2);
+ Free(wkumc9idall_xecbg0pf); Free(wkumc9idall_z4grbpiq);
+ Free(wkumc9idall_d7glzhbj); Free(wkumc9idall_v2eydbxs);
+ Free(wkumc9idall_tt2);
+}
+
+
+void fapc0tnbx6kanjdh(double sjwyig9t[], double xout[], int *f8yswcat, int *wy1vqfzu) {
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, iptr = 0;
+
+
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ for (gp1jxzuh = 1; gp1jxzuh <= *wy1vqfzu; gp1jxzuh++) {
+ xout[iptr++] = (yq6lorbx == gp1jxzuh) ? 1.0e0 : 0.0e0;
+ }
+ }
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ for (gp1jxzuh = 1; gp1jxzuh <= *wy1vqfzu; gp1jxzuh++) {
+ xout[iptr++] = (yq6lorbx == gp1jxzuh) ? sjwyig9t[ayfnwr1v-1] : 0.0e0;
+ }
+ }
+ }
+}
+
+
+double fapc0tnbrd9beyfk(int *f8yswcat, double bhcji9gl[], double po8rwsmy[],
+ double m0ibglfx[]) {
+
+
+ int ayfnwr1v;
+ double rd9beyfk, rxeqjn0y = 0.0, lm9vcjob = 0.0;
+
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ lm9vcjob += *po8rwsmy;
+ rxeqjn0y += *po8rwsmy++ * pow(*bhcji9gl++ - *m0ibglfx++, (double) 2.0);
+ }
+ rd9beyfk = (lm9vcjob > 0.0e0) ? (rxeqjn0y / lm9vcjob) : 0.0e0;
+ return rd9beyfk;
+}
+
+
+void fapc0tnbpitmeh0q(int *f8yswcat, double bhcji9gl[], double po8rwsmy[],
+ double *lfu2qhid, double *lm9vcjob) {
+
+
+ double rxeqjn0yy = 0.0;
+ int ayfnwr1v;
+
+ *lm9vcjob = 0.0e0;
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ *lm9vcjob += *po8rwsmy;
+ rxeqjn0yy += *po8rwsmy++ * *bhcji9gl++;
+ }
+ *lfu2qhid = (*lm9vcjob > 0.0e0) ? (rxeqjn0yy / *lm9vcjob) : 0.0e0;
+}
+
+
+void fapc0tnbdsrt0gem(int *f8yswcat, double sjwyig9t[], double po8rwsmy[], double bhcji9gl[],
+ double ub4xioar[], double ui8ysltq[], int *yzoe1rsp) {
+
+
+ int ayfnwr1v;
+ double pygsw6ko, pasjmo8g, intercept, eck8vubt, qtce8hzo,
+ lm9vcjob = 0.0, q6zdcwxk = 0.0, nsum = 0.0,
+ *fpdlcqk9po8rwsmy, *fpdlcqk9sjwyig9t, *fpdlcqk9bhcji9gl;
+
+
+
+ fapc0tnbpitmeh0q(f8yswcat, sjwyig9t, po8rwsmy, &pygsw6ko, &lm9vcjob);
+ fapc0tnbpitmeh0q(f8yswcat, bhcji9gl, po8rwsmy, &pasjmo8g, &lm9vcjob);
+
+ fpdlcqk9sjwyig9t = sjwyig9t; fpdlcqk9bhcji9gl = bhcji9gl; fpdlcqk9po8rwsmy = po8rwsmy;
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ qtce8hzo = *fpdlcqk9sjwyig9t++ - pygsw6ko;
+ nsum += qtce8hzo * (*fpdlcqk9bhcji9gl++ - pasjmo8g) * *fpdlcqk9po8rwsmy;
+ qtce8hzo = pow(qtce8hzo, (double) 2.0);
+ q6zdcwxk += qtce8hzo * *fpdlcqk9po8rwsmy++;
+ }
+
+ eck8vubt = nsum / q6zdcwxk;
+ intercept = pasjmo8g - eck8vubt * pygsw6ko;
+ fpdlcqk9sjwyig9t = sjwyig9t;
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ *ub4xioar++ = intercept + eck8vubt * *fpdlcqk9sjwyig9t++;
+ }
+
+ if (*yzoe1rsp) {
+ fpdlcqk9sjwyig9t = sjwyig9t; fpdlcqk9po8rwsmy = po8rwsmy;
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ qtce8hzo = *fpdlcqk9sjwyig9t++ - pygsw6ko;
+ if (*fpdlcqk9po8rwsmy++ > 0.0e0) {
+ *ui8ysltq -= (1.0e0 / lm9vcjob + pow(qtce8hzo, (double) 2.0) / q6zdcwxk);
+ ui8ysltq++;
+ } else {
+ *ui8ysltq++ = 0.0e0;
+ }
+ }
+ }
+}
+
+
+void fapc0tnbshm8ynte(int *ftnjamu2,
+ int ezlgm2up[], double pygsw6ko[], double sjwyig9t[]) {
+
+
+ int ayfnwr1v;
+
+
+ for (ayfnwr1v = 0; ayfnwr1v < *ftnjamu2; ayfnwr1v++) {
+ *sjwyig9t++ = pygsw6ko[*ezlgm2up++ -1];
+ }
+}
+
+
+void vknootl2(double sjwyig9t[], int *f8yswcat, double gkdx5jal[], int *rvy1fpli,
+ int *ukgwt7na) {
+
+
+ int ayfnwr1v, yq6lorbx, ndzv2xfhei;
+
+
+ if (*ukgwt7na) {
+ ndzv2xfhei = *rvy1fpli - 6;
+ } else {
+ ndzv2xfhei = (*f8yswcat <= 40) ? *f8yswcat : floor((double) 40.0 +
+ pow((double) *f8yswcat - 40.0, (double) 0.25));
+ }
+
+ *rvy1fpli = ndzv2xfhei + 6;
+
+
+ for (yq6lorbx = 1; yq6lorbx <= 3; yq6lorbx++) {
+ *gkdx5jal++ = sjwyig9t[0];
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= ndzv2xfhei; yq6lorbx++) {
+ ayfnwr1v = (yq6lorbx - 1) * (*f8yswcat - 1) / (ndzv2xfhei - 1);
+ *gkdx5jal++ = sjwyig9t[ayfnwr1v];
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= 3; yq6lorbx++) {
+ *gkdx5jal++ = sjwyig9t[*f8yswcat -1];
+ }
+}
+
+
+void Yee_pknootl2(double *gkdx5jal, int *f8yswcat, int *zo8wpibx, double *Toler_ankcghz2) {
+
+
+
+
+
+ int ayfnwr1v, yq6lorbx = *f8yswcat - 4, cjop5bwm = 4;
+
+ for (ayfnwr1v = 1; ayfnwr1v <= 4; ayfnwr1v++) {
+ *zo8wpibx++ = 1;
+ }
+
+ for (ayfnwr1v = 5; ayfnwr1v <= yq6lorbx; ayfnwr1v++) {
+ if ((gkdx5jal[ayfnwr1v -1] - gkdx5jal[cjop5bwm -1] >= *Toler_ankcghz2) &&
+ (gkdx5jal[ *f8yswcat -1] - gkdx5jal[ayfnwr1v -1] >= *Toler_ankcghz2)) {
+ *zo8wpibx++ = 1;
+ cjop5bwm = ayfnwr1v;
+ } else {
+ *zo8wpibx++ = 0;
+ }
+ }
+
+ for (ayfnwr1v = *f8yswcat - 3; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ *zo8wpibx++ = 1;
+ }
+}
+
+
+
diff --git a/src/vlinpack1.f b/src/vlinpack1.f
index 9d9d623..127ab8e 100644
--- a/src/vlinpack1.f
+++ b/src/vlinpack1.f
@@ -1,44 +1,44 @@
- subroutine dhkt9w(x,ldx,n,p,i0qvzl,jpvt,bgu6fw,cqui1v,eps)
+ subroutine vqrdca(x,ldx,n,p,fasrkub3,jpvt,work,xwdf5ltg,eps)
implicit double precision (a-h,o-z)
implicit integer (i-n)
double precision dsign, dabs, dmax1, dsqrt
integer min0
- integer ldx,n,p,cqui1v
+ integer ldx,n,p,xwdf5ltg
integer jpvt(1)
- integer j,jj,jp,l,lup,qxy4wd
- double precision x(ldx,p),i0qvzl(p),bgu6fw(1),eps
+ integer j,jj,jp,l,lup,curpvt
+ double precision x(ldx,p),fasrkub3(p),work(1),eps
double precision vdnrm2,tt
double precision ddot8,nrmxl,t
do 23000 j=1,p
- i0qvzl(j) = vdnrm2(n,x(1,j),ldx,1)
- bgu6fw(j) = i0qvzl(j)
+ fasrkub3(j) = vdnrm2(n,x(1,j),ldx,1)
+ work(j) = fasrkub3(j)
23000 continue
l=1
lup = min0(n,p)
- qxy4wd = p
+ curpvt = p
23002 if(.not.(l.le.lup))goto 23003
- i0qvzl(l) = 0.0d0
+ fasrkub3(l) = 0.0d0
nrmxl = vdnrm2(n-l+1, x(l,l), ldx, 1)
if(.not.(nrmxl .lt. eps))goto 23004
- call dshift8(x,ldx,n,l,qxy4wd)
+ call dshift8(x,ldx,n,l,curpvt)
jp = jpvt(l)
- t=i0qvzl(l)
- tt=bgu6fw(l)
+ t=fasrkub3(l)
+ tt=work(l)
j=l+1
-23006 if(.not.(j.le.qxy4wd))goto 23008
+23006 if(.not.(j.le.curpvt))goto 23008
jj=j-1
jpvt(jj)=jpvt(j)
- i0qvzl(jj)=i0qvzl(j)
- bgu6fw(jj)=bgu6fw(j)
+ fasrkub3(jj)=fasrkub3(j)
+ work(jj)=work(j)
j=j+1
goto 23006
23008 continue
- jpvt(qxy4wd)=jp
- i0qvzl(qxy4wd)=t
- bgu6fw(qxy4wd)=tt
- qxy4wd=qxy4wd-1
- if(.not.(lup.gt.qxy4wd))goto 23009
- lup=qxy4wd
+ jpvt(curpvt)=jp
+ fasrkub3(curpvt)=t
+ work(curpvt)=tt
+ curpvt=curpvt-1
+ if(.not.(lup.gt.curpvt))goto 23009
+ lup=curpvt
23009 continue
goto 23005
23004 continue
@@ -51,31 +51,31 @@
call dscal8(n-l+1,1.0d0/nrmxl,x(l,l),1)
x(l,l) = 1.0d0+x(l,l)
j=l+1
-23015 if(.not.(j.le.qxy4wd))goto 23017
+23015 if(.not.(j.le.curpvt))goto 23017
t = -ddot8(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
call daxpy8(n-l+1,t,x(l,l),1,x(l,j),1)
- if(.not.(i0qvzl(j).ne.0.0d0))goto 23018
- tt = 1.0d0-(dabs(x(l,j))/i0qvzl(j))**2
+ if(.not.(fasrkub3(j).ne.0.0d0))goto 23018
+ tt = 1.0d0-(dabs(x(l,j))/fasrkub3(j))**2
tt = dmax1(tt,0.0d0)
t = tt
- tt = 1.0d0+0.05d0*tt*(i0qvzl(j)/bgu6fw(j))**2
+ tt = 1.0d0+0.05d0*tt*(fasrkub3(j)/work(j))**2
if(.not.(tt.ne.1.0d0))goto 23020
- i0qvzl(j) = i0qvzl(j)*dsqrt(t)
+ fasrkub3(j) = fasrkub3(j)*dsqrt(t)
goto 23021
23020 continue
- i0qvzl(j) = vdnrm2(n-l,x(l+1,j),ldx,1)
- bgu6fw(j) = i0qvzl(j)
+ fasrkub3(j) = vdnrm2(n-l,x(l+1,j),ldx,1)
+ work(j) = fasrkub3(j)
23021 continue
23018 continue
j=j+1
goto 23015
23017 continue
- i0qvzl(l) = x(l,l)
+ fasrkub3(l) = x(l,l)
x(l,l) = -nrmxl
l=l+1
23005 continue
goto 23002
23003 continue
- cqui1v = lup
+ xwdf5ltg = lup
return
end
diff --git a/src/vmux.f b/src/vmux.f
index 09345ed..31d6072 100644
--- a/src/vmux.f
+++ b/src/vmux.f
@@ -1,576 +1,597 @@
- subroutine qh4ulb(zqve1l, vvl1li, lku8xq)
+ subroutine qpsedg8xf(tgiyxdw1, dufozmt7, wy1vqfzu)
implicit logical (a-z)
- integer lku8xq, zqve1l(1), vvl1li(1)
- integer xi1mqb, i1nkrb, w3gohz
- w3gohz = 1
- xi1mqb = lku8xq
-23000 if(.not.(xi1mqb.ge.1))goto 23002
- do 23003 i1nkrb=1,xi1mqb
- zqve1l(w3gohz) = i1nkrb
- w3gohz = w3gohz+1
+ integer wy1vqfzu, tgiyxdw1(1), dufozmt7(1)
+ integer urohxe6t, bpvaqm5z, ayfnwr1v
+ ayfnwr1v = 1
+ urohxe6t = wy1vqfzu
+23000 if(.not.(urohxe6t.ge.1))goto 23002
+ do 23003 bpvaqm5z=1,urohxe6t
+ tgiyxdw1(ayfnwr1v) = bpvaqm5z
+ ayfnwr1v = ayfnwr1v+1
23003 continue
- xi1mqb=xi1mqb-1
+ urohxe6t=urohxe6t-1
goto 23000
23002 continue
- w3gohz = 1
- do 23005 xi1mqb=1,lku8xq
- do 23007 i1nkrb=xi1mqb,lku8xq
- vvl1li(w3gohz) = i1nkrb
- w3gohz = w3gohz+1
+ ayfnwr1v = 1
+ do 23005 urohxe6t=1,wy1vqfzu
+ do 23007 bpvaqm5z=urohxe6t,wy1vqfzu
+ dufozmt7(ayfnwr1v) = bpvaqm5z
+ ayfnwr1v = ayfnwr1v+1
23007 continue
23005 continue
return
end
- integer function viamf(s17te9, xl6qgm, lku8xq, zqve1l, vvl1li)
- integer s17te9, xl6qgm, lku8xq, zqve1l(1), vvl1li(1)
- integer xi1mqb, j0qwtz
- j0qwtz = lku8xq*(lku8xq+1)/2
- do 23009 xi1mqb=1,j0qwtz
- if(.not.((zqve1l(xi1mqb).eq.s17te9 .and. vvl1li(xi1mqb).eq.xl6qgm)
- & .or.(zqve1l(xi1mqb).eq.xl6qgm .and. vvl1li(xi1mqb).eq.s17te9)))
- &goto 23011
- viamf = xi1mqb
+ integer function viamf(cz8qdfyj, rvy1fpli, wy1vqfzu, tgiyxdw1,
+ &dufozmt7)
+ integer cz8qdfyj, rvy1fpli, wy1vqfzu, tgiyxdw1(1), dufozmt7(1)
+ integer urohxe6t, imk5wjxg
+ imk5wjxg = wy1vqfzu*(wy1vqfzu+1)/2
+ do 23009 urohxe6t=1,imk5wjxg
+ if(.not.((tgiyxdw1(urohxe6t).eq.cz8qdfyj .and. dufozmt7(urohxe6t)
+ &.eq.rvy1fpli) .or.(tgiyxdw1(urohxe6t).eq.rvy1fpli .and. dufozmt7(
+ &urohxe6t).eq.cz8qdfyj)))goto 23011
+ viamf = urohxe6t
return
23011 continue
23009 continue
viamf = 0
return
end
- subroutine vm2af(mat, a, p1yjqz, zqve1l, vvl1li, nfiumb4, lku8xq,
- &teola6)
+ subroutine vm2af(mat, a, dimm, tgiyxdw1, dufozmt7, kuzxj1lo,
+ &wy1vqfzu, upper)
implicit logical (a-z)
- integer p1yjqz, zqve1l(p1yjqz), vvl1li(p1yjqz), nfiumb4, lku8xq,
- &teola6
- double precision mat(p1yjqz,nfiumb4), a(lku8xq,lku8xq,nfiumb4)
- integer w3gohz, d9rjek, nd6mep, j0qwtz
- j0qwtz = lku8xq * (lku8xq + 1) / 2
- if(.not.(teola6 .eq. 1 .or. p1yjqz .ne. j0qwtz))goto 23013
- w3gohz = 1
-23015 if(.not.(w3gohz.le.nfiumb4))goto 23017
- d9rjek = 1
-23018 if(.not.(d9rjek.le.lku8xq))goto 23020
- nd6mep = 1
-23021 if(.not.(nd6mep.le.lku8xq))goto 23023
- a(nd6mep,d9rjek,w3gohz) = 0.0d0
- nd6mep=nd6mep+1
+ integer dimm, tgiyxdw1(dimm), dufozmt7(dimm), kuzxj1lo, wy1vqfzu,
+ &upper
+ double precision mat(dimm,kuzxj1lo), a(wy1vqfzu,wy1vqfzu,kuzxj1lo)
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh, imk5wjxg
+ imk5wjxg = wy1vqfzu * (wy1vqfzu + 1) / 2
+ if(.not.(upper .eq. 1 .or. dimm .ne. imk5wjxg))goto 23013
+ ayfnwr1v = 1
+23015 if(.not.(ayfnwr1v.le.kuzxj1lo))goto 23017
+ yq6lorbx = 1
+23018 if(.not.(yq6lorbx.le.wy1vqfzu))goto 23020
+ gp1jxzuh = 1
+23021 if(.not.(gp1jxzuh.le.wy1vqfzu))goto 23023
+ a(gp1jxzuh,yq6lorbx,ayfnwr1v) = 0.0d0
+ gp1jxzuh=gp1jxzuh+1
goto 23021
23023 continue
- d9rjek=d9rjek+1
+ yq6lorbx=yq6lorbx+1
goto 23018
23020 continue
- w3gohz=w3gohz+1
+ ayfnwr1v=ayfnwr1v+1
goto 23015
23017 continue
23013 continue
- do 23024 w3gohz=1,nfiumb4
- do 23026 d9rjek=1,p1yjqz
- a(zqve1l(d9rjek),vvl1li(d9rjek),w3gohz) = mat(d9rjek,w3gohz)
- if(.not.(teola6 .eq. 0))goto 23028
- a(vvl1li(d9rjek),zqve1l(d9rjek),w3gohz) = mat(d9rjek,w3gohz)
+ do 23024 ayfnwr1v=1,kuzxj1lo
+ do 23026 yq6lorbx=1,dimm
+ a(tgiyxdw1(yq6lorbx),dufozmt7(yq6lorbx),ayfnwr1v) = mat(yq6lorbx,
+ &ayfnwr1v)
+ if(.not.(upper .eq. 0))goto 23028
+ a(dufozmt7(yq6lorbx),tgiyxdw1(yq6lorbx),ayfnwr1v) = mat(yq6lorbx,
+ &ayfnwr1v)
23028 continue
23026 continue
23024 continue
return
end
- subroutine mux22f(jrxg6l, jmwo0z, ghry8z, zkjqhi, zqve1l, vvl1li,
- &nfiumb4, lku8xq, mbd8lk)
+ subroutine nudh6szqf(wpuarq2m, tlgduey8, lfu2qhid, dimu, tgiyxdw1,
+ & dufozmt7, kuzxj1lo, wy1vqfzu, wk1200)
implicit logical (a-z)
- integer zkjqhi, zqve1l(1), vvl1li(1), nfiumb4, lku8xq
- double precision jrxg6l(zkjqhi,nfiumb4), jmwo0z(nfiumb4,lku8xq),
- &ghry8z(lku8xq,nfiumb4), mbd8lk(lku8xq,lku8xq)
- double precision qnk4zf
- integer w3gohz, d9rjek, i1nkrb, one, teola6
+ integer dimu, tgiyxdw1(1), dufozmt7(1), kuzxj1lo, wy1vqfzu
+ double precision wpuarq2m(dimu,kuzxj1lo), tlgduey8(kuzxj1lo,
+ &wy1vqfzu), lfu2qhid(wy1vqfzu,kuzxj1lo), wk1200(wy1vqfzu,wy1vqfzu)
+ double precision q6zdcwxk
+ integer ayfnwr1v, yq6lorbx, bpvaqm5z, one, upper
one = 1
- teola6 = 1
- w3gohz = 1
-23030 if(.not.(w3gohz.le.nfiumb4))goto 23032
- call vm2af(jrxg6l(1,w3gohz), mbd8lk, zkjqhi, zqve1l, vvl1li, one,
- &lku8xq, teola6)
- d9rjek = 1
-23033 if(.not.(d9rjek.le.lku8xq))goto 23035
- qnk4zf = 0.0d0
- i1nkrb = d9rjek
-23036 if(.not.(i1nkrb.le.lku8xq))goto 23038
- qnk4zf = qnk4zf + mbd8lk(d9rjek,i1nkrb) * jmwo0z(w3gohz,i1nkrb)
- i1nkrb=i1nkrb+1
+ upper = 1
+ ayfnwr1v = 1
+23030 if(.not.(ayfnwr1v.le.kuzxj1lo))goto 23032
+ call vm2af(wpuarq2m(1,ayfnwr1v), wk1200, dimu, tgiyxdw1, dufozmt7,
+ & one, wy1vqfzu, upper)
+ yq6lorbx = 1
+23033 if(.not.(yq6lorbx.le.wy1vqfzu))goto 23035
+ q6zdcwxk = 0.0d0
+ bpvaqm5z = yq6lorbx
+23036 if(.not.(bpvaqm5z.le.wy1vqfzu))goto 23038
+ q6zdcwxk = q6zdcwxk + wk1200(yq6lorbx,bpvaqm5z) * tlgduey8(
+ &ayfnwr1v,bpvaqm5z)
+ bpvaqm5z=bpvaqm5z+1
goto 23036
23038 continue
- ghry8z(d9rjek,w3gohz) = qnk4zf
- d9rjek=d9rjek+1
+ lfu2qhid(yq6lorbx,ayfnwr1v) = q6zdcwxk
+ yq6lorbx=yq6lorbx+1
goto 23033
23035 continue
- w3gohz=w3gohz+1
+ ayfnwr1v=ayfnwr1v+1
goto 23030
23032 continue
return
end
- subroutine vbksf(jrxg6l, yg1jzv, lku8xq, nfiumb4, mbd8lk, zqve1l,
- &vvl1li, zkjqhi)
+ subroutine vbksf(wpuarq2m, bvecto, wy1vqfzu, kuzxj1lo, wk1200,
+ &tgiyxdw1, dufozmt7, dimu)
implicit logical (a-z)
- integer lku8xq, nfiumb4, zqve1l, vvl1li, zkjqhi
- double precision jrxg6l(zkjqhi,nfiumb4), yg1jzv(lku8xq,nfiumb4),
- &mbd8lk(lku8xq,lku8xq)
- double precision qnk4zf
- integer w3gohz, d9rjek, nd6mep, teola6, one
- teola6 = 1
+ integer wy1vqfzu, kuzxj1lo, tgiyxdw1(1), dufozmt7(1), dimu
+ double precision wpuarq2m(dimu,kuzxj1lo), bvecto(wy1vqfzu,
+ &kuzxj1lo), wk1200(wy1vqfzu,wy1vqfzu)
+ double precision q6zdcwxk
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh, upper, one
+ upper = 1
one = 1
- w3gohz = 1
-23039 if(.not.(w3gohz.le.nfiumb4))goto 23041
- call vm2af(jrxg6l(1,w3gohz), mbd8lk, zkjqhi, zqve1l, vvl1li, one,
- &lku8xq, teola6)
- d9rjek = lku8xq
-23042 if(.not.(d9rjek.ge.1))goto 23044
- qnk4zf = yg1jzv(d9rjek,w3gohz)
- nd6mep = d9rjek+1
-23045 if(.not.(nd6mep.le.lku8xq))goto 23047
- qnk4zf = qnk4zf - mbd8lk(d9rjek,nd6mep) * yg1jzv(nd6mep,w3gohz)
- nd6mep=nd6mep+1
+ ayfnwr1v = 1
+23039 if(.not.(ayfnwr1v.le.kuzxj1lo))goto 23041
+ call vm2af(wpuarq2m(1,ayfnwr1v), wk1200, dimu, tgiyxdw1, dufozmt7,
+ & one, wy1vqfzu, upper)
+ yq6lorbx = wy1vqfzu
+23042 if(.not.(yq6lorbx.ge.1))goto 23044
+ q6zdcwxk = bvecto(yq6lorbx,ayfnwr1v)
+ gp1jxzuh = yq6lorbx+1
+23045 if(.not.(gp1jxzuh.le.wy1vqfzu))goto 23047
+ q6zdcwxk = q6zdcwxk - wk1200(yq6lorbx,gp1jxzuh) * bvecto(gp1jxzuh,
+ &ayfnwr1v)
+ gp1jxzuh=gp1jxzuh+1
goto 23045
23047 continue
- yg1jzv(d9rjek,w3gohz) = qnk4zf / mbd8lk(d9rjek,d9rjek)
- d9rjek=d9rjek-1
+ bvecto(yq6lorbx,ayfnwr1v) = q6zdcwxk / wk1200(yq6lorbx,yq6lorbx)
+ yq6lorbx=yq6lorbx-1
goto 23042
23044 continue
- w3gohz=w3gohz+1
+ ayfnwr1v=ayfnwr1v+1
goto 23039
23041 continue
return
end
- subroutine vcholf(w8xfic, yg1jzv, lku8xq, c4uxow, ex7hfo)
+ subroutine vcholf(wmat, bvecto, wy1vqfzu, dvhw1ulq, isolve)
implicit logical (a-z)
- integer ex7hfo
- integer lku8xq, c4uxow
- double precision w8xfic(lku8xq,lku8xq), yg1jzv(lku8xq)
- double precision qnk4zf, dsqrt
- integer w3gohz, d9rjek, nd6mep
- c4uxow=1
- do 23048 w3gohz=1,lku8xq
- qnk4zf = 0d0
- do 23050 nd6mep=1,w3gohz-1
- qnk4zf = qnk4zf + w8xfic(nd6mep,w3gohz) * w8xfic(nd6mep,w3gohz)
+ integer isolve
+ integer wy1vqfzu, dvhw1ulq
+ double precision wmat(wy1vqfzu,wy1vqfzu), bvecto(wy1vqfzu)
+ double precision q6zdcwxk, dsqrt
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh
+ dvhw1ulq=1
+ do 23048 ayfnwr1v=1,wy1vqfzu
+ q6zdcwxk = 0d0
+ do 23050 gp1jxzuh=1,ayfnwr1v-1
+ q6zdcwxk = q6zdcwxk + wmat(gp1jxzuh,ayfnwr1v) * wmat(gp1jxzuh,
+ &ayfnwr1v)
23050 continue
- w8xfic(w3gohz,w3gohz) = w8xfic(w3gohz,w3gohz) - qnk4zf
- if(.not.(w8xfic(w3gohz,w3gohz) .le. 0d0))goto 23052
- c4uxow = 0
+ wmat(ayfnwr1v,ayfnwr1v) = wmat(ayfnwr1v,ayfnwr1v) - q6zdcwxk
+ if(.not.(wmat(ayfnwr1v,ayfnwr1v) .le. 0d0))goto 23052
+ dvhw1ulq = 0
return
23052 continue
- w8xfic(w3gohz,w3gohz) = dsqrt(w8xfic(w3gohz,w3gohz))
- do 23054 d9rjek=w3gohz+1,lku8xq
- qnk4zf = 0d0
- do 23056 nd6mep=1,w3gohz-1
- qnk4zf = qnk4zf + w8xfic(nd6mep,w3gohz) * w8xfic(nd6mep,d9rjek)
+ wmat(ayfnwr1v,ayfnwr1v) = dsqrt(wmat(ayfnwr1v,ayfnwr1v))
+ do 23054 yq6lorbx=ayfnwr1v+1,wy1vqfzu
+ q6zdcwxk = 0d0
+ do 23056 gp1jxzuh=1,ayfnwr1v-1
+ q6zdcwxk = q6zdcwxk + wmat(gp1jxzuh,ayfnwr1v) * wmat(gp1jxzuh,
+ &yq6lorbx)
23056 continue
- w8xfic(w3gohz,d9rjek) = (w8xfic(w3gohz,d9rjek) - qnk4zf) / w8xfic(
- &w3gohz,w3gohz)
+ wmat(ayfnwr1v,yq6lorbx) = (wmat(ayfnwr1v,yq6lorbx) - q6zdcwxk) /
+ &wmat(ayfnwr1v,ayfnwr1v)
23054 continue
23048 continue
- if(.not.(ex7hfo .eq. 0))goto 23058
- do 23060 w3gohz=2,lku8xq
- do 23062 d9rjek=1,w3gohz-1
- w8xfic(w3gohz,d9rjek) = 0.0d0
+ if(.not.(isolve .eq. 0))goto 23058
+ do 23060 ayfnwr1v=2,wy1vqfzu
+ do 23062 yq6lorbx=1,ayfnwr1v-1
+ wmat(ayfnwr1v,yq6lorbx) = 0.0d0
23062 continue
return
23060 continue
23058 continue
- do 23064 d9rjek=1,lku8xq
- qnk4zf = yg1jzv(d9rjek)
- do 23066 nd6mep=1,d9rjek-1
- qnk4zf = qnk4zf - w8xfic(nd6mep,d9rjek) * yg1jzv(nd6mep)
+ do 23064 yq6lorbx=1,wy1vqfzu
+ q6zdcwxk = bvecto(yq6lorbx)
+ do 23066 gp1jxzuh=1,yq6lorbx-1
+ q6zdcwxk = q6zdcwxk - wmat(gp1jxzuh,yq6lorbx) * bvecto(gp1jxzuh)
23066 continue
- yg1jzv(d9rjek) = qnk4zf / w8xfic(d9rjek,d9rjek)
+ bvecto(yq6lorbx) = q6zdcwxk / wmat(yq6lorbx,yq6lorbx)
23064 continue
- d9rjek = lku8xq
-23068 if(.not.(d9rjek.ge.1))goto 23070
- qnk4zf = yg1jzv(d9rjek)
- nd6mep = d9rjek+1
-23071 if(.not.(nd6mep.le.lku8xq))goto 23073
- qnk4zf = qnk4zf - w8xfic(d9rjek,nd6mep) * yg1jzv(nd6mep)
- nd6mep=nd6mep+1
+ yq6lorbx = wy1vqfzu
+23068 if(.not.(yq6lorbx.ge.1))goto 23070
+ q6zdcwxk = bvecto(yq6lorbx)
+ gp1jxzuh = yq6lorbx+1
+23071 if(.not.(gp1jxzuh.le.wy1vqfzu))goto 23073
+ q6zdcwxk = q6zdcwxk - wmat(yq6lorbx,gp1jxzuh) * bvecto(gp1jxzuh)
+ gp1jxzuh=gp1jxzuh+1
goto 23071
23073 continue
- yg1jzv(d9rjek) = qnk4zf / w8xfic(d9rjek,d9rjek)
- d9rjek=d9rjek-1
+ bvecto(yq6lorbx) = q6zdcwxk / wmat(yq6lorbx,yq6lorbx)
+ yq6lorbx=yq6lorbx-1
goto 23068
23070 continue
return
end
- subroutine mux17f(jrxg6l, p3vlea, lku8xq, o9ljyn, nfiumb4, mbd8lk,
- & cm6nof, zqve1l, vvl1li, zkjqhi, c4bdmu)
+ subroutine mxrbkut0f(wpuarq2m, he7mqnvy, wy1vqfzu, xjc4ywlh,
+ &kuzxj1lo, wk1200, wk3400, tgiyxdw1, dufozmt7, dimu, rutyk8mg)
implicit logical (a-z)
- integer zkjqhi, lku8xq, o9ljyn, nfiumb4, zqve1l(1), vvl1li(1),
- &c4bdmu
- double precision jrxg6l(zkjqhi,nfiumb4), p3vlea(c4bdmu,o9ljyn),
- &mbd8lk(lku8xq,lku8xq), cm6nof(lku8xq,o9ljyn)
- double precision qnk4zf
- integer w3gohz, d9rjek, nd6mep, i1nkrb
- do 23074 d9rjek=1,lku8xq
- do 23076 w3gohz=1,lku8xq
- mbd8lk(w3gohz,d9rjek) = 0.0d0
+ integer dimu, wy1vqfzu, xjc4ywlh, kuzxj1lo, tgiyxdw1(1), dufozmt7(
+ &1), rutyk8mg
+ double precision wpuarq2m(dimu,kuzxj1lo), he7mqnvy(rutyk8mg,
+ &xjc4ywlh), wk1200(wy1vqfzu,wy1vqfzu), wk3400(wy1vqfzu,xjc4ywlh)
+ double precision q6zdcwxk
+ integer ayfnwr1v, yq6lorbx, gp1jxzuh, bpvaqm5z
+ do 23074 yq6lorbx=1,wy1vqfzu
+ do 23076 ayfnwr1v=1,wy1vqfzu
+ wk1200(ayfnwr1v,yq6lorbx) = 0.0d0
23076 continue
23074 continue
- do 23078 w3gohz=1,nfiumb4
- do 23080 i1nkrb=1,zkjqhi
- mbd8lk(zqve1l(i1nkrb), vvl1li(i1nkrb)) = jrxg6l(i1nkrb,w3gohz)
+ do 23078 ayfnwr1v=1,kuzxj1lo
+ do 23080 bpvaqm5z=1,dimu
+ wk1200(tgiyxdw1(bpvaqm5z), dufozmt7(bpvaqm5z)) = wpuarq2m(
+ &bpvaqm5z,ayfnwr1v)
23080 continue
- do 23082 nd6mep=1,o9ljyn
- do 23084 d9rjek=1,lku8xq
- cm6nof(d9rjek,nd6mep) = p3vlea((w3gohz-1)*lku8xq+d9rjek,nd6mep)
+ do 23082 gp1jxzuh=1,xjc4ywlh
+ do 23084 yq6lorbx=1,wy1vqfzu
+ wk3400(yq6lorbx,gp1jxzuh) = he7mqnvy((ayfnwr1v-1)*wy1vqfzu+
+ &yq6lorbx,gp1jxzuh)
23084 continue
23082 continue
- do 23086 nd6mep=1,o9ljyn
- do 23088 d9rjek=1,lku8xq
- qnk4zf = 0d0
- do 23090 i1nkrb=d9rjek,lku8xq
- qnk4zf = qnk4zf + mbd8lk(d9rjek,i1nkrb) * cm6nof(i1nkrb,nd6mep)
+ do 23086 gp1jxzuh=1,xjc4ywlh
+ do 23088 yq6lorbx=1,wy1vqfzu
+ q6zdcwxk = 0d0
+ do 23090 bpvaqm5z=yq6lorbx,wy1vqfzu
+ q6zdcwxk = q6zdcwxk + wk1200(yq6lorbx,bpvaqm5z) * wk3400(bpvaqm5z,
+ &gp1jxzuh)
23090 continue
- p3vlea((w3gohz-1)*lku8xq+d9rjek,nd6mep) = qnk4zf
+ he7mqnvy((ayfnwr1v-1)*wy1vqfzu+yq6lorbx,gp1jxzuh) = q6zdcwxk
23088 continue
23086 continue
23078 continue
return
end
- subroutine vrinvf9(jrxg6l, ldr, lku8xq, c4uxow, ku0goz, bgu6fw)
+ subroutine vrinvf9(wpuarq2m, ldr, wy1vqfzu, dvhw1ulq, ks3wejcv,
+ &work)
implicit logical (a-z)
- integer ldr, lku8xq, c4uxow
- double precision jrxg6l(ldr,lku8xq), ku0goz(lku8xq,lku8xq),
- &bgu6fw(lku8xq,lku8xq)
- double precision qnk4zf
- integer d9rjek, nd6mep, col, mavy5hmod
- c4uxow = 1
- d9rjek = 1
-23092 if(.not.(d9rjek.le.lku8xq))goto 23094
+ integer ldr, wy1vqfzu, dvhw1ulq
+ double precision wpuarq2m(ldr,wy1vqfzu), ks3wejcv(wy1vqfzu,
+ &wy1vqfzu), work(wy1vqfzu,wy1vqfzu)
+ double precision q6zdcwxk
+ integer yq6lorbx, gp1jxzuh, col, uaoynef0
+ dvhw1ulq = 1
+ yq6lorbx = 1
+23092 if(.not.(yq6lorbx.le.wy1vqfzu))goto 23094
col = 1
-23095 if(.not.(col.le.lku8xq))goto 23097
- bgu6fw(d9rjek,col) = 0.0d0
+23095 if(.not.(col.le.wy1vqfzu))goto 23097
+ work(yq6lorbx,col) = 0.0d0
col=col+1
goto 23095
23097 continue
- d9rjek=d9rjek+1
+ yq6lorbx=yq6lorbx+1
goto 23092
23094 continue
col = 1
-23098 if(.not.(col.le.lku8xq))goto 23100
- d9rjek = col
-23101 if(.not.(d9rjek.ge.1))goto 23103
- if(.not.(d9rjek .eq. col))goto 23104
- qnk4zf = 1.0d0
+23098 if(.not.(col.le.wy1vqfzu))goto 23100
+ yq6lorbx = col
+23101 if(.not.(yq6lorbx.ge.1))goto 23103
+ if(.not.(yq6lorbx .eq. col))goto 23104
+ q6zdcwxk = 1.0d0
goto 23105
23104 continue
- qnk4zf = 0.0d0
+ q6zdcwxk = 0.0d0
23105 continue
- nd6mep = d9rjek+1
-23106 if(.not.(nd6mep.le.col))goto 23108
- qnk4zf = qnk4zf - jrxg6l(d9rjek,nd6mep) * bgu6fw(nd6mep,col)
- nd6mep=nd6mep+1
+ gp1jxzuh = yq6lorbx+1
+23106 if(.not.(gp1jxzuh.le.col))goto 23108
+ q6zdcwxk = q6zdcwxk - wpuarq2m(yq6lorbx,gp1jxzuh) * work(gp1jxzuh,
+ &col)
+ gp1jxzuh=gp1jxzuh+1
goto 23106
23108 continue
- if(.not.(jrxg6l(d9rjek,d9rjek) .eq. 0.0d0))goto 23109
- c4uxow = 0
+ if(.not.(wpuarq2m(yq6lorbx,yq6lorbx) .eq. 0.0d0))goto 23109
+ dvhw1ulq = 0
goto 23110
23109 continue
- bgu6fw(d9rjek,col) = qnk4zf / jrxg6l(d9rjek,d9rjek)
+ work(yq6lorbx,col) = q6zdcwxk / wpuarq2m(yq6lorbx,yq6lorbx)
23110 continue
- d9rjek=d9rjek-1
+ yq6lorbx=yq6lorbx-1
goto 23101
23103 continue
col=col+1
goto 23098
23100 continue
- d9rjek = 1
-23111 if(.not.(d9rjek.le.lku8xq))goto 23113
- col = d9rjek
-23114 if(.not.(col.le.lku8xq))goto 23116
- if(.not.(d9rjek .lt. col))goto 23117
- mavy5hmod = col
+ yq6lorbx = 1
+23111 if(.not.(yq6lorbx.le.wy1vqfzu))goto 23113
+ col = yq6lorbx
+23114 if(.not.(col.le.wy1vqfzu))goto 23116
+ if(.not.(yq6lorbx .lt. col))goto 23117
+ uaoynef0 = col
goto 23118
23117 continue
- mavy5hmod = d9rjek
+ uaoynef0 = yq6lorbx
23118 continue
- qnk4zf = 0.0d0
- nd6mep = mavy5hmod
-23119 if(.not.(nd6mep.le.lku8xq))goto 23121
- qnk4zf = qnk4zf + bgu6fw(d9rjek,nd6mep) * bgu6fw(col,nd6mep)
- nd6mep=nd6mep+1
+ q6zdcwxk = 0.0d0
+ gp1jxzuh = uaoynef0
+23119 if(.not.(gp1jxzuh.le.wy1vqfzu))goto 23121
+ q6zdcwxk = q6zdcwxk + work(yq6lorbx,gp1jxzuh) * work(col,gp1jxzuh)
+ gp1jxzuh=gp1jxzuh+1
goto 23119
23121 continue
- ku0goz(d9rjek,col) = qnk4zf
- ku0goz(col,d9rjek) = qnk4zf
+ ks3wejcv(yq6lorbx,col) = q6zdcwxk
+ ks3wejcv(col,yq6lorbx) = q6zdcwxk
col=col+1
goto 23114
23116 continue
- d9rjek=d9rjek+1
+ yq6lorbx=yq6lorbx+1
goto 23111
23113 continue
return
end
- subroutine atez9d(xx, ghry8z)
+ subroutine tldz5ion(xx, lfu2qhid)
implicit logical (a-z)
- double precision xx, ghry8z
- double precision x, y, j0izmn, qnk4zf, mu4ygk(6)
- integer d9rjek
- mu4ygk(1)= 76.18009172947146d0
- mu4ygk(2)= -86.50532032941677d0
- mu4ygk(3)= 24.01409824083091d0
- mu4ygk(4)= -1.231739572450155d0
- mu4ygk(5)= 0.1208650973866179d-2
- mu4ygk(6)= -0.5395239384953d-5
+ double precision xx, lfu2qhid
+ double precision x, y, hofjnx2e, q6zdcwxk, xd4mybgj(6)
+ integer yq6lorbx
+ xd4mybgj(1)= 76.18009172947146d0
+ xd4mybgj(2)= -86.50532032941677d0
+ xd4mybgj(3)= 24.01409824083091d0
+ xd4mybgj(4)= -1.231739572450155d0
+ xd4mybgj(5)= 0.1208650973866179d-2
+ xd4mybgj(6)= -0.5395239384953d-5
x = xx
y = xx
- j0izmn = x+5.50d0
- j0izmn = j0izmn - (x+0.50d0) * dlog(j0izmn)
- qnk4zf=1.000000000190015d0
- d9rjek=1
-23122 if(.not.(d9rjek.le.6))goto 23124
+ hofjnx2e = x+5.50d0
+ hofjnx2e = hofjnx2e - (x+0.50d0) * dlog(hofjnx2e)
+ q6zdcwxk=1.000000000190015d0
+ yq6lorbx=1
+23122 if(.not.(yq6lorbx.le.6))goto 23124
y = y + 1.0d0
- qnk4zf = qnk4zf + mu4ygk(d9rjek)/y
- d9rjek=d9rjek+1
+ q6zdcwxk = q6zdcwxk + xd4mybgj(yq6lorbx)/y
+ yq6lorbx=yq6lorbx+1
goto 23122
23124 continue
- ghry8z = -j0izmn + dlog(2.5066282746310005d0 * qnk4zf / x)
+ lfu2qhid = -hofjnx2e + dlog(2.5066282746310005d0 * q6zdcwxk / x)
return
end
- subroutine enbin9(qe3jcd, gq815b, xkcm3b, ogq67o, n, c4uxow,
- &lzgs0f, hmr3dx, jftq1, nh2qxl)
+ subroutine enbin9(bzmd6ftv, hdqsx7bk, nm0eljqk, n2kersmx, n,
+ &dvhw1ulq, zy1mchbf, ux3nadiw, rsynp1go, sguwj9ty)
implicit logical (a-z)
- integer n, c4uxow, lzgs0f, nh2qxl
- double precision qe3jcd(n, lzgs0f), gq815b(n, lzgs0f), xkcm3b(n,
- &lzgs0f), ogq67o, hmr3dx, jftq1
- integer w3gohz, myx3od
- double precision nh5zwa, pohw8d, ydb, dyb3po1, qbca1x, pvl5mc,
- &pdjzm4, rxe0so, epx9jf, qnk4zf, scnrp6
- real yogfz6
- if(.not.(ogq67o .le. 0.80d0 .or. ogq67o .ge. 1.0d0))goto 23125
- c4uxow = 0
+ integer n, dvhw1ulq, zy1mchbf, sguwj9ty
+ double precision bzmd6ftv(n, zy1mchbf), hdqsx7bk(n, zy1mchbf),
+ &nm0eljqk(n, zy1mchbf), n2kersmx, ux3nadiw, rsynp1go
+ integer ayfnwr1v, kij0gwer
+ double precision oxjgzv0e, btiehdm2, ydb, vjz5sxty, esql7umk,
+ &pvcjl2na, mwuvskg1, ft3ijqmy, hmayv1xt, q6zdcwxk, plo6hkdr
+ real csi9ydge
+ if(.not.(n2kersmx .le. 0.80d0 .or. n2kersmx .ge. 1.0d0))goto 23125
+ dvhw1ulq = 0
return
23125 continue
- pohw8d = 100.0d0 * jftq1
- nh5zwa = 0.001d0
- c4uxow = 1
- myx3od=1
-23127 if(.not.(myx3od.le.lzgs0f))goto 23129
- w3gohz=1
-23130 if(.not.(w3gohz.le.n))goto 23132
- dyb3po1 = xkcm3b(w3gohz,myx3od) / gq815b(w3gohz,myx3od)
- if(.not.((dyb3po1 .lt. nh5zwa) .or. (xkcm3b(w3gohz,myx3od) .gt. 1.
- &0d5)))goto 23133
- qe3jcd(w3gohz,myx3od) = -xkcm3b(w3gohz,myx3od) * (1.0d0 + gq815b(
- &w3gohz,myx3od)/(gq815b(w3gohz,myx3od) + xkcm3b(w3gohz,myx3od))) /
- &gq815b(w3gohz,myx3od)**2
- if(.not.(qe3jcd(w3gohz,myx3od) .gt. -pohw8d))goto 23135
- qe3jcd(w3gohz,myx3od) = -pohw8d
+ btiehdm2 = 100.0d0 * rsynp1go
+ oxjgzv0e = 0.001d0
+ dvhw1ulq = 1
+ kij0gwer=1
+23127 if(.not.(kij0gwer.le.zy1mchbf))goto 23129
+ ayfnwr1v=1
+23130 if(.not.(ayfnwr1v.le.n))goto 23132
+ vjz5sxty = nm0eljqk(ayfnwr1v,kij0gwer) / hdqsx7bk(ayfnwr1v,
+ &kij0gwer)
+ if(.not.((vjz5sxty .lt. oxjgzv0e) .or. (nm0eljqk(ayfnwr1v,
+ &kij0gwer) .gt. 1.0d5)))goto 23133
+ bzmd6ftv(ayfnwr1v,kij0gwer) = -nm0eljqk(ayfnwr1v,kij0gwer) * (1.
+ &0d0 + hdqsx7bk(ayfnwr1v,kij0gwer)/(hdqsx7bk(ayfnwr1v,kij0gwer) +
+ &nm0eljqk(ayfnwr1v,kij0gwer))) / hdqsx7bk(ayfnwr1v,kij0gwer)**2
+ if(.not.(bzmd6ftv(ayfnwr1v,kij0gwer) .gt. -btiehdm2))goto 23135
+ bzmd6ftv(ayfnwr1v,kij0gwer) = -btiehdm2
23135 continue
goto 20
23133 continue
- qnk4zf = 0.0d0
- pvl5mc = gq815b(w3gohz,myx3od) / (gq815b(w3gohz,myx3od) + xkcm3b(
- &w3gohz,myx3od))
- pdjzm4 = 1.0d0 - pvl5mc
- yogfz6 = gq815b(w3gohz,myx3od)
- if(.not.(pvl5mc .lt. pohw8d))goto 23137
- pvl5mc = pohw8d
+ q6zdcwxk = 0.0d0
+ pvcjl2na = hdqsx7bk(ayfnwr1v,kij0gwer) / (hdqsx7bk(ayfnwr1v,
+ &kij0gwer) + nm0eljqk(ayfnwr1v,kij0gwer))
+ mwuvskg1 = 1.0d0 - pvcjl2na
+ csi9ydge = hdqsx7bk(ayfnwr1v,kij0gwer)
+ if(.not.(pvcjl2na .lt. btiehdm2))goto 23137
+ pvcjl2na = btiehdm2
23137 continue
- if(.not.(pdjzm4 .lt. pohw8d))goto 23139
- pdjzm4 = pohw8d
+ if(.not.(mwuvskg1 .lt. btiehdm2))goto 23139
+ mwuvskg1 = btiehdm2
23139 continue
- qbca1x = 100.0d0 + 15.0d0 * xkcm3b(w3gohz,myx3od)
- if(.not.(qbca1x .lt. nh2qxl))goto 23141
- qbca1x = nh2qxl
+ esql7umk = 100.0d0 + 15.0d0 * nm0eljqk(ayfnwr1v,kij0gwer)
+ if(.not.(esql7umk .lt. sguwj9ty))goto 23141
+ esql7umk = sguwj9ty
23141 continue
- rxe0so = pvl5mc ** yogfz6
- hmr3dx = rxe0so
- scnrp6 = (1.0d0 - hmr3dx) / gq815b(w3gohz,myx3od)**2
- qnk4zf = qnk4zf + scnrp6
+ ft3ijqmy = pvcjl2na ** csi9ydge
+ ux3nadiw = ft3ijqmy
+ plo6hkdr = (1.0d0 - ux3nadiw) / hdqsx7bk(ayfnwr1v,kij0gwer)**2
+ q6zdcwxk = q6zdcwxk + plo6hkdr
ydb = 1.0d0
- rxe0so = gq815b(w3gohz,myx3od) * pdjzm4 * rxe0so
- hmr3dx = hmr3dx + rxe0so
- scnrp6 = (1.0d0 - hmr3dx) / (gq815b(w3gohz,myx3od) + ydb)**2
- qnk4zf = qnk4zf + scnrp6
+ ft3ijqmy = hdqsx7bk(ayfnwr1v,kij0gwer) * mwuvskg1 * ft3ijqmy
+ ux3nadiw = ux3nadiw + ft3ijqmy
+ plo6hkdr = (1.0d0 - ux3nadiw) / (hdqsx7bk(ayfnwr1v,kij0gwer) +
+ &ydb)**2
+ q6zdcwxk = q6zdcwxk + plo6hkdr
ydb = 2.0d0
-23143 if(.not.(((hmr3dx .le. ogq67o) .or. (scnrp6 .gt. 1.0d-4)) .and.(
- &ydb .lt. qbca1x)))goto 23144
- rxe0so = (gq815b(w3gohz,myx3od) - 1.0d0 + ydb) * pdjzm4 * rxe0so /
- & ydb
- hmr3dx = hmr3dx + rxe0so
- scnrp6 = (1.0d0 - hmr3dx) / (gq815b(w3gohz,myx3od) + ydb)**2
- qnk4zf = qnk4zf + scnrp6
+23143 if(.not.(((ux3nadiw .le. n2kersmx) .or. (plo6hkdr .gt. 1.0d-4)) .
+ &and.(ydb .lt. esql7umk)))goto 23144
+ ft3ijqmy = (hdqsx7bk(ayfnwr1v,kij0gwer) - 1.0d0 + ydb) * mwuvskg1
+ &* ft3ijqmy / ydb
+ ux3nadiw = ux3nadiw + ft3ijqmy
+ plo6hkdr = (1.0d0 - ux3nadiw) / (hdqsx7bk(ayfnwr1v,kij0gwer) +
+ &ydb)**2
+ q6zdcwxk = q6zdcwxk + plo6hkdr
ydb = ydb + 1.0d0
goto 23143
23144 continue
- qe3jcd(w3gohz,myx3od) = -qnk4zf
-20 epx9jf = 0.0d0
- w3gohz=w3gohz+1
+ bzmd6ftv(ayfnwr1v,kij0gwer) = -q6zdcwxk
+20 hmayv1xt = 0.0d0
+ ayfnwr1v=ayfnwr1v+1
goto 23130
23132 continue
- myx3od=myx3od+1
+ kij0gwer=kij0gwer+1
goto 23127
23129 continue
return
end
- subroutine enbin8(qe3jcd, gq815b, ncrb2f, ogq67o, nfiumb4, c4uxow,
- & lzgs0f, hmr3dx, jftq1)
+ subroutine enbin8(bzmd6ftv, hdqsx7bk, hsj9bzaq, n2kersmx,
+ &kuzxj1lo, dvhw1ulq, zy1mchbf, ux3nadiw, rsynp1go)
implicit logical (a-z)
- integer nfiumb4, c4uxow, lzgs0f
- double precision qe3jcd(nfiumb4, lzgs0f), gq815b(nfiumb4, lzgs0f),
- & ncrb2f(nfiumb4, lzgs0f), ogq67o, hmr3dx, jftq1
- integer w3gohz, myx3od, qbca1x
- double precision rxe0so, mw6reg, xkwp2m, xndw5e, qnk4zf, d1, d2,
- &scnrp6, onemeps
+ integer kuzxj1lo, dvhw1ulq, zy1mchbf
+ double precision bzmd6ftv(kuzxj1lo, zy1mchbf), hdqsx7bk(kuzxj1lo,
+ &zy1mchbf), hsj9bzaq(kuzxj1lo, zy1mchbf), n2kersmx, ux3nadiw,
+ &rsynp1go
+ integer ayfnwr1v, kij0gwer, esql7umk
+ double precision ft3ijqmy, tad5vhsu, o3jyipdf, pq0hfucn, q6zdcwxk,
+ & d1, d2, plo6hkdr, hnu1vjyw
logical pok1, pok2, pok12
- double precision nh5zwa, hntu8v, xkcm3b, pohw8d, ydb, kbig
+ double precision oxjgzv0e, onemse, nm0eljqk, btiehdm2, ydb, kbig
d1 = 0.0d0
d2 = 0.0d0
- pohw8d = -100.0d0 * jftq1
- qbca1x = 3000
- if(.not.(ogq67o .le. 0.80d0 .or. ogq67o .ge. 1.0d0))goto 23145
- c4uxow = 0
+ btiehdm2 = -100.0d0 * rsynp1go
+ esql7umk = 3000
+ if(.not.(n2kersmx .le. 0.80d0 .or. n2kersmx .ge. 1.0d0))goto 23145
+ dvhw1ulq = 0
return
23145 continue
kbig = 1.0d4
- nh5zwa = 0.001d0
- onemeps = 1.0d0 - jftq1
- hntu8v = 1.0d0 / (1.0d0 + nh5zwa)
- c4uxow = 1
- myx3od=1
-23147 if(.not.(myx3od.le.lzgs0f))goto 23149
- w3gohz=1
-23150 if(.not.(w3gohz.le.nfiumb4))goto 23152
- if(.not.(gq815b(w3gohz,myx3od) .gt. kbig))goto 23153
- gq815b(w3gohz,myx3od) = kbig
+ oxjgzv0e = 0.001d0
+ hnu1vjyw = 1.0d0 - rsynp1go
+ onemse = 1.0d0 / (1.0d0 + oxjgzv0e)
+ dvhw1ulq = 1
+ kij0gwer=1
+23147 if(.not.(kij0gwer.le.zy1mchbf))goto 23149
+ ayfnwr1v=1
+23150 if(.not.(ayfnwr1v.le.kuzxj1lo))goto 23152
+ if(.not.(hdqsx7bk(ayfnwr1v,kij0gwer) .gt. kbig))goto 23153
+ hdqsx7bk(ayfnwr1v,kij0gwer) = kbig
23153 continue
- if(.not.(ncrb2f(w3gohz,myx3od) .lt. nh5zwa))goto 23155
- ncrb2f(w3gohz,myx3od) = nh5zwa
+ if(.not.(hsj9bzaq(ayfnwr1v,kij0gwer) .lt. oxjgzv0e))goto 23155
+ hsj9bzaq(ayfnwr1v,kij0gwer) = oxjgzv0e
23155 continue
- if(.not.((ncrb2f(w3gohz,myx3od) .gt. hntu8v)))goto 23157
- xkcm3b = gq815b(w3gohz,myx3od) * (1.0d0/ncrb2f(w3gohz,myx3od) - 1.
- &0d0)
- qe3jcd(w3gohz,myx3od) = -xkcm3b * (1.0d0 + gq815b(w3gohz,myx3od)/(
- &gq815b(w3gohz,myx3od) + xkcm3b)) / gq815b(w3gohz,myx3od)**2
- if(.not.(qe3jcd(w3gohz,myx3od) .gt. pohw8d))goto 23159
- qe3jcd(w3gohz,myx3od) = pohw8d
+ if(.not.((hsj9bzaq(ayfnwr1v,kij0gwer) .gt. onemse)))goto 23157
+ nm0eljqk = hdqsx7bk(ayfnwr1v,kij0gwer) * (1.0d0/hsj9bzaq(ayfnwr1v,
+ &kij0gwer) - 1.0d0)
+ bzmd6ftv(ayfnwr1v,kij0gwer) = -nm0eljqk * (1.0d0 + hdqsx7bk(
+ &ayfnwr1v,kij0gwer)/(hdqsx7bk(ayfnwr1v,kij0gwer) + nm0eljqk)) /
+ &hdqsx7bk(ayfnwr1v,kij0gwer)**2
+ if(.not.(bzmd6ftv(ayfnwr1v,kij0gwer) .gt. btiehdm2))goto 23159
+ bzmd6ftv(ayfnwr1v,kij0gwer) = btiehdm2
23159 continue
goto 20
23157 continue
- qnk4zf = 0.0d0
+ q6zdcwxk = 0.0d0
pok1 = .true.
- pok2 = ncrb2f(w3gohz,myx3od) .lt. (1.0d0-jftq1)
+ pok2 = hsj9bzaq(ayfnwr1v,kij0gwer) .lt. (1.0d0-rsynp1go)
pok12 = pok1 .and. pok2
if(.not.(pok12))goto 23161
- d2 = gq815b(w3gohz,myx3od) * dlog(ncrb2f(w3gohz,myx3od))
- hmr3dx = dexp(d2)
+ d2 = hdqsx7bk(ayfnwr1v,kij0gwer) * dlog(hsj9bzaq(ayfnwr1v,
+ &kij0gwer))
+ ux3nadiw = dexp(d2)
goto 23162
23161 continue
- hmr3dx = 0.0d0
+ ux3nadiw = 0.0d0
23162 continue
- scnrp6 = (1.0d0 - hmr3dx) / gq815b(w3gohz,myx3od)**2
- qnk4zf = qnk4zf + scnrp6
- call atez9d(gq815b(w3gohz,myx3od), xkwp2m)
+ plo6hkdr = (1.0d0 - ux3nadiw) / hdqsx7bk(ayfnwr1v,kij0gwer)**2
+ q6zdcwxk = q6zdcwxk + plo6hkdr
+ call tldz5ion(hdqsx7bk(ayfnwr1v,kij0gwer), o3jyipdf)
ydb = 1.0d0
- call atez9d(ydb + gq815b(w3gohz,myx3od), mw6reg)
- xndw5e = 0.0d0
+ call tldz5ion(ydb + hdqsx7bk(ayfnwr1v,kij0gwer), tad5vhsu)
+ pq0hfucn = 0.0d0
if(.not.(pok12))goto 23163
- d1 = dlog(1.0d0 - ncrb2f(w3gohz,myx3od))
- rxe0so = dexp(ydb * d1 + d2 + mw6reg - xkwp2m - xndw5e)
+ d1 = dlog(1.0d0 - hsj9bzaq(ayfnwr1v,kij0gwer))
+ ft3ijqmy = dexp(ydb * d1 + d2 + tad5vhsu - o3jyipdf - pq0hfucn)
goto 23164
23163 continue
- rxe0so = 0.0d0
+ ft3ijqmy = 0.0d0
23164 continue
- hmr3dx = hmr3dx + rxe0so
- scnrp6 = (1.0d0 - hmr3dx) / (gq815b(w3gohz,myx3od) + ydb)**2
- qnk4zf = qnk4zf + scnrp6
+ ux3nadiw = ux3nadiw + ft3ijqmy
+ plo6hkdr = (1.0d0 - ux3nadiw) / (hdqsx7bk(ayfnwr1v,kij0gwer) +
+ &ydb)**2
+ q6zdcwxk = q6zdcwxk + plo6hkdr
ydb = 2.0d0
-23165 if(.not.((hmr3dx .le. ogq67o) .or. (scnrp6 .gt. 1.0d-4)))goto 2316
- &6
- mw6reg = mw6reg + dlog(ydb + gq815b(w3gohz,myx3od) - 1.0d0)
- xndw5e = xndw5e + dlog(ydb)
+23165 if(.not.((ux3nadiw .le. n2kersmx) .or. (plo6hkdr .gt. 1.0d-4)))
+ &goto 23166
+ tad5vhsu = tad5vhsu + dlog(ydb + hdqsx7bk(ayfnwr1v,kij0gwer) - 1.
+ &0d0)
+ pq0hfucn = pq0hfucn + dlog(ydb)
if(.not.(pok12))goto 23167
- rxe0so = dexp(ydb * d1 + d2 + mw6reg - xkwp2m - xndw5e)
+ ft3ijqmy = dexp(ydb * d1 + d2 + tad5vhsu - o3jyipdf - pq0hfucn)
goto 23168
23167 continue
- rxe0so = 0.0d0
+ ft3ijqmy = 0.0d0
23168 continue
- hmr3dx = hmr3dx + rxe0so
- scnrp6 = (1.0d0 - hmr3dx) / (gq815b(w3gohz,myx3od) + ydb)**2
- qnk4zf = qnk4zf + scnrp6
+ ux3nadiw = ux3nadiw + ft3ijqmy
+ plo6hkdr = (1.0d0 - ux3nadiw) / (hdqsx7bk(ayfnwr1v,kij0gwer) +
+ &ydb)**2
+ q6zdcwxk = q6zdcwxk + plo6hkdr
ydb = ydb + 1.0d0
if(.not.(ydb .gt. 1.0d3))goto 23169
goto 21
23169 continue
goto 23165
23166 continue
-21 qe3jcd(w3gohz,myx3od) = -qnk4zf
-20 mw6reg = 0.0d0
- w3gohz=w3gohz+1
+21 bzmd6ftv(ayfnwr1v,kij0gwer) = -q6zdcwxk
+20 tad5vhsu = 0.0d0
+ ayfnwr1v=ayfnwr1v+1
goto 23150
23152 continue
- myx3od=myx3od+1
+ kij0gwer=kij0gwer+1
goto 23147
23149 continue
return
end
- subroutine mbessi0(yg1jzv, nfiumb4, xt3fko, d0, d1, d2, gqxvz8,
- &kqoy6w)
+ subroutine mbessi0(bvecto, kuzxj1lo, kpzavbj3, d0, d1, d2,
+ &zjkrtol8, qaltf0nz)
implicit logical (a-z)
- integer nfiumb4, xt3fko, gqxvz8, pga6nus
- double precision yg1jzv(nfiumb4), d0(nfiumb4), d1(nfiumb4), d2(
- &nfiumb4), kqoy6w
- integer w3gohz, nd6mep
+ integer kuzxj1lo, kpzavbj3, zjkrtol8, c5aesxkus
+ double precision bvecto(kuzxj1lo), d0(kuzxj1lo), d1(kuzxj1lo), d2(
+ &kuzxj1lo), qaltf0nz
+ integer ayfnwr1v, gp1jxzuh
double precision f0, t0, m0, f1, t1, m1, f2, t2, m2
double precision toobig
toobig = 20.0d0
- gqxvz8 = 0
- if(.not.(.not.(xt3fko .eq. 0 .or. xt3fko .eq. 1 .or. xt3fko .eq.
- &2)))goto 23171
- gqxvz8 = 1
+ zjkrtol8 = 0
+ if(.not.(.not.(kpzavbj3 .eq. 0 .or. kpzavbj3 .eq. 1 .or. kpzavbj3
+ &.eq. 2)))goto 23171
+ zjkrtol8 = 1
return
23171 continue
- do 23173 nd6mep=1,nfiumb4
- if(.not.(dabs(yg1jzv(nd6mep)) .gt. toobig))goto 23175
- gqxvz8 = 1
+ do 23173 gp1jxzuh=1,kuzxj1lo
+ if(.not.(dabs(bvecto(gp1jxzuh)) .gt. toobig))goto 23175
+ zjkrtol8 = 1
return
23175 continue
- t1 = yg1jzv(nd6mep) / 2.0d0
+ t1 = bvecto(gp1jxzuh) / 2.0d0
f1 = t1
t0 = t1 * t1
f0 = 1.0d0 + t0
t2 = 0.50d0
f2 = t2
- pga6nus = 15
- if(.not.(dabs(yg1jzv(nd6mep)) .gt. 10))goto 23177
- pga6nus = 25
+ c5aesxkus = 15
+ if(.not.(dabs(bvecto(gp1jxzuh)) .gt. 10))goto 23177
+ c5aesxkus = 25
23177 continue
- if(.not.(dabs(yg1jzv(nd6mep)) .gt. 15))goto 23179
- pga6nus = 35
+ if(.not.(dabs(bvecto(gp1jxzuh)) .gt. 15))goto 23179
+ c5aesxkus = 35
23179 continue
- if(.not.(dabs(yg1jzv(nd6mep)) .gt. 20))goto 23181
- pga6nus = 40
+ if(.not.(dabs(bvecto(gp1jxzuh)) .gt. 20))goto 23181
+ c5aesxkus = 40
23181 continue
- if(.not.(dabs(yg1jzv(nd6mep)) .gt. 30))goto 23183
- pga6nus = 55
+ if(.not.(dabs(bvecto(gp1jxzuh)) .gt. 30))goto 23183
+ c5aesxkus = 55
23183 continue
- do 23185 w3gohz=1,pga6nus
- m0 = (yg1jzv(nd6mep) / (2.0d0*(w3gohz+1.0d0))) ** 2.0
- m1 = m0 * (1.0d0 + 1.0d0/w3gohz)
- m2 = m1 * (2.0d0*w3gohz + 1.0d0) / (2.0d0*w3gohz - 1.0d0)
+ do 23185 ayfnwr1v=1,c5aesxkus
+ m0 = (bvecto(gp1jxzuh) / (2.0d0*(ayfnwr1v+1.0d0))) ** 2.0
+ m1 = m0 * (1.0d0 + 1.0d0/ayfnwr1v)
+ m2 = m1 * (2.0d0*ayfnwr1v + 1.0d0) / (2.0d0*ayfnwr1v - 1.0d0)
t0 = t0 * m0
t1 = t1 * m1
t2 = t2 * m2
f0 = f0 + t0
f1 = f1 + t1
f2 = f2 + t2
- if(.not.((dabs(t0) .lt. kqoy6w) .and. (dabs(t1) .lt. kqoy6w)
- &.and. (dabs(t2) .lt. kqoy6w)))goto 23187
+ if(.not.((dabs(t0) .lt. qaltf0nz) .and. (dabs(t1) .lt. qaltf0nz)
+ &.and. (dabs(t2) .lt. qaltf0nz)))goto 23187
goto 23186
23187 continue
23185 continue
23186 continue
- if(.not.(0 .le. xt3fko))goto 23189
- d0(nd6mep) = f0
+ if(.not.(0 .le. kpzavbj3))goto 23189
+ d0(gp1jxzuh) = f0
23189 continue
- if(.not.(1 .le. xt3fko))goto 23191
- d1(nd6mep) = f1
+ if(.not.(1 .le. kpzavbj3))goto 23191
+ d1(gp1jxzuh) = f1
23191 continue
- if(.not.(2 .le. xt3fko))goto 23193
- d2(nd6mep) = f2
+ if(.not.(2 .le. kpzavbj3))goto 23193
+ d2(gp1jxzuh) = f2
23193 continue
23173 continue
return
diff --git a/src/vmux3.c b/src/vmux3.c
new file mode 100644
index 0000000..90a37c2
--- /dev/null
+++ b/src/vmux3.c
@@ -0,0 +1,698 @@
+
+
+#include<math.h>
+#include<stdio.h>
+#include<stdlib.h>
+#include<R.h>
+#include<Rmath.h>
+
+void fvlmz9iyC_qpsedg8x(int tgiyxdw1[], int dufozmt7[], int *wy1vqfzu);
+int fvlmz9iyC_VIAM(int *cz8qdfyj, int *rvy1fpli, int *wy1vqfzu);
+void fvlmz9iyC_vm2a(double mtlgduey8[], double bzmd6ftvmat[], int *dim1m, int *f8yswcat,
+ int *wy1vqfzu, int *iupper, int tgiyxdw1[], int dufozmt7[], int *oey3ckps);
+void fvlmz9iyC_nudh6szq(double wpuarq2m[], double tlgduey8[], double bzmd6ftvmat[],
+ int *npjlv3mr, int *f8yswcat, int *wy1vqfzu);
+void fvlmz9iyC_vbks(double wpuarq2m[], double unvxka0m[],
+ int *wy1vqfzu, int *f8yswcat, int *dimu);
+void fvlmz9iyjdbomp0g(double rbne6ouj[], double unvxka0m[],
+ int *wy1vqfzu, int *dvhw1ulq, int *i_solve);
+void fvlmz9iyC_mxrbkut0(double wpuarq2m[], double he7mqnvy[],
+ int *wy1vqfzu, int *xjc4ywlh, int *f8yswcat, int *dimu, int *rutyk8mg);
+void fvlmz9iyC_lkhnw9yq(double wpuarq2m[], double ks3wejcv[],
+ int *npjlv3mr, int *wy1vqfzu, int *dvhw1ulq);
+double fvlmz9iyC_tldz5ion(double xx);
+void fvlmz9iyC_enbin9(double bzmd6ftv[], double hdqsx7bk[], double nm0eljqk[],
+ double *n2kersmx, int *f8yswcat, int *dvhw1ulq, int *zy1mchbf,
+ double *ux3nadiw, double *rsynp1go, int *sguwj9ty);
+void fvlmz9iyC_enbin8(double bzmd6ftv[], double hdqsx7bk[], double hsj9bzaq[],
+ double *n2kersmx, int *f8yswcat, int *dvhw1ulq, int *zy1mchbf,
+ double *ux3nadiw, double *rsynp1go);
+void fvlmz9iyC_mbessI0(double unvxka0m[], int *f8yswcat, int *kpzavbj3,
+ double dvector0[], double dvector1[], double dvector2[],
+ int *zjkrtol8, double *qaltf0nz);
+void VGAM_C_mux34(double he7mqnvy[], double Dmat[], int *vnc1izfy, int *e0nmabdk,
+ int *ui4ntmvd, double bqelz3cy[]);
+
+
+void fvlmz9iyC_qpsedg8x(int tgiyxdw1[], int dufozmt7[], int *wy1vqfzu) {
+
+ int urohxe6t, bpvaqm5z, *ptri;
+
+ ptri = tgiyxdw1;
+ for (urohxe6t = *wy1vqfzu; urohxe6t >= 1; urohxe6t--) {
+ for (bpvaqm5z = 1; bpvaqm5z <= urohxe6t; bpvaqm5z++) {
+ *ptri++ = bpvaqm5z;
+ }
+ }
+
+ ptri = dufozmt7;
+ for (urohxe6t = 1; urohxe6t <= *wy1vqfzu; urohxe6t++) {
+ for (bpvaqm5z = urohxe6t; bpvaqm5z <= *wy1vqfzu; bpvaqm5z++) {
+ *ptri++ = bpvaqm5z;
+ }
+ }
+
+}
+
+
+int fvlmz9iyC_VIAM(int *cz8qdfyj, int *rvy1fpli, int *wy1vqfzu) {
+
+
+ int urohxe6t;
+
+ int *wkumc9idtgiyxdw1, *wkumc9iddufozmt7;
+ int imk5wjxg = *wy1vqfzu * (*wy1vqfzu + 1) / 2;
+ wkumc9idtgiyxdw1 = Calloc(imk5wjxg, int);
+ wkumc9iddufozmt7 = Calloc(imk5wjxg, int);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw1, wkumc9iddufozmt7, wy1vqfzu);
+
+ for (urohxe6t = 1; urohxe6t <= imk5wjxg; urohxe6t++) {
+ if ((wkumc9idtgiyxdw1[urohxe6t-1]== *cz8qdfyj && wkumc9iddufozmt7[urohxe6t-1] == *rvy1fpli) ||
+ (wkumc9idtgiyxdw1[urohxe6t-1]== *rvy1fpli && wkumc9iddufozmt7[urohxe6t-1] == *cz8qdfyj)) {
+ Free(wkumc9idtgiyxdw1); Free(wkumc9iddufozmt7);
+ return urohxe6t;
+ }
+ }
+
+ Free(wkumc9idtgiyxdw1); Free(wkumc9iddufozmt7);
+ return 0;
+}
+
+
+void fvlmz9iyC_vm2a(double mtlgduey8[], double bzmd6ftvmat[], int *dim1m, int *f8yswcat,
+ int *wy1vqfzu, int *iupper, int tgiyxdw1[], int dufozmt7[], int *oey3ckps) {
+
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, urohxe6t;
+ int bpvaqm5z, usvdbx3tk, i_size_bzmd6ftvmat, imk5wjxg = *wy1vqfzu * (*wy1vqfzu + 1) / 2,
+ zyojx5hw = *wy1vqfzu * *wy1vqfzu;
+ double *qnwamo0e;
+
+ if (*oey3ckps == 1) {
+ if (*iupper == 1 || *dim1m != imk5wjxg) {
+ i_size_bzmd6ftvmat = zyojx5hw * *f8yswcat;
+ qnwamo0e = bzmd6ftvmat;
+ for (ayfnwr1v = 0; ayfnwr1v < i_size_bzmd6ftvmat; ayfnwr1v++) {
+ *qnwamo0e++ = 0.0e0;
+ }
+ }
+ }
+
+ if (iupper == 0) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ urohxe6t = (ayfnwr1v-1) * zyojx5hw;
+ for (yq6lorbx = 1; yq6lorbx <= *dim1m; yq6lorbx++) {
+ bpvaqm5z = tgiyxdw1[yq6lorbx-1] - 1 +
+ (dufozmt7[yq6lorbx-1] - 1) * *wy1vqfzu + urohxe6t;
+ usvdbx3tk = dufozmt7[yq6lorbx-1] - 1 +
+ (tgiyxdw1[yq6lorbx-1] - 1) * *wy1vqfzu + urohxe6t;
+ gp1jxzuh = (yq6lorbx-1) + (ayfnwr1v-1) * *dim1m;
+ bzmd6ftvmat[usvdbx3tk] =
+ bzmd6ftvmat[bpvaqm5z] = mtlgduey8[gp1jxzuh];
+ }
+ }
+ } else {
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ urohxe6t = (ayfnwr1v-1) * zyojx5hw;
+ for (yq6lorbx = 1; yq6lorbx <= *dim1m; yq6lorbx++) {
+ bpvaqm5z = tgiyxdw1[yq6lorbx-1] - 1 +
+ (dufozmt7[yq6lorbx-1] - 1) * *wy1vqfzu + urohxe6t;
+ gp1jxzuh = (ayfnwr1v-1) * *dim1m + (yq6lorbx-1);
+ bzmd6ftvmat[bpvaqm5z] = mtlgduey8[gp1jxzuh];
+ }
+ }
+ }
+}
+
+
+void fvlmz9iyC_nudh6szq(double wpuarq2m[], double tlgduey8[], double bzmd6ftvmat[],
+ int *npjlv3mr, int *f8yswcat, int *wy1vqfzu) {
+
+
+
+ int ayfnwr1v, yq6lorbx, bpvaqm5z, pqneb2ra = 1, djaq7ckz = 1, oey3ckps = 0;
+ int zyojx5hw = *wy1vqfzu * *wy1vqfzu,
+ imk5wjxg = *wy1vqfzu * (*wy1vqfzu + 1) / 2;
+ int *wkumc9idtgiyxdw1, *wkumc9iddufozmt7;
+ double q6zdcwxk;
+
+ double *wkumc9idwk12, *qnwamo0e;
+ wkumc9idwk12 = Calloc(zyojx5hw, double);
+
+ wkumc9idtgiyxdw1 = Calloc(imk5wjxg, int);
+ wkumc9iddufozmt7 = Calloc(imk5wjxg, int);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw1, wkumc9iddufozmt7, wy1vqfzu);
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ fvlmz9iyC_vm2a(wpuarq2m + (ayfnwr1v - 1) * *npjlv3mr, wkumc9idwk12, npjlv3mr, &pqneb2ra,
+ wy1vqfzu, &djaq7ckz, wkumc9idtgiyxdw1, wkumc9iddufozmt7, &oey3ckps);
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ q6zdcwxk = 0.0e0;
+ for (bpvaqm5z = yq6lorbx; bpvaqm5z <= *wy1vqfzu; bpvaqm5z++) {
+ q6zdcwxk += wkumc9idwk12[yq6lorbx-1 + (bpvaqm5z-1) * *wy1vqfzu] *
+ tlgduey8[ayfnwr1v-1 + (bpvaqm5z-1) * *f8yswcat];
+ }
+ bzmd6ftvmat[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] = q6zdcwxk;
+ }
+ }
+
+ Free(wkumc9idwk12);
+ Free(wkumc9idtgiyxdw1); Free(wkumc9iddufozmt7);
+}
+
+
+void fvlmz9iyC_vbks(double wpuarq2m[], double unvxka0m[],
+ int *wy1vqfzu, int *f8yswcat, int *npjlv3mr) {
+
+
+
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, pqneb2ra = 1, djaq7ckz = 1, oey3ckps = 0,
+ zyojx5hw = *wy1vqfzu * *wy1vqfzu,
+ imk5wjxg = *wy1vqfzu * (*wy1vqfzu + 1) / 2;
+ int *wkumc9idtgiyxdw1, *wkumc9iddufozmt7;
+ double q6zdcwxk, *qnwamo0e;
+
+ double *wkumc9idwk12;
+ wkumc9idwk12 = Calloc(zyojx5hw , double);
+
+ wkumc9idtgiyxdw1 = Calloc(imk5wjxg, int);
+ wkumc9iddufozmt7 = Calloc(imk5wjxg, int);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw1, wkumc9iddufozmt7, wy1vqfzu);
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ fvlmz9iyC_vm2a(wpuarq2m + (ayfnwr1v - 1) * *npjlv3mr, wkumc9idwk12, npjlv3mr, &pqneb2ra,
+ wy1vqfzu, &djaq7ckz, wkumc9idtgiyxdw1, wkumc9iddufozmt7, &oey3ckps);
+
+ for (yq6lorbx = *wy1vqfzu; yq6lorbx >= 1; yq6lorbx--) {
+ q6zdcwxk = unvxka0m[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu];
+ for (gp1jxzuh = yq6lorbx+1; gp1jxzuh <= *wy1vqfzu; gp1jxzuh++) {
+ q6zdcwxk -= wkumc9idwk12[yq6lorbx-1 + (gp1jxzuh-1) * *wy1vqfzu] *
+ unvxka0m[gp1jxzuh-1 + (ayfnwr1v-1) * *wy1vqfzu];
+ }
+ unvxka0m[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] =
+ q6zdcwxk / wkumc9idwk12[yq6lorbx-1 + (yq6lorbx-1) * *wy1vqfzu];
+ }
+ }
+
+ Free(wkumc9idwk12);
+ Free(wkumc9idtgiyxdw1); Free(wkumc9iddufozmt7);
+}
+
+
+void fvlmz9iyjdbomp0g(double rbne6ouj[], double unvxka0m[],
+ int *wy1vqfzu, int *dvhw1ulq, int *i_solve) {
+
+
+
+
+ double q6zdcwxk;
+ int ayfnwr1v, yq6lorbx, gp1jxzuh;
+
+ *dvhw1ulq = 1;
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *wy1vqfzu; ayfnwr1v++) {
+ q6zdcwxk = 0.0e0;
+ for (gp1jxzuh = 1; gp1jxzuh <= ayfnwr1v-1; gp1jxzuh++) {
+ q6zdcwxk += pow(rbne6ouj[gp1jxzuh-1 + (ayfnwr1v-1) * *wy1vqfzu], (double) 2.0);
+ }
+ rbne6ouj[ayfnwr1v-1 + (ayfnwr1v-1) * *wy1vqfzu] -= q6zdcwxk;
+
+ if (rbne6ouj[ayfnwr1v-1 + (ayfnwr1v-1) * *wy1vqfzu] <= 0.0e0) {
+ Rprintf("Error in fvlmz9iyjdbomp0g: not pos-def.\n");
+ *dvhw1ulq = 0;
+ return;
+ }
+ rbne6ouj[ayfnwr1v-1 + (ayfnwr1v-1) * *wy1vqfzu] =
+ sqrt(rbne6ouj[ayfnwr1v-1 + (ayfnwr1v-1) * *wy1vqfzu]);
+
+ for (yq6lorbx = ayfnwr1v+1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ q6zdcwxk = 0.0e0;
+ for (gp1jxzuh = 1; gp1jxzuh <= ayfnwr1v-1; gp1jxzuh++) {
+ q6zdcwxk += rbne6ouj[gp1jxzuh-1 + (ayfnwr1v-1) * *wy1vqfzu] *
+ rbne6ouj[gp1jxzuh-1 + (yq6lorbx-1) * *wy1vqfzu];
+ }
+ rbne6ouj[ayfnwr1v-1 + (yq6lorbx-1) * *wy1vqfzu] =
+ (rbne6ouj[ayfnwr1v-1 + (yq6lorbx-1) * *wy1vqfzu] -
+ q6zdcwxk) / rbne6ouj[ayfnwr1v-1 + (ayfnwr1v-1) * *wy1vqfzu];
+ }
+ }
+
+ if (*i_solve == 0) {
+ for (ayfnwr1v = 2; ayfnwr1v <= *wy1vqfzu; ayfnwr1v++) {
+ for (yq6lorbx = 1; yq6lorbx <= ayfnwr1v-1; yq6lorbx++) {
+ rbne6ouj[ayfnwr1v-1 + (yq6lorbx-1) * *wy1vqfzu] = 0.0e0;
+ }
+ return;
+ }
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ q6zdcwxk = unvxka0m[yq6lorbx-1];
+ for (gp1jxzuh = 1; gp1jxzuh <= yq6lorbx-1; gp1jxzuh++) {
+ q6zdcwxk -= rbne6ouj[gp1jxzuh-1 + (yq6lorbx-1) * *wy1vqfzu] * unvxka0m[gp1jxzuh-1];
+ }
+ unvxka0m[yq6lorbx-1] = q6zdcwxk / rbne6ouj[yq6lorbx-1 + (yq6lorbx-1) * *wy1vqfzu];
+ }
+
+ for(yq6lorbx = *wy1vqfzu; yq6lorbx >= 1; yq6lorbx--) {
+ q6zdcwxk = unvxka0m[yq6lorbx-1];
+ for(gp1jxzuh = yq6lorbx+1; gp1jxzuh <= *wy1vqfzu; gp1jxzuh++) {
+ q6zdcwxk -= rbne6ouj[yq6lorbx-1 + (gp1jxzuh-1) * *wy1vqfzu] * unvxka0m[gp1jxzuh-1];
+ }
+ unvxka0m[yq6lorbx-1] = q6zdcwxk / rbne6ouj[yq6lorbx-1 + (yq6lorbx-1) * *wy1vqfzu];
+ }
+}
+
+
+void fvlmz9iyC_mxrbkut0(double wpuarq2m[], double he7mqnvy[],
+ int *wy1vqfzu, int *xjc4ywlh, int *f8yswcat,
+ int *npjlv3mr, int *rutyk8mg) {
+
+
+
+
+ double q6zdcwxk;
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, bpvaqm5z;
+
+ double *wkumc9idwk12, *wkumc9idwk34, *qnwamo0e;
+ int *wkumc9idtgiyxdw1, *wkumc9iddufozmt7,
+ imk5wjxg = *wy1vqfzu * (*wy1vqfzu + 1) / 2,
+ zyojx5hw = *wy1vqfzu * *wy1vqfzu,
+ dz1lbtph = *wy1vqfzu * *xjc4ywlh;
+ wkumc9idtgiyxdw1 = Calloc(imk5wjxg, int);
+ wkumc9iddufozmt7 = Calloc(imk5wjxg, int);
+ fvlmz9iyC_qpsedg8x(wkumc9idtgiyxdw1, wkumc9iddufozmt7, wy1vqfzu);
+
+ wkumc9idwk12 = Calloc(zyojx5hw, double);
+ wkumc9idwk34 = Calloc(dz1lbtph, double);
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ for (bpvaqm5z = 1; bpvaqm5z <= *npjlv3mr; bpvaqm5z++) {
+ yq6lorbx = wkumc9idtgiyxdw1[bpvaqm5z-1] - 1 +
+ (wkumc9iddufozmt7[bpvaqm5z-1] - 1) * *wy1vqfzu;
+ wkumc9idwk12[yq6lorbx] = wpuarq2m[bpvaqm5z-1 + (ayfnwr1v-1) * *npjlv3mr];
+ }
+
+ for (gp1jxzuh = 1; gp1jxzuh <= *xjc4ywlh; gp1jxzuh++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ wkumc9idwk34[yq6lorbx-1 + (gp1jxzuh-1) * *wy1vqfzu] =
+ he7mqnvy[(ayfnwr1v-1) * *wy1vqfzu + yq6lorbx-1 + (gp1jxzuh-1) * *rutyk8mg];
+ }
+ }
+
+ for (gp1jxzuh = 1; gp1jxzuh <= *xjc4ywlh; gp1jxzuh++) {
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ q6zdcwxk = 0.0e0;
+ for (bpvaqm5z = yq6lorbx; bpvaqm5z <= *wy1vqfzu; bpvaqm5z++) {
+ q6zdcwxk += wkumc9idwk12[yq6lorbx-1 + (bpvaqm5z-1) * *wy1vqfzu] *
+ wkumc9idwk34[bpvaqm5z-1 + (gp1jxzuh-1) * *wy1vqfzu];
+ }
+ he7mqnvy[(ayfnwr1v-1) * *wy1vqfzu + yq6lorbx-1 + (gp1jxzuh-1) * *rutyk8mg] = q6zdcwxk;
+ }
+ }
+ }
+
+ Free(wkumc9idwk12);
+ Free(wkumc9idwk34);
+ Free(wkumc9idtgiyxdw1); Free(wkumc9iddufozmt7);
+}
+
+
+void fvlmz9iyC_lkhnw9yq(double wpuarq2m[], double ks3wejcv[],
+ int *npjlv3mr, int *wy1vqfzu, int *dvhw1ulq) {
+
+
+
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh, uaoynef0,
+ zyojx5hw = *wy1vqfzu * *wy1vqfzu;
+ double q6zdcwxk, *qnwamo0e, vn3iasxugno = 1.0e-14;
+ double *wkumc9idwrk;
+ wkumc9idwrk = Calloc(zyojx5hw, double);
+
+ *dvhw1ulq = 1;
+
+ for (ayfnwr1v = 1; ayfnwr1v <= *wy1vqfzu; ayfnwr1v++) {
+ for (yq6lorbx = ayfnwr1v; yq6lorbx >= 1; yq6lorbx--) {
+ q6zdcwxk = (yq6lorbx == ayfnwr1v) ? 1.0e0 : 0.0e0;
+ for (gp1jxzuh = yq6lorbx+1; gp1jxzuh <= ayfnwr1v; gp1jxzuh++) {
+ q6zdcwxk -= wpuarq2m[yq6lorbx-1 + (gp1jxzuh-1) * *npjlv3mr] *
+ wkumc9idwrk[gp1jxzuh-1 + (ayfnwr1v-1) * *wy1vqfzu];
+ }
+ if (fabs(wpuarq2m[yq6lorbx-1 + (yq6lorbx-1) * *npjlv3mr]) < vn3iasxugno) {
+ Rprintf("Error in fvlmz9iyC_lkhnw9yq: U(cz8qdfyj,cz8qdfyj) is zero.\n");
+ *dvhw1ulq = 0;
+ } else {
+ wkumc9idwrk[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] =
+ q6zdcwxk / wpuarq2m[yq6lorbx-1 + (yq6lorbx-1) * *npjlv3mr];
+ }
+ }
+ }
+
+ for (yq6lorbx = 1; yq6lorbx <= *wy1vqfzu; yq6lorbx++) {
+ for (ayfnwr1v = yq6lorbx; ayfnwr1v <= *wy1vqfzu; ayfnwr1v++) {
+ uaoynef0 = (yq6lorbx < ayfnwr1v) ? ayfnwr1v : yq6lorbx;
+ q6zdcwxk = 0.0e0;
+ for(gp1jxzuh = uaoynef0; gp1jxzuh <= *wy1vqfzu; gp1jxzuh++) {
+ q6zdcwxk += wkumc9idwrk[yq6lorbx-1 + (gp1jxzuh-1) * *wy1vqfzu] *
+ wkumc9idwrk[ayfnwr1v-1 + (gp1jxzuh-1) * *wy1vqfzu];
+ }
+ ks3wejcv[yq6lorbx-1 + (ayfnwr1v-1) * *wy1vqfzu] =
+ ks3wejcv[ayfnwr1v-1 + (yq6lorbx-1) * *wy1vqfzu] = q6zdcwxk;
+ }
+ }
+ Free(wkumc9idwrk);
+}
+
+
+double fvlmz9iyC_tldz5ion(double xval) {
+
+ double hofjnx2e, xd4mybgj[6], q6zdcwxk = 1.000000000190015, tmp_y = xval;
+ int yq6lorbx;
+
+ xd4mybgj[0]= 76.18009172947146e0;
+ xd4mybgj[1]= -86.50532032941677e0;
+ xd4mybgj[2]= 24.01409824083091e0;
+ xd4mybgj[3]= -1.231739572450155e0;
+ xd4mybgj[4]= 0.1208650973866179e-2;
+ xd4mybgj[5]= -0.5395239384953e-5;
+ hofjnx2e = xval + 5.50;
+ hofjnx2e -= (xval + 0.50) * log(hofjnx2e);
+ for (yq6lorbx = 0; yq6lorbx < 6; yq6lorbx++) {
+ tmp_y += 1.0e0;
+ q6zdcwxk += xd4mybgj[yq6lorbx] / tmp_y;
+ }
+ return -hofjnx2e + log(2.5066282746310005e0 * q6zdcwxk / xval);
+}
+
+
+void fvlmz9iyC_enbin9(double bzmd6ftvmat[], double hdqsx7bk[], double nm0eljqk[],
+ double *n2kersmx, int *f8yswcat, int *dvhw1ulq, int *zy1mchbf,
+ double *ux3nadiw, double *rsynp1go, int *sguwj9ty) {
+
+
+
+
+
+
+ int ayfnwr1v, kij0gwer, esql7umk;
+ double vjz5sxty, pvcjl2na, mwuvskg1, btiehdm2 = 100.0e0 * *rsynp1go,
+ ydb, ft3ijqmy, bk3ymcih, q6zdcwxk, plo6hkdr, csi9ydge, oxjgzv0e = 0.001e0;
+
+ if (*n2kersmx <= 0.80e0 || *n2kersmx >= 1.0e0) {
+ Rprintf("Error in fvlmz9iyC_enbin9: bad n2kersmx value.\n");
+ *dvhw1ulq = 0;
+ return;
+ }
+
+ *dvhw1ulq = 1;
+ for (kij0gwer = 1; kij0gwer <= *zy1mchbf; kij0gwer++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+ vjz5sxty = nm0eljqk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]
+ / hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat];
+
+ if ((vjz5sxty < oxjgzv0e) ||
+ ( nm0eljqk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] > 1.0e5)) {
+ bzmd6ftvmat[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] =
+ -nm0eljqk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] * (1.0e0 +
+ hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]
+ / (hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] +
+ nm0eljqk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]))
+ / pow(hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat], (double) 2.0);
+ if (bzmd6ftvmat[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] > -btiehdm2)
+ bzmd6ftvmat[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] = -btiehdm2;
+ goto ceqzd1hi20;
+ }
+
+ q6zdcwxk = 0.0e0;
+ pvcjl2na = hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]
+ / (hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] +
+ nm0eljqk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]);
+ mwuvskg1 = 1.0e0 - pvcjl2na;
+ csi9ydge = hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat];
+ if (pvcjl2na < btiehdm2)
+ pvcjl2na = btiehdm2;
+ if (mwuvskg1 < btiehdm2)
+ mwuvskg1 = btiehdm2;
+ esql7umk = 100 + 15 * floor(nm0eljqk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]);
+ if (esql7umk < *sguwj9ty) {
+ esql7umk = *sguwj9ty;
+ }
+
+ ft3ijqmy = pow(pvcjl2na, csi9ydge);
+ *ux3nadiw = ft3ijqmy;
+ plo6hkdr = (1.0e0 - *ux3nadiw) / pow(hdqsx7bk[ayfnwr1v-1 +
+ (kij0gwer-1) * *f8yswcat], (double) 2.0);
+ q6zdcwxk += plo6hkdr;
+
+ ydb = 1.0e0;
+ ft3ijqmy = hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] * mwuvskg1 * ft3ijqmy;
+ *ux3nadiw += ft3ijqmy;
+ plo6hkdr = (1.0e0 - *ux3nadiw) / pow((hdqsx7bk[ayfnwr1v-1 +
+ (kij0gwer-1) * *f8yswcat] + ydb), (double) 2.0);
+ q6zdcwxk += plo6hkdr;
+
+ ydb = 2.0e0;
+ while (((*ux3nadiw <= *n2kersmx) || (plo6hkdr > 1.0e-4))
+ && (ydb < esql7umk)) {
+ ft3ijqmy = (hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] - 1.0 + ydb) *
+ mwuvskg1 * ft3ijqmy / ydb;
+ *ux3nadiw += ft3ijqmy;
+ plo6hkdr = (1.0e0 - *ux3nadiw) / pow((hdqsx7bk[ayfnwr1v-1 +
+ (kij0gwer-1) * *f8yswcat] + ydb), (double) 2.0);
+ q6zdcwxk += plo6hkdr;
+ ydb += 1.0e0;
+ }
+ bzmd6ftvmat[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] = -q6zdcwxk;
+
+ ceqzd1hi20: bk3ymcih = 0.0e0;
+ }
+ }
+}
+
+
+
+void fvlmz9iyC_enbin8(double bzmd6ftvmat[], double hdqsx7bk[], double hsj9bzaq[],
+ double *n2kersmx, int *f8yswcat, int *dvhw1ulq, int *zy1mchbf,
+ double *ux3nadiw, double *rsynp1go) {
+
+
+
+
+ int ayfnwr1v, kij0gwer, esql7umk = 3000;
+ double ft3ijqmy, tad5vhsu, o3jyipdf, pq0hfucn, q6zdcwxk,
+ plo6hkdr, qtce8hzo1 = 0.0e0, qtce8hzo2 = 0.0e0,
+ hnu1vjyw = 1.0e0 - *rsynp1go;
+ int fw2rodat, rx8qfndg, mqudbv4y;
+ double onemse, nm0eljqk, ydb, btiehdm2 = -100.0 * *rsynp1go,
+ kbig = 1.0e4, oxjgzv0e = 0.0010;
+
+ Rprintf("zz 20100122; this function fvlmz9iyC_enbin8 unchecked.\n");
+ if (*n2kersmx <= 0.80e0 || *n2kersmx >= 1.0e0) {
+ Rprintf("returning since n2kersmx <= 0.8 or >= 1\n");
+ *dvhw1ulq = 0;
+ return;
+ }
+
+ onemse = 1.0e0 / (1.0e0 + oxjgzv0e);
+ *dvhw1ulq = 1;
+
+ for (kij0gwer = 1; kij0gwer <= *zy1mchbf; kij0gwer++) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *f8yswcat; ayfnwr1v++) {
+
+ if ( hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] > kbig)
+ hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] = kbig;
+ if (hsj9bzaq[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] < oxjgzv0e)
+ hsj9bzaq[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] = oxjgzv0e;
+
+ if (hsj9bzaq[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] > onemse) {
+ nm0eljqk = hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] *
+ (1.0e0 / hsj9bzaq[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] - 1.0e0);
+ bzmd6ftvmat[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] = -nm0eljqk * (1.0e0 +
+ hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] /
+ (hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] + nm0eljqk))
+ / pow(hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat], (double) 2.0);
+ if (bzmd6ftvmat[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] > btiehdm2)
+ bzmd6ftvmat[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] = btiehdm2;
+ goto ceqzd1hi20;
+ }
+
+ q6zdcwxk = 0.0e0;
+ fw2rodat = 1;
+ rx8qfndg = hsj9bzaq[ayfnwr1v-1 + (kij0gwer-1)**f8yswcat] < (1.0 - *rsynp1go)
+ ? 1 : 0;
+ mqudbv4y = fw2rodat && rx8qfndg ? 1 : 0;
+
+ if (mqudbv4y) {
+ qtce8hzo2 = hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] *
+ log(hsj9bzaq[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]);
+ *ux3nadiw = exp(qtce8hzo2);
+ } else {
+ *ux3nadiw = 0.0e0;
+ }
+ plo6hkdr = (1.0e0 - *ux3nadiw) / pow(hdqsx7bk[ayfnwr1v-1 +
+ (kij0gwer-1) * *f8yswcat], (double) 2.0);
+ q6zdcwxk += plo6hkdr;
+ o3jyipdf = fvlmz9iyC_tldz5ion(hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]);
+
+ ydb = 1.0e0;
+ tad5vhsu = fvlmz9iyC_tldz5ion(ydb + hdqsx7bk[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]);
+ pq0hfucn = 0.0e0;
+ if (mqudbv4y) {
+ qtce8hzo1 = log(1.0e0 - hsj9bzaq[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat]);
+ ft3ijqmy = exp(ydb * qtce8hzo1 + qtce8hzo2 + tad5vhsu - o3jyipdf - pq0hfucn);
+ } else {
+ ft3ijqmy = 0.0e0;
+ }
+ *ux3nadiw += ft3ijqmy;
+ plo6hkdr = (1.0e0 - *ux3nadiw) / pow(hdqsx7bk[ayfnwr1v-1 +
+ (kij0gwer-1) * *f8yswcat] + ydb, (double) 2.0);
+ q6zdcwxk += plo6hkdr;
+
+ ydb = 2.0e0;
+ while((*ux3nadiw <= *n2kersmx) || (plo6hkdr > 1.0e-4)) {
+
+ tad5vhsu += log(ydb + hdqsx7bk[ayfnwr1v-1+(kij0gwer-1) * *f8yswcat] - 1.0);
+ pq0hfucn += log(ydb);
+ if (mqudbv4y) {
+ ft3ijqmy = exp(ydb * qtce8hzo1 + qtce8hzo2 + tad5vhsu - o3jyipdf - pq0hfucn);
+ } else {
+ ft3ijqmy = 0.0e0;
+ }
+ *ux3nadiw += ft3ijqmy;
+ plo6hkdr = (1.0e0 - *ux3nadiw) / pow(hdqsx7bk[ayfnwr1v-1 +
+ (kij0gwer-1) * *f8yswcat] + ydb, (double) 2.0);
+ q6zdcwxk += plo6hkdr;
+ ydb += 1.0e0;
+
+ if (ydb > 1.0e3) goto ceqzd1hi21;
+ }
+
+ ceqzd1hi21: bzmd6ftvmat[ayfnwr1v-1 + (kij0gwer-1) * *f8yswcat] = -q6zdcwxk;
+
+ ceqzd1hi20: tad5vhsu = 0.0e0;
+ }
+ }
+
+}
+
+
+
+
+
+void fvlmz9iyC_mbessI0(double unvxka0m[], int *f8yswcat, int *kpzavbj3,
+ double dvector0[], double dvector1[], double dvector2[],
+ int *zjkrtol8, double *qaltf0nz) {
+
+
+
+
+
+ int ayfnwr1v, gp1jxzuh, c5aesxkus;
+ double f0, t0, m0, f1, t1, m1, f2, t2, m2, Toobig = 20.0e0;
+
+ Rprintf("zz 20100122; this function fvlmz9iyC_mbessI0 unchecked.\n");
+ *zjkrtol8 = 0;
+ if (!(*kpzavbj3 == 0 || *kpzavbj3 == 1 || *kpzavbj3 == 2)) {
+ Rprintf("Error in fvlmz9iyC_mbessI0: kpzavbj3 not in 0:2. Returning.\n");
+ *zjkrtol8 = 1;
+ return;
+ }
+
+ for (gp1jxzuh = 1; gp1jxzuh <= *f8yswcat; gp1jxzuh++) {
+ if (fabs(unvxka0m[gp1jxzuh-1]) > Toobig) {
+ Rprintf("Error in fvlmz9iyC_mbessI0: unvxka0m[] value > too big.\n");
+ *zjkrtol8 = 1;
+ return;
+ }
+ t1 = unvxka0m[gp1jxzuh-1] / 2.0e0;
+ f1 = t1;
+ t0 = t1 * t1;
+ f0 = 1.0e0 + t0;
+ t2 = 0.50e0;
+ f2 = t2;
+ c5aesxkus = 15;
+ if (fabs(unvxka0m[gp1jxzuh-1]) > 10.0) c5aesxkus = 25;
+ if (fabs(unvxka0m[gp1jxzuh-1]) > 15.0) c5aesxkus = 35;
+ if (fabs(unvxka0m[gp1jxzuh-1]) > 20.0) c5aesxkus = 40;
+ if (fabs(unvxka0m[gp1jxzuh-1]) > 30.0) c5aesxkus = 55;
+
+ for (ayfnwr1v = 1; ayfnwr1v <= c5aesxkus; ayfnwr1v++) {
+ m0 = pow(unvxka0m[gp1jxzuh-1] / (2.0 * (ayfnwr1v + 1.0)), (double) 2);
+ m1 = m0 * (1.0e0 + 1.0e0 / ayfnwr1v);
+ m2 = m1 * (2.0e0 * ayfnwr1v + 1.0e0) / (2.0e0 * ayfnwr1v - 1.0e0);
+ t0 = t0 * m0;
+ t1 = t1 * m1;
+ t2 = t2 * m2;
+ f0 = f0 + t0;
+ f1 = f1 + t1;
+ f2 = f2 + t2;
+ if ((fabs(t0) < *qaltf0nz) &&
+ (fabs(t1) < *qaltf0nz) &&
+ (fabs(t2) < *qaltf0nz))
+ break;
+ }
+ if (0 <= *kpzavbj3) dvector0[gp1jxzuh-1] = f0;
+ if (1 <= *kpzavbj3) dvector1[gp1jxzuh-1] = f1;
+ if (2 <= *kpzavbj3) dvector2[gp1jxzuh-1] = f2;
+ }
+
+}
+
+
+void VGAM_C_mux34(double he7mqnvy[], double Dmat[], int *vnc1izfy, int *e0nmabdk,
+ int *ui4ntmvd, double bqelz3cy[]) {
+
+
+
+
+ int ayfnwr1v, yq6lorbx, gp1jxzuh;
+ double *qnwamo0e1, *qnwamo0e2, *qnwamo0e3;
+
+ if (*e0nmabdk == 1) {
+ qnwamo0e1 = bqelz3cy; qnwamo0e2 = he7mqnvy;
+ for (ayfnwr1v = 0; ayfnwr1v < *vnc1izfy; ayfnwr1v++) {
+ *qnwamo0e1++ = *Dmat * pow(*qnwamo0e2++, (double) 2.0);
+ }
+ return;
+ }
+
+ if (*ui4ntmvd == 1) {
+ for (ayfnwr1v = 1; ayfnwr1v <= *vnc1izfy; ayfnwr1v++) {
+ bqelz3cy[ayfnwr1v-1] = 0.0e0;
+ for (yq6lorbx = 1; yq6lorbx <= *e0nmabdk; yq6lorbx++) {
+ bqelz3cy[ayfnwr1v-1] += Dmat[yq6lorbx-1 + (yq6lorbx-1) * *e0nmabdk] *
+ pow(he7mqnvy[ayfnwr1v-1 + (yq6lorbx-1) * *vnc1izfy],
+ (double) 2.0);
+ }
+ if (*e0nmabdk > 1) {
+ for (yq6lorbx = 1; yq6lorbx <= *e0nmabdk; yq6lorbx++) {
+ for (gp1jxzuh = yq6lorbx+1; gp1jxzuh <= *e0nmabdk; gp1jxzuh++) {
+ bqelz3cy[ayfnwr1v-1] += Dmat[yq6lorbx-1 + (gp1jxzuh-1) * *e0nmabdk] *
+ he7mqnvy[ayfnwr1v-1 + (yq6lorbx-1) * *vnc1izfy] *
+ he7mqnvy[ayfnwr1v-1 + (gp1jxzuh-1) * *vnc1izfy] *
+ 2.0;
+ }
+ }
+ }
+ }
+ } else {
+ for (ayfnwr1v = 1; ayfnwr1v <= *vnc1izfy; ayfnwr1v++) {
+ bqelz3cy[ayfnwr1v-1] = 0.0e0;
+ for (yq6lorbx = 1; yq6lorbx <= *e0nmabdk; yq6lorbx++) {
+ for (gp1jxzuh = 1; gp1jxzuh <= *e0nmabdk; gp1jxzuh++) {
+ bqelz3cy[ayfnwr1v-1] += Dmat[yq6lorbx-1 + (gp1jxzuh-1) * *e0nmabdk] *
+ he7mqnvy[ayfnwr1v-1 + (yq6lorbx-1) * *vnc1izfy] *
+ he7mqnvy[ayfnwr1v-1 + (gp1jxzuh-1) * *vnc1izfy];
+ }
+ }
+ }
+ }
+}
+
+
diff --git a/src/zeta3.c b/src/zeta3.c
new file mode 100644
index 0000000..285ea64
--- /dev/null
+++ b/src/zeta3.c
@@ -0,0 +1,188 @@
+
+
+#include <math.h>
+#include <Rmath.h>
+#include <R.h>
+
+void vzetawr(double sjwyig9t[], double *bqelz3cy, int *kpzavbj3, int *f8yswcat);
+double fvlmz9iyzeta8(double , double kxae8glp[]);
+double fvlmz9iydzeta8(double , double kxae8glp[]);
+double fvlmz9iyddzeta8(double , double kxae8glp[]);
+void vbecoef(double kxae8glp[]);
+
+
+void vzetawr(double sjwyig9t[], double *bqelz3cy, int *kpzavbj3, int *f8yswcat) {
+
+
+
+ int ayfnwr1v;
+ double *qnwamo0e1, *qnwamo0e2;
+
+ double kxae8glp[12];
+
+ vbecoef(kxae8glp);
+
+ qnwamo0e1 = bqelz3cy;
+ qnwamo0e2 = sjwyig9t;
+ if (*kpzavbj3 == 0) {
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ *qnwamo0e1++ = fvlmz9iyzeta8(*qnwamo0e2++, kxae8glp);
+ }
+ } else
+ if (*kpzavbj3 == 1) {
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ *qnwamo0e1++ = fvlmz9iydzeta8(*qnwamo0e2++, kxae8glp);
+ }
+ } else
+ if (*kpzavbj3 == 2) {
+ for (ayfnwr1v = 0; ayfnwr1v < *f8yswcat; ayfnwr1v++) {
+ *qnwamo0e1++ = fvlmz9iyddzeta8(*qnwamo0e2++, kxae8glp);
+ }
+ } else {
+ Rprintf("Error: *kpzavbj3 must equal 0, 1 or 2 in C function vzetawr\n");
+ }
+}
+
+
+
+double fvlmz9iyzeta8(double ghz9vuba, double kxae8glp[]) {
+
+
+
+ int ayfnwr1v, gp1jxzuh, uw3favmo, nsvdbx3tk, m2svdbx3tk;
+ double q6zdcwxk, xvr7bonh, a2svdbx3tk, fred;
+
+ ayfnwr1v = 12;
+ gp1jxzuh = 8;
+
+ a2svdbx3tk = pow((double) ayfnwr1v, (double) 2.0);
+ xvr7bonh = ghz9vuba / 2.000 / a2svdbx3tk;
+ q6zdcwxk = 1.000 / (ghz9vuba - 1.000) + 0.500 / ayfnwr1v + kxae8glp[0] * xvr7bonh;
+
+ for (uw3favmo = 2; uw3favmo <= gp1jxzuh; uw3favmo++) {
+ m2svdbx3tk = uw3favmo + uw3favmo;
+ xvr7bonh *= (ghz9vuba + m2svdbx3tk - 3.000) *
+ (ghz9vuba + m2svdbx3tk - 2.000) / (m2svdbx3tk -
+ 1.000) / m2svdbx3tk / a2svdbx3tk;
+ q6zdcwxk += xvr7bonh * kxae8glp[uw3favmo-1];
+ }
+ fred = pow((double) ayfnwr1v, (double) 1.0 - ghz9vuba);
+ q6zdcwxk = 1.000 + q6zdcwxk * fred;
+
+ for (nsvdbx3tk = 2; nsvdbx3tk < ayfnwr1v; nsvdbx3tk++) {
+ q6zdcwxk += pow((double) nsvdbx3tk, (double) -ghz9vuba);
+ }
+
+ return q6zdcwxk;
+}
+
+
+
+double fvlmz9iydzeta8(double ghz9vuba, double kxae8glp[]) {
+
+
+ int ayfnwr1v, gp1jxzuh, uw3favmo, nsvdbx3tk, m2svdbx3tk;
+ double q6zdcwxk, xvr7bonh, dh9mgvze, a2svdbx3tk, ugqvjoe5a, ugqvjoe5n, fred;
+
+ ayfnwr1v = 12;
+ gp1jxzuh = 8;
+
+ ugqvjoe5a = log( (double) ayfnwr1v );
+ a2svdbx3tk = ayfnwr1v * ayfnwr1v;
+ xvr7bonh = ghz9vuba / 2.000 / a2svdbx3tk;
+ dh9mgvze = 1.000 / ghz9vuba - ugqvjoe5a;
+ q6zdcwxk = kxae8glp[0] * xvr7bonh * dh9mgvze;
+
+ for (uw3favmo = 2; uw3favmo <= gp1jxzuh; uw3favmo++) {
+ m2svdbx3tk = uw3favmo + uw3favmo;
+ xvr7bonh *= (ghz9vuba + m2svdbx3tk - 3.0) *
+ (ghz9vuba + m2svdbx3tk - 2.0) / (m2svdbx3tk - 1.0) / m2svdbx3tk / a2svdbx3tk;
+ dh9mgvze += 1.0 / (ghz9vuba + m2svdbx3tk - 3.0) + 1.0 / (ghz9vuba + m2svdbx3tk - 2.0);
+ q6zdcwxk += kxae8glp[uw3favmo-1] * xvr7bonh * dh9mgvze;
+ }
+ fred = pow((double) ayfnwr1v, (double) 1.0 - ghz9vuba);
+ q6zdcwxk = (q6zdcwxk - 1.000 / pow(ghz9vuba - 1.000, (double) 2.0) -
+ ugqvjoe5a * (1.000 / (ghz9vuba - 1.000) + 0.5000 / ayfnwr1v)) * fred;
+
+ for (nsvdbx3tk = 2; nsvdbx3tk < ayfnwr1v; nsvdbx3tk++) {
+ ugqvjoe5n = log( (double) nsvdbx3tk );
+ q6zdcwxk -= ugqvjoe5n / exp(ugqvjoe5n * ghz9vuba);
+ }
+
+ return q6zdcwxk;
+}
+
+
+
+
+
+
+
+
+double fvlmz9iyddzeta8(double ghz9vuba, double kxae8glp[]) {
+
+
+ int ayfnwr1v, gp1jxzuh, uw3favmo, nsvdbx3tk, m2svdbx3tk;
+ double q6zdcwxk, xvr7bonh, dh9mgvze, hpmwnav2, a2svdbx3tk, ugqvjoe5a, ugqvjoe5n, fred, fred2;
+
+ ayfnwr1v = 12;
+ gp1jxzuh = 8;
+
+ ugqvjoe5a = log( (double) ayfnwr1v );
+ a2svdbx3tk = ayfnwr1v * ayfnwr1v;
+ xvr7bonh = ghz9vuba / 2.000 / a2svdbx3tk;
+ dh9mgvze = 1.000 / ghz9vuba - ugqvjoe5a;
+ hpmwnav2 = 1.000 / ghz9vuba / ghz9vuba;
+ q6zdcwxk = kxae8glp[0] * xvr7bonh * (pow(dh9mgvze, (double) 2.0) - hpmwnav2);
+
+ for (uw3favmo = 2; uw3favmo < gp1jxzuh; uw3favmo++) {
+ m2svdbx3tk = uw3favmo + uw3favmo;
+ xvr7bonh *= (ghz9vuba + m2svdbx3tk - 3.000) *
+ (ghz9vuba + m2svdbx3tk - 2.000) / (m2svdbx3tk -
+ 1.0) / m2svdbx3tk / a2svdbx3tk;
+ dh9mgvze += 1.000 / (ghz9vuba + m2svdbx3tk - 3.000) +
+ 1.000 / (ghz9vuba + m2svdbx3tk - 2.000);
+ hpmwnav2 += 1.000 / pow(ghz9vuba + m2svdbx3tk - 3.000, (double) 2.0) +
+ 1.000 / pow(ghz9vuba + m2svdbx3tk - 2.000, (double) 2.0);
+ q6zdcwxk += kxae8glp[uw3favmo-1] * xvr7bonh * (dh9mgvze * dh9mgvze - hpmwnav2);
+ }
+ fred = pow((double) ayfnwr1v, (double) 1.0 - ghz9vuba);
+ fred2 = pow(ugqvjoe5a, (double) 2.0) * (1.0 / (ghz9vuba - 1.0) + 0.50 / ayfnwr1v);
+ q6zdcwxk = (q6zdcwxk + 2.0 / pow(ghz9vuba - 1.0, (double) 3.0) +
+ 2.0 * ugqvjoe5a / pow(ghz9vuba - 1.0, (double) 2.0) + fred2) * fred;
+
+ for (nsvdbx3tk = 2; nsvdbx3tk < ayfnwr1v; nsvdbx3tk++) {
+ ugqvjoe5n = log( (double) nsvdbx3tk );
+ q6zdcwxk += pow(ugqvjoe5n, (double) 2.0) / exp(ugqvjoe5n * ghz9vuba);
+ }
+
+ return q6zdcwxk;
+}
+
+
+
+
+
+
+
+
+
+void vbecoef(double kxae8glp[]) {
+
+
+
+ kxae8glp[0] = 1.000 / 6.000;
+ kxae8glp[1] = -1.000 / 30.000;
+ kxae8glp[2] = 1.000 / 42.000;
+ kxae8glp[3] = -1.000 / 30.000;
+ kxae8glp[4] = 5.000 / 66.000;
+ kxae8glp[5] = -691.000 / 2730.000;
+ kxae8glp[6] = 7.000 / 6.000;
+ kxae8glp[7] = -3617.000 / 510.000;
+ kxae8glp[8] = 4386.700 / 79.800;
+ kxae8glp[9] = -1746.1100 / 3.3000;
+ kxae8glp[10] = 8545.1300 / 1.3800;
+ kxae8glp[11] = -2363.6409100 / 0.0273000;
+}
+
+
diff --git a/src/zeta4.c b/src/zeta4.c
deleted file mode 100644
index a944a6f..0000000
--- a/src/zeta4.c
+++ /dev/null
@@ -1,258 +0,0 @@
-/* 20091207 Thomas W Yee */
-/* This is my attempt to convert zeta.pas into zeta.r */
-/* It seems that zeta.pas implements 2 algorithms; Ive chosen */
-/* the latest algorithm. */
-/* */
-/* 20020802; Ive added a "8" to the function names: just in case */
-/* */
-/* Adapted from zeta.c */
-/* Adapted from Garry Tees Pascal program Gram: # 1999-8-11 */
-/* It all works, since Ive compared the results to Garrys for */
-/* s=1.1,...,4.9 */
-/* */
-/* Evaluate zeta(s) by Grams method, 1903 */
-/* */
-/* gn = 20; # Stieltjes coefficients gg(0..gn) of length(gn+1) */
-/* # Stieltjes for zeta(s) O.K. for s<4 */
-/* */
-/* Note: */
-/* Subroutine vstcoef(gg) */
-/* Subroutine vzsdzs(s, zs, dzs, gg) */
-/* commented out (not needed) */
-
-/* ------------------------------------------------------------------------ */
-
-#include <math.h>
-#include <Rmath.h>
-#include <R.h>
-
-/* Function prototype */
-void aaaa_vzetawr(double x[], double *ans, long *deriv, long *nn);
-double aaaa_zeta8(double s, double B2[]);
-double aaaa_dzeta8(double s, double B2[]);
-double Upsilon8(double s, double B2[]);
-double aaaa_ddzeta8(double s, double B2[]);
-double duds(double s, double B2[]);
-void vbecoef(double B2[]);
-
-/* ------------------------------------------------------------------------ */
-
-void aaaa_vzetawr(double x[], double *ans, long *deriv, long *nn) {
-
-/* Wrapper function for the zeta function and first 2 derivs */
-
-/* double precision x(nn), ans(nn), */
-/* double x[nn-1], ans[nn-1] */
-
- int ilocal;
-
-/* Bernoulli numbers B(2k) */
- double B2[12];
-
- vbecoef(B2);
-
-/* Generate the Bernoulli coefficients into B2 */
-
- if (*deriv == 0) {
- for (ilocal = 0; ilocal < *nn; ilocal++) {
- ans[ilocal] = aaaa_zeta8(x[ilocal], B2);
- }
- }
- else if (*deriv == 1) {
- for (ilocal = 0; ilocal < *nn; ilocal++) {
- ans[ilocal] = aaaa_dzeta8(x[ilocal], B2);
- }
- }
- else if (*deriv == 2) {
- for (ilocal = 0; ilocal < *nn; ilocal++) {
- ans[ilocal] = aaaa_ddzeta8(x[ilocal], B2);
- }
- }
- else {
- Rprintf("Error: *deriv must equal 0, 1 or 2\n");
- }
-
-}
-
-/* ------------------------------------------------------------------------ */
-
-double aaaa_zeta8(double s, double B2[]) {
-
-/* Grams method for zeta(s), s>0,s<>1 */
-/* cf Bengt Markman, BIT 5 (1965), 138-141 */
-
-/* Bernoulli numbers B(2k) assumed set */
-
- int alocal, klocal;
-
-/* Local var */
- int mlocal, nlocal, m2local;
- double sum, plocal, a2local, fred;
-
- alocal = 12;
-/* For 62 significant binary digits in zeta(s) */
- klocal = 8;
-
- a2local = pow(alocal, 2.0);
- plocal = s / 2.000 / a2local;
- sum = 1.000 / (s - 1.000) + 0.500 / alocal + B2[0] * plocal;
-
- for (mlocal = 2; mlocal <= klocal; mlocal++){
- m2local = mlocal + mlocal;
- plocal *= (s + m2local - 3.000) *
- (s + m2local - 2.000) / (m2local - 1.000) / m2local / a2local;
- sum += plocal * B2[mlocal-1];
- }
- fred = exp((s - 1.000) * log( (double) alocal));
- sum = 1.000 + sum / fred;
-
- for (nlocal = 2; nlocal < alocal; nlocal++){
-/* nlocal ** (-s) # power(nlocal, -s) */
- sum += exp(-s * log( (double) nlocal ));
- }
-
- return sum;
-}
-
-/* ------------------------------------------------------------------------ */
-
-double aaaa_dzeta8(double s, double B2[]) {
-
-/* Grams method for d zeta(s)/ds, s>0,s<>1 */
-/* cf Bengt Markman, BIT 5 (1965), 138-141 */
-
-/* Local var */
- int alocal, klocal;
- int mlocal, nlocal, m2local;
- double sum, plocal, qlocal, a2local, loga, logn;
- double fred;
-
- alocal = 12;
-/* For 62 significant binary digits in zeta8(s) */
- klocal = 8;
-
- loga = log( (double) alocal );
- a2local = alocal * alocal;
- plocal = s / 2.000 / a2local;
- qlocal = 1.000 / s - loga;
- sum = B2[0] * plocal * qlocal;
-
- for (mlocal = 2; mlocal <= klocal; mlocal++){
- m2local = mlocal + mlocal;
- plocal *= (s + m2local - 3.000) *
- (s + m2local - 2.000) / (m2local - 1.000) / m2local / a2local;
- qlocal += 1.000 / (s + m2local - 3.000) + 1.000 / (s + m2local - 2.000);
- sum += B2[mlocal-1] * plocal * qlocal;
- }
- fred = exp((1.000 - s) * loga);
-/* nb. sqr in pascal is square, not square root */
- sum = (sum - 1.000/ pow((s - 1.000), 2.0) - loga * (1.000/(s - 1.000) +
- 0.5000/alocal)) * fred;
-
- for (nlocal = 2; nlocal < alocal; nlocal++){
- logn = log( (double) nlocal );
- sum -= logn / exp(logn * s);
- }
-
- return sum;
-}
-
-/* ------------------------------------------------------------------------ */
-
-double Upsilon8(double s, double B2[]) {
-/* double precision dzeta8, zeta8; */
- double Upsilon8;
-
- Upsilon8 = -aaaa_dzeta8(s, B2) / aaaa_zeta8(s, B2);
-
- return Upsilon8;
-}
-
-/* ------------------------------------------------------------------------ */
-
-double aaaa_ddzeta8(double s, double B2[]) {
-
-/* Grams method for zeta"(s), s>0,s<>1 */
-/* cf Bengt Markman, BIT 5 (1965), 138-141 */
-
-
-/* Local var */
- int alocal, klocal;
- int mlocal, nlocal, m2local;
- double sum, plocal, qlocal, rlocal, a2local, loga, logn;
- double fred, fred2;
-
- alocal = 12;
-/* For 62 significant binary digits in zeta8(s) */
- klocal = 8;
-
- loga = log( (double) alocal );
- a2local = alocal * alocal;
- plocal = s / 2.000 / a2local;
- qlocal = 1.000 / s - loga;
- rlocal = 1.000 / s / s;
- sum = B2[0] * plocal * (pow(qlocal, 2.0) - rlocal);
-
- for (mlocal = 2; mlocal < klocal; mlocal++){
- m2local = mlocal + mlocal;
- plocal *= (s + m2local - 3.000) *
- (s + m2local - 2.000) / (m2local - 1.000) / m2local / a2local;
-/* plocal = s(s+1)...(s+2mlocal-2)/(2mlocal)!/a^(2mlocal) */
- qlocal += 1.000 / (s + m2local - 3.000) +
- 1.000 / (s + m2local - 2.000);
-/* qlocal = 1/s + 1/(s+1) + ... + 1/(s+2mlocal-2) - log alocal */
- rlocal += 1.000 / pow((s + m2local - 3.000), 2.0) +
- 1.000 / pow((s + m2local - 2.000), 2.0);
-/* rlocal = -dq/ds = 1/s^2 + 1/(s+1)^2 + ... + 1/(s+2mlocal-2)^2 */
- sum += B2[mlocal-1] * plocal * (qlocal * qlocal - rlocal);
- }
- fred = exp((1.000 - s) * loga);
- fred2 = pow(loga, 2.0) * (1.000/(s - 1.000) + 0.500/alocal);
- sum = (sum + 2.000 / pow((s - 1.000), 3.0) +
- 2.000 * loga / pow((s - 1.000), 2.0) + fred2) * fred;
-
- for (nlocal = 2; nlocal < alocal; nlocal++) {
- logn = log( (double) nlocal );
- sum += pow(logn, 2.0) / exp(logn * s);
- }
-
- return sum;
-}
-
-/* ------------------------------------------------------------------------ */
-
-double duds(double s, double B2[]) {
-/* d Upsilon / ds */
-/* double zs, zeta8, dzeta8, ddzeta8 */
-
- double zs, duds;
-
- zs = aaaa_zeta8(s, B2);
- duds = pow(aaaa_dzeta8(s, B2) / zs, 2.0) - aaaa_ddzeta8(s, B2) / zs;
-
- return duds;
-}
-
-/* ------------------------------------------------------------------------ */
-
-void vbecoef(double B2[]) {
-/* Bernoulli numbers B(2k) */
-
-/* Generate (set) the Bernoulli numbers */
-/* Reference: p.810 Abramowitz and Stegun */
-
- B2[0] = 1.000 / 6.000;
- B2[1] = -1.000 / 30.000;
- B2[2] = 1.000 / 42.000;
- B2[3] = -1.000 / 30.000;
- B2[4] = 5.000 / 66.000;
- B2[5] = -691.000 / 2730.000;
- B2[6] = 7.000 / 6.000;
- B2[7] = -3617.000 / 510.000;
- B2[8] = 4386.700 / 79.800;
- B2[9] = -1746.1100 / 3.3000;
- B2[10] = 8545.1300 / 1.3800;
- B2[11] = -2363.6409100 / 0.0273000;
-}
-
-/* ------------------------------------------------------------------------ */
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-vgam.git
More information about the debian-science-commits
mailing list