statmod/ 0000755 0001762 0000144 00000000000 15071672342 011734 5 ustar ligges users statmod/tests/ 0000755 0001762 0000144 00000000000 14616616043 013076 5 ustar ligges users statmod/tests/statmod-Tests.Rout.save 0000644 0001762 0000144 00000024340 14352244561 017463 0 ustar ligges users
R version 4.2.2 (2022-10-31 ucrt) -- "Innocent and Trusting"
Copyright (C) 2022 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.
R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.
Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.
> library(statmod)
> options(warnPartialMatchArgs=TRUE,warnPartialMatchAttr=TRUE,warnPartialMatchDollar=TRUE)
>
> set.seed(0); u <- runif(100)
>
> ### fitNBP
>
> y <- matrix(rnbinom(2*4,mu=4,size=1.5),2,4)
> lib.size <- rep(50000,4)
> group <- c(1,1,2,2)
> fitNBP(y,group=group,lib.size=lib.size)
$coefficients
1 2
[1,] -10.414313 -10.81978
[2,] -9.315701 -10.41431
$fitted.values
[,1] [,2] [,3] [,4]
[1,] 1.5 1.5 1.0 1.0
[2,] 4.5 4.5 1.5 1.5
$dispersion
[1] 0.9886071
>
> ### glmgam.fit
>
> glmgam.fit(1,1)
$coefficients
[1] 1
$fitted.values
[1] 1
$deviance
[1] 0
$iter
[1] 1
> glmgam.fit(c(1,1),c(0,4))
$coefficients
[1] 2
$fitted.values
[1] 2 2
$deviance
[1] Inf
$iter
[1] 1
> glmgam.fit(X=cbind(1,c(1,0.5,0.5,0,0)),y=rchisq(5,df=1))
$coefficients
[1] 0.1873533 0.6578903
$fitted.values
[1] 0.8452436 0.5162985 0.5162985 0.1873533 0.1873533
$deviance
[1] 10.7196
$iter
[1] 12
>
> ### glmnb.fit
>
> y <- rnbinom(5,mu=10,size=10)
> glmnb.fit(X=cbind(1,c(1,0.5,0.5,0,0)),y=y,dispersion=0.1)
$coefficients
x1 x2
2.3042476 -0.2210662
$fitted.values
[1] 8.029975 8.968465 8.968465 10.016639 10.016639
$deviance
[1] 0.5750191
$iter
[1] 3
$convergence
[1] "converged"
> glmnb.fit(X=cbind(1,c(1,0.5,0.5,0,0)),y=y,dispersion=runif(6))
$coefficients
x1 x2
2.2854591 -0.2049791
$fitted.values
[1] 8.008312 8.872615 8.872615 9.830198 9.830198
$deviance
[1] 0.150322
$iter
[1] 3
$convergence
[1] "converged"
> glmnb.fit(X=cbind(1,c(1,1,0,0,0)),y=c(0,0,6,2,9),dispersion=0.1)
$coefficients
x1 x2
1.734601 -17.510821
$fitted.values
[1] 1.407586e-07 1.407586e-07 5.666667e+00 5.666667e+00 5.666667e+00
$deviance
[1] 3.242349
$iter
[1] 17
$convergence
[1] "converged"
> fit <- glmnb.fit(X=cbind(1,c(1,1,0,0,0)),y=c(0,0,0,0,0),dispersion=0.1)
> fit$coefficients <- zapsmall(fit$coefficients,digits=15)
> fit
$coefficients
x1 x2
-1e+10 0e+00
$fitted.values
[1] 0 0 0 0 0
$deviance
[1] 0
$iter
[1] 0
$convergence
[1] "converged"
> X <- matrix(rnorm(10),5,2)
> glmnb.fit(X,y=c(0,0,0,0,0),offset=rnorm(5),dispersion=0.05)
$coefficients
x1 x2
9316725672 -10048340530
$fitted.values
[1] 0 0 0 0 0
$deviance
[1] 0
$iter
[1] 0
$convergence
[1] "converged"
>
> ### mixedModel2
>
> y <- rnorm(6)
> x <- rnorm(6)
> z <- c(1,1,2,2,3,3)
> mixedModel2(y~x,random=z)
$varcomp
Residual Block
2.548669 -0.870409
$se.varcomp
[1] 2.543947 1.363837
$coefficients
(Intercept) x
0.1585957 0.5996677
$se.coefficients
[1] 0.3983904 0.6857404
>
> ### mixedModel2Fit
>
> y <- c(-1,1,-2,2,0.5,1.7,-0.1)
> X <- matrix(1,7,1)
> Z <- model.matrix(~0+factor(c(1,1,2,2,3,3,4)))
> mixedModel2Fit(y,X,Z)
$varcomp
Residual Block
2.923462 -1.098564
$se.varcomp
[1] 2.195145 1.177909
$coefficients
x1
0.3376358
$se.coefficients
[1] 0.3369346
>
> ### qresiduals
>
> y <- rnorm(6)
> fit <- glm(y~1)
> residuals(fit)
1 2 3 4 5 6
0.68815664 0.33141358 0.07456884 0.39104513 -0.87533184 -0.60985235
> qresiduals(fit)
1 2 3 4 5 6
1.1222606 0.5404764 0.1216085 0.6377248 -1.4275100 -0.9945603
> qresiduals(fit,dispersion=1)
1 2 3 4 5 6
0.68815664 0.33141358 0.07456884 0.39104513 -0.87533184 -0.60985235
>
> if(require("MASS")) {
+ fit <- glm(Days~Age,family=negative.binomial(2),data=quine)
+ print(summary(qresiduals(fit)))
+ options(warnPartialMatchArgs=FALSE)
+ fit <- glm.nb(Days~Age,link=log,data = quine)
+ options(warnPartialMatchArgs=TRUE)
+ print(summary(qresiduals(fit)))
+ }
Loading required package: MASS
Min. 1st Qu. Median Mean 3rd Qu. Max.
-2.9227 -0.8494 -0.2115 -0.1294 0.7212 3.0678
Min. 1st Qu. Median Mean 3rd Qu. Max.
-3.14845 -0.50446 -0.02932 0.00518 0.67937 2.47162
>
> ### gauss.quad
>
> options(digits=10)
> g <- gauss.quad(5,"legendre")
> zapsmall(data.frame(g),digits=15)
nodes weights
1 -0.9061798459 0.2369268851
2 -0.5384693101 0.4786286705
3 0.0000000000 0.5688888889
4 0.5384693101 0.4786286705
5 0.9061798459 0.2369268851
> g <- gauss.quad(5,"chebyshev1")
> zapsmall(data.frame(g),digits=15)
nodes weights
1 -0.9510565163 0.6283185307
2 -0.5877852523 0.6283185307
3 0.0000000000 0.6283185307
4 0.5877852523 0.6283185307
5 0.9510565163 0.6283185307
> g <- gauss.quad(5,"chebyshev2")
> zapsmall(data.frame(g),digits=15)
nodes weights
1 -0.8660254038 0.1308996939
2 -0.5000000000 0.3926990817
3 0.0000000000 0.5235987756
4 0.5000000000 0.3926990817
5 0.8660254038 0.1308996939
> g <- gauss.quad(5,"hermite")
> zapsmall(data.frame(g),digits=15)
nodes weights
1 -2.0201828705 0.01995324206
2 -0.9585724646 0.39361932315
3 0.0000000000 0.94530872048
4 0.9585724646 0.39361932315
5 2.0201828705 0.01995324206
> g <- gauss.quad(5,"laguerre",alpha=5)
> zapsmall(data.frame(g),digits=15)
nodes weights
1 2.510558565 18.05274373485
2 5.115656536 63.52567706777
3 8.635874626 34.74331388323
4 13.417467882 3.63334627180
5 20.320442391 0.04491904235
> g <- gauss.quad(5,"jacobi",alpha=5,beta=1.1)
> zapsmall(data.frame(g),digits=15)
nodes weights
1 -0.8844049819 0.40981005618
2 -0.6382606000 1.16318993548
3 -0.2943950347 0.93716413992
4 0.1024254205 0.26378902100
5 0.5034550719 0.01840428809
> g <- gauss.quad.prob(5,dist="uniform")
> zapsmall(data.frame(g),digits=15)
nodes weights
1 0.04691007703 0.1184634425
2 0.23076534495 0.2393143352
3 0.50000000000 0.2844444444
4 0.76923465505 0.2393143352
5 0.95308992297 0.1184634425
> g <- gauss.quad.prob(5,dist="normal")
> zapsmall(data.frame(g),digits=15)
nodes weights
1 -2.856970014 0.01125741133
2 -1.355626180 0.22207592201
3 0.000000000 0.53333333333
4 1.355626180 0.22207592201
5 2.856970014 0.01125741133
> g <- gauss.quad.prob(5,dist="beta")
> zapsmall(data.frame(g),digits=15)
nodes weights
1 0.04691007703 0.1184634425
2 0.23076534495 0.2393143352
3 0.50000000000 0.2844444444
4 0.76923465505 0.2393143352
5 0.95308992297 0.1184634425
> g <- gauss.quad.prob(5,dist="gamma")
> zapsmall(data.frame(g),digits=15)
nodes weights
1 0.2635603197 5.217556106e-01
2 1.4134030591 3.986668111e-01
3 3.5964257710 7.594244968e-02
4 7.0858100059 3.611758680e-03
5 12.6408008443 2.336997239e-05
>
> ### invgauss
>
> pinvgauss(c(0,0.1,1,2.3,3.1,NA),mean=c(1,2,3,0,1,2),dispersion=0.5)
[1] 0.000000000e+00 2.057306477e-05 2.854596328e-01 1.000000000e+00
[5] 9.812161963e-01 NA
> pinvgauss(c(0,0.1,1,2.3,3.1,NA),mean=c(1,2,3,0,1,2),dispersion=0.5,log.p=TRUE)
[1] -Inf -10.79152787332 -1.25365465102 0.00000000000
[5] -0.01896246007 NA
> pinvgauss(c(0,0.1,1,2.3,3.1,NA),mean=c(1,2,3,0,1,2),dispersion=0.5,lower.tail=FALSE,log.p=TRUE)
[1] 0.0000000000000 -0.0000205732764 -0.3361157861191 -Inf
[5] -3.9747602878610 NA
> pinvgauss(1,mean=c(1,2,NA))
[1] 0.6681020012 0.4901383399 NA
> p <- c(0,0.001,0.5,0.999,1)
> qinvgauss(p,mean=1.3,dispersion=0.6)
[1] 0.0000000000 0.1271035164 0.9446753861 9.2602074131 Inf
> qinvgauss(p,mean=1.3,dispersion=0.6,lower.tail=FALSE)
[1] Inf 9.2602074131 0.9446753861 0.1271035164 0.0000000000
> qinvgauss(0.5,mean=c(1,2,NA))
[1] 0.6758413057 1.0284597846 NA
> qinvgauss(log(p),mean=1.3,dispersion=0.6,log.p=TRUE)
[1] 0.0000000000 0.1271035164 0.9446753861 9.2602074131 Inf
> qinvgauss(log(p),mean=1.3,dispersion=0.6,lower.tail=FALSE,log.p=TRUE)
[1] Inf 9.2602074131 0.9446753861 0.1271035164 0.0000000000
> rinvgauss(5,mean=c(1,NA,3,Inf,1e10),dispersion=c(2,3,NA,Inf,4))
[1] 0.64715825862 NA NA 0.00000000000 0.08624417187
>
> ### tweedie
>
> tw <- tweedie(var.power=1.25, link.power=0)
> tw$linkinv( matrix(u[1:10],5,2,dimnames=list(R=LETTERS[1:5],C=letters[1:2])) )
C
R a b
A 2.451492935 1.223458802
B 1.304094152 2.455645563
C 1.450812725 2.571978041
D 1.773319765 1.936336513
E 2.479874093 1.875947835
>
> ### expectedDeviance
> expectedDeviance(c(0,0.4,1),family="binomial",binom.size=2)
$mean
[1] 0.000000000 1.361204081 0.000000000
$variance
[1] 0.000000000 1.802700721 0.000000000
> expectedDeviance(matrix(c(0,NA,1,Inf),2,2),family="gaussian")
$mean
[,1] [,2]
[1,] 1 1
[2,] 1 1
$variance
[,1] [,2]
[1,] 2 2
[2,] 2 2
> expectedDeviance(c(0,1,Inf),family="Gamma",gamma.shape=2)
$mean
[1] 1.081451382 1.081451382 1.081451382
$variance
[1] 2.31894507 2.31894507 2.31894507
> expectedDeviance(c(1,2),family="inverse.gaussian")
$mean
[1] 1 1
$variance
[1] 2 2
> expectedDeviance(c(0,1,2),family="negative.binomial",nbinom.size=2)
$mean
[1] 0.000000000 1.057480184 1.120623536
$variance
[1] 0.0000000000 0.9740485644 1.6273323121
> expectedDeviance(c(0,2,Inf),family="poisson")
$mean
[1] 0.000000000 1.139404056 1.000000017
$variance
[1] 0.000000000 2.232975219 2.000000067
>
> ### extra tests done only locally
>
> #GKSTest <- Sys.getenv("GKSTest")
> #if(GKSTest=="on") {
> #print("hello")
> #}
>
> proc.time()
user system elapsed
0.18 0.06 0.20
statmod/tests/statmod-Tests.R 0000644 0001762 0000144 00000006735 14351537605 016011 0 ustar ligges users library(statmod)
options(warnPartialMatchArgs=TRUE,warnPartialMatchAttr=TRUE,warnPartialMatchDollar=TRUE)
set.seed(0); u <- runif(100)
### fitNBP
y <- matrix(rnbinom(2*4,mu=4,size=1.5),2,4)
lib.size <- rep(50000,4)
group <- c(1,1,2,2)
fitNBP(y,group=group,lib.size=lib.size)
### glmgam.fit
glmgam.fit(1,1)
glmgam.fit(c(1,1),c(0,4))
glmgam.fit(X=cbind(1,c(1,0.5,0.5,0,0)),y=rchisq(5,df=1))
### glmnb.fit
y <- rnbinom(5,mu=10,size=10)
glmnb.fit(X=cbind(1,c(1,0.5,0.5,0,0)),y=y,dispersion=0.1)
glmnb.fit(X=cbind(1,c(1,0.5,0.5,0,0)),y=y,dispersion=runif(6))
glmnb.fit(X=cbind(1,c(1,1,0,0,0)),y=c(0,0,6,2,9),dispersion=0.1)
fit <- glmnb.fit(X=cbind(1,c(1,1,0,0,0)),y=c(0,0,0,0,0),dispersion=0.1)
fit$coefficients <- zapsmall(fit$coefficients,digits=15)
fit
X <- matrix(rnorm(10),5,2)
glmnb.fit(X,y=c(0,0,0,0,0),offset=rnorm(5),dispersion=0.05)
### mixedModel2
y <- rnorm(6)
x <- rnorm(6)
z <- c(1,1,2,2,3,3)
mixedModel2(y~x,random=z)
### mixedModel2Fit
y <- c(-1,1,-2,2,0.5,1.7,-0.1)
X <- matrix(1,7,1)
Z <- model.matrix(~0+factor(c(1,1,2,2,3,3,4)))
mixedModel2Fit(y,X,Z)
### qresiduals
y <- rnorm(6)
fit <- glm(y~1)
residuals(fit)
qresiduals(fit)
qresiduals(fit,dispersion=1)
if(require("MASS")) {
fit <- glm(Days~Age,family=negative.binomial(2),data=quine)
print(summary(qresiduals(fit)))
options(warnPartialMatchArgs=FALSE)
fit <- glm.nb(Days~Age,link=log,data = quine)
options(warnPartialMatchArgs=TRUE)
print(summary(qresiduals(fit)))
}
### gauss.quad
options(digits=10)
g <- gauss.quad(5,"legendre")
zapsmall(data.frame(g),digits=15)
g <- gauss.quad(5,"chebyshev1")
zapsmall(data.frame(g),digits=15)
g <- gauss.quad(5,"chebyshev2")
zapsmall(data.frame(g),digits=15)
g <- gauss.quad(5,"hermite")
zapsmall(data.frame(g),digits=15)
g <- gauss.quad(5,"laguerre",alpha=5)
zapsmall(data.frame(g),digits=15)
g <- gauss.quad(5,"jacobi",alpha=5,beta=1.1)
zapsmall(data.frame(g),digits=15)
g <- gauss.quad.prob(5,dist="uniform")
zapsmall(data.frame(g),digits=15)
g <- gauss.quad.prob(5,dist="normal")
zapsmall(data.frame(g),digits=15)
g <- gauss.quad.prob(5,dist="beta")
zapsmall(data.frame(g),digits=15)
g <- gauss.quad.prob(5,dist="gamma")
zapsmall(data.frame(g),digits=15)
### invgauss
pinvgauss(c(0,0.1,1,2.3,3.1,NA),mean=c(1,2,3,0,1,2),dispersion=0.5)
pinvgauss(c(0,0.1,1,2.3,3.1,NA),mean=c(1,2,3,0,1,2),dispersion=0.5,log.p=TRUE)
pinvgauss(c(0,0.1,1,2.3,3.1,NA),mean=c(1,2,3,0,1,2),dispersion=0.5,lower.tail=FALSE,log.p=TRUE)
pinvgauss(1,mean=c(1,2,NA))
p <- c(0,0.001,0.5,0.999,1)
qinvgauss(p,mean=1.3,dispersion=0.6)
qinvgauss(p,mean=1.3,dispersion=0.6,lower.tail=FALSE)
qinvgauss(0.5,mean=c(1,2,NA))
qinvgauss(log(p),mean=1.3,dispersion=0.6,log.p=TRUE)
qinvgauss(log(p),mean=1.3,dispersion=0.6,lower.tail=FALSE,log.p=TRUE)
rinvgauss(5,mean=c(1,NA,3,Inf,1e10),dispersion=c(2,3,NA,Inf,4))
### tweedie
tw <- tweedie(var.power=1.25, link.power=0)
tw$linkinv( matrix(u[1:10],5,2,dimnames=list(R=LETTERS[1:5],C=letters[1:2])) )
### expectedDeviance
expectedDeviance(c(0,0.4,1),family="binomial",binom.size=2)
expectedDeviance(matrix(c(0,NA,1,Inf),2,2),family="gaussian")
expectedDeviance(c(0,1,Inf),family="Gamma",gamma.shape=2)
expectedDeviance(c(1,2),family="inverse.gaussian")
expectedDeviance(c(0,1,2),family="negative.binomial",nbinom.size=2)
expectedDeviance(c(0,2,Inf),family="poisson")
### extra tests done only locally
#GKSTest <- Sys.getenv("GKSTest")
#if(GKSTest=="on") {
#print("hello")
#}
statmod/MD5 0000644 0001762 0000144 00000005751 15071672342 012254 0 ustar ligges users a009eeee60bb0c4f174e4e6458d2c02a *DESCRIPTION
b303fc206ae40bb7143926532e4d6ff3 *NAMESPACE
cabcedc80916e132755147508dc1808b *R/digamma.R
0c8d8470000a346a83d8111358acf736 *R/digammaf.R
2ca5d21ceedcedb7a85e9f46800187c7 *R/elda.R
52ec6befa756863ee941f3c35d9303c8 *R/expectedDeviance.R
f48cdb780b1cc86bfeef8c4722912c2f *R/fitNBP.R
27838c3de5b6c7ff37ea6e92870903cc *R/forward.R
02f3c0306402de128ade0f53e3ddc213 *R/gaussquad.R
389bcfb763ddf57a875ca6ad1dad9bbf *R/glmgam.R
e0a5de6d8c194cdd1d59907eca7b8370 *R/glmnb.R
87e2551f59f03a67cf4b0a9bf6479972 *R/glmscoretest.R
c087af260a90389d175df8e01f078665 *R/growthcurve.R
1747893341300d18e4af7032e4f91fc0 *R/hommel.R
2547be942f2c8f2a7dc64076ca1e3daa *R/invgauss.R
c85f7bc07419ec6489a122fd6c5d9d41 *R/matvec.R
0b89726b40fa6877768afb616cd2f5df *R/mixedmodel.R
aead17fe81a6209b2c9cc7414ab7aa53 *R/mscale.R
5db770d7cd2194251a831b33b35b6dd8 *R/permp.R
e5134cb238e761646fb22e32e95ec08e *R/power.R
b2b000ae89b3aa6d40a8ff4feac8878e *R/qres.R
cb4885f03160dcbca66990cd8db7ae0a *R/remlscor.R
4843a9f5f3be5605ac7a96d5772bab26 *R/remlscorgamma.R
a3185c8c817e40182c9c31a41970df90 *R/sagetest.R
0922dac3e20ee58bd8782d15c57af3fb *R/tweedie.R
9d40159f50a5fc9949cbfe95a2884126 *build/partial.rdb
e600a474fedf570b1913b278022d46bf *data/welding.rdata
85ad52a717a6957a2c6c469a9344077b *inst/CITATION
39e4d248afd35c23c0aff590ca74efec *inst/NEWS
b2c27582e0b5e69cfbe9284ee0741f5c *man/digammaf.Rd
e7b573a3f838a766401a8f636248657d *man/elda.Rd
9fe316547ec9e29afe1960bdda75ef3a *man/expectedDeviance.Rd
7dcb6e1d40da3946b7d8b9fa14496b78 *man/fitNBP.Rd
3508ac5839f19813b7894387b7a21bb7 *man/forward.Rd
3ce658055cc4868c2e9e7e0e189bea27 *man/gauss.quad.Rd
53700424a431344afeccea0594e16127 *man/gauss.quad.prob.Rd
d03406d3a739fe7b6027aa7954937918 *man/glmgam.Rd
455da9def3a71b5848593423234a2ac8 *man/glmnbfit.Rd
f21a9d84ca4e38ef0a4965fa235ff125 *man/glmscoretest.Rd
c367efaf590bf1f621035e27b4e08aa9 *man/growthcurve.Rd
0f8f3ac69241aedf8664fbdf9d50f085 *man/hommel.test.Rd
93df53ae01a97635287bd0abec533306 *man/invgauss.Rd
ee394dd22edb184f213f2e3e754cc980 *man/logmdigamma.Rd
ae5d97dda72b73d6688128ac79753757 *man/matvec.Rd
e9426cfaf3b6bd604658f95c3e57a032 *man/meanT.Rd
458f31ce6fab473a95c5df35d0fb0527 *man/mixedmodel.Rd
ac05feb7d63c4dd33f0f0d79e8903bff *man/mscale.Rd
d6f8d7639d6c0b96a3e0a27b831d4f08 *man/permp.Rd
03485b19a3f73e050a942b597d9addc8 *man/plot.limdil.Rd
4609bc143ac65678e93f462ad77ee2ce *man/power.Rd
697952498d67f0ae9845e769fff8eb5d *man/qresiduals.Rd
066e8fd1ba6978fba7be06c486ee76c4 *man/remlscor.Rd
840325acacf28bed3ea24ec191f64795 *man/remlscorgamma.Rd
4049225be6fff5feb069a13f46f0c7a3 *man/sage.test.Rd
542b2dac5e344bf19914046c1fb85d57 *man/statmod.Rd
a6d428f10b8395f75d1ef78f1c6f7bb4 *man/tweedie.Rd
d8a58e7e91ba0dbf41668a06d0bc34dc *man/welding.Rd
a4009073f792f536c518f716a591582b *src/expectedDeviance.c
0848d2cac41cdeea7c861b02f73fafea *src/gaussq2.f
ce01c594724c29559594a261ddc156e5 *src/init.c
d78504eb1b0599f80eab02bbafd8cc5e *tests/statmod-Tests.R
304275ad1f1e58cefd5da92ac383c9d2 *tests/statmod-Tests.Rout.save
statmod/R/ 0000755 0001762 0000144 00000000000 14616616043 012135 5 ustar ligges users statmod/R/glmgam.R 0000644 0001762 0000144 00000006633 13622170031 013520 0 ustar ligges users # GLMGAM.R
glmgam.fit <- function(X,y,coef.start=NULL,tol=1e-6,maxit=50,trace=FALSE)
# Fit gamma generalized linear model with identity link
# by Fisher scoring with Levenberg-style damping
# Gordon Smyth
# Created 12 Mar 2003. Last revised 3 November 2010.
{
# check input
X <- as.matrix(X)
n <- nrow(X)
p <- ncol(X)
if(p > n) stop("More columns than rows in X")
y <- as.vector(y)
if(n != length(y)) stop("length(y) not equal to nrow(X)")
if(n == 0) return(list(coefficients=numeric(0),fitted.values=numeric(0),deviance=numeric(0)))
if(!(all(is.finite(y)) || all(is.finite(X)))) stop("All values must be finite and non-missing")
if(any(y < 0)) stop("y must be non-negative")
maxy <- max(y)
if(maxy==0) return(list(coefficients=rep(0,p),fitted.values=rep(0,n),deviance=NA))
y1 <- pmax(y,maxy*1e-3)
# starting values
if(is.null(coef.start)) {
fit <- lm.fit(X,y)
beta <- fit$coefficients
mu <- fit$fitted.values
if(any(mu < 0)) {
fit <- lm.wfit(X,y,1/y1^2)
beta <- fit$coefficients
mu <- fit$fitted.values
}
if(any(mu < 0)) {
fit <- lm.fit(X,rep(mean(y),n))
beta <- fit$coefficients
mu <- fit$fitted.values
}
if(any(mu < 0)) {
samesign <- apply(X>0,2,all) | apply(X<0,2,all)
if(any(samesign)) {
i <- (1:p)[samesign][1]
beta <- rep(0,p)
beta[i] <- lm.wfit(X[,i,drop=FALSE],y,1/y1^2)$coefficients
mu <- X[,i] * beta[i]
} else
return(list(coefficients=rep(0,p),fitted.values=rep(0,n),deviance=Inf))
}
} else {
beta <- coef.start
mu <- X %*% beta
}
if(any(mu<0)) stop("Starting values give negative fitted values")
deviance.gamma <- function(y,mu) {
if(any(mu<0)) return(Inf)
o <- (y < 1e-15) & (mu < 1e-15)
if(any(o)) {
if(all(o)) {
dev <- 0
} else {
y1 <- y[!o]
mu1 <- mu[!o]
dev <- 2*sum( (y1-mu1)/mu1 - log(y1/mu1) )
}
} else {
dev <- 2*sum( (y-mu)/mu - log(y/mu) )
}
}
dev <- deviance.gamma(y,mu)
# Scoring iteration with Levenberg damping
iter <- 0
if(trace) cat("Iter =",iter,", Dev =",dev," Beta",beta,"\n")
repeat {
iter <- iter+1
# information matrix
v <- mu^2
v <- pmax(v,max(v)/10^3)
XVX <- crossprod(X,vecmat(1/v,X))
maxinfo <- max(diag(XVX))
if(iter==1) {
lambda <- abs(mean(diag(XVX)))/p
I <- diag(p)
}
# score vector
dl <- crossprod(X,(y-mu)/v)
# Levenberg damping
betaold <- beta
devold <- dev
lev <- 0
repeat {
lev <- lev+1
# trial step
R <- chol(XVX + lambda*I)
dbeta <- backsolve(R,backsolve(R,dl,transpose=TRUE))
beta <- betaold + dbeta
mu <- X %*% beta
dev <- deviance.gamma(y,mu)
if(dev <= devold || dev/max(mu) < 1e-15) break
# exit if too much damping
if(lambda/maxinfo > 1e15) {
beta <- betaold
warning("Too much damping - convergence tolerance not achievable")
break
}
# step not successful so increase damping
lambda <- 2*lambda
if(trace) cat("Damping increased to",lambda,"\n")
}
# iteration output
if(trace) cat("Iter =",iter,", Dev =",dev," Beta",beta,"\n")
# keep exiting if too much damping
if(lambda/maxinfo > 1e15) break
# decrease damping if successful at first try
if(lev==1) lambda <- lambda/10
# test for convergence
if( crossprod(dl,dbeta) < tol || dev/max(mu) < 1e-15) break
# test for iteration limit
if(iter > maxit) break
}
beta <- drop(beta)
names(beta) <- colnames(X)
list(coefficients=beta,fitted.values=as.vector(mu),deviance=dev,iter=iter)
}
statmod/R/digammaf.R 0000644 0001762 0000144 00000005243 14351535207 014027 0 ustar ligges users Digamma <- function(link = "log") {
# Digamma generalized linear model family
# Gordon Smyth, smyth@wehi.edu.au
# 3 July 1998. Last revised 9 Dec 2002.
#
# improve on the link deparsing code in quasi()
linkarg <- substitute(link)
if (is.expression(linkarg) || is.call(linkarg)) {
linkname <- deparse(linkarg)
} else if(is.character(linkarg)) {
linkname <- linkarg
link <- make.link(linkarg)
} else if(is.numeric(linkarg)) {
linkname <- paste("power(",linkarg,")",sep="")
link <- make.link(linkarg)
} else {
linkname <- deparse(linkarg)
link <- make.link(linkname)
}
validmu <- function(mu) all(mu>0)
dev.resids <- function(y, mu, wt) wt * unitdeviance.digamma(y,mu)
initialize <- expression({
if (any(y <= 0)) stop(paste("Non-positive values not", "allowed for the Digamma family"))
n <- rep(1, nobs)
mustart <- y
})
aic <- function(y, n, mu, wt, dev) NA
structure(list(
family = "Digamma",
variance = varfun.digamma, dev.resids = dev.resids, aic = aic,
link = linkname,
linkfun = link$linkfun, linkinv = link$linkinv, mu.eta = link$mu.eta,
valideta = link$valideta, validmu = validmu, initialize = initialize,
class = "family"))
}
cumulant.digamma <- function(theta)
# Cumulant function for the Digamma family
# GKS 3 July 98
2*( theta*(log(-theta)-1) + lgamma(-theta) )
meanval.digamma <- function(theta)
# Mean value function for the Digamma family
# Gordon Smyth
# Created 3 July 1998. Last modified 24 Dec 2022.
{
2 * logmdigamma(-theta)
}
d2cumulant.digamma <- function(theta)
# 2nd derivative of cumulant function for Digamma family
# Gordon Smyth
# Created 3 July 1998. Last modified 24 Dec 2022.
{
out <- 2*( 1/theta + trigamma(-theta) )
min.theta <- min(theta)
if(min.theta < -1e3) {
i <- (theta < -1e3)
out[i] <- (1 - 1/3/theta[i]) / theta[i]^2
}
out
}
canonic.digamma <- function(mu) {
# Canonical mapping for Digamma family
# Solve meanval.digamma(theta) = mu for theta
# GKS 3 July 98
#
# Starting value from -log(-theta) =~ log(mu)
mlmt <- log(mu)
theta <- -exp(-mlmt)
for (i in 1:3) {
mu1 <- meanval.digamma(theta)
v <- d2cumulant.digamma(theta)
deriv <- -v/mu1*theta
mlmt <- mlmt - log(mu1/mu)/deriv
theta <- -exp(-mlmt)
}
theta
}
varfun.digamma <- function(mu) {
# Variance function for Digamma family
# GKS 3 July 98
#
theta <- canonic.digamma(mu)
2*( 1/theta + trigamma(-theta) )
}
unitdeviance.digamma <- function(y,mu) {
# Unit deviance for Digamma family
# GKS 3 July 98
#
thetay <- canonic.digamma(y)
theta <- canonic.digamma(mu)
2*( y*(thetay-theta) - (cumulant.digamma(thetay)-cumulant.digamma(theta)) )
}
statmod/R/permp.R 0000644 0001762 0000144 00000002145 12672426126 013406 0 ustar ligges users permp <- function(x,nperm,n1,n2,total.nperm=NULL,method="auto",twosided=TRUE)
# Exact permutation p-values
# Gordon Smyth and Belinda Phipson
# 16 February 2010. Last modified 17 March 2016.
{
if(any(x<0)) stop("negative x values")
if(any(x>nperm)) stop("x cannot exceed nperm")
if(is.null(total.nperm)) {
total.nperm <- choose((n1+n2),n1)
if(n1==n2 & twosided==TRUE) total.nperm <- total.nperm/2
}
method <- match.arg(method,c("auto","exact","approximate"))
if(method=="auto") if(total.nperm>10000) method <- "approximate" else method <- "exact"
# exact p-value by summation
if(method=="exact") {
p <- (1:total.nperm)/total.nperm
prob <- rep(p,length(x))
x2 <- rep(x,each=total.nperm)
Y <- matrix(pbinom(x2,prob=prob,size=nperm),total.nperm,length(x))
x[] <- colMeans(Y)
}
# integral approximation
else {
z <- gauss.quad.prob(128,l=0,u=0.5/total.nperm)
prob <- rep(z$nodes,length(x))
x2 <- rep(x,each=128)
Y <- matrix(pbinom(x2,prob=prob,size=nperm),128,length(x))
int <- 0.5/total.nperm*colSums(z$weights*Y)
x[] <- (x+1)/(nperm+1)-int
}
x
}
statmod/R/glmnb.R 0000644 0001762 0000144 00000013672 13473431170 013364 0 ustar ligges users glmnb.fit <- function(X,y,dispersion,weights=NULL,offset=0,coef.start=NULL,start.method="mean",tol=1e-6,maxit=50,trace=FALSE)
# Fit negative binomial generalized linear model with log link
# by Fisher scoring with Levenberg-style damped
# Gordon Smyth and Yunshun Chen
# Created 2 November 2010. Last modified 29 May 2019.
{
# Check input values for y
y <- as.vector(y)
if(any(y < 0)) stop("y must be non-negative")
if(!all(is.finite(y))) stop("All y values must be finite and non-missing")
ymax <- max(y)
n <- length(y)
# Handle zero length y as special case
if(n == 0) stop("y has length zero")
# Check input values for X
X <- as.matrix(X)
if(n != nrow(X)) stop("length(y) not equal to nrow(X)")
if(!all(is.finite(X))) stop("All X values must be finite and non-missing")
p <- ncol(X)
if(p > n) stop("More columns than rows in X")
if(is.null(colnames(X))) colnames(X) <- paste0("x",1:p)
# Check input values for dispersion
if(any(dispersion<0)) stop("dispersion values must be non-negative")
phi <- rep_len(dispersion,n)
# Check input values for offset
if(!all(is.finite(offset))) stop("All offset values must be finite and non-missing")
offset <- rep_len(offset,n)
# Check input values for weights
if(is.null(weights)) weights <- rep_len(1,n)
if(any(weights <= 0)) stop("All weights must be positive")
# Handle y all zero as special case
if(ymax==0) {
# Does X include an intercept term?
if(colnames(X)[1]=="(Intercept)") {
beta <- rep_len(0,p)
names(beta) <- colnames(X)
beta[1] <- -Inf
mu <- rep.int(0,n)
names(mu) <- rownames(X)
return(list(coefficients=beta,fitted.values=mu,deviance=0,iter=0L,convergence="converged"))
}
# Does X span the intercept term, at least closely enough to preserve signs?
One <- rep_len(1,n)
fit <- .lm.fit(X,One)
if(max(abs(fit$residuals)) < 1) {
beta <- -1e10 * fit$coefficients
names(beta) <- colnames(X)
mu <- rep_len(0,n)
names(mu) <- rownames(X)
return(list(coefficients=beta,fitted.values=mu,deviance=0,iter=0L,convergence="converged"))
}
# If X is far from spanning the intercept term, then
# initialize the iteration by trying to cancel out the offsets
if(is.null(coef.start)) {
fit <- lm.wfit(x=X,y=offset,w=weights)
coef.start <- -fit$coefficients
}
}
# Starting values
delta <- 1/6
y1 <- pmax(y,delta)
if(is.null(coef.start)) {
start.method <- match.arg(start.method,c("log(y)","mean"))
if(start.method=="log(y)") {
fit <- lm.wfit(X,log(y1)-offset,weights)
beta <- fit$coefficients
mu <- exp(fit$fitted.values+offset)
} else {
N <- exp(offset)
rate <- y/N
w <- weights*N/(1+phi*N)
beta.mean <- log(sum(w*rate)/sum(w))
beta <- qr.coef(qr(X),rep_len(beta.mean,n))
mu <- drop(exp(X %*% beta + offset))
}
} else {
beta <- coef.start
mu <- drop(exp(X %*% beta + offset))
}
unit.dev.poissonlimit <- function(y,mu,phi) {
b <- y-mu
b2 <- 0.5*b^2*phi*(1+phi*(2/3*b-y))
2 * ( y*log(y/mu) - b - b2 )
}
unit.dev.gamma <- function(y,mu) {
2 * ( (y-mu)/mu - log(y/mu))
}
unit.dev.negbin <- function(y,mu,phi) {
2 * ( y*log(y/mu) - (y+1/phi)*log((1+y*phi)/(1+mu*phi)) )
}
total.deviance <- function(y,mu,phi,w) {
if(any(is.infinite(mu))) return(Inf)
poisson.like <- (phi < 1e-4)
gamma.like <- (phi*mu > 1e6)
negbin <- !(poisson.like | gamma.like)
y <- y+1e-8
mu <- mu+1e-8
unit.dev <- y
if(any(poisson.like)) unit.dev[poisson.like] <- unit.dev.poissonlimit(y[poisson.like],mu[poisson.like],phi[poisson.like])
if(any(gamma.like)) {
m <- mu[gamma.like]
alpha <- m/(1+phi[gamma.like]*m)
unit.dev[gamma.like] <- unit.dev.gamma(y[gamma.like],m)*alpha
}
if(any(negbin)) unit.dev[negbin] <- unit.dev.negbin(y[negbin],mu[negbin],phi[negbin])
sum(w*unit.dev)
}
dev <- total.deviance(y,mu,phi,weights)
# Scoring iteration with Levenberg damping
iter <- 0
if(trace) cat("Iter =",iter,", Dev =",dev," Beta",beta,"\n")
repeat {
iter <- iter+1
# test for iteration limit
if(iter > maxit) break
# information matrix
v.div.mu <- 1+phi*mu
XVX <- crossprod(X,(weights*mu/v.div.mu)*X)
maxinfo <- max(diag(XVX))
if(iter==1) {
lambda <- maxinfo * 1e-6
lambda <- max(lambda,1e-13)
lambdaceiling <- maxinfo * 1e13
lambdabig <- FALSE
I <- diag(p)
}
# score vector
dl <- crossprod(X,weights*(y-mu)/v.div.mu)
# Levenberg damping
dbeta <- beta
lev <- 0
repeat {
lev <- lev+1
# trial step
R <- chol(XVX + lambda*I, pivot=TRUE)
while(attr(R,"rank")
lambdaceiling)
if(lambdabig) {
warning("Too much damping - convergence tolerance not achievable")
break
}
}
# iteration output
if(trace) cat("Iter =",iter,", Dev =",dev," Beta",beta,"\n")
# keep exiting if too much damping
if(lambdabig) break
# test for convergence
scoresquare <- crossprod(dl,dbeta)
if(trace) cat("Convergence criterion",scoresquare,dl,dbeta,"\n")
if( scoresquare < tol || dev/ymax < 1e-12) break
# decrease damping if successful at first try
if(lev==1) lambda <- lambda/10
}
beta <- drop(beta)
names(beta) <- colnames(X)
convergence <- "converged"
if(lambdabig) convergence <- "lambdabig"
if(iter>maxit) convergence <- "maxit"
list(coefficients=beta,fitted.values=as.vector(mu),deviance=dev,iter=iter,convergence=convergence)
}
statmod/R/gaussquad.R 0000644 0001762 0000144 00000007251 14316502544 014257 0 ustar ligges users # NUMERICAL INTEGRATION
gauss.quad <- function(n,kind="legendre",alpha=0,beta=0)
# Calculate nodes and weights for Gaussian quadrature.
# Adapted from Netlib routine gaussq.f
# Gordon Smyth, Walter and Eliza Hall Institute
# Suggestion from Stephane Laurent 6 Aug 2012
# Created 4 Sept 2002. Last modified 28 Aug 2016.
{
n <- as.integer(n)
if(n<0L) stop("need non-negative number of nodes")
if(n==0L) return(list(nodes=numeric(0L), weights=numeric(0L)))
kind <- match.arg(kind,c("legendre","chebyshev1","chebyshev2","hermite","jacobi","laguerre"))
i <- 1L:n
i1 <- i[-n]
switch(kind, legendre={
lnmuzero <- log(2)
a <- rep_len(0,n)
b <- i1/sqrt(4*i1^2-1)
}, chebyshev1={
lnmuzero <- log(pi)
a <- rep_len(0,n)
b <- rep_len(0.5,n-1L)
b[1] <- sqrt(0.5)
}, chebyshev2={
lnmuzero <- log(pi/2)
a <- rep_len(0,n)
b <- rep_len(0.5,n-1L)
}, hermite={
lnmuzero <- log(pi)/2
a <- rep_len(0,n)
b <- sqrt(i1/2)
}, jacobi={
ab <- alpha+beta
# muzero <- 2^(ab+1) * gamma(alpha+1) * gamma(beta+1) / gamma(ab+2)
lnmuzero <- (ab+1)*log(2) + lgamma(alpha+1) + lgamma(beta+1) - lgamma(ab+2)
a <- i
a[1] <- (beta-alpha)/(ab+2)
i2 <- i[-1]
abi <- ab+2*i2
a[i2] <- (beta^2-alpha^2)/(abi-2)/abi
b <- i1
b[1] <- sqrt(4*(alpha+1)*(beta+1)/(ab+2)^2/(ab+3))
i2 <- i1[-1]
abi <- ab+2*i2
b[i2] <- sqrt(4*i2*(i2+alpha)*(i2+beta)*(i2+ab)/(abi^2-1)/abi^2)
}, laguerre={
a <- 2*i-1+alpha
b <- sqrt(i1*(i1+alpha))
lnmuzero <- lgamma(alpha+1)
})
b <- c(b,0)
z <- rep_len(0,n)
z[1] <- 1
ierr <- 0L
out <- .Fortran("gausq2",n,as.double(a),as.double(b),as.double(z),ierr,PACKAGE="statmod")
x <- out[[2]]
w <- out[[4]]
w <- exp(lnmuzero + 2*log(abs(w)))
list(nodes=x,weights=w)
}
gauss.quad.prob <- function(n,dist="uniform",l=0,u=1,mu=0,sigma=1,alpha=1,beta=1)
# Calculate nodes and weights for Guassian quadrature using probability densities.
# Adapted from Netlib routine gaussq.f
# Gordon Smyth, Walter and Eliza Hall Institute
# Corrections for n=1 and n=2 by Spencer Graves, 28 Dec 2005
# Created 4 Sept 2002. Last modified 28 Aug 2016.
{
n <- as.integer(n)
if(n<0L) stop("need non-negative number of nodes")
if(n==0L) return(list(nodes=numeric(0L), weights=numeric(0L)))
dist <- match.arg(dist,c("uniform","beta1","beta2","normal","beta","gamma"))
if(n==1L){
switch(dist,
uniform={x <- (l+u)/2},
beta1=,beta2=,beta={x <- alpha/(alpha+beta)},
normal={x <- mu},
gamma={x <- alpha*beta}
)
return(list(nodes=x, weights=1))
}
if(dist=="beta" && alpha==0.5 && beta==0.5) dist <- "beta1"
if(dist=="beta" && alpha==1.5 && beta==1.5) dist <- "beta2"
i <- 1L:n
i1 <- 1L:(n-1L)
switch(dist, uniform={
a <- rep_len(0,n)
b <- i1/sqrt(4*i1^2-1)
}, beta1={
a <- rep_len(0,n)
b <- rep_len(0.5,n-1L)
b[1] <- sqrt(0.5)
}, beta2={
a <- rep_len(0,n)
b <- rep_len(0.5,n-1L)
}, normal={
a <- rep_len(0,n)
b <- sqrt(i1/2)
}, beta={
ab <- alpha+beta
a <- i
a[1] <- (alpha-beta)/ab
i2 <- 2:n
abi <- ab-2+2*i2
a[i2] <- ((alpha-1)^2-(beta-1)^2)/(abi-2)/abi
b <- i1
b[1] <- sqrt(4*alpha*beta/ab^2/(ab+1))
i2 <- i1[-1] # 2:(n-1)
abi <- ab-2+2*i2
b[i2] <- sqrt(4*i2*(i2+alpha-1)*(i2+beta-1)*(i2+ab-2)/(abi^2-1)/abi^2)
}, gamma={
a <- 2*i+alpha-2
b <- sqrt(i1*(i1+alpha-1))
})
b <- c(b,0)
z <- rep_len(0,n)
z[1] <- 1
ierr <- 0L
out <- .Fortran("gausq2",n,as.double(a),as.double(b),as.double(z),ierr,PACKAGE="statmod")
x <- out[[2]]
w <- out[[4]]^2
switch(dist,
uniform = x <- l+(u-l)*(x+1)/2,
beta1=,beta2=,beta = x <- (x+1)/2,
normal = x <- mu + sqrt(2)*sigma*x,
gamma = x <- beta*x)
list(nodes=x,weights=w)
}
statmod/R/qres.R 0000644 0001762 0000144 00000007600 12751041606 013230 0 ustar ligges users ## QRES.R
qresiduals <- qresid <- function(glm.obj, dispersion=NULL)
# Wrapper function for quantile residuals
# Peter K Dunn
# 28 Sep 2004. Last modified 5 Oct 2004.
{
glm.family <- glm.obj$family$family
if(substr(glm.family,1,17)=="Negative Binomial") glm.family <- "nbinom"
switch(glm.family,
binomial = qres.binom( glm.obj),
poisson = qres.pois(glm.obj),
Gamma = qres.gamma(glm.obj, dispersion),
inverse.gaussian = qres.invgauss(glm.obj, dispersion),
Tweedie = qres.tweedie(glm.obj, dispersion),
nbinom = qres.nbinom(glm.obj),
qres.default(glm.obj, dispersion))
}
qres.binom <- function(glm.obj)
# Randomized quantile residuals for binomial glm
# Gordon Smyth
# 20 Oct 96. Last modified 25 Jan 02.
{
p <- fitted(glm.obj)
y <- glm.obj$y
if(!is.null(glm.obj$prior.weights))
n <- glm.obj$prior.weights
else
n <- rep(1,length(y))
y <- n * y
a <- pbinom(y - 1, n, p)
b <- pbinom(y, n, p)
u <- runif(n = length(y), min = a, max = b)
qnorm(u)
}
qres.pois <- function(glm.obj)
# Quantile residuals for Poisson glm
# Gordon Smyth
# 28 Dec 96
{
y <- glm.obj$y
mu <- fitted(glm.obj)
a <- ppois(y - 1, mu)
b <- ppois(y, mu)
u <- runif(n = length(y), min = a, max = b)
qnorm(u)
}
qres.gamma <- function(glm.obj, dispersion = NULL)
# Quantile residuals for gamma glm
# Gordon Smyth
# 28 Dec 96. Last modified 5 Augusts 2016
{
mu <- fitted(glm.obj)
y <- glm.obj$y
df <- glm.obj$df.residual
w <- glm.obj$prior.weights
if(is.null(w)) w <- 1
if(is.null(dispersion)) dispersion <- sum(w * ((y - mu)/mu)^2)/df
logp <- pgamma((w * y)/mu/dispersion, w/dispersion, log.p=TRUE)
qnorm(logp, log.p=TRUE)
}
qres.invgauss <- function(glm.obj, dispersion = NULL)
# Quantile residuals for inverse Gaussian glm
# Gordon Smyth
# Created 15 Jan 98. Last modified 5 August 2016.
{
mu <- fitted(glm.obj)
y <- glm.obj$y
df <- glm.obj$df.residual
w <- glm.obj$prior.weights
if(is.null(w)) w <- 1
if(is.null(dispersion)) dispersion <- sum(w * (y - mu)^2 / (mu^2*y)) / df
up <- y>mu
down <- y 0, pbeta(p, size, pmax(y, 1)), 0)
b <- pbeta(p, size, y + 1)
u <- runif(n = length(y), min = a, max = b)
qnorm(u)
}
qres.tweedie <- function(glm.obj, dispersion = NULL)
# Quantile residuals for Tweedie glms
# Gordon Smyth
# Created 29 April 1998. Last modified 30 March 2015.
{
requireNamespace("tweedie")
mu <- fitted(glm.obj)
y <- glm.obj$y
df <- glm.obj$df.residual
w <- glm.obj$prior.weights
if(is.null(w))
w <- 1
p <- get("p",envir=environment(glm.obj$family$variance))
if(is.null(dispersion))
dispersion <- sum((w * (y - mu)^2)/mu^p)/df
u <- tweedie::ptweedie(q=y, power=p, mu=fitted(glm.obj), phi=dispersion/w)
if(p>1&&p<2)
u[y == 0] <- runif(sum(y == 0), min = 0, max = u[y == 0])
qnorm(u)
}
qres.default <- function(glm.obj, dispersion=NULL)
# Quantile residuals for Gaussian and default glms
# Gordon Smyth
# 5 Oct 2004.
{
r <- residuals(glm.obj, type="deviance")
if(is.null(dispersion)) {
df.r <- glm.obj$df.residual
if(df.r > 0) {
if(any(glm.obj$weights==0)) warning("observations with zero weight ", "not used for calculating dispersion")
dispersion <- sum(glm.obj$weights*glm.obj$residuals^2)/df.r
} else
dispersion <- 1
}
r/sqrt(dispersion)
}
statmod/R/glmscoretest.R 0000644 0001762 0000144 00000001353 11351052503 014761 0 ustar ligges users ## glmscore.R
glm.scoretest <- function(fit, x2, dispersion=NULL)
# Score test for new covariate in glm
# Gordon Smyth
# 27 March 2009. Last modified 20 Mar 2010.
{
w <- fit$weights
r <- fit$residuals
if(any(w <= 0)) {
r <- r[w>0]
x2 <- x2[w>0]
w <- w[w>0]
}
if (is.null(dispersion)) {
fixed.dispersion <- (fit$family$family %in% c("poisson","binomial"))
if(fixed.dispersion)
dispersion <- 1
else if(fit$df.residual > 0) {
dispersion <- sum(w*r^2)/fit$df.residual
} else {
stop("No residual df available to estimate dispersion")
}
}
ws <- sqrt(w)
x2.1w <- qr.resid(fit$qr,ws*x2)
zw <- ws*r
colSums(as.matrix(x2.1w*zw))/sqrt(colSums(as.matrix(x2.1w * x2.1w)))/sqrt(dispersion)
}
statmod/R/elda.R 0000644 0001762 0000144 00000024705 12607604374 013177 0 ustar ligges users # LIMDIL.R
elda <- limdil <- function(response, dose, tested = rep(1, length(response)), group=rep(1,length(response)), observed = FALSE, confidence = 0.95, test.unit.slope = FALSE)
# Limiting dilution analysis
# Gordon Smyth, Yifang Hu
# 21 June 2005. Last revised 18 August 2015.
{
n <- length(response)
if(n==0) stop("No data")
if(length(dose) != n) stop("length(dose) doesn't match length(response)")
if(length(tested) != n) {
if(length(tested)==1)
tested <- rep_len(tested,n)
else
stop("length(tested) doesn't match length(response)")
}
# Allow for structural zeros
SZ <- response==0 & (dose==0 | tested==0)
if(any(SZ)) {
i <- !SZ
out <- Recall(response=response[i],dose=dose[i],tested=tested[i],group=group[i],observed=observed,confidence=confidence,test.unit.slope=test.unit.slope)
out$response <- response
out$dose <- dose
out$tested <- tested
return(out)
}
# Check valid data
y <- response/tested
if (any(y < 0)) stop("Negative values for response or tested")
if (any(y > 1)) stop("The response cannot be greater than the number tested")
if (any(dose <= 0)) stop("dose must be positive")
size <- 1 - confidence
out <- list()
f <- binomial(link = "cloglog")
f$aic <- quasi()$aic
group <- factor(group)
num.group <- length(levels(group))
groupLevel <- levels(group)
out$response <- response
out$tested <- tested
out$dose <- dose
out$group <- group
out$num.group <- num.group
class(out) <- "limdil"
out$CI <- matrix(nrow=num.group,ncol=3)
colnames(out$CI) <- c("Lower","Estimate","Upper")
rownames(out$CI) <- paste("Group",levels(group))
# Groupwise frequency estimates
deviance0 <- dloglik.logdose <- FisherInfo.logdose <- dloglik.dose <- FisherInfo.dose <- 0
for(i in 1:num.group) {
index <- (group == groupLevel[i])
fit0 <- eldaOneGroup(response=response[index],dose=dose[index],tested=tested[index],observed=observed,confidence=confidence,trace=FALSE)
deviance0 <- deviance0 + fit0$deviance
dloglik.logdose <- dloglik.logdose + fit0$dloglik.logdose
FisherInfo.logdose <- FisherInfo.logdose + fit0$FisherInfo.logdose
dloglik.dose <- dloglik.dose + fit0$dloglik.dose
FisherInfo.dose <- FisherInfo.dose + fit0$FisherInfo.dose
out$CI[i,] <- pmax(fit0$CI.frequency,1)
}
# Test for difference between groups
if(num.group>1) {
fitequal <- eldaOneGroup(response=response,dose=dose,tested=tested,observed=observed,confidence=confidence,trace=FALSE)
dev.g <- pmax(fitequal$deviance - deviance0, 0)
group.p <- pchisq(dev.g, df=num.group-1, lower.tail=FALSE)
out$test.difference <- c(Chisq=dev.g, P.value=group.p, df=num.group-1)
}
# Test for unit slope
if(test.unit.slope) {
if(is.na(FisherInfo.logdose)) FisherInfo.logdose <- 0
if(FisherInfo.logdose > 1e-15) {
# Wald test
if(num.group>1)
fit.slope <- suppressWarnings(glm(y~group+log(dose), family=f, weights=tested))
else
fit.slope <- suppressWarnings(glm(y~log(dose), family=f, weights=tested))
s.slope <- summary(fit.slope)
est.slope <- s.slope$coef["log(dose)","Estimate"]
se.slope <- s.slope$coef["log(dose)", "Std. Error"]
z.wald <- (est.slope-1)/se.slope
p.wald <- 2*pnorm(-abs(z.wald))
out$test.slope.wald <- c("Estimate"=est.slope, "Std. Error"=se.slope, "z value"=z.wald, "Pr(>|z|)"=p.wald)
# Likelihood ratio test
dev <- pmax(deviance0 - fit.slope$deviance,0)
z.lr <- sqrt(dev)*sign(z.wald)
p.lr <- pchisq(dev, df = 1, lower.tail = FALSE)
out$test.slope.lr <- c("Estimate"=NA, "Std. Error"=NA, "z value"=z.lr, "Pr(>|z|)"=p.lr)
# Score tests for log(dose) and dose
z.score.logdose <- dloglik.logdose / sqrt(FisherInfo.logdose)
p.score.logdose <- 2*pnorm(-abs(z.score.logdose))
z.score.dose <- dloglik.dose / sqrt(FisherInfo.dose)
p.score.dose <- 2*pnorm(-abs(z.score.dose))
out$test.slope.score.logdose <- c("Estimate"= NA, "Std. Error"=NA, "z value"=z.score.logdose,"Pr(>|z|)"=p.score.logdose)
out$test.slope.score.dose <- c("Estimate"= NA, "Std. Error"=NA, "z value"=z.score.dose,"Pr(>|z|)"=p.score.dose)
} else {
out$test.slope.wald <- out$test.slope.lr <- out$test.slope.score.logdose <- out$test.slope.score.dose <- c("Estimate"=NA, "Std. Error"=NA, "z value"=NA, "Pr(>|z|)"=1)
}
}
out
}
print.limdil <- function(x, ...)
# Print method for limdil objects
# Yifang Hu and Gordon Smyth
# 20 February 2009. Last revised 31 January 2013.
{
cat("Confidence intervals for frequency:\n\n")
print(x$CI)
if(!is.null(x$test.difference)) {
difference <- x$test.difference
cat("\nDifferences between groups:\n")
cat("Chisq",difference[1], "on", difference[3], "DF, p-value:", format.pval(difference[2],4), "\n")
}
if(!is.null(x$test.slope.wald)) {
a <- rbind(x$test.slope.wald, x$test.slope.lr, x$test.slope.score.logdose, x$test.slope.score.dose)
a <- data.frame(a, check.names=FALSE)
rownames(a) <- c("Wald test", "LR test", "Score test: log(Dose)", "Score test: Dose")
cat("\nGoodness of fit (test log-Dose slope equals 1):\n")
suppressWarnings(printCoefmat(a,tst.ind=1,has.Pvalue=TRUE,P.values=TRUE))
}
}
plot.limdil <- function(x, col.group=NULL, cex=1, lwd=1, legend.pos="bottomleft", ...)
# Plot method for limdil objects
# Yifang Hu and Gordon Smyth
# 20 February 2009. Last revised 6 February 2013.
{
x$group <- factor(x$group)
num.group <- nlevels(x$group)
if(is.null(col.group))
col.group <- 1:num.group
else
col.group <- rep(col.group,num.group)
col <- x$group
levels(col) <- col.group
col <- as.character(col)
dose <- x$dose
maxx <- max(dose)
i <- x$response==x$tested
x$response[i] <- x$response[i]-0.5
nonres <- log(1-x$response/x$tested)
if(num.group>1 && any(i)) nonres <- pmin(0,jitter(nonres))
miny <- min(nonres)
plot(x=1,y=1,xlim=c(0,maxx),ylim=c(min(miny,-0.5),0),xlab="dose (number of cells)",ylab="log fraction nonresponding",type="n",...)
points(dose[!i],nonres[!i],pch=1,col=col[!i],cex=cex)
points(dose[i],nonres[i],pch=6,col=col[i],cex=cex)
for(g in 1:num.group) {
abline(a=0,b=-1/x$CI[g,2],col=col.group[g],lty=1,lwd=lwd)
abline(a=0,b=-1/x$CI[g,1],col=col.group[g],lty=2,lwd=lwd)
abline(a=0,b=-1/x$CI[g,3],col=col.group[g],lty=2,lwd=lwd)
}
if(num.group>1) legend(legend.pos,legend=paste("Group",levels(x$group)),text.col=col.group,cex=0.6*cex)
invisible(list(x=dose,y=nonres,group=x$group))
}
.limdil.allpos <- function(tested, dose, confidence, observed)
# One-sided confidence interval when all assays are positive
# Uses globally convergent Newton iteration
# Yifang Hu.
# Created 18 March 2009. Last modified 18 Dec 2012.
{
alpha <- 1 - confidence
dosem <- min(dose)
tested.group <- tested
tested.sum <- sum(tested.group[dose == dosem])
beta <- log(-log(1 - alpha^(1/tested.sum))) - log(dosem)
# Starting value
lambda <- exp(beta)
if(observed) lambda <- -expm1(lambda)
# Newton-iteration
repeat {
if(observed)
f <- sum(tested*log(1-(1-lambda)^dose))-log(alpha)
else
f <- sum(tested*log(1-exp(-lambda*dose)))-log(alpha)
if(observed)
deriv <- sum(tested*(-dose)*(1-lambda)^(dose-1)/(1-(1-lambda)^dose))
else
deriv <- sum(tested*dose*exp(-dose*lambda)/(1-exp(-dose*lambda)))
step <- f/deriv
lambda <- lambda-step
if(-step < 1e-6) break
}
lambda
}
eldaOneGroup <- function(response,dose,tested,observed=FALSE,confidence=0.95,tol=1e-8,maxit=100,trace=FALSE)
# Estimate active cell frequency from LDA data
# using globally convergent Newton iteration
# Gordon Smyth
# 5 Dec 2012. Last modified 30 Jan 2013.
{
y <- response
n <- tested
d <- dose
phat <- y/n
size <- 1-confidence
# Special case of all negative responses
if(all(y < 1e-14)) {
N <- sum(dose*tested)
if (observed)
U <- 1 - size^(1/N)
else
U <- -log(size)/N
out <- list()
out$CI.frequency <- c(Lower = Inf, Estimate = Inf, Upper = 1/U)
out$deviance <- out$dloglik.logdose <- out$FisherInfo.logdose <- out$dloglik.dose <- out$FisherInfo.dose <- 0
return(out)
}
# Special case of all positive responses
if(all(phat > 1-1e-14)) {
U <- .limdil.allpos(tested=tested,dose=dose,confidence=confidence,observed=observed)
out <- list()
out$CI.frequency <- c(Lower = 1/U, Estimate = 1, Upper = 1)
out$deviance <- out$dloglik.logdose <- out$FisherInfo.logdose <- out$dloglik.dose <- out$FisherInfo.dose <- 0
return(out)
}
# Starting value guaranteed to be left of the solution
pmean <- mean(y)/mean(n)
lambda <- -log1p(-pmean) / max(d)
if(trace) cat(0,lambda,1/lambda,"\n")
# Globally convergent Newton iteration
iter <- 0
repeat{
iter <- iter+1
if(iter > maxit) {
warning("max iterations exceeded")
break
}
p <- -expm1(-lambda*d)
onemp <- exp(-lambda*d)
# First derivative
dloglik.lambda <- mean(n*d*(phat-p)/p)
# Second derivative
d2loglik.lambda <- -mean(n*phat*d*d*onemp/p/p)
# Newton step
step <- dloglik.lambda / d2loglik.lambda
lambda <- lambda - step
if(trace) cat(iter,lambda,1/lambda,step,"\n")
if(abs(step) < tol) break
}
# Wald confidence interval for alpha
alpha <- log(lambda)
p <- -expm1(-lambda*d)
onemp <- exp(-lambda*d)
FisherInfo.alpha <- sum(n*d*d*onemp/p)*lambda^2
SE.alpha <- 1/sqrt(FisherInfo.alpha)
z <- qnorm( (1-confidence)/2, lower.tail=FALSE )
CI.alpha <- c(Lower=alpha-z*SE.alpha,Estimate=alpha,Upper=alpha+z*SE.alpha)
# Wald confidence interval for frequency
if(observed)
CI.frequency <- -1/expm1(-exp(CI.alpha))
else
CI.frequency <- exp(-CI.alpha)
# Deviance
f <- binomial(link="cloglog")
deviance <- sum(f$dev.resid(phat,p,n))
# Score test for log(dose) unit slope
v <- p*onemp/n
x <- log(d)
eta <- alpha+x
mu.eta <- f$mu.eta(eta)
info.alpha <- mu.eta^2/v
xmean <- sum(x*info.alpha)/sum(info.alpha)
mu.beta <- (x-xmean)*mu.eta
dloglik.beta <- sum(mu.beta*(phat-p)/v)
FisherInfo.beta <- sum(mu.beta^2/v)
z.scoretest <- dloglik.beta/sqrt(FisherInfo.beta)
# Score test for dose
x <- d
xmean <- sum(x*info.alpha)/sum(info.alpha)
mu.beta <- (x-xmean)*mu.eta
dloglik.beta.dose <- sum(mu.beta*(phat-p)/v)
FisherInfo.beta.dose <- sum(mu.beta^2/v)
z.scoretest.dose <- dloglik.beta.dose/sqrt(FisherInfo.beta.dose)
list(p=p,lambda=lambda,alpha=alpha,CI.alpha=CI.alpha,CI.frequency=CI.frequency,deviance=deviance,iter=iter,z.scoretest=z.scoretest,z.scoretest.dose=z.scoretest.dose,dloglik.logdose=dloglik.beta,FisherInfo.logdose=FisherInfo.beta,dloglik.dose=dloglik.beta.dose,FisherInfo.dose=FisherInfo.beta.dose)
}
statmod/R/hommel.R 0000644 0001762 0000144 00000001050 11161616415 013530 0 ustar ligges users hommel.test <-
# Multiple testing from Hommel (1988).
# Similar but very slightly more powerful that Hochberg (1988).
# Controls Family-Wise Error rate for hypotheses which are independent or
# which satisfy the free-association condition of Simes (1986).
# Gordon Smyth, Walter and Eliza Hall Institute, smyth@wehi.edu.au
# 29 Aug 2002
function(p,alpha=0.05) {
n <- length(p)
i <- 1:n
po <- sort(p)
j <- n
repeat {
k <- 1:j
if(all( po[n - j + k] > k * alpha / j )) break
j <- j-1
if(j == 0) break
}
p >= alpha/j
}
statmod/R/matvec.R 0000644 0001762 0000144 00000001047 11161616415 013534 0 ustar ligges users matvec <- function(M,v) {
# Multiply the columns of matrix by the elements of a vector,
# i.e., compute M %*% diag(v)
# Gordon Smyth
# 5 July 1999
#
v <- as.vector(v)
M <- as.matrix(M)
if(length(v)!=dim(M)[2]) stop("matvec: Dimensions do not match")
t(v * t(M))
}
vecmat <- function(v,M) {
# Multiply the rows of matrix by the elements of a vector,
# i.e., compute diag(v) %*% M
# Gordon Smyth
# 5 July 1999
#
v <- as.vector(v)
M <- as.matrix(M)
if(length(v)!=dim(M)[1]) stop("vecmat: Dimensions do not match")
v * M
}
statmod/R/mscale.R 0000644 0001762 0000144 00000003157 11362711054 013523 0 ustar ligges users mscale <- function(u, na.rm=FALSE)
# Scale M-estimator with 50% breakdown
# Yohai (1987) Annals, Stromberg (1993) JASA.
#
# GKS 2 June 1999
# Revised 17 April 2010
{
isna <- is.na(u)
if(any(isna)) {
if(na.rm) {
if(any(!isna))
u <- u[!isna]
else
return(NA)
} else {
return(NA)
}
}
if(mean(u==0) >= 0.5) return(0)
U <- abs(u)
s <- median(U)/0.6744898
iter <- 0
repeat {
iter <- iter+1
z <- u/0.212/s
d1 <- mean(.rho.hampel(z))-3.75
d2 <- mean(z*.psi.hampel(z))
s <- s*(1+d1/d2)
if(iter > 50) {
warning("Max iterations exceeded")
break
}
if(abs(d1/d2) < 1e-13) break
}
s
}
.rho.hampel <- function(u, a = 1.5, b = 3.5, c = 8)
{
# Integral of Hampel's redescending psi function (Hampel, Ronchetti,
# Rousseeuw and Stahel, 1986, Robust Statistics, Wiley, page 150).
# Default values are as in Stromberg (1993) JASA.
#
# GKS 31 May 99
#
U <- abs(u)
A <- (U <= a) #increasing
B <- (U > a) & (U <= b) #flat
C <- (U > b) & (U <= c) #descending
D <- (U > c) # zero
rho <- U
rho[A] <- (U[A] * U[A])/2
rho[B] <- a * (U[B] - a/2)
rho[C] <- a * (b - a/2) + a * (U[C] - b) * (1 - (U[C] - b)/(c - b)/2)
rho[D] <- (a * (b - a + c))/2
rho
}
.psi.hampel <- function(u, a = 1.5, b = 3.5, c = 8)
{
# Hampel's redescending psi function (Hampel, Ronchetti,
# Rousseeuw and Stahel, 1986, Robust Statistics, Wiley, page 150).
# Default values are as in Stromberg (1993) JASA.
#
# GKS 2 June 99
#
U <- abs(u)
B <- (U > a) & (U <= b) #flat
C <- (U > b) & (U <= c) #descending
D <- (U > c) # zero
psi <- u
psi[B] <- sign(u[B]) * a
psi[C] <- sign(u[C]) * a * (c - U[C])/(c - b)
psi[D] <- 0
psi
} statmod/R/remlscor.R 0000644 0001762 0000144 00000006041 11354247604 014106 0 ustar ligges users remlscore <- function(y,X,Z,trace=FALSE,tol=1e-5,maxit=40)
# Mean-variance fit by REML scoring
# Fit normal(mu,phi) model to y with
# mu=X%*%beta and log(phi)=Z%*%gam
#
# Gordon Smyth
# Created 11 Sept 2000. Last modified 30 March 2010.
{
n <- length(y)
p <- dim(X)[2]
q <- dim(Z)[2]
const <- n*log(2*pi)
# initial residuals from unweighted regression
fitm <- lm.fit(X,y)
if(fitm$qr$rank < p) stop("X is of not of full column rank")
Q <- qr.Q(fitm$qr)
h <- as.vector(Q^2 %*% array(1, c(p, 1)))
d <- fitm$residuals^2
# starting values
# use of weights guarantee that regression can be computed even if 1-h = 0
wd <- 1-h
zd <- log( d/(1-h) )+1.27
fitd <- lm.wfit(Z,zd,wd)
gam <- ifelse(is.na(fitd$coef),0,fitd$coef)
g <- fitd$fitted.values
phi <- exp(g)
wm <- 1/phi
fitm <- lm.wfit(X,y,wm)
d <- fitm$residuals^2
dev <- sum(d/phi)+sum(log(phi))+const+2*log(prod(abs(diag(fitm$qr$qr))))
# reml scoring
iter <- 0
if(trace) cat("Iter =",iter,", Dev =",dev," Gamma",gam,"\n")
Q2 <- array(0,c(n,p*(p+1)/2))
repeat {
iter <- iter+1
# information matrix and leverages
Q <- qr.qy(fitm$qr, diag(1, nrow = n, ncol = p))
j0 <- 0
for(k in 0:(p-1)) {
Q2[ ,(j0+1):(j0+p-k)] <- Q[ ,1:(p-k)] * Q[ ,(k+1):p]
j0 <- j0+p-k
}
if(p>1) Q2[ ,(p+1):(p*(p+1)/2)] <- sqrt(2) * Q2[ ,(p+1):(p*(p+1)/2)]
h <- drop( Q2[ ,1:p] %*% array(1,c(p,1)) )
Q2Z <- t(Q2) %*% Z
ZVZ <- ( t(Z) %*% vecmat(1-2*h,Z) + t(Q2Z) %*% Q2Z )/2
maxinfo <- max(diag(ZVZ))
if(iter==1) {
lambda <- abs(mean(diag(ZVZ)))/q
I <- diag(q)
}
# score vector
zd <- ( d - (1-h)*phi ) / phi
dl <- crossprod(Z,zd)/2
# Levenberg damping
gamold <- gam
devold <- dev
lev <- 0
repeat {
lev <- lev+1
# trial step
R <- chol(ZVZ + lambda*I)
dgam <- backsolve(R,backsolve(R,dl,transpose=TRUE))
gam <- gamold + dgam
phi <- as.vector(exp( Z %*% gam ))
wm <- 1/phi
fitm <- lm.wfit(X,y,wm)
d <- fitm$residuals^2
dev <- sum(d/phi)+sum(log(phi))+const+2*log(prod(abs(diag(fitm$qr$qr))))
if(dev < devold - 1e-15) break
# exit if too much damping
if(lambda/maxinfo > 1e15) {
gam <- gamold
warning("Too much damping - convergence tolerance not achievable")
break
}
# step not successful so increase damping
lambda <- 2*lambda
if(trace) cat("Damping increased to",lambda,"\n")
}
# iteration output
if(trace) cat("Iter =",iter,", Dev =",dev," Gamma",gam,"\n")
# keep exiting if too much damping
if(lambda/maxinfo > 1e15) break
# decrease damping if successful at first try
if(lev==1) lambda <- lambda/10
# test for convergence
if( crossprod(dl,dgam) < tol ) break
# test for iteration limit
if(iter > maxit) {
warning("reml: Max iterations exceeded")
break
}
}
# Nominal standard errors
cov.gam <- chol2inv(chol(ZVZ))
se.gam <- sqrt(diag(cov.gam))
cov.beta <- chol2inv(qr.R(fitm$qr))
se.beta <- sqrt(diag(cov.beta))
list(beta=fitm$coef,se.beta=se.beta,gamma=gam,se.gam=se.gam,mu=fitm$fitted,phi=phi,deviance=dev,h=h,
cov.beta=cov.beta,cov.gam=cov.gam,iter=iter)
}
statmod/R/power.R 0000644 0001762 0000144 00000000742 11661623622 013415 0 ustar ligges users power.fisher.test <- function(p1,p2,n1,n2,alpha=0.05,nsim=100,alternative="two.sided") {
# Calculation of power for Fisher's exact test for
# comparing two proportions
# Gordon smyth
# 3 June 2003. Revised 19 Nov 2011.
y1 <- rbinom(nsim,size=n1,prob=p1)
y2 <- rbinom(nsim,size=n2,prob=p2)
y <- cbind(y1,n1-y1,y2,n2-y2)
p.value <- rep(0,nsim)
for (i in 1:nsim) p.value[i] <- fisher.test(matrix(y[i,],2,2),alternative=alternative)$p.value
mean(p.value < alpha)
}
statmod/R/remlscorgamma.R 0000644 0001762 0000144 00000006341 11161616415 015110 0 ustar ligges users remlscoregamma <- function(y,X,Z,mlink="log",dlink="log",trace=FALSE,tol=1e-5,maxit=40) {
#
# Mean-dispersion fit by REML scoring for gamma responses
# Fit ED(mu,phi) model to y with
# g(mu)=X%*%beta and f(phi)=Z%*%gam
#
# Gordon Smyth, Walter and Eliza Hall Institute
# 16 Dec 2002.
n <- length(y)
X <- as.matrix(X)
if(is.null(colnames(X))) colnames(X) <- paste("X",as.character(1:ncol(X)),sep="")
Z <- as.matrix(Z)
if(is.null(colnames(Z))) colnames(Z) <- paste("Z",as.character(1:ncol(Z)),sep="")
q <- dim(Z)[2]
const <- 2*sum(log(y))
# Link functions
mli <- make.link(mlink)
dli <- make.link(dlink)
# Mean family
f <- Gamma()
f$linkfun <- mli$linkfun
f$linkinv <- mli$linkinv
f$mu.eta <- mli$mu.eta
f$valideta <- mli$valideta
# initial residuals and leverages assuming constant dispersion
fitm <- glm.fit(X,y,family=f)
mu <- fitted(fitm)
d <- 2*( (y-mu)/mu - log(y/mu) )
p <- fitm$rank
# start from constant dispersion
phi <- -1/canonic.digamma(mean(d))*n/(n-p)
phi <- rep(phi,n)
fitd <- lm.fit(Z,dli$linkfun(phi))
gam <- ifelse(is.na(fitd$coef),0,fitd$coef)
if( mean(abs(fitd$residuals))/phi[1] > 1e-12 ) {
# intercept is not in span of Z
phi <- drop(dli$linkinv( Z %*% gam ))
fitm <- glm.fit(X,y,weights=1/phi,mustart=mu,family=f)
mu <- fitted(fitm)
d <- 2*( (y-mu)/mu - log(y/mu) )
} else
fitm <- glm.fit(X,y,weights=1/phi,mustart=mu,family=f)
dev <- const+sum(2*(lgamma(1/phi)+(1+log(phi))/phi)+d/phi)+const+2*log(prod(abs(diag(fitm$qr$qr)[1:p])))
# reml scoring
iter <- 0
if(trace) cat("Iter =",iter,", Dev =",format(dev,digits=13)," Gamma",gam,"\n")
Q2 <- array(0,c(n,p*(p+1)/2))
repeat {
iter <- iter+1
# gradient matrix
eta <- dli$linkfun(phi)
phidot <- dli$mu.eta(eta) * Z
Z2 <- phidot / phi / sqrt(2)
# information matrix and leverages
Q <- qr.qy(fitm$qr, diag(1, nrow = n, ncol = p))
j0 <- 0
for(k in 0:(p-1)) {
Q2[ ,(j0+1):(j0+p-k)] <- Q[ ,1:(p-k)] * Q[ ,(k+1):p]
j0 <- j0+p-k
}
if(p>1) Q2[ ,(p+1):(p*(p+1)/2)] <- sqrt(2) * Q2[ ,(p+1):(p*(p+1)/2)]
h <- drop( Q2[ ,1:p] %*% array(1,c(p,1)) )
Q2Z <- crossprod(Q2,Z2)
extradisp <- 2*( trigamma(1/phi) - trigamma(1/phi/h)/h )/phi^2 - (1-h)
info <- crossprod(Z2,(extradisp+1-2*h)*Z2) + crossprod(Q2Z)
# score vector
deltah <- 2*(digamma(1/h/phi)+log(h)-digamma(1/phi))
dl <- crossprod(phidot, (d - deltah)/(2*phi^2))
# scoring step
R <- chol(info)
dgam <- backsolve(R,backsolve(R,dl,transpose=TRUE))
gam <- gam + dgam
# evaluate modified profile likelihood
phi <- drop(dli$linkinv( Z %*% gam ))
fitm <- glm.fit(X,y,weights=1/phi,mustart=mu,family=f)
mu <- fitted(fitm)
d <- 2*( (y-mu)/mu - log(y/mu) )
dev <- const+sum(2*(lgamma(1/phi)+(1+log(phi))/phi)+d/phi)+const+2*log(prod(abs(diag(fitm$qr$qr)[1:p])))
# iteration output
if(trace) cat("Iter =",iter,", Dev =",format(dev,digits=13)," Gamma",gam,"\n")
# test for convergence
if( crossprod(dl,dgam) < tol ) break
# test for iteration limit
if(iter > maxit) {
warning("Max iterations exceeded")
break
}
}
# Standard errors
se.gam <- sqrt(diag(chol2inv(chol(info))))
se.beta <- sqrt(diag(chol2inv(qr.R(fitm$qr))))
list(beta=fitm$coef,se.beta=se.beta,gamma=gam,se.gam=se.gam,mu=mu,phi=phi,deviance=dev,h=h)
}
statmod/R/digamma.R 0000644 0001762 0000144 00000001470 11161616415 013654 0 ustar ligges users # SPECIAL FUNCTIONS
logmdigamma <- function(x)
{
# log(x) - digamma(x)
# Saves computation of log(x) and avoids subtractive cancellation in digamma(x) when x is large
# Gordon Smyth, smyth@wehi.edu.au
# 19 Jan 98. Last revised 9 Dec 2002.
#
z <- x
if(any(omit <- is.na(z) | Re(z) <= 0)) {
ps <- z
ps[omit] <- NA
if(any(!omit)) ps[!omit] <- Recall(z[!omit])
return(ps)
}
if(any(small <- Mod(z) < 5)) {
ps <- z
x <- z[small]
ps[small] <- log(x/(x+5)) + Recall(x+5) + 1/x + 1/(x+1) + 1/(x+2) + 1/(x+3) + 1/(x+4)
if(any(!small)) ps[!small] <- Recall(z[!small])
return(ps)
}
x <- 1/z^2
tail <- ((x * (-1/12 + ((x * (1/120 + ((x * (-1/252 + ((
x * (1/240 + ((x * (-1/132 + ((x * (691/32760 + (
(x * (-1/12 + (3617 * x)/8160)))))))))))))))))))))
1/(2 * z) - tail
}
statmod/R/mixedmodel.R 0000644 0001762 0000144 00000007131 13622172247 014410 0 ustar ligges users # MIXEDMODEL.R
randomizedBlock <- mixedModel2 <- function(formula, random, weights=NULL, only.varcomp=FALSE, data=list(), subset=NULL, contrasts=NULL, tol=1e-6, maxit=50, trace=FALSE)
# REML for mixed linear models with 2 variance components
# Gordon Smyth, Walter and Eliza Hall Institute
# 28 Jan 2003. Last revised 20 October 2005.
{
# Extract model from formula
cl <- match.call()
mf <- match.call(expand.dots = FALSE)
mf$only.varcomp <- mf$tol <- mf$tol <- mf$maxit <- NULL
mf$drop.unused.levels <- TRUE
mf[[1]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
mt <- attr(mf, "terms")
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")
w <- model.weights(mf)
x <- model.matrix(mt, mf, contrasts)
random <- mf[["(random)"]]
# Missing values not allowed
if(any(is.na(y)) || any(is.na(x)) || any(is.na(random))) stop("Missing values not allowed")
if(!is.null(weights)) if(any(is.na(weights))) stop("Missing values not allowed")
# Design matrix for random effects
lev <- unique.default(random)
z <- 0 + (matrix(random,length(random),length(lev)) == t(matrix(lev,length(lev),length(random))))
mixedModel2Fit(y,x,z,w=w,only.varcomp=only.varcomp,tol=tol,maxit=maxit,trace=trace)
}
randomizedBlockFit <- mixedModel2Fit <- function(y,X,Z,w=NULL,only.varcomp=FALSE,tol=1e-6,maxit=50,trace=FALSE)
# REML for mixed linear models with 2 variance components
# Fits the model Y = X*BETA + Z*U + E where BETA is fixed
# and U is random.
#
# GAMMA holds the variance components. The errors E and
# random effects U are assumed to have covariance matrices
# EYE*GAMMA(1) and EYE*GAMMA(2) respectively.
# Gordon Smyth, Walter and Eliza Hall Institute
# Matlab version 19 Feb 94. Converted to R, 28 Jan 2003.
# Last revised 4 Jan 2020.
{
# Prior weights
if(!is.null(w)) {
sw <- sqrt(w)
y <- sw * y
X <- sw * X
}
# Find null space Q of X
X <- as.matrix(X)
Z <- as.matrix(Z)
mx <- nrow(X)
nx <- ncol(X)
nz <- ncol(Z)
fit <- lm.fit(X,cbind(Z,y))
r <- fit$rank
QtZ <- fit$effects[(r+1):mx,1:nz]
# Apply Q to Z and transform to independent observations
mq <- mx-r
if(mq == 0) return(list(varcomp=c(NA,NA)))
s <- La.svd(QtZ,nu=mq,nv=0)
uqy <- crossprod(s$u,fit$effects[(r+1):mx,nz+1])
d <- rep(0,mq)
d[1:length(s$d)] <- s$d^2
dx <- cbind(Residual=1,Block=d)
dy <- uqy^2
# Try unweighted starting values
dfit <- lm.fit(dx,dy)
varcomp <- dfit$coefficients
dfitted.values <- dfit$fitted.values
# Main fit
if(mq > 2 && sum(abs(d)>1e-15)>1 && var(d)>1e-15) {
if(all(dfitted.values >= 0))
start <- dfit$coefficients
else
start <- c(Residual=mean(dy),Block=0)
# fit gamma glm identity link to dy with dx as covariates
dfit <- glmgam.fit(dx,dy,coef.start=start,tol=tol,maxit=maxit,trace=trace)
varcomp <- dfit$coefficients
dfitted.values <- dfit$fitted.values
}
out <- list(varcomp=dfit$coefficients)
#out$reml.residuals <- uqy/sqrt(dfitted.values)
if(only.varcomp) return(out)
# Standard errors for variance components
dinfo <- crossprod(dx,vecmat(1/dfitted.values^2,dx))
out$se.varcomp=sqrt(2*diag(chol2inv(chol(dinfo))))
# fixed effect estimates
s <- La.svd(Z,nu=mx,nv=0)
d <- rep(0,mx)
d[1:length(s$d)] <- s$d^2
v <- drop( cbind(Residual=1,Block=d) %*% varcomp )
mfit <- lm.wfit(x=crossprod(s$u,X),y=crossprod(s$u,y),w=1/v)
out$coefficients <- mfit$coefficients
out$se.coefficients <- sqrt(diag(chol2inv(mfit$qr$qr)))
out
}
statmod/R/invgauss.R 0000644 0001762 0000144 00000026632 13120716704 014122 0 ustar ligges users dinvgauss <- function(x, mean=1, shape=NULL, dispersion=1, log=FALSE)
# Probability density function of inverse Gaussian distribution
# Gordon Smyth
# Created 15 Jan 1998. Last revised 2 Feb 2016.
{
# Dispersion is reciprocal of shape
if(!is.null(shape)) dispersion <- 1/shape
# Check for special cases
spec.x <- any(!is.finite(x) | x<=0)
spec.mean <- any(!is.finite(mean) | mean<=0)
spec.disp <- any(!is.finite(dispersion) | dispersion<=0)
any.special <- spec.x | spec.mean | spec.disp
# If any parameter has length 0, return result of length 0
r <- range(length(x),length(mean),length(dispersion))
if(r[1L]==0L) return(numeric(0L))
# Make arguments same length
n <- r[2L]
if(length(x)0 & phimu & (mu==0 | phi==0)) | x==Inf | (x>0 & phi==Inf)
spike <- (x==mu & (mu==0 | phi==0)) | (x==0 & phi==Inf)
invchisq <- mu==Inf & !(left.limit | right.limit | spike)
NA.cases <- is.na(x) | is.na(mu) | is.na(phi) | mu<0 | phi<0
left.limit[NA.cases] <- FALSE
right.limit[NA.cases] <- FALSE
spike[NA.cases] <- FALSE
invchisq[NA.cases] <- FALSE
logd[left.limit] <- -Inf
logd[right.limit] <- -Inf
logd[spike] <- Inf
logd[invchisq] <- .dinvgaussInfMean(x=x[invchisq],dispersion=phi[invchisq])
logd[NA.cases] <- NA
ok <- !(left.limit | right.limit | spike | invchisq | NA.cases)
logd[ok] <- .dinvgauss(x[ok],mean=mu[ok],dispersion=phi[ok],log=TRUE)
} else {
logd[] <- .dinvgauss(x,mean=mu,dispersion=phi,log=TRUE)
}
if(log) logd else exp(logd)
}
.dinvgauss <- function(x, mean=NULL, dispersion=1, log=FALSE)
# Probability density function of inverse Gaussian distribution
# with no argument checking and assuming mean=1
{
notnullmean <- !is.null(mean)
if(notnullmean) {
x <- x/mean
dispersion <- dispersion*mean
}
d <- (-log(dispersion)-log(2*pi)-3*log(x) - (x-1)^2/dispersion/x)/2
if(notnullmean) d <- d-log(mean)
if(log) d else exp(d)
}
.dinvgaussInfMean <- function(x, dispersion=1)
{
(-log(dispersion) - log(2*pi) - 3*log(x) - 1/dispersion/x) / 2
}
pinvgauss <- function(q, mean=1, shape=NULL, dispersion=1, lower.tail=TRUE, log.p=FALSE)
# Cumulative distribution function of inverse Gaussian distribution
# Gordon Smyth
# Created 15 Jan 1998. Last revised 8 December 2016.
{
# Dispersion is reciprocal of shape
if(!is.null(shape)) dispersion <- 1/shape
# Check for special cases
spec.q <- any(!is.finite(q) | q<=0)
spec.mean <- any(!is.finite(mean) | mean<=0)
spec.disp <- any(!is.finite(dispersion) | dispersion<=0)
spec.cv <- any(mean*dispersion < 1e-14)
any.special <- spec.q | spec.mean | spec.disp | spec.cv
# If any parameter has length 0, return result of length 0
r <- range(length(q),length(mean),length(dispersion))
if(r[1L]==0L) return(numeric(0L))
# Make arguments same length
n <- r[2L]
if(length(q)0 & phimu & (mu==0 | phi==0)) | q==Inf | (q>0 & phi==Inf)
spike <- (q==mu & (mu==0 | phi==0)) | (q==0 & phi==Inf)
invchisq <- mu==Inf & !(left.limit | right.limit | spike)
cv2 <- mu*phi
smallcv <- cv2<1e-14 & !(left.limit | right.limit | spike)
NA.cases <- is.na(q) | is.na(mu) | is.na(phi) | mu<0 | phi<0
left.limit[NA.cases] <- FALSE
right.limit[NA.cases] <- FALSE
spike[NA.cases] <- FALSE
invchisq[NA.cases] <- FALSE
if(lower.tail) {
logp[left.limit] <- -Inf
logp[right.limit] <- 0
} else {
logp[left.limit] <- 0
logp[right.limit] <- -Inf
}
logp[spike] <- 0
logp[invchisq] <- pchisq(1/q[invchisq]/phi[invchisq],df=1,lower.tail=!lower.tail,log.p=TRUE)
logp[smallcv] <- pgamma(q[smallcv],shape=1/cv2[smallcv],scale=cv2[smallcv]*mu[smallcv],lower.tail=lower.tail,log.p=TRUE)
logp[NA.cases] <- NA
ok <- !(left.limit | right.limit | spike | invchisq | smallcv | NA.cases)
logp[ok] <- .pinvgauss(q[ok],mean=mu[ok],dispersion=phi[ok],lower.tail=lower.tail,log.p=TRUE)
} else {
logp <- .pinvgauss(q,mean=mu,dispersion=phi,lower.tail=lower.tail,log.p=TRUE)
}
if(log.p) logp else(exp(logp))
}
.pinvgauss <- function(q, mean=NULL, dispersion=1, lower.tail=TRUE, log.p=FALSE)
# Cumulative distribution function of inverse Gaussian distribution
# without argument checking
# Gordon Smyth
# Created 15 Jan 1998. Last revised 2 May 2016
{
if(!is.null(mean)) {
q <- q/mean
dispersion <- dispersion*mean
}
pq <- sqrt(dispersion*q)
a <- pnorm((q-1)/pq,lower.tail=lower.tail,log.p=TRUE)
b <- 2/dispersion + pnorm(-(q+1)/pq,log.p=TRUE)
if(lower.tail) b <- exp(b-a) else b <- -exp(b-a)
logp <- a+log1p(b)
# Asymptotic right tail
if(!lower.tail) {
i <- (q > 1e6 & q/2/dispersion > 5e5)
if(any(i)) {
q <- q[i]
phi <- dispersion[i]
logp[i] <- 1/phi-0.5*log(pi)-log(2*phi)-1.5*log1p(q/2/phi)-q/2/phi
}
}
if(log.p) logp else exp(logp)
}
rinvgauss <- function(n, mean=1, shape=NULL, dispersion=1)
# Random variates from inverse Gaussian distribution
# Gordon Smyth
# Created 15 Jan 1998. Last revised 27 Feb 2017.
{
# Dispersion is reciprocal of shape
if(!is.null(shape)) dispersion <- 1/shape
# Check n
if(length(n)>1L) n <- length(n) else n <- as.integer(n)
if(n<0L) stop("n can't be negative")
if(n==0L || length(mean)==0L || length(dispersion)==0L) return(numeric(0L))
# Make arguments same length
mu <- rep_len(mean,n)
phi <- rep_len(dispersion,n)
# Setup output vector
r <- rep_len(0,n)
# Non-positive parameters give NA
mu.ok <- (mu > 0 & is.finite(mu))
phi.ok <- (phi > 0 & is.finite(phi))
i <- (mu.ok & phi.ok)
if(!all(i)) {
j <- !i
# Infinite mu is special case
invchisq <- (mu[j]==Inf & phi.ok[j])
invchisq[is.na(invchisq)] <- FALSE
if(any(invchisq)) {
m <- sum(invchisq)
r[j][invchisq] <- rnorm(m)^(-2) / phi[j][invchisq]
j[j][invchisq] <- FALSE
}
infdisp <- (phi[j]==Inf)
infdisp[is.na(infdisp)] <- FALSE
if(any(infdisp)) {
r[j][infdisp] <- 0
j[j][infdisp] <- FALSE
}
r[j] <- NA
n <- sum(i)
if(n==0L) return(r)
}
# Generate chisquare on 1 df
Y <- rnorm(n)^2
# Divide out mu
Yphi <- Y*phi[i]*mu[i]
# Taylor series is more accurate when Y*phi is large
bigphi <- (Yphi > 5e5)
if(any(bigphi)) {
X1 <- Y
X1[bigphi] <- 1 / Yphi[bigphi]
X1[!bigphi] <- 1 + Yphi[!bigphi]/2 * (1 - sqrt(1 + 4/Yphi[!bigphi]))
} else {
X1 <- 1 + Yphi/2 * (1 - sqrt(1 + 4/Yphi))
}
firstroot <- (runif(n) < 1/(1+X1))
r[i][firstroot] <- X1[firstroot]
r[i][!firstroot] <- 1/X1[!firstroot]
# Add mu back in again
r[i] <- mu[i]*r[i]
r
}
qinvgauss <- function(p, mean=1, shape=NULL, dispersion=1, lower.tail=TRUE, log.p=FALSE, maxit=200L, tol=1e-14, trace=FALSE)
# Quantiles of the inverse Gaussian distribution
# using globally convergent Newton iteration.
# Gordon Smyth
# Created 12 May 2014. Last revised 16 June 2017.
#
# Replaced an earlier function by Paul Bagshaw of 23 Dec 1998
{
# Dispersion is reciprocal of shape
if(!is.null(shape)) dispersion <- 1/shape
# Make sure that p is exp(logp)
if(log.p)
logp <- p
else {
p[p<0] <- NA
p[p>1] <- NA
logp <- log(p)
}
p <- exp(logp)
# Make arguments same length
r <- range(length(p),length(mean),length(dispersion))
if(r[1L]==0L) return(numeric(0L))
n <- r[2L]
if(length(p)1e3
k1 <- 1/2/kappa[bigcv]
if(length(k1)) x[bigcv] <- k1*(1-k1^2)
if(trace) {
if(n < 6L)
cat("mode ",x,"\n")
else
cat("quantile(mode) ",quantile(x),"\n")
}
# Identify cases with very small tail probabilities
if(lower.tail) {
small.left <- (logp < -11.51)
small.right <- (logp > -1e-5)
} else {
small.left <- (logp > -1e-5)
small.right <- (logp < -11.51)
}
# For small left tail prob, use inverse chisq as starting value
if(any(small.left)) x[small.left] <- 1/phi[small.left]/qnorm(logp[small.left],lower.tail=lower.tail,log.p=TRUE)^2
# For small right tail prob, use qgamma with same mean and var as starting value
if(any(small.right)) {
alpha <- 1/phi[small.right]
q.gam <- qgamma(logp[small.right],shape=alpha,rate=alpha,lower.tail=lower.tail,log.p=TRUE)
x[small.right] <- pmax(x[small.right],q.gam)
}
step <- function(x,p,logp,phi) {
logF <- .pinvgauss(x,dispersion=phi,lower.tail=lower.tail,log.p=TRUE)
dp <- dlogp <- logp-logF
smallstep <- abs(dlogp) < 1e-5
dp[smallstep] <- exp(logp[smallstep]+log1p(-dlogp[smallstep]/2)) * dlogp[smallstep]
dp[!smallstep] <- p[!smallstep]-exp(logF[!smallstep])
dp / .dinvgauss(x,dispersion=phi)
}
# First Newton step
iter <- 0
dx <- step(x,p,logp,phi)
dx[is.na(dx)] <- 0
sdx <- sign(dx)
if(lower.tail)
x <- x + dx
else
x <- x - dx
i <- (abs(dx) > tol)
if(trace) {
cat("Iter=",iter,"Still converging=",sum(i),"\n")
if(n < 6L)
cat("x ",x,"\ndx ",dx,"\n")
else
cat("quantile(x) ",quantile(x),"\nMax dx ",max(abs(dx)),"\n")
}
# Newton iteration is monotonically convergent from point of inflexion
while(any(i)) {
iter <- iter+1
if(iter > maxit) {
warning("max iterations exceeded")
break
}
dx <- step(x[i],p[i],logp[i],phi[i])
# Change of sign indicates that machine precision has been overstepped
dx[is.na(dx) | dx * sdx[i] < 0] <- 0
if(lower.tail)
x[i] <- x[i] + dx
else
x[i] <- x[i] - dx
i[i] <- (abs(dx)/pmax(x[i],1) > tol)
if(trace) {
cat("Iter=",iter,"Still converging=",sum(i),"\n")
if(n < 6L)
cat("x ",x,"\ndx ",dx,"\n")
else
cat("quantile(x) ",quantile(x),"\nMax dx ",max(abs(dx)),"\n")
}
}
# Mu scales the distribution
q[ok] <- x*mu[ok]
q
}
statmod/R/growthcurve.R 0000644 0001762 0000144 00000006763 14350242106 014641 0 ustar ligges users meanT <- function(y1,y2) {
# Mean t-statistic difference between two groups of growth curves
# Columns are time points, rows are individuals
# Gordon Smyth
# 14 Feb 2003
if(is.null(dim(y1)) || is.null(dim(y2))) return(NA)
y1 <- as.matrix(y1)
y2 <- as.matrix(y2)
if(ncol(y1) != ncol(y2)) stop("Number of time points must match")
m1 <- colMeans(y1,na.rm=TRUE)
m2 <- colMeans(y2,na.rm=TRUE)
v1 <- apply(y1,2,var,na.rm=TRUE)
v2 <- apply(y2,2,var,na.rm=TRUE)
n1 <- apply(!is.na(y1),2,sum)
n2 <- apply(!is.na(y2),2,sum)
s <- ( (n1-1)*v1 + (n2-1)*v2 ) / (n1+n2-2)
t.stat <- (m1-m2) / sqrt(s*(1/n1+1/n2))
weighted.mean(t.stat,w=(n1+n2-2)/(n1+n2),na.rm=TRUE)
}
compareTwoGrowthCurves <- function(group,y,nsim=100,fun=meanT,n0=0.5) {
# Permutation test between two groups of growth curves
# Columns are time points, rows are individuals
# Gordon Smyth
# Created 14 Feb 2003. Last modified 20 Dec 2022.
group <- as.vector(group)
g <- unique(group)
if(length(g) != 2) stop("Must be exactly 2 groups")
stat.obs <- fun(y[group==g[1],,drop=FALSE], y[group==g[2],,drop=FALSE])
asbig <- 0
for (i in 1:nsim) {
pgroup <- sample(group)
stat <- fun(y[pgroup==g[1],,drop=FALSE], y[pgroup==g[2],,drop=FALSE])
if(abs(stat) == abs(stat.obs)) asbig <- asbig+0.5
if(abs(stat) > abs(stat.obs)) asbig <- asbig+1
}
list(stat=stat.obs, p.value=(asbig+n0)/(nsim+n0))
}
compareGrowthCurves <- function(group,y,levels=NULL,nsim=100,fun=meanT,times=NULL,verbose=TRUE,adjust="holm",n0=0.5) {
# All pairwise permutation tests between groups of growth curves
# Columns of y are time points, rows are individuals
# Gordon Smyth
# Craeted 14 Feb 2003. Last modified 20 Dec 2022.
group <- as.character(group)
if(is.null(levels)) {
tab <- table(group)
tab <- tab[tab >= 2]
lev <- names(tab)
} else
lev <- as.character(levels)
nlev <- length(lev)
if(nlev < 2) stop("Less than 2 groups to compare")
if(is.null(dim(y))) stop("y must be matrix-like")
y <- as.matrix(y)
if(!is.null(times)) y <- y[,times,drop=FALSE]
g1 <- g2 <- rep("",nlev*(nlev-1)/2)
stat <- pvalue <- rep(0,nlev*(nlev-1)/2)
pair <- 0
for (i in 1:(nlev-1)) {
for (j in (i+1):nlev) {
if(verbose) cat(lev[i],lev[j])
pair <- pair+1
sel <- group %in% c(lev[i],lev[j])
out <- compareTwoGrowthCurves(group[sel],y[sel,,drop=FALSE],nsim=nsim,fun=fun,n0=n0)
if(verbose) cat("\ ",round(out$stat,2),"\n")
g1[pair] <- lev[i]
g2[pair] <- lev[j]
stat[pair] <- out$stat
pvalue[pair] <- out$p.value
}
}
tab <- data.frame(Group1=g1,Group2=g2,Stat=stat,P.Value=pvalue)
tab$adj.P.Value <- p.adjust(pvalue,method=adjust)
tab
}
plotGrowthCurves <- function(group,y,levels=sort(unique(group)),times=NULL,col=NULL,...) {
# Plot growth curves with colors for groups
# Columns of y are time points, rows are individuals
# Gordon Smyth
# 30 May 2006. Last modified 8 July 2006.
group <- as.character(group)
if(!is.null(levels)) levels <- as.character(levels)
nlev <- length(levels)
if(nlev < 2) stop("Less than 2 groups to compare")
if(is.null(dim(y))) stop("y must be matrix-like")
y <- as.matrix(y)
if(!is.null(times)) y <- y[,times,drop=FALSE]
if(is.null(col)) col <- 1:nlev
group.col <- col[match(group,levels)]
plot(col(y),y,type="n",xlab="Time",ylab="Response",...)
x <- 1:ncol(y)
for (i in 1:nrow(y)) {
lines(x,y[i,],col=group.col[i])
}
yr <- range(y,na.rm=TRUE)
legend(1,yr[2]-diff(yr)/40,legend=levels,col=col,lty=1)
invisible()
}
statmod/R/forward.R 0000644 0001762 0000144 00000002600 12102144571 013710 0 ustar ligges users forward <- function(y,x,xkept=NULL,intercept=TRUE,nvar=ncol(x))
# Forward selection for linear regression
# 30 Jan 2013
{
# Check y
y <- as.numeric(y)
n <- length(y)
# Check x
x <- as.matrix(x)
if(nrow(x) != n) stop("nrow of x must match length of y")
# Check xkept
if(!is.null(xkept)) {
xkept <- as.matrix(xkept)
if(nrow(xkept) != n) stop("nrow of xkept must match length of y")
}
# Add intercept
if(intercept) xkept <- cbind(rep.int(1,n),xkept)
# Sweep out xkept columns
if(is.null(xkept)) {
rank.xkept <- 0
} else {
QR <- qr(xkept)
y <- qr.resid(QR,y)
x <- qr.resid(QR,x)
rank.xkept <- QR$rank
}
# Check nvar
nvar <- min(nvar,ncol(x),n-rank.xkept)
if(nvar <= 0) return(numeric(0))
orderin <- rep.int(0,nvar)
candidates <- 1:ncol(x)
for (nin in 1:nvar) {
if(ncol(x)==1) {
orderin[nin] <- candidates
break
}
# Standardize
y <- y/sqrt(sum(y^2))
x <- t(t(x)/sqrt(colSums(x^2)))
# Next to add
b.y.x <- crossprod(x,y)
bestj <- which.max(abs(b.y.x))
bestx <- x[,bestj]
# Record and remove best covariate
orderin[nin] <- candidates[bestj]
candidates <- candidates[-bestj]
x <- x[,-bestj,drop=FALSE]
# Orthogonalize remaining wrt best covariate
y <- y - b.y.x[bestj]*bestx
b.x.x <- crossprod(x,bestx)
x <- x - matrix(bestx,ncol=1) %*% matrix(b.x.x,nrow=1)
}
orderin
}
statmod/R/sagetest.R 0000644 0001762 0000144 00000002343 12002172210 014055 0 ustar ligges users # SAGE.R
sage.test <- function(x, y, n1=sum(x), n2=sum(y))
# Exact binomial probabilities for comparing SAGE libraries
# Gordon Smyth
# 15 Nov 2003. Last modified 20 July 2012.
{
if(any(is.na(x)) || any(is.na(y))) stop("missing values not allowed")
x <- round(x)
y <- round(y)
if(any(x<0) || any(y<0)) stop("x and y must be non-negative")
if(length(x) != length(y)) stop("x and y must have same length")
n1 <- round(n1)
n2 <- round(n2)
if(!missing(n1) && any(x>n1)) stop("x cannot be greater than n1")
if(!missing(n2) && any(y>n2)) stop("y cannot be greater than n2")
size <- x+y
p.value <- rep(1,length(x))
if(n1==n2) {
i <- (size>0)
if(any(i)) {
x <- pmin(x[i],y[i])
size <- size[i]
p.value[i] <- pmin(2*pbinom(x,size=size,prob=0.5),1)
}
return(p.value)
}
prob <- n1/(n1+n2)
if(any(big <- size>10000)) {
ibig <- (1:length(x))[big]
for (i in ibig) p.value[i] <- chisq.test(matrix(c(x[i],y[i],n1-x[i],n2-y[i]),2,2))$p.value
}
size0 <- size[size>0 & !big]
if(length(size0)) for (isize in unique(size0)) {
i <- (size==isize)
p <- dbinom(0:isize,prob=prob,size=isize)
o <- order(p)
cumsump <- cumsum(p[o])[order(o)]
p.value[i] <- cumsump[x[i]+1]
}
p.value
}
statmod/R/tweedie.R 0000644 0001762 0000144 00000004037 13753602046 013711 0 ustar ligges users ## TWEEDIE.R
tweedie <- function(var.power=0, link.power=1-var.power)
# Tweedie generalized linear model family
# Gordon Smyth
# 22 Oct 2002. Last modified 25 Aug 2020.
{
lambda <- link.power
if(is.character(lambda)) {
m <- match(lambda,c("identity","log","inverse"))
if(is.na(m))
stop("link.power should be a number")
else {
lambda <- c(1,0,-1)[m]
message("Setting link.power = ",lambda)
}
}
if(lambda==0) {
linkfun <- function(mu) log(mu)
linkinv <- function(eta) pmax(exp(eta), .Machine$double.eps)
mu.eta <- function(eta) pmax(exp(eta), .Machine$double.eps)
valideta <- function(eta) TRUE
} else {
linkfun <- function(mu) mu^lambda
linkinv <- function(eta) eta^(1/lambda)
mu.eta <- function(eta) (1/lambda) * eta^(1/lambda - 1)
valideta <- function(eta) TRUE
}
p <- var.power
if(is.character(p)) {
m <- match(p,c("gaussian","poisson","Gamma","gamma","inverse.gaussian"))
if(is.na(m))
stop("var.power should be a number")
else {
p <- c(0,1,2,2,3)[m]
message("Setting var.power = ",p)
}
}
variance <- function(mu) mu^p
if(p == 0)
validmu <- function(mu) TRUE
else if(p > 0)
validmu <- function(mu) all(mu >= 0)
else
validmu <- function(mu) all(mu > 0)
dev.resids <- function(y, mu, wt) {
y1 <- y + 0.1*(y == 0)
if (p == 1)
theta <- log(y1/mu)
else
theta <- ( y1^(1-p) - mu^(1-p) ) / (1-p)
if (p == 2)
# Returns a finite somewhat arbitrary residual for y==0, although theoretical value is -Inf
kappa <- log(y1/mu)
else
kappa <- ( y^(2-p) - mu^(2-p) ) / (2-p)
2 * wt * (y*theta - kappa)
}
initialize <- expression({
n <- rep(1, nobs)
mustart <- y + 0.1 * (y == 0)
})
aic <- function(y, n, mu, wt, dev) NA
structure(list(
family = "Tweedie", variance = variance, dev.resids = dev.resids, aic = aic,
link = paste("mu^",as.character(lambda),sep=""), linkfun = linkfun, linkinv = linkinv,
mu.eta = mu.eta, initialize = initialize, validmu = validmu, valideta = valideta),
class = "family")
}
statmod/R/expectedDeviance.R 0000644 0001762 0000144 00000010220 14352706675 015523 0 ustar ligges users expectedDeviance <- function(mu, family="binomial", binom.size, nbinom.size, gamma.shape)
# Expectation and variance of the unit deviance for linear exponential families
# Lizhong Chen and Gordon Smyth
# Created 02 October 2022, last revised 28 December 2022.
{
# For simplicity, NA inputs or invalid arguments are not allowed and will generate an error.
# Output will preserve dimensions and attributes of `mu`.
out <- list(mean=mu,variance=mu)
m <- as.numeric(mu)
length.m <- length(m)
if(!length.m) return(out)
# Check family
if(identical(family,"Poisson")) family <- "poisson"
if(identical(family,"gamma")) family <- "Gamma"
family <- match.arg(family,c("binomial","gaussian","Gamma","inverse.gaussian","poisson","negative.binomial"))
if(identical(family,"binomial")) {
# Check binom.size
binom.size <- as.integer(binom.size)
length.n <- length(binom.size)
if(!identical(length.n,1L) && !identical(length.n,length.m))
stop("binom.size must have length 1 or length must agree with mu")
min.n <- min(binom.size)
if(is.na(min.n)) stop("NAs not allowed in binom.size")
if(min.n < 1) stop("binom.size must be >= 1")
# Check for permissable mu
min.m <- min(m)
max.m <- max(m)
if(is.na(min.m)) stop("NAs not allowed in mu")
if(min.m < 0 || max.m > 1) stop("binomial mu must be between 0 and 1")
big.n <- 200L
C.out <- .C("mbinomdev", m, binom.size,
mean = double(length.m), variance = double(length.m),
length.m, length.n, big.n)[c(3,4)]
out$mean[] <- C.out$mean
out$variance[] <- C.out$variance
}
if(identical(family,"gaussian")) {
out$mean[] <- 1
out$variance[] <- 2
}
if(identical(family,"Gamma")) {
gamma.shape <- as.numeric(gamma.shape)
length.s <- length(gamma.shape)
if(!identical(length.s,1L) && !identical(length.s,length.m))
stop("gamma.shape must have length 1 or length must agree with mu")
min.s <- min(gamma.shape)
if(is.na(min.s)) stop("NAs not allowed in gamma.shape")
if(min.s <=0) stop("gamma.shape should be positive")
out$mean[] <- meanval.digamma(-gamma.shape) * gamma.shape
out$variance[] <- 2*d2cumulant.digamma(-gamma.shape) * gamma.shape * gamma.shape
}
if(identical(family,"inverse.gaussian")) {
min.m <- min(m)
if(is.na(min.m)) stop("NAs not allowed in mu")
if(min.m < 0) stop("inverse.gaussian mu must be non-negative")
out$mean[] <- 1
out$variance[] <- 2
}
if(identical(family,"poisson")) {
min.m <- min(m)
if(is.na(min.m)) stop("NAs not allowed in mu")
if(min.m < 0) stop("Poisson mu must be non-negative")
m <- pmin(m,1e7)
C.out <- .C("mpoisdev", m,
mean = double(length.m), variance = double(length.m),
length.m)[c(2,3)]
out$mean[] <- C.out$mean
out$variance[] <- C.out$variance
}
if(identical(family,"negative.binomial")) {
# Check nbinom.size
nbinom.size <- as.numeric(nbinom.size)
length.s <- length(nbinom.size)
if(!identical(length.s,1L) && !identical(length.s,length.m))
stop("nbinom.size must have length 1 or length must agree with mu")
min.s <- min(nbinom.size)
if(is.na(min.s)) stop("NAs not allowed in nbinom.size")
if(min.s <= 0) stop("nbinom.size must be positive")
# Large size corresponds to Poisson
if(min.s > 1e7) return(Recall(mu=mu,family="poisson"))
nbinom.size <- pmin(nbinom.size,1e7)
# Need to avoid very small size parameters
# Chebychev approximation works for size > 1/4. For a limited range of
# smaller values, direct summation is used.
if(min.s <= 0.25) {
limit.size <- pmin(mu*mu/(1e5 - 10),0.25) + 1e-10
nbinom.size <- pmax(nbinom.size,limit.size)
}
# Check for permissable mu
min.m <- min(m)
if(is.na(min.m)) stop("NAs not allowed in mu")
if(min.m < 0) stop("Negative binomial mu must be non-negative")
m <- pmin(m,1e7)
C.out <- .C("mnbinomdev", m, nbinom.size,
mean = double(length.m), variance = double(length.m),
length.m, length.s)[c(3,4)]
out$mean[] <- C.out$mean
out$variance[] <- C.out$variance
}
out
}
statmod/R/fitNBP.R 0000644 0001762 0000144 00000004554 11226536532 013410 0 ustar ligges users ## fitNBP.R
fitNBP <- function(y,group=NULL,lib.size=colSums(y),tol=1e-5,maxit=40,verbose=FALSE)
# Fit multi-group negative-binomial model to SAGE data
# with Pearson estimation of common overdispersion
# Gordon Smyth
# 8 July 2006. Last modified 13 July 2009.
{
# Argument checking
y <- as.matrix(y)
if(is.null(group)) group <- rep(1,ncol(y))
group <- as.factor(group)
if(length(group) != ncol(y)) stop("length(group) must agree with ncol(y)")
# Derived quantities
ngenes <- nrow(y)
nlib <- ncol(y)
ngroups <- length(levels(group))
res.df <- ncol(y)-ngroups
ind <- matrix(FALSE,nlib,ngroups)
for (i in 1:ngroups) ind[,i] <- group==levels(group)[i]
# Starting values
offset <- matrix(1,ngenes,1) %*% log(lib.size)
mu <- pmax(y,0.5)
phi <- 0
w <- mu
z <- w*(log(mu)-offset)
beta <- matrix(0,ngenes,ngroups)
eta <- offset
for (i in 1:ngroups) {
beta[,i] <- rowSums(z[,ind[,i],drop=FALSE])/rowSums(w[,ind[,i],drop=FALSE])
eta[,ind[,i]] <- eta[,ind[,i]]+beta[,i]
}
if(verbose) cat("mean coef",colMeans(beta),"\n")
mu <- exp(eta)
# Alternating iterations
iter <- 0
repeat{
# Update phi
iter <- iter+1
if(iter > maxit) {
warning("maxit exceeded")
break
}
e2 <- (y-mu)^2
dV <- mu*mu
# Need to ensure phi is converging from below
inneriter <- 0
repeat {
inneriter <- inneriter+1
if(inneriter > 10) stop("problem with inner iteration")
V <- mu*(1+phi*mu)
X2 <- sum(e2/V)/res.df-ngenes
if(X2 >= 0) {
low <- phi
break
} else {
if(phi==0) break
if(inneriter > 4)
phi <- 0.9*phi
else
phi <- (low+phi)/2
if(verbose) cat("mean disp",phi,"\n")
}
}
if(X2<0) break
dX2 <- sum(e2/V/V*dV)/res.df
step.phi <- X2/pmax(dX2,1e-6)
phi <- phi+step.phi
conv.crit <- step.phi/(phi+1)
if(verbose) cat("Conv criterion",conv.crit,"\n")
if(conv.crit < tol) break
# Update mu
w <- mu/(1+phi*mu)
z <- (y-mu)/V*mu
eta <- offset
for (i in 1:ngroups) {
beta[,i] <- beta[,i]+rowSums(z[,ind[,i],drop=FALSE])/rowSums(w[,ind[,i],drop=FALSE])
eta[,ind[,i]] <- eta[,ind[,i]]+beta[,i]
}
if(verbose) cat("mean coef",colMeans(beta),"\n")
if(verbose) cat("disp",phi,"\n")
mu <- exp(eta)
}
colnames(beta) <- levels(group)
dimnames(mu) <- dimnames(y)
list(coefficients=beta,fitted.values=mu,dispersion=phi)
}
statmod/data/ 0000755 0001762 0000144 00000000000 14616616041 012643 5 ustar ligges users statmod/data/welding.rdata 0000644 0001762 0000144 00000002344 11161616415 015311 0 ustar ligges users RDX2
X
welding
ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
ÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
ÿÿÿÿ ÿÿÿÿ ÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿ ÿÿÿÿ ÿÿÿÿ
ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ
ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ
ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ
ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
ÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿ ÿÿÿÿÿÿÿÿ
ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿ ÿÿÿÿÿÿÿÿ ÿÿÿÿ @EÙ™™™™š@D™™™™š@E333333@FY™™™™š@E333333@Fó33333@E™™™™š@DLÌÌÌÌÍ@E333333@FÀ @EÌÌÌÌÌÍ@DLÌÌÌÌÍ@F @D™™™™š@E@ @G@ names
Rods Drying Material Thickness Angle Opening Current Method
Preheating Strength class
data.frame row.names 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 þ þ statmod/src/ 0000755 0001762 0000144 00000000000 14616616043 012523 5 ustar ligges users statmod/src/gaussq2.f 0000644 0001762 0000144 00000010624 12760526763 014271 0 ustar ligges users C This function was extracted from the file gaussq.f, downloaded from
C http://www.netlib.org/go/gaussq.f on 7 August 2012.
C The function was modified for portability (Aug and Sep 2012) and
C updated to Fortran 77 (28 Aug 2016) by Gordon Smyth.
C All modified lines are commented out with a capital "C" and the new
C version follows immediately.
subroutine gausq2(n, d, e, z, ierr)
c
c this subroutine is a translation of an algol procedure,
c num. math. 12, 377-383(1968) by martin and wilkinson,
c as modified in num. math. 15, 450(1970) by dubrulle.
c handbook for auto. comp., vol.ii-linear algebra, 241-248(1971).
c this is a modified version of the 'eispack' routine imtql2.
c
c this subroutine finds the eigenvalues and first components of the
c eigenvectors of a symmetric tridiagonal matrix by the implicit ql
c method.
c
c on input:
c
c n is the order of the matrix;
c
c d contains the diagonal elements of the input matrix;
c
c e contains the subdiagonal elements of the input matrix
c in its first n-1 positions. e(n) is arbitrary;
c
c z contains the first row of the identity matrix.
c
c on output:
c
c d contains the eigenvalues in ascending order. if an
c error exit is made, the eigenvalues are correct but
c unordered for indices 1, 2, ..., ierr-1;
c
c e has been destroyed;
c
c z contains the first components of the orthonormal eigenvectors
c of the symmetric tridiagonal matrix. if an error exit is
c made, z contains the eigenvectors associated with the stored
c eigenvalues;
c
c ierr is set to
c zero for normal return,
c j if the j-th eigenvalue has not been
c determined after 30 iterations.
c
c ------------------------------------------------------------------
c
integer i, j, k, l, m, n, ii, mml, ierr
C real*8 d(n), e(n), z(n), b, c, f, g, p, r, s, machep
double precision d(n), e(n), z(n), b, c, f, g, p, r, s, machep
C real*8 dsqrt, dabs, dsign, d1mach
double precision dsqrt, dabs, dsign
c
C machep=d1mach(4)
machep = 2.0d0**(-52.0d0)
c
ierr = 0
if (n .eq. 1) go to 1001
c
e(n) = 0.0d0
do 240 l = 1, n
j = 0
c :::::::::: look for small sub-diagonal element ::::::::::
105 do 110 m = l, n
if (m .eq. n) go to 120
if (dabs(e(m)) .le. machep * (dabs(d(m)) + dabs(d(m+1))))
x go to 120
110 continue
c
120 p = d(l)
if (m .eq. l) go to 240
if (j .eq. 30) go to 1000
j = j + 1
c :::::::::: form shift ::::::::::
g = (d(l+1) - p) / (2.0d0 * e(l))
r = dsqrt(g*g+1.0d0)
g = d(m) - p + e(l) / (g + dsign(r, g))
s = 1.0d0
c = 1.0d0
p = 0.0d0
mml = m - l
c
c :::::::::: for i=m-1 step -1 until l do -- ::::::::::
do 200 ii = 1, mml
i = m - ii
f = s * e(i)
b = c * e(i)
if (dabs(f) .lt. dabs(g)) go to 150
c = g / f
r = dsqrt(c*c+1.0d0)
e(i+1) = f * r
s = 1.0d0 / r
c = c * s
go to 160
150 s = f / g
r = dsqrt(s*s+1.0d0)
e(i+1) = g * r
c = 1.0d0 / r
s = s * c
160 g = d(i+1) - p
r = (d(i) - g) * s + 2.0d0 * c * b
p = s * r
d(i+1) = g + p
g = c * r - b
c :::::::::: form first component of vector ::::::::::
f = z(i+1)
z(i+1) = s * z(i) + c * f
C 200 z(i) = c * z(i) - s * f
z(i) = c * z(i) - s * f
200 continue
c
d(l) = d(l) - p
e(l) = g
e(m) = 0.0d0
go to 105
240 continue
c
c :::::::::: order eigenvalues and eigenvectors ::::::::::
do 300 ii = 2, n
i = ii - 1
k = i
p = d(i)
c
do 260 j = ii, n
if (d(j) .ge. p) go to 260
k = j
p = d(j)
260 continue
c
if (k .eq. i) go to 300
d(k) = d(i)
d(i) = p
p = z(i)
z(i) = z(k)
z(k) = p
300 continue
c
go to 1001
c :::::::::: set error -- no convergence to an
c eigenvalue after 30 iterations ::::::::::
1000 ierr = l
1001 return
c :::::::::: last card of gausq2 ::::::::::
end
statmod/src/init.c 0000644 0001762 0000144 00000001563 14352674050 013636 0 ustar ligges users #include
#include
#include // for NULL
#include
/* .Fortran calls */
extern void F77_NAME(gausq2)(void *, void *, void *, void *, void *);
static const R_FortranMethodDef FortranEntries[] = {
{"gausq2", (DL_FUNC) &F77_NAME(gausq2), 5},
{NULL, NULL, 0}
};
/* .C calls */
extern void mpoisdev (double *, double *, double *, int *);
extern void mbinomdev (double *, int *, double *, double *, int *, int *, int *);
extern void mnbinomdev (double *, double *, double *, double *, int *, int *);
static const R_CMethodDef CEntries[] = {
{"mpoisdev", (DL_FUNC) &mpoisdev, 4},
{"mbinomdev", (DL_FUNC) &mbinomdev, 7},
{"mnbinomdev", (DL_FUNC) &mnbinomdev, 6},
{NULL, NULL, 0}
};
void R_init_statmod(DllInfo *dll)
{
R_registerRoutines(dll, CEntries, NULL, FortranEntries, NULL);
R_useDynamicSymbols(dll, FALSE);
}
statmod/src/expectedDeviance.c 0000644 0001762 0000144 00000163521 14352674050 016136 0 ustar ligges users #include
#include
/* small threshold to control extremely small mu */
const double low_bound = 1e-32;
/* Poisson distribution weights */
const double pois_alpha_weights[] = {0.992269079723461,-0.00876330120996393,-0.000899675388042544,7.89660557196009e-05,-2.57354549725262e-05,1.08697519751391e-05,-5.35069556616911e-06,2.84372162217423e-06,-1.50386201954269e-06,6.57650652677658e-07,1.85780813766284,1.24247480214702,-0.21715340185502,-0.0631511240632299,0.00340555750851111,0.00803518029869897,-0.00193332946300635,0.000422285597551136,-0.000358792369207728,0.00018078402690016,1.91315214581754,-0.856602731401166,0.14506703274623,0.0282393880322191,-0.0342290401769809,0.0164475718752771,-0.00537219169999174,0.00111151176883841,3.53510678861024e-06,-0.000112100033404627,0.993770062727655,-0.137524078134838,0.0577356484590452,-0.0146150722546239,0.00321203741534916,-0.000697567780801707,0.000148410349572635,-2.99784860990367e-05,5.64558922538649e-06,-9.49347957962532e-07,0.963842126602874,0.0400326805227385,-0.0189806647831021,0.00660614625198861,-0.000644918979770783,-0.00133133783618231,0.00141013711041267,-0.000921896816221545,0.000464099586562025,-0.00017597576489865};
const double pois_kappa_weights[] = {1.98775180998087,-0.0140162756693573,-0.00156029275453937,0.000123049848636432,-4.08304177779774e-05,1.71720371481344e-05,-8.42336547993185e-06,4.4646802776689e-06,-2.35658416200667e-06,1.02938173103251e-06,1.60458875341805,1.477085480242,-0.19980775848221,-0.131588940571592,0.0220740847667339,0.00967036309540797,-0.0016317349486263,-0.000935545763694168,0.000214605308912541,5.45674582952849e-05,2.03462160780017,-0.732803114491053,0.0825292616057215,0.0319556185536422,-0.0247880343267009,0.0100493097517216,-0.00293285060419899,0.000582324399808305,-2.62735420803323e-05,-3.47213262170909e-05,1.08644201311408,-0.190240854290349,0.0875963322357097,-0.026205913685883,0.0065783791460467,-0.00160331441788305,0.000386861436014592,-8.86429171986961e-05,1.855123830804e-05,-3.33626166532652e-06,0.989053963537709,0.015979160846486,-0.00859775363058498,0.0032276071532244,-0.000399428679513209,-0.000588586841491422,0.00065224130088336,-0.000431002058576289,0.000218230833245675,-8.32345704255971e-05};
/* The Chebyshev approximation is piece-wise
I can not find a way to visit the const long vector quickly
here I choose a simple way using iter as an indictor
When mu increases to infinity, the approximation is o(n^3)
*/
double pois_alpha (double mu){
double out = 0, x = 0, logmu = 0; int iter = 0;
if(mu < low_bound) return out;
else if(mu < 0.0200) x = 2*mu/0.02 - 1, logmu = log(mu);
else if(mu < 0.4249) x = (2*mu-0.4449)/0.4049, iter = 10;
else if(mu < 1.5000) x = (2*mu-1.9249)/1.0751, iter = 20;
else if(mu < 3.5440) x = (2*mu-5.0440)/2.0440, iter = 30;
else if(mu < 20.000) x = (2*mu-23.544)/16.456, iter = 40;
else return out = 1 - 1/(6*mu) - 1/(2*mu*mu);
/* we use the recurrsive formula to compute values of Chebyshev polynomials
to avoid duplicated computation
*/
double x_cheb[10]; x_cheb[0] = 1, x_cheb[1] = x;
out = pois_alpha_weights[iter]+pois_alpha_weights[iter+1]*x;
for(int i=2; i < 10; ++i) x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], out += pois_alpha_weights[iter+i]*x_cheb[i];
/* trend for mu close to 0 */
if(mu < 0.0200) out = -out*logmu/((1+logmu)*(1+logmu));
return out;
}
double pois_kappa (double mu){
double out = 0, x = 0, logmu = 0; int iter = 0;
if(mu < low_bound) return out;
else if(mu < 0.0200) x = 2*mu/0.02 - 1, logmu = log(mu)/(1+log(mu));
else if(mu < 0.4966) x = (2*mu-0.5166)/0.4766, iter = 10;
else if(mu < 1.5000) x = (2*mu-1.9966)/1.0034, iter = 20;
else if(mu < 4.2714) x = (2*mu-5.7714)/2.7714, iter = 30;
else if(mu < 20.000) x = (2*mu-24.2714)/15.7286, iter = 40;
else return out = 1 - 1/(2.5*mu*mu);
double x_cheb[10]; x_cheb[0] = 1, x_cheb[1] = x;
out = pois_kappa_weights[iter]+pois_kappa_weights[iter+1]*x;
for(int i=2; i < 10; ++i) x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], out += pois_kappa_weights[iter+i]*x_cheb[i];
/* trend for mu close to 0 */
if(mu < 0.0200) out=out*mu*logmu*logmu;
return out;
}
/* our approximation to mean and variance of the unit deviance is not direct
because of the complexity of variance function
instead, we approximate the weight functions alpha and kappa
which have the similar and simple trend
Then we recover the mean and variance from the weight functions
*/
void mpoisdev (double *mu, double *mans, double *vans, int *len){
for(int i=0; i<(*len); ++i){
mans[i] = 0, vans[i]=0; // zero output for extremely small mu
if(mu[i] > low_bound){
double amu = pois_alpha(mu[i]), kmu=pois_kappa(mu[i]);
mans[i] = kmu/amu, vans[i] = 2*kmu/(amu*amu);
}
}
return;
}
/* Binomial distribution */
void mbinomdev (double *prob, int *size, double *mans, double *vans, int *len, int *slen, int *n){
for(int i=0; i< (*len); ++i){
double pp=prob[i]; int mm=size[i % (*slen)];
/* symmetry of probability for binomial distribution */
if(1-pp < pp) pp=1-pp;
double mu=pp*mm;
if(mu < low_bound) mans[i]=0, vans[i]=0;
/* quick formula for size = 1 */
else if (mm < 2){
mans[i] = -2*(pp*log(pp) + (1-pp)*log(1-pp));
double logpp = log((1-pp)/pp);
vans[i] = 4*pp*(1-pp)*logpp*logpp;
}
/* direct sum for small size < n, the default is 200 */
else if (mm < (*n)){
double pr[mm+1], de[mm+1];
pr[0]=dbinom(0,mm,pp,0), pr[mm]=dbinom(mm,mm,pp,0);
de[0]=2*mm*log(1/(1-pp)), de[mm]=2*mm*log(1/(pp));
double dd=pr[0]*de[0]+pr[mm]*de[mm];
for(int k=1; k < mm; ++k){
pr[k]=dbinom(k,mm,pp,0);
de[k]=2*(k*log(k/(mu))+(mm-k)*log((mm-k)/(mm-mu)));
dd += pr[k]*de[k];
}
mans[i]=dd;
vans[i] = pr[0]*(de[0]-dd)*(de[0]-dd)+pr[mm]*(de[mm]-dd)*(de[mm]-dd);
for(int j=1; j < mm; ++j) vans[i] += pr[j]*(de[j]-dd)*(de[j]-dd);
}
/* Poisson approximation for binomial distribution */
else{
double amu = pois_alpha(mu), kmu=pois_kappa(mu);
mans[i] = kmu/amu, vans[i] = 2*kmu/(amu*amu);
}
}
return;
}
/* Negative binomial distribution */
/* We provide three cases to compute the approximation to
the mean and variance of unit deviance of negative binomial distribution
based on the range of size (1/dispersion)
The reason is that we can not know the limit behavior for NB distribution
1. when the dispersion is small, we use a simple approximation for a range of mu
2. when the dispersion is a little large, we use the trend decomposition for large mu
3. when the dispersion is large, we use direct sum to compute for a limit range of mu
*/
const double sweet_cutoff1=0.736, sweet_cutoff2=4.00;
// Case 1: phi < sweet_cutoff1, quick approximation for slightly large mu (mu>20)
const double nb_a_1_1[]={1.04049914108557,0.0127829261351696,-0.00360455781917675,0.00169216027426875,-0.000932212854791133,0.000515955109346805,-0.000233370296542144,0.039204768073801,0.0124949086947064,-0.00351407730783974,0.00164497502188393,-0.000905424668193214,0.000500833449545262,-0.000226229529813676,-0.00120807372808612,-0.000268829996423627,8.48980124941129e-05,-4.40956191245684e-05,2.5209920352366e-05,-1.42256360918374e-05,6.49146898845057e-06,7.90086546632299e-05,1.7370412236139e-05,-5.25206676548285e-06,2.74417720188475e-06,-1.573608026899e-06,8.89879048604737e-07,-4.06545231382484e-07,-6.55455243538993e-06,-1.55533745363278e-06,4.05582620479861e-07,-2.17596237102604e-07,1.25249172035386e-07,-7.09433688382276e-08,3.24347786296094e-08,6.22832528839386e-07,1.69292458244868e-07,-3.4362367794877e-08,1.94602405615533e-08,-1.12653831527225e-08,6.39525950737642e-09,-2.92661653851364e-09,-6.46069021535491e-08,-2.10435790040596e-08,2.92723268357146e-09,-1.8425346846335e-09,1.07695805239289e-09,-6.13657623352106e-10,2.8124615388151e-10,1.06424701129544,-0.00445227760352371,-0.00812278333788542,0.0065250301476989,-0.00155168300170678,0.000534749169753732,-0.000199852018701397,0.0598095363563134,-0.00724465687163299,-0.00792637800128617,0.00654673850950836,-0.0015993633481645,0.000574403119281069,-0.000265049420968128,-0.00386234266184615,-0.00222288913294229,0.000243267365215804,1.70577521913158e-05,-3.76973638690368e-05,-6.81694428657795e-06,7.5387948087131e-06,0.000486626937461981,0.000453286454186866,4.68454695450085e-05,-1.96077488303009e-05,-3.76665810544259e-06,1.99716527656491e-06,-2.13931539156521e-07,-7.63345309731219e-05,-8.39766671322446e-05,-1.41022939211181e-05,2.7766199703885e-06,1.28985391127772e-06,-8.59865871701407e-08,-6.65035381168432e-08,1.32416700591369e-05,1.5636556863828e-05,2.99560885605302e-06,-3.91923794531312e-07,-2.3791530594303e-07,-1.18988827428514e-08,1.26538480275952e-08,-2.36309694132414e-06,-2.88685662926369e-06,-5.83128390212439e-07,6.00861732871828e-08,3.99610130695816e-08,3.44600487993849e-09,-1.88365327478652e-09,1.18525897060528,0.110622667675842,-0.0312709289670913,-0.00471845164893182,0.00568273171751003,-0.00266120079391508,0.000863763918906479,0.179615115315884,0.115586391897639,-0.0286043133961031,-0.00567849513547171,0.00582982419494136,-0.0025515830961685,0.000765890449348615,-0.00500183038775851,0.00401040800281335,0.00249871059318371,-0.000834536966280148,5.3685139567558e-05,0.000139880414808427,-9.38061585820301e-05,0.000465335006171737,-0.000843463634004466,-0.000144241295748217,0.000112764065432697,-7.49013718670456e-05,2.16222577426405e-05,-6.31043059849805e-07,-0.000120696524771701,0.000101920368955321,1.81287018034102e-05,-1.25019661425765e-05,1.48471005362438e-05,-7.100360218617e-06,2.04104488493934e-06,3.35975385446848e-05,-6.91384424492635e-06,-3.42736805195046e-06,1.90216717199321e-06,-2.58282226787259e-06,1.34105601946279e-06,-4.62285763372737e-07,-8.86279025545242e-06,-1.61640138437832e-06,4.87589207033766e-07,-3.7120970648758e-07,4.4000491267876e-07,-2.15051162638944e-07,7.50558076331363e-08,1.19544438789949,-0.0773100100554574,-0.00492889189508714,0.00349917759124764,-0.000630069859470966,7.5664290041388e-05,3.19847626071802e-06,0.212049412445435,-0.0623720849879723,-0.00565013585624764,0.00323979845792352,-0.000615217145014969,7.53241210873651e-05,-5.15454196224282e-06,0.0135242642247185,0.0122443868397377,-0.000645509764621205,-0.000154889669365253,1.14861054572146e-05,3.85150436726167e-06,-6.24947181321617e-07,-0.0026722443881629,-0.00223650358184969,5.14601588431917e-05,8.10922321881989e-05,-2.1460567026664e-06,-2.55578951600511e-06,4.0720062807818e-07,0.000397676639522537,0.000399714773806229,-2.95662441419623e-05,-2.84024606483782e-05,5.42937934241391e-07,9.21938274203052e-07,-9.7304942841531e-08,-2.51256487247361e-05,-3.99600654832094e-05,1.72966752433537e-05,8.82368754936036e-06,-1.11695321988844e-07,-3.3375599713366e-07,2.15921415421398e-08,-1.27833636664884e-05,-7.42633007900127e-06,-7.09805069751622e-06,-2.44469403463076e-06,3.93701365634999e-08,1.06064543202022e-07,-4.14675873596401e-09,1.0225567220461,-0.0673925936177268,0.0212753698769062,-0.00458336079276947,0.000456790781947487,7.56225994568141e-05,-3.29624763155598e-05,0.0541208982148202,-0.0716914555311019,0.0175474809277264,-0.00315179676762023,0.00030597647545073,4.83869507480045e-05,-3.23169564224085e-05,0.0301271743662228,0.000905455043074157,-0.00327082016952318,0.000883937996216929,-0.00010416961367834,-9.71017918700334e-06,7.80270018611677e-06,-0.00294828536697095,0.0029539363538755,0.00069829678072009,-0.000382241782614151,5.4590469528186e-05,7.08704105324809e-06,-4.96234618603406e-06,-0.000651426477171804,-0.00156161830675502,1.25268568367179e-05,0.000152447697936549,-3.42978590767859e-05,-1.65415392077584e-06,2.4698572262237e-06,0.000515651163499266,0.000508236817598213,-0.000113592264780958,-4.91891828540802e-05,1.862504151202e-05,-4.22600136996305e-07,-1.09139557488312e-06,-0.000186298449474523,-0.000111791314945222,6.43037922830365e-05,1.16263302845459e-05,-7.75343230668744e-06,5.73350297349161e-07,3.91899950830608e-07,0.961649944581677,-0.00769554332509738,0.00221807977830475,-0.000584596744438663,0.000162468816478291,-5.69505081476282e-05,-6.02670291160918e-06,-0.0229737788535761,-0.0154055501813675,0.00373539125095005,-0.00079289204340887,0.000157278185698056,-2.94080741251818e-05,5.85366352375027e-06,0.0208591900989835,-0.00684424897975748,0.000831366984970052,-3.10246373042132e-05,-1.81120619589943e-05,6.89709338033865e-06,-2.02099126676063e-06,0.0028249579856111,0.00169019911470862,-0.000630034157757312,0.000115692406348481,-1.15422520759204e-05,-8.79578182834161e-07,6.35910698929679e-07,-0.00192392363209026,0.000401300963184934,0.000159381778478925,-6.81190348617846e-05,1.42468124967748e-05,-1.59916578470436e-06,-2.35284913434789e-08,0.000437508313134998,-0.000437086420173263,3.41143137077315e-05,2.01189582481101e-05,-8.31369698659812e-06,1.6763257238898e-06,-1.75898013783907e-07,-3.32063933269639e-05,0.000156510669826146,-4.45195427650763e-05,-1.08635372960636e-06,3.07547659524779e-06,-8.92310634907793e-07,1.36516152111499e-07};
const double nb_a_1_2[]={0.955633454636176,-0.0353017999327798,0.014801527359565,0.00398866639936046,-0.00141861487166827,4.78412981759927e-05,8.0003971219361e-05,0.95405198091524,-0.0393730367060334,0.0116733341309116,0.00379776138108256,-0.000896666497542174,-8.33239067378239e-05,5.25286614834842e-05,0.953241775830876,-0.0415342139986733,0.00968827990430808,0.00342743877143424,-0.000542803055687517,-0.000113755226167609,7.86348198228029e-06,0.952500080216221,-0.043546376957867,0.00743653256730117,0.0026934491727019,-0.000152524833664607,-8.40494492726932e-05,-5.77702773907796e-05,0.952046538229577,-0.0447035472302332,0.00560242980315084,0.00170281148403691,0.000105282375830592,-2.62704164066942e-06,-9.59567582148542e-05,0.463662750451396,-0.49762028390154,0.0361887823199828,-0.00237069760928119,0.000147928207122997,-8.98649934616215e-06,5.3527662624564e-07,0.469749219769089,-0.498363361657382,0.0301667671216273,-0.0016324504404238,8.38080956855595e-05,-4.17796121517893e-06,2.04063316593712e-07,0.451256313241208,-0.495787088893,0.048399714975517,-0.00418571540776048,0.000341864340877962,-2.70336724540148e-05,2.08303944586914e-06,0.428749253234344,-0.491146072493907,0.0702137207158178,-0.00873816129301612,0.00102411089556573,-0.000114374459178271,1.26178552522901e-05};
const double nb_a_1_3[]={0.951987668582991,-0.0448581648629627,0.0052764825617196,0.00142363147629304,0.000164539457990479,-4.09021449015654e-05,0.951872601228331,-0.0449472596488782,0.00461714691814746,0.00079816777628508,0.000173515645685499,2.61593127098628e-05,0.951844993678891,-0.0448948939017227,0.00445172575177597,0.000584124087073856,0.000156610785751354,4.31713532349729e-05};
double anbinomdevc_1 (double mu, double phi){
int iter=0; double x=0, y=phi/0.368-1, out=0;
if(mu < low_bound) return out;
/* simple approximation for a range of large mu */
else if(mu>60){
if(mu>120) iter=12;
else if(mu>80) iter=6;
double y_cheb[6];
y_cheb[0]=1, y_cheb[1]=y;
out = nb_a_1_3[iter]+nb_a_1_3[iter+1]*y;
for(int i=2; i < 6; ++i) y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2], out += nb_a_1_3[iter+i]*y_cheb[i];
out = out*(1 - 1/(6*mu) - 1/(2*mu*mu));
}
/* trend deccomposition of middle range of mu */
else if(mu>20){
if(mu < 25) x=(2*mu-45)/5;
else if(mu < 30) x=(2*mu-55)/5, iter=7;
else if(mu < 40) x=(mu-35)/5, iter=14;
else x=(mu-50)/10, iter=21;
double x_cheb[7], y_cheb[7], w1, w2, w3;
x_cheb[0]=1, x_cheb[1]=x, y_cheb[0]=1, y_cheb[1]=y;
w1=nb_a_1_2[iter]+nb_a_1_2[iter+1]*y, w2=nb_a_1_2[iter+7]+nb_a_1_2[iter+8]*y, w3=nb_a_1_2[iter+35]+nb_a_1_2[iter+36]*x;
for(int i=2; i < 7; ++i){
x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2];
w1 += nb_a_1_2[iter+i]*y_cheb[i], w2 += nb_a_1_2[iter+7+i]*y_cheb[i], w3 += nb_a_1_2[iter+35+i]*x_cheb[i];
}
out = (w2+(w1-w2)*w3)*(1 - 1/(6*mu) - 1/(2*mu*mu));
}
/* two dimensional Chebyshev polynomial approximation */
else {
if(mu<0.01) x=200*mu-1;
else if(mu < 0.33) x=(2*mu-0.34)/0.32, iter=49;
else if(mu < 1.77) x=(2*mu-2.10)/1.44, iter=98;
else if(mu < 4.00) x=(2*mu-5.77)/2.23, iter=147;
else if(mu < 10.0) x=(mu-7)/3, iter=196;
else x=(mu-15)/5, iter=245;
double x_cheb[7], y_cheb[7];
x_cheb[0]=1, x_cheb[1]=x, y_cheb[0]=1, y_cheb[1]=y;
for(int i=2; i < 7; ++i) x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2];
for(int i=0; i < 7; ++i){
for(int j=0; j < 7; ++j, ++iter) out+=nb_a_1_1[iter]*x_cheb[j]*y_cheb[i];
}
out = out*pois_alpha(mu);
}
return out;
}
/* same for weight function kappa */
const double nb_k_1_1[]={1.01093193289832,0.00462853770318509,-0.0013257790514778,0.00058718464473768,-0.000313667356834079,0.00017051235847544,-7.64887186619954e-05,0.0105133161944017,0.00444339389041176,-0.00128494354041815,0.000567492953176159,-0.00030302590164197,0.000164652911822336,-7.36629415499648e-05,-0.000390213876528697,-0.000172250152098295,3.83388390407595e-05,-1.83281385721324e-05,1.00412565538404e-05,-5.52709717036985e-06,2.48893880146899e-06,2.58914015036293e-05,1.16187466558406e-05,-2.39058520599079e-06,1.17751559814183e-06,-6.47018264245274e-07,3.56892441907046e-07,-1.60890095810609e-07,-2.22600165151887e-06,-1.07967380032374e-06,1.79197682909908e-07,-9.37820851908349e-08,5.18811661464574e-08,-2.87007407590861e-08,1.29549707151856e-08,2.25050796907116e-07,1.23206553274927e-07,-1.38646567634652e-08,8.30202137219825e-09,-4.64772123276187e-09,2.58359957155045e-09,-1.16853096810167e-09,-2.55165450489502e-08,-1.61020691268932e-08,9.34469288478596e-10,-7.66536134276264e-10,4.38164982807883e-10,-2.45613031618184e-10,1.11458233555504e-10,0.999782466356686,-0.0217395164752148,-0.00136065410605654,0.00410671347791474,-0.000724838429757106,0.000211477224137636,-0.000119969954131525,-0.00262479261783484,-0.0232863554628768,-0.00113706519554179,0.00402867715254928,-0.000759468050041847,0.000211484497171724,-0.000114981890208271,-0.00192052067361352,-0.0010287206211033,0.00027383989199694,-0.000102862787249167,-3.57645126906077e-05,2.2555624227282e-07,5.8836599538702e-06,0.000398533720169022,0.000407594606430905,3.33336751051403e-05,-1.48913633591519e-05,-1.04378380498225e-06,1.44004221776175e-06,-3.02312905541102e-07,-7.43659848081565e-05,-8.69927910677015e-05,-1.39500576738242e-05,3.12001526702217e-06,1.16203313780644e-06,-1.07204723581969e-07,-5.75913133290787e-08,1.38674400564893e-05,1.70416555369113e-05,3.27002078732208e-06,-4.89104373764075e-07,-2.62864492674841e-07,-9.00083988528769e-09,1.44493039230895e-08,-2.55070621493684e-06,-3.20438480135503e-06,-6.61829726017853e-07,7.55100519434572e-08,4.78887143731464e-08,3.75453287591688e-09,-2.33418331617108e-09,1.08657653584548,0.112966369812148,-0.00431235744212862,-0.00704453550109759,0.00311144953809285,-0.000810352751102421,9.10051060002878e-05,0.0783190959635853,0.110472726637074,-0.00212212587266686,-0.00713052053585931,0.00289293936980041,-0.000680201162981986,6.10057779217409e-05,-0.00736838089287954,-0.00305250670560969,0.00190730229152324,3.84905399852992e-05,-0.000244737412736932,0.000116218158658951,-2.72785127527176e-05,0.000721259935939989,-0.000439099378093384,-0.000238226623782394,9.444636263816e-05,-1.50171511032126e-05,-7.09683143743382e-06,5.1115190463917e-06,-0.000127298147240348,0.000102881239728336,3.03038562803951e-05,-2.07513430795027e-05,8.28724587764598e-06,-9.80197156702065e-07,-5.59126101957378e-07,2.95186782478303e-05,-1.49379889428777e-05,-5.36546584476294e-06,3.7232010505347e-06,-1.81484639404335e-06,3.83589252838927e-07,3.71028581367066e-08,-6.9843979155793e-06,1.37119335749273e-06,1.07793979273086e-06,-6.38299779029065e-07,3.18614295018979e-07,-7.49778956768421e-08,-1.18446714391017e-09,1.20349910269204,-0.0244285226929874,-0.027501476565759,0.00863082537382384,-0.00114178819870073,5.21429464931338e-05,4.6461808467283e-07,0.212726278839578,-0.00550329429150672,-0.0273239985214072,0.0079148273577492,-0.00110121363752523,6.42002092030218e-05,1.02120877488363e-06,0.00572878785085981,0.015138654588278,0.000186881606676356,-0.000534786691047413,5.63841270982302e-05,1.37319358571942e-06,1.29552102139137e-06,-0.00280610191434446,-0.00303300736111316,-7.79574386808508e-06,0.000117623331500726,1.03707325614439e-05,-7.75851575797932e-06,8.56880629246779e-07,0.000580804735087941,0.00062228609668188,-2.08594742776028e-06,-4.23367598301475e-05,-4.03213665647869e-06,2.56484736050404e-06,-1.21546393508457e-07,-0.000103367003595746,-0.000119351261790355,7.36539298671015e-06,1.39637757399001e-05,1.37647347766318e-06,-8.0227960245283e-07,-2.45588464651666e-08,1.43304418609481e-05,1.87725861273021e-05,-3.91716443155408e-06,-4.05137380291927e-06,-4.1185511627974e-07,2.36555685248085e-07,2.01211479970673e-08,1.07343427008151,-0.0636462581170872,0.0186914102849887,-0.00343711271748352,0.000140987066879791,0.00012864664524751,-4.32557212947592e-05,0.105450092513193,-0.0653821427116433,0.0143032552996045,-0.00192784293680669,-6.99805732116574e-05,0.00014016744333778,-4.8971167852551e-05,0.0281573112395602,0.00287946115242847,-0.00371090944608537,0.000921031225858324,-9.43314889210288e-05,-1.5424326890036e-05,9.14235914447912e-06,-0.00426825705072003,0.00269799221060197,0.000813968607467724,-0.000389659058420281,5.11423453428474e-05,8.24758004262836e-06,-5.10616154165635e-06,-4.41310251759636e-05,-0.00143123961752165,-4.64600411910262e-05,0.000156900251006438,-3.22511334916637e-05,-2.38255307642868e-06,2.58069618072368e-06,0.000254902314608232,0.00043876655814503,-8.52908834165834e-05,-5.21272798938455e-05,1.7681708408662e-05,-1.44885769036637e-08,-1.16121307068839e-06,-9.15081196127163e-05,-8.2862934808353e-05,5.38220725879876e-05,1.29701644294864e-05,-7.40854488867587e-06,3.95539249126622e-07,4.2439391478743e-07,1.01431155927191,-0.00785380365724673,0.00231880183982156,-0.000598760225672643,0.000153584007173812,-4.19478550416061e-05,-6.13826727855979e-06,0.0320223464107577,-0.0157934953086863,0.00370906775192677,-0.000766195919174174,0.000148805336054292,-2.77366843767371e-05,4.42658380611198e-06,0.0206954884551707,-0.00678012662842718,0.000707777463459694,2.76744400985432e-06,-2.497550964731e-05,8.30393455164392e-06,-2.19368419964827e-06,0.00163633293770298,0.00197896823988567,-0.000633332853909624,0.000107976661250467,-9.19773408543018e-06,-1.30235141865011e-06,7.34263614429709e-07,-0.00134463758440543,0.000297151243551216,0.000163990395737169,-6.59069485923075e-05,1.32723114990257e-05,-1.37731593330268e-06,-7.65643730530063e-08,0.000156726293081861,-0.000412607162128543,3.31923919247524e-05,1.98143522185518e-05,-8.02903105479738e-06,1.57552693133545e-06,-1.48898592466148e-07,8.10664711169916e-05,0.000155532303123849,-4.5011318484676e-05,-1.18679606570382e-06,3.04070004784726e-06,-8.60163521395389e-07,1.2540732452363e-07};
const double nb_k_1_2[]={1.00834766392583,0.0192979279059682,0.0146083035144376,0.00308022583666966,-0.000937596125903907,-0.000209491597665304,0.000192710909226761,1.00686253063177,0.0149356810248778,0.01126012476528,0.00308772268183088,-0.000480799720749079,-0.000320327887887822,0.000159721286563437,1.00619751243379,0.0125737930820398,0.00907164985240881,0.0028592201089205,-0.000175761102535182,-0.00033094253440056,0.00010751046243034,1.00575021163364,0.0103183760283486,0.00650375639074266,0.00230727584847106,0.000144113576127633,-0.000265049112222215,2.59224051219644e-05,1.00574866572579,0.00894649307842045,0.00429575570667532,0.00149501855868558,0.000315522538881028,-0.000130001158361778,-3.71662558734308e-05,0.463732255482877,-0.497650142070071,0.0361230879882763,-0.00234119665174697,0.000144146492079203,-8.63146398489516e-06,5.06598335804829e-07,0.469597928838205,-0.49836556211003,0.0303189893820078,-0.00163034251955743,8.28836559655311e-05,-4.08587908107867e-06,1.97228693297826e-07,0.450567753089914,-0.495732824123936,0.049085905164632,-0.0042400073062975,0.000344254834029005,-2.70096212096378e-05,2.06319779323077e-06,0.426448639619048,-0.490793472420116,0.0724732969298092,-0.00908656217111574,0.00106474893150343,-0.000118537962073022,1.30117552146679e-05};
const double nb_k_1_3[]={1.00583242222469,0.00873709502448643,0.00376552611974505,0.00123376716719861,0.000319027732575897,-0.000103464972872556,1.00607786894243,0.00858542384423476,0.00297488242801692,0.000739257572744861,0.000276314028663275,-1.72329691626533e-05,1.00635045350281,0.00868250398415398,0.00254061639483328,0.000370445832422752,0.00019376009123299,3.02571933150642e-05,1.00684587759935,0.0091522827500655,0.00230701638763935,-1.80996899546194e-05,2.07822890340898e-05,3.03635924785072e-05};
double knbinomdevc_1 (double mu, double phi){
int iter=0; double x=0, y=phi/0.368-1, out=0;
if(mu < low_bound) return out;
else if(mu>60){
if(mu>250) iter=18;
else if(mu>120) iter=12;
else if(mu>80) iter=6;
double y_cheb[6];
y_cheb[0]=1, y_cheb[1]=y;
out = nb_k_1_3[iter]+nb_k_1_3[iter+1]*y;
for(int i=2; i < 6; ++i) y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2], out += nb_k_1_3[iter+i]*y_cheb[i];
out = out*(1 - 1/(2.5*mu*mu));
}
else if(mu>20){
if(mu < 25) x=(2*mu-45)/5;
else if(mu < 30) x=(2*mu-55)/5, iter=7;
else if(mu < 40) x=(mu-35)/5, iter=14;
else x=(mu-50)/10, iter=21;
double x_cheb[7], y_cheb[7], w1, w2, w3;
x_cheb[0]=1, x_cheb[1]=x, y_cheb[0]=1, y_cheb[1]=y;
w1=nb_k_1_2[iter]+nb_k_1_2[iter+1]*y, w2=nb_k_1_2[iter+7]+nb_k_1_2[iter+8]*y, w3=nb_k_1_2[iter+35]+nb_k_1_2[iter+36]*x;
for(int i=2; i < 7; ++i){
x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2];
w1 += nb_k_1_2[iter+i]*y_cheb[i], w2 += nb_k_1_2[iter+7+i]*y_cheb[i], w3 += nb_k_1_2[iter+35+i]*x_cheb[i];
}
out = (w2+(w1-w2)*w3)*(1 - 1/(2.5*mu*mu));
}
else {
if(mu<0.01) x=200*mu-1;
else if(mu < 0.33) x=(2*mu-0.34)/0.32, iter=49;
else if(mu < 1.30) x=(2*mu-1.63)/0.97, iter=98;
else if(mu < 4.00) x=(2*mu-5.30)/2.70, iter=147;
else if(mu < 10.0) x=(mu-7)/3, iter=196;
else x=(mu-15)/5, iter=245;
double x_cheb[7], y_cheb[7];
x_cheb[0]=1, x_cheb[1]=x, y_cheb[0]=1, y_cheb[1]=y;
for(int i=2; i < 7; ++i) x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2];
for(int i=0; i < 7; ++i){
for(int j=0; j < 7; ++j, ++iter) out+=nb_k_1_1[iter]*x_cheb[j]*y_cheb[i];
}
out = out*pois_kappa(mu);
}
return out;
}
// Case 2: phi < sweet_cutoff2, enough approximation
const double nb_a_2_1[]={-1.16722391014247,-0.0546256908019699,0.0170793200599762,-0.00804740645688377,0.0047630509804499,-0.00308300749457653,0.00206330505315553,-0.00136533690951409,0.000837415658420806,-0.00039913902158864,-0.154153127597451,-0.0543377608208736,0.0155408219510873,-0.00734130700460622,0.00433312771788251,-0.00279916581200137,0.00187065417877222,-0.00123660134310969,0.000757945664203257,-0.0003611214907502,0.0130418509478454,0.00307967307978365,-0.00100469607476531,0.000547873443316112,-0.000341035002520363,0.000227001270109255,-0.000154652291396383,0.000103544598040902,-6.3985911235002e-05,3.06260412358941e-05,-0.00238914014014019,-0.000513276027378282,0.000178889289036894,-9.6502127610301e-05,6.01698555590128e-05,-4.01790992063982e-05,2.74415257013936e-05,-1.84057968086555e-05,1.13875686248569e-05,-5.45426398265434e-06,0.000550637258888052,0.000117163382182506,-3.99077972713885e-05,2.15961963902439e-05,-1.35049723021659e-05,9.03327356889918e-06,-6.17646485351526e-06,4.14591638834687e-06,-2.56635381652109e-06,1.22955163885351e-06,-0.000142736810440748,-3.09044348983343e-05,1.00470294542678e-05,-5.4766710992874e-06,3.43097178962954e-06,-2.29712573511776e-06,1.57162341759151e-06,-1.05537889845464e-06,6.53461918993409e-07,-3.13123699004237e-07,3.98631473379949e-05,8.94900589386699e-06,-2.71894875886667e-06,1.49803733616335e-06,-9.40083243180891e-07,6.29908669141569e-07,-4.31161944121561e-07,2.89617503223381e-07,-1.79355253509363e-07,8.5951314135875e-08,-1.17292434382893e-05,-2.77584992207106e-06,7.69690506960468e-07,-4.30696076793736e-07,2.70838964847677e-07,-1.8163125399774e-07,1.24378856150003e-07,-8.3568650111873e-08,5.17606052706602e-08,-2.48069583119167e-08,3.56220236168492e-06,9.00169962347319e-07,-2.22743872534993e-07,1.27323211073609e-07,-8.02748554451852e-08,5.38885944984316e-08,-3.69206790911975e-08,2.48134289808225e-08,-1.53713315160413e-08,7.36752550649388e-09,-1.01947738840646e-06,-2.74576384660108e-07,6.05968248201805e-08,-3.54690524186074e-08,2.24245042013127e-08,-1.50693249190148e-08,1.03296512094647e-08,-6.94418808958736e-09,4.30242026432798e-09,-2.06232665644554e-09,2.19177644367907,1.46946112268895,-0.287261982947043,-0.0110204727590795,0.000108717599429569,0.00708322092644729,-0.00402479139611959,0.00205267004136486,-0.00114413903311179,0.000518374751056418,0.285045603833933,0.11185463606765,-0.0497741492825227,0.0516503393146531,-0.00350286245590367,-0.00315705919773758,-6.78264538763366e-05,0.000555506505402722,-0.000233675644466058,7.95613246334069e-05,-0.0526010558138137,-0.0396868283573155,0.00624829284325377,-0.00445869833218103,-0.00265506452425111,0.00116303057697719,0.000297552236101003,-0.000195169619671923,1.66896012995388e-05,3.14372243349244e-06,0.0162142328873837,0.0156424084129644,-0.000559652732798628,-0.000504125908805775,0.000646472953550888,-1.10300198742975e-05,-0.000164658282787258,3.08384415503524e-05,1.34699763366627e-05,-3.44272174655889e-06,-0.00612089420814747,-0.00672214548470423,-0.00029120923838331,0.000606131329944741,-3.18524718565219e-05,-7.72489390523521e-05,3.26445136384769e-05,6.51910226128158e-06,-5.58344029462565e-06,-5.18312174733047e-07,0.00252484919195595,0.00298752694551629,0.000292460029201985,-0.000322806731059286,-6.09371070597273e-05,3.88511587300224e-05,2.1293052415021e-06,-5.10727697728961e-06,3.98114080277897e-07,8.32646755986661e-07,-0.0010827657123351,-0.0013394439606634,-0.000180783078674982,0.000147302746725034,4.6488629281248e-05,-1.45343441991703e-05,-5.45593188669291e-06,1.73714165178067e-06,5.66476978573623e-07,-3.35910555635441e-07,0.000471317019243641,0.000599093493869607,9.57268453069892e-05,-6.37830175484136e-05,-2.51721584296757e-05,4.91043578184438e-06,3.39307120227866e-06,-3.7955780177606e-07,-4.11324963973882e-07,7.14125669417352e-08,-0.000202192413300886,-0.000261296950522389,-4.59749048757893e-05,2.66174455281915e-05,1.18286376489109e-05,-1.59560908034422e-06,-1.6269543353966e-06,2.57453293400333e-08,1.96597338545049e-07,1.95498311998077e-09,7.51971927407524e-05,9.80775705378845e-05,1.81795331751011e-05,-9.63366759392903e-06,-4.55062717044374e-06,4.74746246515653e-07,6.20301380558489e-07,2.10084676717168e-08,-7.2297246369547e-08,-8.43880485993081e-09,2.56813447698693,-0.735435030513319,0.181907489726715,-0.00232003127043097,-0.0365247447481438,0.0345069157183025,-0.0235680035713836,0.013725541243189,-0.00703887125750823,0.00287807123930044,1.08414492797523,0.26850094769957,-0.263727264648089,0.134388795947091,-0.0447053294814637,0.00561014692581434,0.00668253547945574,-0.00784330647108019,0.00548048490661248,-0.00263068139028896,-0.0676993337635559,0.0999051824668334,0.0221216016847372,-0.0285790870906516,0.0191623723933489,-0.00838882790868529,0.00181580553543879,0.000810376762688633,-0.0012561828495928,0.000776988891986595,-0.00179625480432948,-0.0352986016849718,0.00874591646627203,0.00222525678470606,-0.00404861276064511,0.00309817214709717,-0.00166029454645659,0.00056871565700848,-3.83266079181114e-05,-7.73605921550287e-05,0.00334045993385561,0.0139511231194863,-0.00287404648937032,0.00119797785999628,0.00015068737160496,-0.000780932422718831,0.000679304789816955,-0.000402098303682325,0.000185743233470867,-6.33417365776938e-05,-0.001104007996255,-0.00537626415760712,0.00092773047796782,-0.000711063194802622,0.000189548736857684,0.000124383610285577,-0.000208393079051185,0.000179061614308504,-0.000111480726104121,4.94348126689509e-05,0.000479972047772159,0.00244352306905941,-0.000307681755542364,0.000241992733934785,-0.000135712792476898,-5.80607948387789e-06,6.81383749926438e-05,-6.90021842025716e-05,4.83856022338225e-05,-2.40845748327752e-05,-0.000229970198322359,-0.00117018063751512,7.39321046462887e-05,-9.19974783162457e-05,6.78340944687064e-05,1.23516625991582e-06,-2.41405317004791e-05,2.54174683407126e-05,-1.96047953146037e-05,1.03343998353437e-05,9.19612817412685e-05,0.000522987018644589,-1.55945058044682e-05,3.76617507368171e-05,-2.67180538380174e-05,-9.13003134069557e-07,9.10631866206234e-06,-1.01677393679741e-05,7.80663609360799e-06,-4.02335126942807e-06,-2.8581569730477e-05,-0.000194455947587304,4.84864216231173e-06,-1.18076098844933e-05,9.2920080057024e-06,6.34882175884477e-08,-3.60135805047082e-06,3.75925092441567e-06,-2.66277077343599e-06,1.37350197870992e-06,1.74454187246023,-0.187598343804154,0.0382711278100216,-0.0088192387602456,0.00212102130818851,-0.0005087984048742,0.000118729409860525,-2.68805884123034e-05,5.98580432942804e-06,-1.27931757615315e-06,0.966824819981767,-0.169017612227891,0.0242209724162969,-0.00292215350597323,8.77293385636511e-05,9.76513246098106e-05,-4.25117535519911e-05,1.28884954271538e-05,-3.56598117860342e-06,9.31740559574186e-07,0.0882593511403611,0.0493593219848723,-0.0125792305741734,0.00253056934877706,-0.000422797520529407,6.6610877964794e-05,-1.40752631538471e-05,4.32445655698079e-06,-1.33631602015216e-06,3.31471747064483e-07,-0.0497383355609957,-0.0100990502955599,0.0038901807858901,-0.000684437380315692,3.28383922387991e-05,1.6384392122421e-05,-3.69597093861809e-06,-5.7618732632183e-07,5.89867317183099e-07,-2.01744910877495e-07,0.0196971878199526,0.00338391360223226,-0.00230173364844542,0.000407774584919418,1.52767301522715e-05,-2.78450737413495e-05,7.51332517221607e-06,-7.59919309939514e-07,-1.67204712941793e-07,8.92812510706885e-08,-0.00807898935483216,-0.000244300925170411,0.00148121454802224,-0.000331468769807696,-2.86903966173194e-06,2.09716695729223e-05,-6.08365932896113e-06,6.80876541341752e-07,1.0921605102604e-07,-6.34516009295832e-08,0.00291123867191853,-0.00108467868663886,-0.000872583527960933,0.000252992286999821,-4.74232735813076e-06,-1.46780336607586e-05,4.49606281850305e-06,-4.87981098641842e-07,-9.6629302154971e-08,5.2112491020213e-08,-0.00069946993816816,0.00129993195419112,0.000475011021810713,-0.000179764825656301,7.18705714651002e-06,9.87920979891111e-06,-3.18833421353199e-06,3.42695800982589e-07,7.58558947739466e-08,-3.96631117082906e-08,-6.10783391032221e-05,-0.00100612342561093,-0.000234968842541174,0.000114645206259347,-6.49091376239518e-06,-6.05164406006307e-06,2.04524698576172e-06,-2.21035685526503e-07,-5.10136086302114e-08,2.64390790646883e-08,0.000156265116218659,0.000527797812255377,9.38173383589774e-05,-5.56883530036052e-05,3.75740782707781e-06,2.86259048827464e-06,-9.98809414951321e-07,1.08707533173154e-07,2.5482418813393e-08,-1.3178749078964e-08,1.44661823459421,-0.112132427725358,0.0225665033477026,-0.00514309093235508,0.00123550836774177,-0.000305357644675104,7.68108042368605e-05,-1.95727645613383e-05,5.03034835047846e-06,-1.2300787121587e-06,0.660748521290301,-0.127651361243069,0.0241371692705357,-0.00519212600386762,0.00117428995572317,-0.00027219631724216,6.38735454701334e-05,-1.5011167354352e-05,3.47585681041505e-06,-7.47839170020245e-07,0.143054830440596,0.00948432702827647,-0.00437325069952857,0.00140828370484909,-0.000418654399478355,0.000120481849322971,-3.40160480697017e-05,9.41656576774665e-06,-2.52660582372642e-06,6.17361831955686e-07,-0.0511899526106159,0.00572681063870222,-6.7137717880131e-05,-0.000224662781644157,0.000111126102912362,-4.17298210174797e-05,1.40407616800403e-05,-4.38109322211039e-06,1.2659741394666e-06,-3.19887666558302e-07,0.0146267407169202,-0.00581124673824278,0.000787266421308082,-3.17152546177197e-05,-3.8394473929288e-05,2.30572922598525e-05,-9.53751718513942e-06,3.34419928697886e-06,-1.03701624359654e-06,2.73220980497092e-07,-0.00169736187122299,0.00428548833635551,-0.00101365251030567,0.000174702553277576,-9.41095160444763e-06,-9.81722324312262e-06,6.22770865970777e-06,-2.57771847471041e-06,8.7312810281181e-07,-2.42488360924254e-07,-0.00224845991800643,-0.00228831421906382,0.000899147657518651,-0.000223601015470803,3.59427992666547e-05,6.82979150050647e-07,-3.53657995093706e-06,1.85050311506636e-06,-6.90443929103337e-07,2.0177444992352e-07,0.00256555618565994,0.000764676711476169,-0.000642428604711898,0.000205189784488846,-4.30180157680216e-05,3.93556826682856e-06,1.69832932382305e-06,-1.23670892531046e-06,5.08099897465846e-07,-1.55282796546843e-07,-0.00176161364431881,8.19344393344523e-06,0.00038275439914222,-0.000149840404312034,3.59920088722745e-05,-4.81502613958368e-06,-6.40560300828965e-07,7.42889464217726e-07,-3.32417268250669e-07,1.05245673425879e-07,0.000833264968912353,-0.000166620735565239,-0.000171721965783591,7.77923806682282e-05,-2.01074126347173e-05,3.07856313982085e-06,1.64964358884078e-07,-3.44883244445955e-07,1.63934163244125e-07,-5.31003617196067e-08,1.31256031837516,-0.0365824361416769,0.00335961417072592,-0.000353645740028721,3.94478528682562e-05,-4.54295361332742e-06,5.33889296249662e-07,-6.36348618395466e-08,7.6630450062659e-09,-9.16768764813204e-10,0.50455844504986,-0.0440928900317907,0.00389683263168004,-0.000398864386748602,4.3437668259404e-05,-4.89157269026202e-06,5.62115191117916e-07,-6.54368570302802e-08,7.68107111534920e-09,-8.94304260851634e-10,0.148393046200453,-0.00107548115272704,-0.000172912808120591,3.8891604389596e-05,-6.25359699014342e-06,9.12434951289837e-07,-1.27274797814475e-07,1.72978663889585e-08,-2.31068509148419e-09,3.00020724383349e-10,-0.0420314798531724,0.003384525760562,-0.0002400940719526,1.76383742985389e-05,-1.12496509951055e-06,3.47646581656643e-08,6.71319954070153e-09,-2.04250364740116e-09,3.90236261070008e-10,-6.29693064357921e-11,0.00718559011387008,-0.00212572827993254,0.000213499199760115,-2.15052744726246e-05,2.1515892048549e-06,-2.0999990376758e-07,1.94351105581905e-08,-1.60607246543168e-09,9.75700859545674e-11,7.00417188683951e-13,0.00270124713274945,0.000814629352105269,-0.000132247946196851,1.75726513889312e-05,-2.21823472295491e-06,2.71987962514597e-07,-3.24318167454666e-08,3.7368646960407e-09,-4.10702230925885e-10,4.17420482262914e-11,-0.00377119596947872,0.000109104742403079,4.17772212687551e-05,-9.780806025548e-06,1.64703626508212e-06,-2.44966238308555e-07,3.38345157679561e-08,-4.41586625313133e-09,5.4726512213929e-10,-6.35259032847587e-11,0.00234402561667888,-0.000495927001694854,1.87754230757549e-05,2.8349129824347e-06,-9.30120380918586e-07,1.7661155065858e-07,-2.7929848665835e-08,3.9902142374732e-09,-5.30240639338096e-10,6.54216074177113e-11,-0.000960939494931763,0.000488779862466886,-3.93379111011428e-05,9.30858074028693e-07,3.87526175897263e-07,-1.05039056118358e-07,1.89617265713342e-08,-2.91237648749815e-09,4.06196146861105e-10,-5.2010918515583e-11,0.000246180651864663,-0.000280135078152641,2.80369038325828e-05,-1.43782067474354e-06,-1.06114810587099e-07,4.67071659293539e-08,-9.38884370778449e-09,1.51548951641865e-09,-2.17827110782867e-10,2.84960079580858e-11};
const double nb_a_2_2[]={1.27901923265303,0.464002572908361,0.147178090663608,-0.0388704949853813,0.00525381527471972,0.00339922587609729,-0.00362866283366029,0.001868931031525,-0.000510267789729385,-7.4228162943224e-06,1.20144061121365,0.367790084558894,0.140146369159432,-0.0307135196248815,0.00132417869560944,0.00406375305848214,-0.00266728096612815,0.000648279409651754,0.000341828144492967,-0.000397494193264381,1.0511541649247,0.171662964840304,0.110209630663404,-0.0140094523635252,-0.00235574124081925,0.00193367244900671,-4.61020316163428e-05,-0.000489868019092097,0.000283854974371295,-6.17988948719228e-05,0.996857562766985,0.0964033749846483,0.0921530532066982,-0.00874158811443212,-0.00158096839378969,0.000356616153774879,0.000500311195000911,-0.000281475017127144,-4.90682313524948e-05,0.000116474304115738,0.472255377928953,-0.497302789017012,0.0274301408074467,-0.0026570054977465,0.000309042550261815,-3.94411074873225e-05,5.32827497327774e-06,-7.48075989387594e-07,1.07938043200639e-07,-1.55591509787278e-08,0.407666978519895,-0.471653746300708,0.082061239878469,-0.024293763963617,0.00858707424343456,-0.00332602096993726,0.00136136261435912,-0.000575597530018397,0.000243191107591659,-8.98792430236828e-05,0.428767300408055,-0.483858534063321,0.0669338363306574,-0.0148958981516649,0.00391868666415752,-0.00112533022034369,0.000341112038849306,-0.000107158553608014,3.42232770820627e-05,-1.01304384733658e-05};
double anbinomdevc_2 (double mu, double phi){
int iter=0; double x=0, y=phi/2-1, out=0;
if(mu < low_bound) return out;
else if(mu < 50){
if(mu < 0.01) x=mu/0.01-1;
else if(mu < 0.43) x=(mu-0.22)/0.21, iter=100;
else if(mu < 3.62) x=(2*mu-4.05)/3.19, iter=200;
else if(mu < 10.0) x=(2*mu-13.62)/6.38, iter=300;
else if(mu < 30.0) x=mu/10-2, iter=400;
else x=mu/10-4, iter=500;
double x_cheb[10], y_cheb[10];
x_cheb[0]=1, x_cheb[1]=x, y_cheb[0]=1, y_cheb[1]=y;
for(int i=2; i < 10; ++i) x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2];
for(int i=0; i < 10; ++i){
for(int j=0; j < 10; ++j, ++iter) out+=nb_a_2_1[iter]*x_cheb[j]*y_cheb[i];
}
if(mu<0.01){
double logmu=log(mu);
out=out*(logmu/((1+logmu)*(1+logmu)));
}
}
else if(mu < 5000){
if(mu < 100) x=200/mu-3;
else if(mu < 1000) x=(2000/mu-11)/9, iter=10;
else x=2500/mu-1.5, iter=20;
double x_cheb[10], y_cheb[10], w1, w2, w3;
x_cheb[0]=1, x_cheb[1]=x, y_cheb[0]=1, y_cheb[1]=y;
w1=nb_a_2_2[iter]+nb_a_2_2[iter+1]*y, w2=nb_a_2_2[iter+10]+nb_a_2_2[iter+11]*y, w3=nb_a_2_2[iter+40]+nb_a_2_2[iter+41]*x;
for(int i=2; i < 10; ++i){
x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2];
w1 += nb_a_2_2[iter+i]*y_cheb[i], w2 += nb_a_2_2[iter+10+i]*y_cheb[i], w3 += nb_a_2_2[iter+40+i]*x_cheb[i];
}
out = w1+(w2-w1)*w3;
}
else{
iter=30;
double y_cheb[10]; y_cheb[0]=1, y_cheb[1]=y;
out = nb_a_2_2[iter]+nb_a_2_2[iter+1]*y;
for(int i=2; i < 10; ++i) y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2], out += nb_a_2_2[iter+i]*y_cheb[i];
}
return out;
}
const double nb_k_2_1[]={2.08206884879209,0.0308557221218032,-0.0121647054052645,0.00531555584096633,-0.0030349624533247,0.00191929115105982,-0.00126408730036736,0.000827269113943132,-0.000503705656442577,0.000239083119260642,0.0764572189330207,0.0315905993674644,-0.0105652858563205,0.0047287900329908,-0.00270045429411021,0.00170705751991458,-0.00112372941900901,0.000735089208641621,-0.000447434945423754,0.000212333055634876,-0.00841491860065422,-0.00380601737770928,0.000881154205686593,-0.000431191682421155,0.000256087428209791,-0.000165221617256669,0.00011016890632675,-7.26775946817839e-05,4.44766261906645e-05,-2.11705388441743e-05,0.00153801661508973,0.000668460038440809,-0.000160088559924449,7.96779041178785e-05,-4.72741780989762e-05,3.05493897268033e-05,-2.04015152136304e-05,1.34744634959531e-05,-8.25261624969471e-06,3.93002077166865e-06,-0.000355819680275117,-0.000154773625858464,3.62944263109156e-05,-1.81830237142726e-05,1.08143319807279e-05,-6.99968102479944e-06,4.67925514213939e-06,-3.09255414219332e-06,1.89489755442309e-06,-9.02599597767152e-07,9.31977337088433e-05,4.14412681567896e-05,-9.13933052512646e-06,4.64914264032397e-06,-2.77259551822682e-06,1.79691062867971e-06,-1.20213554811934e-06,7.9487826358562e-07,-4.87189188109112e-07,2.32101542860918e-07,-2.64592078452712e-05,-1.22139861788059e-05,2.44514715112521e-06,-1.27481175881946e-06,7.62733519794553e-07,-4.95026848472098e-07,3.3142727562645e-07,-2.19246083017232e-07,1.34414510059876e-07,-6.40456506167351e-08,7.96665322309577e-06,3.86865796453358e-06,-6.76371911508484e-07,3.65969933066178e-07,-2.19908898895806e-07,1.42979605397787e-07,-9.58144543524396e-08,6.34161558450848e-08,-3.88906179152261e-08,1.85334929420932e-08,-2.4908741350127e-06,-1.28373241370841e-06,1.88785460074441e-07,-1.07693417515566e-07,6.50765927845062e-08,-4.24072014629673e-08,2.8450353168597e-08,-1.88420832328891e-08,1.15592387023517e-08,-5.50963451477655e-09,7.33973184221526e-07,3.99613081709105e-07,-4.91515236197837e-08,2.98196689847707e-08,-1.81284348896998e-08,1.18417614969335e-08,-7.95385339043275e-09,5.27109003141749e-09,-3.23489603421163e-09,1.54218671370981e-09,1.43325194104243,1.33961237580868,-0.152286582746308,-0.0726878787229801,0.0206950011861293,0.000742859733458131,-0.000406301049489568,-0.000383442186935807,0.000178491234435621,-3.48051008349293e-05,-0.163505671438694,-0.187829486288863,0.0301022879930871,0.0570813358623534,-0.00395512774270033,-0.00718102928552259,0.00143561702877113,0.000354199392311261,-9.01665764522882e-05,-3.9135530135717e-05,0.000130421630831756,-0.000314190708535859,-0.00940232582498807,-0.0121516962501225,-0.00126852257097601,0.0025083017162688,5.61803138680095e-05,-0.00034141708433001,3.01004426511432e-05,3.26418451017582e-05,0.00758325909171979,0.00944065351906358,0.00284318959634758,0.00175865834940007,0.000524483141192739,-0.000510745053335503,-0.000154601689840876,0.000105272438435609,1.68377153889253e-05,-1.82366187092739e-05,-0.00450324870149408,-0.00561353445790241,-0.000901909650317802,0.0001672089516862,-6.67387215716642e-05,3.70505793733457e-05,5.38727975894809e-05,-1.45516186572481e-05,-1.15505571520472e-05,4.59540236846976e-06,0.00224931910705733,0.00282653727496252,0.000341932124064466,-0.000315799012720499,-4.59204634193846e-05,3.17100088984378e-05,-6.70299983884861e-06,-3.27469348498512e-06,3.2416904808306e-06,-4.40355148019668e-08,-0.00107194647529833,-0.00136073152859038,-0.000153787491699216,0.000200128119979271,4.73217056570614e-05,-2.48156573845673e-05,-4.54672177442266e-06,3.49601360387238e-06,-8.90435116132203e-08,-5.35680793960882e-07,0.000498721661001113,0.000639269036497244,7.48948434133422e-05,-0.000102746433910623,-2.95504022519054e-05,1.30168461314045e-05,4.56495354777602e-06,-1.79501648991575e-06,-4.9108845514763e-07,3.15478799650456e-07,-0.000223503088458065,-0.000288816403078443,-3.60763199800596e-05,4.74055899025227e-05,1.52290975830091e-05,-5.89611076959762e-06,-2.69891622025134e-06,7.47184578729233e-07,3.70479087093096e-07,-1.2633185902102e-07,8.5320618885687e-05,0.000110865293805915,1.46009322477225e-05,-1.81363351940922e-05,-6.19844108568454e-06,2.20472177248771e-06,1.15451773678936e-06,-2.56138714298084e-07,-1.70535642465769e-07,3.89456974521124e-08,2.27493407924473,-0.371416526926058,0.0572609682633895,0.0314971839001834,-0.0388155974570845,0.0286639666025479,-0.0177077320654452,0.00975223227708291,-0.00483439429468741,0.00194048406812581,0.665798873158015,0.527645890527456,-0.289447247207714,0.117443099625076,-0.0303678052152874,-0.000718078917131843,0.00800019390186596,-0.00727256910158515,0.00466122255152426,-0.0021517082530369,-0.124872051835562,0.023462317928128,0.0626024663361809,-0.0407866347234605,0.0203658354631932,-0.00735424654223463,0.00102869167400011,0.00106228724110721,-0.00122286135614939,0.000701510334078165,0.0089372446884,-0.0312032747827991,-0.000580697798952387,0.00748177990249174,-0.00596597230441212,0.00336622471924274,-0.00148879112994981,0.000415967117169688,2.75057635488177e-05,-9.356682573777e-05,0.00411890144838968,0.015823725016081,-0.00198078899367366,-0.000116065117867908,0.000754295816296197,-0.000945266614807064,0.000667108329721887,-0.000344706842744642,0.000141655204896463,-4.36704147815743e-05,-0.00247763223896593,-0.00658040733674968,0.000954708947718426,-0.000546218412213323,9.12617613502802e-05,0.000161340022456332,-0.00019451716365904,0.000151203489652689,-9.01421396895714e-05,3.88572906226195e-05,0.0012335381644497,0.00296777109211048,-0.000424781802905229,0.000239789011471104,-0.000134405684957213,8.0300606863358e-06,5.18823350599202e-05,-5.53564701027564e-05,3.81227010671426e-05,-1.85721436419973e-05,-0.000627324354276201,-0.00145510214666981,0.000148619100213682,-8.87971420446909e-05,8.35330275088902e-05,-1.38411226382881e-05,-1.47807468748785e-05,1.80019822154572e-05,-1.43390119422428e-05,7.78024399950445e-06,0.000295642447593285,0.000687568533331209,-4.64465173446049e-05,3.65288262044161e-05,-3.71764318171453e-05,6.37938370259661e-06,3.94870471337721e-06,-6.33339904072622e-06,5.50459593445539e-06,-2.96369674830103e-06,-0.00011337892964832,-0.000268164215466733,1.56613344036316e-05,-1.21541100992961e-05,1.2850613989519e-05,-2.96929481884511e-06,-1.2408670697403e-06,2.37717452586966e-06,-1.8439720551057e-06,9.38223770959312e-07,1.80796250637391,-0.118993464553825,0.0215852701986281,-0.00458293181495866,0.00103143315653826,-0.000230962687788554,4.94412121810203e-05,-1.00032707889067e-05,1.94232371000971e-06,-3.61784436775266e-07,0.899121892459448,-0.0666397846880035,0.00276513801905683,0.00143570633842226,-0.00073752811269604,0.000240476147680184,-6.452350789293e-05,1.55361441762383e-05,-3.57791923686531e-06,7.90651262813944e-07,-0.0111142433368148,0.0576829820058678,-0.0115256918672587,0.00187868220696845,-0.000219974584486338,1.07782825719954e-05,1.79682828723522e-06,-3.39931969782325e-07,-2.45909863784757e-08,1.17716583012805e-08,-0.0456399150377906,-0.0141907150094285,0.00454780753702893,-0.00080926721468158,7.19184666025495e-05,5.45277830483067e-06,-2.2542061744278e-06,-1.96047125955837e-07,2.86802800157748e-07,-9.79780960670767e-08,0.022765098725876,0.00329527102818271,-0.00227095045434458,0.000424875147464019,-1.02920853039813e-05,-1.64769560376613e-05,4.77731599711788e-06,-4.83448954134864e-07,-1.06380643099696e-07,5.64142273723895e-08,-0.00979783930376944,0.000111824264498265,0.00135947452494467,-0.000310718408708645,7.89493826266284e-06,1.39807934480407e-05,-4.27902972209711e-06,5.2334265993931e-07,5.28667963934928e-08,-3.77854669660342e-08,0.00382460209409474,-0.00125814636180862,-0.00079138047643941,0.000232186052618335,-1.03731904821343e-05,-9.98041221638849e-06,3.25582688954736e-06,-4.05713764614176e-07,-4.19321359148361e-08,2.96538080017074e-08,-0.0012212970789824,0.00135420476424938,0.000429659218422553,-0.000163701235162064,1.02364362622419e-05,6.7081255921485e-06,-2.32451635510323e-06,2.916870982122e-07,3.28901681314855e-08,-2.24470987479532e-08,0.000233414518919018,-0.00100922100301286,-0.000212263990703416,0.000103782296471003,-7.96907482476237e-06,-4.09954579594512e-06,1.49592269905224e-06,-1.89771446624749e-07,-2.22392769726627e-08,1.49962578987404e-08,2.16717403914579e-05,0.000520314799673662,8.4716906013436e-05,-5.02162736887102e-05,4.32588826633155e-06,1.93646985450978e-06,-7.32047757815658e-07,9.3732170874448e-08,1.11272562951818e-08,-7.4881021527244e-09,1.60154877837244,-0.0845210628161747,0.016096150451567,-0.00354680331942509,0.000831578909341359,-0.000201648315020195,4.99383895846401e-05,-1.2568739189512e-05,3.20440093845721e-06,-7.81468887003263e-07,0.73996668080051,-0.0802549019691381,0.0129355929372237,-0.00240445061936414,0.000464301315707479,-8.91219239812355e-05,1.63185760794742e-05,-2.60395094494651e-06,2.42529669958316e-07,4.52974449740036e-08,0.0701754552026199,0.0238789469815556,-0.00697316524487234,0.00190789624065943,-0.000514118866726677,0.000137713935997941,-3.6700433893059e-05,9.67110223995536e-06,-2.48239778706464e-06,5.8315228542214e-07,-0.0530641970188518,0.0041713095658793,0.000564833458746284,-0.000412067332267503,0.000162155632076054,-5.49965544063627e-05,1.73678388864487e-05,-5.18729235343706e-06,1.45419803220482e-06,-3.60495952226814e-07,0.0168587540316855,-0.00660429334780659,0.000810714865676047,-8.86029654557825e-06,-4.89659945358914e-05,2.64330641724163e-05,-1.04491037473789e-05,3.56043631879922e-06,-1.08157656202052e-06,2.80718995227825e-07,-0.00247385150127898,0.00490356637179088,-0.00108591067554912,0.000172941383554542,-5.03043319395579e-06,-1.1554515856349e-05,6.72025543114217e-06,-2.68742430366812e-06,8.9049598034828e-07,-2.43375941558341e-07,-0.00186756600602412,-0.00265236565651471,0.000956255205082565,-0.000224571244190689,3.2991589761139e-05,2.01266217072606e-06,-3.93618883080324e-06,1.94269280807538e-06,-7.05392445722651e-07,2.02561855054149e-07,0.00230558319570477,0.00096474181547603,-0.000680723501651049,0.000206473012696603,-4.09761406865301e-05,2.93964481301306e-06,2.01068373294297e-06,-1.31125440522742e-06,5.20756085408237e-07,-1.56138322400053e-07,-0.00158334834157499,-9.54626068814757e-05,0.000405338733951418,-0.000150791601927849,3.46899392539704e-05,-4.14848095842703e-06,-8.55554415476213e-07,7.95360114310164e-07,-3.41586964127945e-07,1.05947808533661e-07,0.000741433488928838,-0.000122333996846629,-0.000182053106192765,7.82750281579638e-05,-1.94714477792787e-05,2.74405128528395e-06,2.74656724144948e-07,-3.72011851296212e-07,1.68755949943737e-07,-5.34945462065923e-08,1.49807273163734,-0.0293224670219557,0.00255869626860635,-0.000260946359611808,2.84373531827947e-05,-3.21470304483813e-06,3.7201178601762e-07,-4.3764394611793e-08,5.21153829156109e-09,-6.17642761086121e-10,0.636121041198279,-0.0317099798666925,0.00253335354798408,-0.000240302644035193,2.44963878577344e-05,-2.59385382632916e-06,2.80649224028023e-07,-3.0728361514621e-08,3.38181807752523e-09,-3.67991407451815e-10,0.0931887209904959,0.00387231631445795,-0.000633758528491274,8.59953228976375e-05,-1.12699593023798e-05,1.45792883504897e-06,-1.87231179614486e-07,2.39178607912262e-08,-3.04169054837776e-09,3.79542885031772e-10,-0.0449438459792192,0.00345818045942173,-0.00020652433132965,1.108421672435e-05,-1.302427251037e-07,-1.04367239858538e-07,2.54245691251454e-08,-4.50195701244914e-09,7.08606525738887e-10,-1.03110574689015e-10,0.00818620304737732,-0.00256535828359749,0.000247859286949875,-2.40802888232489e-05,2.31216002102924e-06,-2.14045189393106e-07,1.82994330263047e-08,-1.29318845200506e-09,4.05488872962646e-11,9.52630625341982e-12,0.00272365171149271,0.0010379573328512,-0.000157899800759635,2.01327423633803e-05,-2.45173689670571e-06,2.90709726646909e-07,-3.35457667649852e-08,3.73468938744831e-09,-3.94345121712383e-10,3.79949344234540e-11,-0.00380695807547749,1.91804377083341e-05,5.66525723571923e-05,-1.15718166595488e-05,1.83619392516913e-06,-2.6272737586943e-07,3.52263252453383e-08,-4.48180773440372e-09,5.42056093679028e-10,-6.13317973208957e-11,0.00228891832970032,-0.000464271006874102,1.11630088282949e-05,3.93618622645726e-06,-1.06213999342901e-06,1.90453412684967e-07,-2.91682949498514e-08,4.07108657318181e-09,-5.3027503631325e-10,6.41923440026709e-11,-0.000880576251740988,0.00047786707349005,-3.58679228448552e-05,3.31447017738358e-07,4.67913807140891e-07,-1.14221473683187e-07,1.98561483269185e-08,-2.97969416326819e-09,4.08030506488687e-10,-5.13873126567838e-11,0.000194570507801508,-0.000276330190633692,2.67466944393796e-05,-1.18072955036708e-06,-1.43577987822575e-07,5.12395763315701e-08,-9.85336120575911e-09,1.55301762469516e-09,-2.19292345930665e-10,2.82470860788084e-11};
const double nb_k_2_2[]={1.47107357007529,0.606726267737109,0.0965032960556014,-0.0416813187048704,0.00584673893094613,0.00362165078856726,-0.00374109218485856,0.00183884926199942,-0.000437874723663312,-5.62945505165113e-05,1.40633587142072,0.532573697441418,0.0996264069268105,-0.0326665009374596,0.000948940588515306,0.0046158235979294,-0.00283430769938751,0.000606830944577483,0.000422247979015644,-0.000446107066080925,1.27052060401718,0.362954588828754,0.0858725564025334,-0.0122201511044634,-0.00407959697139479,0.00238702791287164,3.99744277180342e-05,-0.000610781628625445,0.000327618942421801,-6.40824868670675e-05,1.21669061346608,0.289888567583572,0.0711581420994488,-0.00507535645846862,-0.00333014317433887,0.000538258828628294,0.000665877776956594,-0.000366504466632854,-4.58025954888364e-05,0.000130223821210906,0.467719207492528,-0.496755967004945,0.0318951452197283,-0.00319405933867979,0.000378817692004189,-4.90059108703262e-05,6.68882206374488e-06,-9.46845206413818e-07,1.37551493080423e-07,-1.99391020361261e-08,0.39713599018272,-0.467511720087748,0.090898855310456,-0.0277149805374783,0.00996413458793538,-0.00390464645944911,0.00161220679652104,-0.000686314291188118,0.000291492761933432,-0.000108109237944853,0.423902395218573,-0.482402109471717,0.0713555166369812,-0.0162127148240246,0.00431669915734149,-0.00124997765166743,0.000381284118282679,-0.000120378689085621,3.86007377873893e-05,-1.14599548166949e-05};
double knbinomdevc_2 (double mu, double phi){
int iter=0; double x=0, y=phi/2-1, out=0;
if(mu < low_bound) return out;
else if(mu < 50){
if(mu < 0.01) x=mu/0.01-1;
else if(mu < 0.50) x=(2*mu-0.51)/0.49, iter=100;
else if(mu < 3.88) x=(2*mu-4.38)/3.38, iter=200;
else if(mu < 10.0) x=(2*mu-13.88)/6.12, iter=300;
else if(mu < 30.0) x=mu/10-2, iter=400;
else x=mu/10-4, iter=500;
double x_cheb[10], y_cheb[10];
x_cheb[0]=1, x_cheb[1]=x, y_cheb[0]=1, y_cheb[1]=y;
for(int i=2; i < 10; ++i) x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2];
for(int i=0; i<10; ++i){
for(int j=0; j<10; ++j, ++iter) out+=nb_k_2_1[iter]*x_cheb[j]*y_cheb[i];
}
if(mu<0.01){
double logmu = log(mu)/(1+log(mu));
out=out*mu*logmu*logmu;
}
}
else if(mu < 5000){
if(mu < 100) x=200/mu-3;
else if(mu < 1000) x=(2000/mu-11)/9, iter=10;
else x=2500/mu-1.5, iter=20;
double x_cheb[10], y_cheb[10], w1, w2, w3;
x_cheb[0]=1, x_cheb[1]=x, y_cheb[0]=1, y_cheb[1]=y;
w1=nb_k_2_2[iter]+nb_k_2_2[iter+1]*y, w2=nb_k_2_2[iter+10]+nb_k_2_2[iter+11]*y, w3=nb_k_2_2[iter+40]+nb_k_2_2[iter+41]*x;
for(int i=2; i < 10; ++i){
x_cheb[i] = 2*x*x_cheb[i-1]-x_cheb[i-2], y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2];
w1 += nb_k_2_2[iter+i]*y_cheb[i], w2 += nb_k_2_2[iter+10+i]*y_cheb[i], w3 += nb_k_2_2[iter+40+i]*x_cheb[i];
}
out = w1+(w2-w1)*w3;
}
else{
iter=30;
double y_cheb[10]; y_cheb[0]=1, y_cheb[1]=y;
out = nb_k_2_2[iter]+nb_k_2_2[iter+1]*y;
for(int i=2; i < 10; ++i) y_cheb[i] = 2*y*y_cheb[i-1]-y_cheb[i-2], out += nb_k_2_2[iter+i]*y_cheb[i];
}
return out;
}
// summarize all cases
void mnbinomdev (double *m, double *s, double *mans, double *vans, int *len, int *slen){
for(int i=0; i<(*len); ++i){
double mu=m[i], size=s[i % (*slen)];
double phi=1/size;
if(mu