statmod/0000755000176200001440000000000015071672342011734 5ustar liggesusersstatmod/tests/0000755000176200001440000000000014616616043013076 5ustar liggesusersstatmod/tests/statmod-Tests.Rout.save0000644000176200001440000002434014352244561017463 0ustar liggesusers 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.R0000644000176200001440000000673514351537605016011 0ustar liggesuserslibrary(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/MD50000644000176200001440000000575115071672342012254 0ustar liggesusersa009eeee60bb0c4f174e4e6458d2c02a *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/0000755000176200001440000000000014616616043012135 5ustar liggesusersstatmod/R/glmgam.R0000644000176200001440000000663313622170031013520 0ustar liggesusers# 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.R0000644000176200001440000000524314351535207014027 0ustar liggesusersDigamma <- 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.R0000644000176200001440000000214512672426126013406 0ustar liggesuserspermp <- 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.R0000644000176200001440000001367213473431170013364 0ustar liggesusersglmnb.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.R0000644000176200001440000000725114316502544014257 0ustar liggesusers# 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.R0000644000176200001440000000760012751041606013230 0ustar liggesusers## 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.R0000644000176200001440000000135311351052503014761 0ustar liggesusers## 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.R0000644000176200001440000002470512607604374013177 0ustar liggesusers# 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.R0000644000176200001440000000105011161616415013530 0ustar liggesusershommel.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.R0000644000176200001440000000104711161616415013534 0ustar liggesusersmatvec <- 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.R0000644000176200001440000000315711362711054013523 0ustar liggesusersmscale <- 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.R0000644000176200001440000000604111354247604014106 0ustar liggesusersremlscore <- 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.R0000644000176200001440000000074211661623622013415 0ustar liggesuserspower.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.R0000644000176200001440000000634111161616415015110 0ustar liggesusersremlscoregamma <- 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.R0000644000176200001440000000147011161616415013654 0ustar liggesusers# 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.R0000644000176200001440000000713113622172247014410 0ustar liggesusers# 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.R0000644000176200001440000002663213120716704014122 0ustar liggesusersdinvgauss <- 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.R0000644000176200001440000000676314350242106014641 0ustar liggesusersmeanT <- 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.R0000644000176200001440000000260012102144571013710 0ustar liggesusersforward <- 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.R0000644000176200001440000000234312002172210014055 0ustar liggesusers# 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.R0000644000176200001440000000403713753602046013711 0ustar liggesusers## 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.R0000644000176200001440000001022014352706675015523 0ustar liggesusersexpectedDeviance <- 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.R0000644000176200001440000000455411226536532013410 0ustar liggesusers## 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/0000755000176200001440000000000014616616041012643 5ustar liggesusersstatmod/data/welding.rdata0000644000176200001440000000234411161616415015311 0ustar liggesusersRDX2 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/0000755000176200001440000000000014616616043012523 5ustar liggesusersstatmod/src/gaussq2.f0000644000176200001440000001062412760526763014271 0ustar liggesusersC 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.c0000644000176200001440000000156314352674050013636 0ustar liggesusers#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.c0000644000176200001440000016352114352674050016136 0ustar liggesusers#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(muq).} \item{log}{logical; if \code{TRUE}, the log-density is returned.} \item{log.p}{logical; if \code{TRUE}, probabilities are on the log-scale.} \item{maxit}{maximum number of Newton iterations used to find \code{q}.} \item{tol}{small positive numeric value giving the convergence tolerance for the quantile.} \item{trace}{logical, if \code{TRUE} then the working estimate for \code{q} from each iteration will be output.} } \value{ Output values give density (\code{dinvgauss}), probability (\code{pinvgauss}), quantile (\code{qinvgauss}) or random sample (\code{rinvgauss}) for the inverse Gaussian distribution with mean \code{mean} and dispersion \code{dispersion}. Output is a vector of length equal to the maximum length of any of the arguments \code{x}, \code{q}, \code{mean}, \code{shape} or \code{dispersion}. If the first argument is the longest, then all the attributes of the input argument are preserved on output, for example, a matrix \code{x} will give a matrix on output. Elements of input vectors that are missing will cause the corresponding elements of the result to be missing, as will non-positive values for \code{mean} or \code{dispersion}. } \details{ The inverse Gaussian distribution takes values on the positive real line. It is somewhat more right skew than the gamma distribution, with variance given by \code{dispersion*mean^3}. The distribution has applications in reliability and survival analysis and is one of the response distributions used in generalized linear models. Giner and Smyth (2016) show that the inverse Gaussian distribution converges to an inverse chi-squared distribution as the mean becomes large. The functions provided here implement numeric algorithms developed by Giner and Smyth (2016) that achieve close to full machine accuracy for all possible parameter values. Giner and Smyth (2016) show that the probability calculations provided by these functions are considerably more accurate, and in most cases faster, than previous implementations of inverse Gaussian functions. The improvement in accuracy is most noticeable for extreme probability values and for large parameter values. The shape and dispersion parameters are alternative parametrizations for the variability, with \code{dispersion=1/shape}. Only one of these two arguments needs to be specified. If both are set, then \code{shape} takes precedence. } \references{ Giner, G., and Smyth, G. K. (2016). statmod: Probability calculations for the inverse Gaussian distribution. \emph{R Journal} 8(1), 339-351. \url{https://journal.r-project.org/archive/2016-1/giner-smyth.pdf} } \author{Gordon Smyth. Very early S-Plus versions of these functions, using simpler algorithms, were published 1998 at \url{http://www.statsci.org/s/invgauss.html}. Paul Bagshaw (Centre National d'Etudes des Telecommunications, France) contributed the original version of \code{qinvgauss} in December 1998. Trevor Park (Department of Statistics, University of Florida) suggested improvements to a version of \code{rinvguass} in 2005.} \examples{ q <- rinvgauss(10, mean=1, disp=0.5) # generate vector of 10 random numbers p <- pinvgauss(q, mean=1, disp=0.5) # p should be uniformly distributed # Quantile for small right tail probability: qinvgauss(1e-20, mean=1.5, disp=0.7, lower.tail=FALSE) # Same quantile, but represented in terms of left tail probability on log-scale qinvgauss(-1e-20, mean=1.5, disp=0.7, lower.tail=TRUE, log.p=TRUE) } \keyword{distribution} statmod/man/statmod.Rd0000644000176200001440000000552712342323725014456 0ustar liggesusers\name{statmod-package} \alias{statmod} \alias{statmod-package} \docType{package} \title{Introduction to the StatMod Package} \description{ This package includes a variety of functions for numerical analysis and statistical modelling. The functions are briefly summarized by type of application below. } \section{Generalized Linear Models}{ The function \code{\link{tweedie}} defines a large class of generalized linear model families with power variance functions. It used in conjunction with the glm function, and widens the class of families that can be fitted. \code{\link{qresiduals}} implements randomized quantile residuals for generalized linear models. The functions \code{canonic.digamma}, \code{unitdeviance.digamma}, \code{varfun.digamma}, \code{cumulant.digamma}, \code{d2cumulant.digamma}, \code{meanval.digamma} and \code{logmdigamma} are used to fit double-generalized models, in which a link-linear model is fitted to the dispersion as well as to the mean. Spefically they are used to fit the dispersion submodel associated with a gamma glm. } \section{Growth Curves}{ \code{\link{compareGrowthCurves}}, \code{compareTwoGrowthCurves} and \code{meanT} are functions to test for differences between growth curves with repeated measurements on subjects. } \section{Limiting Dilution Analysis}{ The \code{\link{limdil}} function is used in the analysis of stem cell frequencies. It implements limiting dilution analysis using complemenary log-log binomial generalized linear model regression, with some improvements on previous programs. } \section{Probability Distributions}{ The functions \code{\link{qinvgauss}}, \code{\link{dinvgauss}}, \code{\link{pinvgauss}} and \code{\link{rinvgauss}} provide probability calculations for the inverse Gaussian distribution. \code{\link{gauss.quad}} and \code{gauss.quad.prob} compute Gaussian Quadrature with probability distributions. } \section{Tests}{ \code{\link{hommel.test}} performs Hommel's multiple comparison tests. \code{\link{power.fisher.test}} computes the power of Fisher's Exact Test for comparing proportions. \code{\link{sage.test}} is a fast approximation to Fisher's exact test for each tag for comparing two Serial Analysis of Gene Expression (SAGE) libraries. \code{\link{permp}} computes p-values for permutation tests when the permutations are randomly drawn. } \section{Variance Models}{ \code{\link{mixedModel2}}, \code{\link{mixedModel2Fit}} and \code{\link{glmgam.fit}} fit mixed linear models. \code{\link{remlscore}} and \code{\link{remlscoregamma}} fit heteroscedastic and varying dispersion models by REML. \code{\link{welding}} is an example data set. } \section{Matrix Computations}{ \code{\link{matvec}} and \code{\link{vecmat}} facilitate multiplying matrices by vectors. } \author{Gordon Smyth} \keyword{documentation} statmod/man/logmdigamma.Rd0000644000176200001440000000145711260271745015261 0ustar liggesusers\name{logmdigamma} \alias{logmdigamma} \title{Log Minus Digamma Function} \description{ The difference between the \code{log} and \code{digamma} functions. } \usage{ logmdigamma(x) } \arguments{ \item{x}{numeric vector or array of positive values. Negative or zero values will return \code{NA}.} } \details{ \code{digamma(x)} is asymptotically equivalent to \code{log(x)}. \code{logmdigamma(x)} computes \code{log(x) - digamma(x)} without subtractive cancellation for large \code{x}. } \author{Gordon Smyth} \references{ Abramowitz, M., and Stegun, I. A. (1970). \emph{Handbook of mathematical functions.} Dover, New York. } \seealso{ \code{\link{digamma}} } \examples{ log(10^15) - digamma(10^15) # returns 0 logmdigamma(10^15) # returns value correct to 15 figures } \keyword{math} statmod/man/welding.Rd0000644000176200001440000000301411161616416014421 0ustar liggesusers\name{welding} \alias{welding} \title{Data: Tensile Strength of Welds} \description{ This is a highly fractionated two-level factorial design employed as a screening design in an off-line welding experiment performed by the National Railway Corporation of Japan. There were 16 runs and 9 experimental factors. The response variable is the observed tensile strength of the weld, one of several quality characteristics measured. All other variables are at plus and minus levels. } \usage{data(welding)} \format{ A data frame containing the following variables. All the explanatory variables are numeric with two levels, \code{-1} and \code{1}. \tabular{lll}{ \tab \bold{Variable} \tab \bold{Description}\cr \tab Rods \tab Kind of welding rods\cr \tab Drying \tab Period of drying\cr \tab Material \tab Welded material\cr \tab Thickness \tab Thickness\cr \tab Angle \tab Angle\cr \tab Opening \tab Opening\cr \tab Current \tab Current\cr \tab Method \tab Welding method\cr \tab Preheating \tab Preheating\cr \tab Strength \tab Tensile strength of the weld in kg/mm. The response variable.\cr } } \source{ \url{http://www.statsci.org/data/general/welding.html} } \references{ Smyth, G. K., Huele, F., and Verbyla, A. P. (2001). Exact and approximate REML for heteroscedastic regression. \emph{Statistical Modelling} \bold{1}, 161-175. Smyth, G. K. (2002). An efficient algorithm for REML in heteroscedastic regression. \emph{Journal of Computational and Graphical Statistics} \bold{11}, 1-12. } \keyword{datasets} statmod/man/sage.test.Rd0000644000176200001440000000630213753602046014673 0ustar liggesusers\name{sage.test} \alias{sage.test} \title{Exact Binomial Tests For Comparing Two SAGE Libraries (Obsolete)} \description{ Computes p-values for differential abundance for each tag between two digital libraries, conditioning on the total count for each tag. The counts in each group as a proportion of the whole are assumed to follow a binomial distribution. } \usage{ sage.test(x, y, n1=sum(x), n2=sum(y)) } \arguments{ \item{x}{integer vector giving counts in first library. Non-integer values are rounded to the nearest integer.} \item{y}{integer vector giving counts in second library. Non-integer values are rounded to the nearest integer.} \item{n1}{total number of tags in first library. Non-integer values are rounded to the nearest integer.} \item{n2}{total number of tags in second library. Non-integer values are rounded to the nearest integer.} } \details{ This function was originally written for comparing SAGE libraries (a method for counting the frequency of sequence tags in samples of RNA). It can however be used for comparing any two digital libraries from RNA-Seq, ChIP-Seq or other technologies with respect to technical variation. An exact two-sided binomial test is computed for each tag. This test is closely related to Fisher's exact test for 2x2 contingency tables but, unlike Fisher's test, it conditions on the total number of counts for each tag. The null hypothesis is that the expected counts are in the same proportions as the library sizes, i.e., that the binomial probability for the first library is \code{n1/(n1+n2)}. The two-sided rejection region is chosen analogously to Fisher's test. Specifically, the rejection region consists of those values with smallest probabilities under the null hypothesis. When the counts are reasonably large, the binomial test, Fisher's test and Pearson's chisquare all give the same results. When the counts are smaller, the binomial test is usually to be preferred in this context. This function is a later version of the earlier \code{sage.test} function in the sagenhaft Bioconductor package. This function has been made obsolete by \code{binomTest} in the edgeR package. } \note{ This function is kept in the statmod package so as not to break code that depends on it but it has been replaced by \code{binomTest} in the edgeR Bioconductor package and is no longer updated. It may be removed in a later release of this package. } \value{ Numeric vector of p-values. } \references{ \url{https://en.wikipedia.org/wiki/Binomial_test} \url{https://en.wikipedia.org/wiki/Fisher's_exact_test} \url{https://en.wikipedia.org/wiki/Serial_analysis_of_gene_expression} \url{https://en.wikipedia.org/wiki/RNA-Seq} } \author{Gordon Smyth} \seealso{ The \code{binomTest} function in the \href{https://doi.org/doi:10.18129/B9.bioc.edgeR}{edgeR} package on Bioconductor is a newer and better version of this function. \code{\link{binom.test}} in the stats package performs univariate binomial tests. } \examples{ sage.test(c(0,5,10),c(0,30,50),n1=10000,n2=15000) # Univariate equivalents: binom.test(5,5+30,p=10000/(10000+15000))$p.value binom.test(10,10+50,p=10000/(10000+15000))$p.value } \keyword{htest} statmod/man/growthcurve.Rd0000644000176200001440000001020514350237240015344 0ustar liggesusers\name{growthcurve} \alias{compareGrowthCurves} \alias{compareTwoGrowthCurves} \alias{plotGrowthCurves} \title{Compare Groups of Growth Curves} \description{ Do all pairwise comparisons between groups of growth curves using a permutation test. } \usage{ compareGrowthCurves(group, y, levels=NULL, nsim=100, fun=meanT, times=NULL, verbose=TRUE, adjust="holm", n0=0.5) compareTwoGrowthCurves(group, y, nsim=100, fun=meanT, n0=0.5) plotGrowthCurves(group, y, levels=sort(unique(group)), times=NULL, col=NULL,...) } \arguments{ \item{group}{vector or factor indicating group membership. Missing values are allowed in \code{compareGrowthCurves} but not in \code{compareTwoGrowthCurves}.} \item{y}{matrix of response values with rows for individuals and columns for times. The number of rows must agree with the length of \code{group}. Missing values are allowed.} \item{levels}{a character vector containing the identifiers of the groups to be compared. By default all groups with two more more members will be compared.} \item{nsim}{number of permutations to estimated p-values.} \item{fun}{a function defining the statistic used to measure the distance between two groups of growth curves. Defaults to \code{\link{meanT}}.} \item{times}{a numeric vector containing the column numbers on which the groups should be compared. By default all the columns are used.} \item{verbose}{should progress results be printed?} \item{adjust}{method used to adjust for multiple testing, see \code{p.adjust}.} \item{n0}{offset used for numerator and denominator of p-value calculation.} \item{col}{vector of colors corresponding to distinct groups} \item{...}{other arguments passed to \code{plot()}} } \details{ \code{compareTwoGrowthCurves} performs a permutation test of the difference between two groups of growth curves. \code{compareGrowthCurves} does all pairwise comparisons between two or more groups of growth curves. The permutation p-values are computed as p = (ngt + neq/2 + n0) / (nsim + n0) where ngt is the number of permutations with test statistics greater than observed, neq is the number of permuttation with test statistics equal to that observed, and n0 is an offset to avoid p-values of zero (Phipson & Smyth 2010). The offset n0 improves the type I error rate control and can be interpreted as allowing for the observed data as one of the permutations. High resolution p-values can be obtained by setting \code{nsim} to some large value, \code{nsim=10000} say. } \value{ \code{compareTwoGrowthCurves} returns a list with two components, \code{stat} and \code{p.value}, containing the observed statistics and the estimated p-value. \code{compareGrowthCurves} returns a data frame with components \item{Group1}{name of first group in a comparison} \item{Group2}{name of second group in a comparison} \item{Stat}{observed value of the statistic} \item{P.Value}{permutation p-value} \item{adj.P.Value}{p-value adjusted for multiple testing} } \author{Gordon Smyth} \references{ Elso, C. M., Roberts, L. J., Smyth, G. K., Thomson, R. J., Baldwin, T. M., Foote, S. J., and Handman, E. (2004). Leishmaniasis host response loci (lmr13) modify disease severity through a Th1/Th2-independent pathway. \emph{Genes and Immunity} 5, 93-100. Baldwin, T., Sakthianandeswaren, A., Curtis, J., Kumar, B., Smyth, G. K., Foote, S., and Handman, E. (2007). Wound healing response is a major contributor to the severity of cutaneous leishmaniasis in the ear model of infection. \emph{Parasite Immunology} 29, 501-513. Phipson B, Smyth GK (2010). Permutation P-values should never be zero: calculating exact P-values when permutations are randomly drawn. \emph{Statistical Applications in Genetics and Molecular Biology}, Volume 9, Issue 1, Article 39. \doi{10.2202/1544-6115.1585}, \doi{10.48550/arXiv.1603.05766}. } \seealso{ \code{\link{meanT}}, \code{\link{compareGrowthCurves}}, \code{\link{compareTwoGrowthCurves}} } \examples{ # A example with only one time data(PlantGrowth) compareGrowthCurves(PlantGrowth$group,as.matrix(PlantGrowth$weight)) # Can make p-values more accurate by nsim=10000 } \keyword{regression} statmod/man/remlscorgamma.Rd0000644000176200001440000001013113620137212015611 0ustar liggesusers\name{remlscoregamma} \alias{remlscoregamma} \title{Approximate REML for Gamma Regression with Structured Dispersion} \description{ Estimates structured dispersion effects using approximate REML with gamma responses. } \usage{ remlscoregamma(y, X, Z, mlink="log", dlink="log", trace=FALSE, tol=1e-5, maxit=40) } \arguments{ \item{y}{numeric vector of responses.} \item{X}{design matrix for predicting the mean.} \item{Z}{design matrix for predicting the variance.} \item{mlink}{character string or numeric value specifying link for mean model.} \item{dlink}{character string or numeric value specifying link for dispersion model.} \item{trace}{logical value. If \code{TRUE} then diagnostic information is output at each iteration.} \item{tol}{convergence tolerance.} \item{maxit}{maximum number of iterations allowed.} } \value{ List with the following components: \item{beta}{numeric vector of regression coefficients for predicting the mean.} \item{se.beta}{numeric vector of standard errors for beta.} \item{gamma}{numeric vector of regression coefficients for predicting the variance.} \item{se.gam}{numeric vector of standard errors for gamma.} \item{mu}{numeric vector of estimated means.} \item{phi}{numeric vector of estimated dispersions.} \item{deviance}{minus twice the REML log-likelihood.} \item{h}{numeric vector of leverages.} } \details{ This function fits a double generalized linear model (glm) with gamma responses. As for ordinary gamma glms, a link-linear model is assumed for the expected values. The double glm assumes a separate link-linear model for the dispersions as well. The responses \code{y} are assumed to follow a gamma generalized linear model with link \code{mlink} and design matrix \code{X}. The dispersions follow a link-linear model with link \code{dlink} and design matrix \code{Z}. Write \eqn{y_i} for the \eqn{i}th response. The \eqn{y_i} are assumed to be independent and gamma distributed with \eqn{E(y_i) = \mu_i} and var\eqn{(y_i)=\phi_i\mu_i^2}. The link-linear model for the means can be written as \deqn{g(\mu)=X\beta} where \eqn{g} is the mean-link function defined by \code{mlink} and \eqn{\mu} is the vector of means. The dispersion link-linear model can be written as \deqn{h(\phi)=Z\gamma} where \eqn{h} is the dispersion-link function defined by \code{dlink} and \eqn{\phi} is the vector of dispersions. The parameters \eqn{\gamma} are estimated by approximate REML likelihood using an adaption of the algorithm described by Smyth (2002). See also Smyth and Verbyla (1999a,b) and Smyth and Verbyla (2009). Having estimated \eqn{\gamma} and \eqn{\phi}, the \eqn{\beta} are estimated as usual for a gamma glm. The estimated values for \eqn{\beta}, \eqn{\mu}, \eqn{\gamma} and \eqn{\phi} are return as \code{beta}, \code{mu}, \code{gamma} and \code{phi} respectively. } \references{ Smyth, G. K., and Verbyla, A. P. (1999a). Adjusted likelihood methods for modelling dispersion in generalized linear models. \emph{Environmetrics} 10, 695-709. \url{http://www.statsci.org/smyth/pubs/ties98tr.html} Smyth, G. K., and Verbyla, A. P. (1999b). Double generalized linear models: approximate REML and diagnostics. In \emph{Statistical Modelling: Proceedings of the 14th International Workshop on Statistical Modelling}, Graz, Austria, July 19-23, 1999, H. Friedl, A. Berghold, G. Kauermann (eds.), Technical University, Graz, Austria, pages 66-80. \url{http://www.statsci.org/smyth/pubs/iwsm99-Preprint.pdf} Smyth, G. K. (2002). An efficient algorithm for REML in heteroscedastic regression. \emph{Journal of Computational and Graphical Statistics} \bold{11}, 836-847. Smyth, GK, and Verbyla, AP (2009). Leverage adjustments for dispersion modelling in generalized nonlinear models. \emph{Australian and New Zealand Journal of Statistics} 51, 433-448. } \examples{ data(welding) attach(welding) y <- Strength X <- cbind(1,(Drying+1)/2,(Material+1)/2) colnames(X) <- c("1","B","C") Z <- cbind(1,(Material+1)/2,(Method+1)/2,(Preheating+1)/2) colnames(Z) <- c("1","C","H","I") out <- remlscoregamma(y,X,Z) } \keyword{regression} statmod/man/fitNBP.Rd0000644000176200001440000000606314275416513014126 0ustar liggesusers\name{fitNBP} \alias{fitNBP} \title{Negative Binomial Model for SAGE Libraries with Pearson Estimation of Dispersion} \description{ Fit a multi-group negative-binomial model to SAGE data, with Pearson estimation of the common overdispersion parameter. } \usage{ fitNBP(y, group=NULL, lib.size=colSums(y), tol=1e-5, maxit=40, verbose=FALSE) } \arguments{ \item{y}{numeric matrix giving counts. Rows correspond to tags (genes) and columns to SAGE libraries.} \item{group}{factor indicating which library belongs to each group. If \code{NULL} then one group is assumed.} \item{lib.size}{vector giving total number of tags in each library.} \item{tol}{small positive numeric tolerance to judge convergence} \item{maxit}{maximum number of iterations permitted} \item{verbose}{logical, if \code{TRUE} then iteration progress information is output.} } \details{ The overdispersion parameter is estimated equating the Pearson goodness of fit to its expectation. The variance is assumed to be of the form Var(y)=mu*(1+phi*mu) where E(y)=mu and phi is the dispersion parameter. All tags are assumed to share the same dispersion. For given dispersion, the model for each tag is a negative-binomial generalized linear model with log-link and \code{log(lib.size)} as offset. The coefficient parametrization used is that corresponding to the formula \code{~0+group+offset(log(lib.size)}. Except for the dispersion being common rather than genewise, the model fitted by this function is equivalent to that proposed by Lu et al (2005). The numeric algorithm used is that of alternating iterations (Smyth, 1996) using Newton's method as the outer iteration for the dispersion parameter starting at phi=0. This iteration is monotonically convergent for the dispersion. } \note{ This function has been made obsolete by the \href{https://doi.org/doi:10.18129/B9.bioc.edgeR}{edgeR} package on Bioconductor. } \value{ List with components \item{coefficients}{numeric matrix of rates for each tag (gene) and each group} \item{fitted.values}{numeric matrix of fitted values} \item{dispersion}{estimated dispersion parameter} } \author{Gordon Smyth} \references{ Lu, J, Tomfohr, JK, Kepler, TB (2005). Identifying differential expression in multiple SAGE libraries: an overdispersed log-linear model approach. \emph{BMC Bioinformatics} 6,165. Smyth, G. K. (1996). Partitioned algorithms for maximum likelihood and other nonlinear estimation. \emph{Statistics and Computing}, 6, 201-216. \doi{10.1007/BF00140865} } \seealso{ \code{\link{sage.test}} The edgeR package on Biconductor provides new and better functions to fit negative-binomial glms to SAGE or RNA-seq data. See particularly the \code{glmFit} and \code{mglmOneWay} functions. } \examples{ # True value for dispersion is 1/size=2/3 # Note the Pearson method tends to under-estimate the dispersion y <- matrix(rnbinom(10*4,mu=4,size=1.5),10,4) lib.size <- rep(50000,4) group <- c(1,1,2,2) fit <- fitNBP(y,group=group,lib.size=lib.size) logratio <- fit$coef \%*\% c(-1,1) } \keyword{regression} statmod/man/meanT.Rd0000644000176200001440000000226511161616416014043 0ustar liggesusers\name{meanT} \alias{meanT} \title{Mean t-Statistic Between Two Groups of Growth Curves} \description{ The mean-t statistic of the distance between two groups of growth curves. } \usage{ meanT(y1, y2) } \arguments{ \item{y1}{matrix of response values for the first group, with a row for each individual and a column for each time. Missing values are allowed.} \item{y2}{matrix of response values for the second group. Must have the same number of columns as \code{y1}. Missing values are allowed.} } \details{ This function computes the pooled two-sample t-statistic between the response values at each time, and returns the mean of these values weighted by the degrees of freedom. This function is used by \code{compareGrowthCurves}. } \value{numeric vector of length one containing the mean t-statistic.} \author{Gordon Smyth} \seealso{ \code{\link{compareGrowthCurves}}, \code{\link{compareTwoGrowthCurves}} } \examples{ y1 <- matrix(rnorm(4*3),4,3) y2 <- matrix(rnorm(4*3),4,3) meanT(y1,y2) data(PlantGrowth) compareGrowthCurves(PlantGrowth$group,as.matrix(PlantGrowth$weight)) # Can make p-values more accurate by nsim=10000 } \keyword{regression} statmod/man/tweedie.Rd0000644000176200001440000001514014046200541014412 0ustar liggesusers\name{tweedie} \alias{tweedie} \title{Tweedie Generalized Linear Models} \description{ Produces a generalized linear model family object with any power variance function and any power link. Includes the Gaussian, Poisson, gamma and inverse-Gaussian families as special cases. } \usage{ tweedie(var.power = 0, link.power = 1 - var.power) } \arguments{ \item{var.power}{index of power variance function} \item{link.power}{index of power link function. \code{link.power=0} produces a log-link. Defaults to the canonical link, which is \code{1-var.power}.} } \value{ A family object, which is a list of functions and expressions used by \code{glm} and \code{gam} in their iteratively reweighted least-squares algorithms. See \code{\link{family}} and \code{\link{glm}} in the R base help for details. } \details{ This function provides access to a range of generalized linear model (GLM) response distributions that are not otherwise provided by R. It is also useful for accessing distribution/link combinations that are disallowed by the R \code{glm} function. The variance function for the GLM is assumed to be V(mu) = mu^var.power, where mu is the expected value of the distribution. The link function of the GLM is assumed to be mu^link.power for non-zero values of link.power or log(mu) for var.power=0. For example, \code{var.power=1} produces the identity link. The canonical link for each Tweedie family is \code{link.power = 1 - var.power}. The Tweedie family of GLMs is discussed in detail by Dunn and Smyth (2018). Each value of \code{var.power} corresponds to a particular type of response distribution. The values 0, 1, 2 and 3 correspond to the normal distribution, the Poisson distribution, the gamma distribution and the inverse-Gaussian distribution respectively. For these choices of \code{var.power}, the Tweedie family is exactly equivalent to the usual GLM famly except with a greater choice of link powers. For example, \code{tweedie(var.power = 1, link.power = 0)} is exactly equivalent to \code{poisson(link = "log")}. The most interesting Tweedie families occur for \code{var.power} between 1 and 2. For these GLMs, the response distribution has mass at zero (i.e., it has exact zeros) but is otherwise continuous on the positive real numbers (Smyth, 1996; Hasan et al, 2012). These GLMs have been used to model rainfall for example. Many days there is no rain at all (exact zero) but, if there is any rain, then the actual amount of rain is continuous and positive. Generally speaking, \code{var.power} should be chosen so that the theoretical response distribution matches the type of response data being modeled. Hence \code{var.power} should be chosen between 1 and 2 only if the response observations are continuous and positive except for exact zeros and \code{var.power} should be chosen greater than or equal to 2 only if the response observations are continuous and strictly positive. There are no theoretical Tweedie GLMs with var.power between 0 and 1 (Jorgensen 1987). The \code{tweedie} function will work for those values but the family should be interpreted in a quasi-likelihood sense. Theoretical Tweedie GLMs do exist for negative values of var.power, but they are of little practical application. These distributions assume The \code{tweedie} function will work for those values but the family should be interpreted in a quasi-likelihood sense. The name Tweedie has been associated with this family by Joergensen (1987) in honour of M. C. K. Tweedie. Joergensen (1987) gives a mathematical derivation of the Tweedie distributions proving that no distributions exist for var.power between 0 and 1. Mathematically, a Tweedie GLM assumes the following. Let \eqn{\mu_i = E(y_i)} be the expectation of the \eqn{i}th response. We assume that \deqn{\mu_i^q = x_i^Tb, var(y_i) = \phi \mu_i^p} where \eqn{x_i} is a vector of covariates and b is a vector of regression cofficients, for some \eqn{\phi}, \eqn{p} and \eqn{q}. This family is specified by \code{var.power = p} and \code{link.power = q}. A value of zero for \eqn{q} is interpreted as \eqn{\log(\mu_i) = x_i^Tb}. The following table summarizes the possible Tweedie response distributions: \tabular{cl}{ \bold{var.power} \tab \bold{Response distribution}\cr 0 \tab Normal\cr 1 \tab Poisson\cr (1, 2) \tab Compound Poisson, non-negative with mass at zero\cr 2 \tab Gamma\cr 3 \tab Inverse-Gaussian\cr > 2 \tab Stable, with support on the positive reals } } \references{ Dunn, P. K., and Smyth, G. K, (2018). \emph{Generalized linear models with examples in R}. Springer, New York, NY. \doi{10.1007/978-1-4419-0118-7} (Chapter 12 gives an overall discussion of Tweedie GLMs with R code and case studies.) Hasan, M.M. and Dunn, P.K. (2012). Understanding the effect of climatology on monthly rainfall amounts in Australia using Tweedie GLMs. \emph{International Journal of Climatology}, 32(7) 1006-1017. (An example with var.power between 1 and 2) Joergensen, B. (1987). Exponential dispersion models. \emph{J. R. Statist. Soc.} B \bold{49}, 127-162. (Mathematical derivation of Tweedie response distributions) Tweedie, M. C. K. (1984). An index which distinguishes between some important exponential families. In \emph{Statistics: Applications and New Directions}. Proceedings of the Indian Statistical Institute Golden Jubilee International Conference. (Eds. J. K. Ghosh and J. Roy), pp. 579-604. Calcutta: Indian Statistical Institute. (The original mathematical paper from which the family is named) Smyth, G. K. (1996). Regression modelling of quantity data with exact zeroes. \emph{Proceedings of the Second Australia-Japan Workshop on Stochastic Models in Engineering, Technology and Management}. Technology Management Centre, University of Queensland, pp. 572-580. \url{http://www.statsci.org/smyth/pubs/RegressionWithExactZerosPreprint.pdf} (Derivation and examples of Tweedie GLMS with var.power between 0 and 1) Smyth, G. K., and Verbyla, A. P., (1999). Adjusted likelihood methods for modelling dispersion in generalized linear models. \emph{Environmetrics} \bold{10}, 695-709. \url{http://www.statsci.org/smyth/pubs/Ties98-Preprint.pdf} (Includes examples of Tweedie GLMs with \code{var.power=2} and \code{var.power=4}) } \author{Gordon Smyth} \seealso{\code{\link{glm}}, \code{\link{family}}, \code{\link[tweedie]{dtweedie}}} \examples{ y <- rgamma(20,shape=5) x <- 1:20 # Fit a poisson generalized linear model with identity link glm(y~x,family=tweedie(var.power=1,link.power=1)) # Fit an inverse-Gaussion glm with log-link glm(y~x,family=tweedie(var.power=3,link.power=0)) } \keyword{regression} statmod/man/power.Rd0000644000176200001440000000256514213252411014126 0ustar liggesusers\name{power.fisher.test} \alias{power.fisher.test} \title{Power of Fisher's Exact Test for Comparing Proportions} \description{ Calculate by simulation the power of Fisher's exact test for comparing two proportions given two margin counts. } \usage{ power.fisher.test(p1, p2, n1, n2, alpha=0.05, nsim=100, alternative="two.sided") } \arguments{ \item{p1}{first proportion to be compared.} \item{p2}{second proportion to be compared.} \item{n1}{first sample size.} \item{n2}{second sample size.} \item{alpha}{significance level.} \item{nsim}{number of data sets to simulate.} \item{alternative}{indicates the alternative hypothesis and must be one of "two.sided", "greater" or "less".} } \details{ Estimates the power of Fisher's exact test for testing the null hypothesis that \code{p1} equals \code{p2} against the alternative that they are not equal. The power is estimated by simulation. The function generates \code{nsim} pairs of binomial deviates and calls \code{fisher.test} to obtain \code{nsim} p-values. The required power is tnen the proportion of the simulated p-values that are less than \code{alpha}. } \value{ Estimated power of the test. } \author{Gordon Smyth} \seealso{ \code{\link{fisher.test}}, \code{\link{power.t.test}} } \examples{ power.fisher.test(0.5,0.9,20,20) # 70% chance of detecting difference } \keyword{htest} statmod/man/gauss.quad.Rd0000644000176200001440000000556114275420757015066 0ustar liggesusers\name{gauss.quad} \alias{gauss.quad} \title{Gaussian Quadrature} \description{Calculate nodes and weights for Gaussian quadrature.} \usage{ gauss.quad(n, kind = "legendre", alpha = 0, beta = 0) } \arguments{ \item{n}{number of nodes and weights} \item{kind}{kind of Gaussian quadrature, one of \code{"legendre"}, \code{"chebyshev1"}, \code{"chebyshev2"}, \code{"hermite"}, \code{"jacobi"} or \code{"laguerre"}} \item{alpha}{parameter for Jacobi or Laguerre quadrature, must be greater than -1} \item{beta}{parameter for Jacobi quadrature, must be greater than -1} } \value{A list containing the components \item{nodes}{vector of values at which to evaluate the function} \item{weights}{vector of weights to give the function values} } \details{ The integral from \code{a} to \code{b} of \code{w(x)*f(x)} is approximated by \code{sum(w*f(x))} where \code{x} is the vector of nodes and \code{w} is the vector of weights. The approximation is exact if \code{f(x)} is a polynomial of order no more than \code{2n-1}. The possible choices for \code{w(x)}, \code{a} and \code{b} are as follows: Legendre quadrature: \code{w(x)=1} on \code{(-1,1)}. Chebyshev quadrature of the 1st kind: \code{w(x)=1/sqrt(1-x^2)} on \code{(-1,1)}. Chebyshev quadrature of the 2nd kind: \code{w(x)=sqrt(1-x^2)} on \code{(-1,1)}. Hermite quadrature: \code{w(x)=exp(-x^2)} on \code{(-Inf,Inf)}. Jacobi quadrature: \code{w(x)=(1-x)^alpha*(1+x)^beta} on \code{(-1,1)}. Note that Chebyshev quadrature is a special case of this. Laguerre quadrature: \code{w(x)=x^alpha*exp(-x)} on \code{(0,Inf)}. The algorithm used to generated the nodes and weights is explained in Golub and Welsch (1969). } \references{ Golub, G. H., and Welsch, J. H. (1969). Calculation of Gaussian quadrature rules. \emph{Mathematics of Computation} \bold{23}, 221-230. Golub, G. H. (1973). Some modified matrix eigenvalue problems. \emph{Siam Review} \bold{15}, 318-334. Smyth, G. K. (1998). Numerical integration. In: \emph{Encyclopedia of Biostatistics}, P. Armitage and T. Colton (eds.), Wiley, London, pages 3088-3095. \url{http://www.statsci.org/smyth/pubs/NumericalIntegration-Preprint.pdf} Smyth, G. K. (1998). Polynomial approximation. In: \emph{Encyclopedia of Biostatistics}, P. Armitage and T. Colton (eds.), Wiley, London, pages 3425-3429. \url{http://www.statsci.org/smyth/pubs/PolyApprox-Preprint.pdf} Stroud, AH, and Secrest, D (1966). \emph{Gaussian Quadrature Formulas}. Prentice-Hall, Englewood Cliffs, N.J. } \author{Gordon Smyth, using Netlib Fortran code \url{https://netlib.org/go/gaussq.f}, and including a suggestion from Stephane Laurent} \seealso{ \code{\link{gauss.quad.prob}}, \code{\link{integrate}} } \examples{ # mean of gamma distribution with alpha=6 out <- gauss.quad(10,"laguerre",alpha=5) sum(out$weights * out$nodes) / gamma(6) } \keyword{math} statmod/man/glmnbfit.Rd0000644000176200001440000000612314046200372014571 0ustar liggesusers\name{glmnb.fit} \alias{glmnb.fit} \title{Fit Negative Binomial Generalized Linear Model with Log-Link} \description{ Fit a generalized linear model with secure convergence. } \usage{ glmnb.fit(X, y, dispersion, weights = NULL, offset = 0, coef.start = NULL, start.method = "mean", tol = 1e-6, maxit = 50L, trace = FALSE) } \arguments{ \item{X}{design matrix, assumed to be of full column rank. Missing values not allowed.} \item{y}{numeric vector of responses. Negative or missing values not allowed.} \item{dispersion}{numeric vector of dispersion parameters for the negative binomial distribution. If of length 1, then the same dispersion is assumed for all observations.} \item{weights}{numeric vector of positive weights, defaults to all one.} \item{offset}{offset vector for linear model} \item{coef.start}{numeric vector of starting values for the regression coefficients} \item{start.method}{method used to find starting values, possible values are \code{"mean"} or \code{"log(y)"}} \item{tol}{small positive numeric value giving convergence tolerance} \item{maxit}{maximum number of iterations allowed} \item{trace}{logical value. If \code{TRUE} then output diagnostic information at each iteration.} } \value{ List with the following components: \item{coefficients}{numeric vector of regression coefficients} \item{fitted}{numeric vector of fitted values} \item{deviance}{residual deviance} \item{iter}{number of iterations used to convergence. If convergence was not achieved then \code{iter} is set to \code{maxit+1}.} } \details{ This function implements a modified Fisher scoring algorithm for generalized linear models, analogous to the Levenberg-Marquardt algorithm for nonlinear least squares. The Levenberg-Marquardt modification checks for a reduction in the deviance at each step, and avoids the possibility of divergence. The result is a very secure algorithm that converges for almost all datasets. \code{glmnb.fit} is in principle equivalent to \code{glm.fit(X,y,family=negative.binomial(link="log",theta=1/dispersion))} but with more secure convergence. Here \code{negative.binomial} is a function in the MASS package. The \code{dispersion} parameter is the same as \code{1/theta} for the \code{MASS::negative.binomial} function or \code{1/size} for the \code{stats::rnbinom} function. \code{dispersion=0} corresponds to the Poisson distribution. } \author{Gordon Smyth and Yunshun Chen} \references{ Dunn, PK, and Smyth, GK (2018). \emph{Generalized linear models with examples in R}. Springer, New York, NY. \doi{10.1007/978-1-4419-0118-7} } \seealso{ The \code{glmFit} function in the edgeR package on Bioconductor is a high-performance version of \code{glmnb.fit} for many \code{y} vectors at once. \code{\link{glm}} is the standard glm fitting function in the stats package. \code{negative.binomial} in the MASS package defines a negative binomial family for use with \code{glm}. } \examples{ y <- rnbinom(10, mu=1:10, size=5) X <- cbind(1, 1:10) fit <- glmnb.fit(X, y, dispersion=0.2, trace=TRUE) } \keyword{regression} statmod/man/plot.limdil.Rd0000644000176200001440000000354312104350427015221 0ustar liggesusers\name{plot.limdil} \docType{class} \alias{print.limdil} \alias{plot.limdil} \title{Plot or print an object of class limdil} \description{ Plot or print the results of a limiting dilution analysis. } \usage{ \S3method{print}{limdil}(x, \dots) \S3method{plot}{limdil}(x, col.group=NULL, cex=1, lwd=1, legend.pos="bottomleft", \dots) } \arguments{ \item{x}{object of class \code{limdil}.} \item{col.group}{vector of colors for the groups of the same length as \code{levels(x$group)}.} \item{cex}{relative symbol size} \item{lwd}{relative line width} \item{legend.pos}{positioning on plot of legend when there are multiple groups} \item{\dots}{other arguments to be passed to \code{plot} or \code{print}. Note that \code{pch} and \code{lty} are reserved arguments for the plot method.} } \details{ The print method formats results similarly to a regression or anova summary in R. The plot method produces a plot of a limiting dilution experiment similar to that in Bonnefoix et al (2001). The basic design of the plot was made popular by Lefkovits and Waldmann (1979). The plot shows frequencies and confidence intervals for the multiple groups. A novel feature is that assays with 100\% successes are included in the plot and are represented by down-pointing triangles. } \author{Yifang Hu and Gordon Smyth} \references{ Bonnefoix, T, Bonnefoix, P, Callanan, M, Verdiel, P, and Sotto, JJ (2001). Graphical representation of a generalized linear model-based statistical test estimating the fit of the single-hit poisson model to limiting dilution assays. \emph{The Journal of Immunology} 167, 5725-5730. Lefkovits, I, and Waldmann, H (1979). \emph{Limiting dilution analysis of cells in the immune system}. Cambridge University Press, Cambridge. } \seealso{\link{limdil} describes the \code{limdil} class.} \keyword{regression} statmod/man/digammaf.Rd0000644000176200001440000000661114351542354014546 0ustar liggesusers\name{Digamma} \alias{Digamma} \alias{canonic.digamma} \alias{d2cumulant.digamma} \alias{unitdeviance.digamma} \alias{cumulant.digamma} \alias{meanval.digamma} \alias{varfun.digamma} \title{Digamma Generalized Linear Model Family} \description{ Produces a Digamma generalized linear model family object. The Digamma distribution is the distribution of the unit deviance for a gamma response. } \usage{ Digamma(link = "log") unitdeviance.digamma(y, mu) cumulant.digamma(theta) meanval.digamma(theta) d2cumulant.digamma(theta) varfun.digamma(mu) canonic.digamma(mu) } \arguments{ \item{link}{character string, number or expressing specifying the link function. See \code{quasi} for specification of this argument.} \item{y}{numeric vector of (positive) response values} \item{mu}{numeric vector of (positive) fitted values} \item{theta}{numeric vector of values of the canonical variable, equal to \eqn{-1/\phi} where \eqn{\phi} is the dispersion parameter of the gamma distribution} } \value{ \code{Digamma} produces a glm family object, which is a list of functions and expressions used by \code{glm} in its iteratively reweighted least-squares algorithm. See \code{family} for details. The other functions take vector arguments and produce vector values of the same length and called by \code{Digamma}. \code{unitdeviance.digamma} gives the unit deviances of the family, equal to the squared deviance residuals. \code{cumulant.digamma} is the cumulant function. If the dispersion is unity, then successive derivatives of the cumulant function give successive cumulants of the Digamma distribution. \code{meanvalue.digamma} gives the first derivative, which is the expected value. \code{d2cumulant.digamma} gives the second derivative, which is the variance. \code{canonic.digamma} is the inverse of \code{meanvalue.digamma} and gives the canonical parameter as a function of the mean parameter. \code{varfun.digamma} is the variance function of the Digamma family, the variance as a function of the mean. } \details{ This family is useful for dispersion modelling with gamma generalized linear models. The Digamma distribution describes the distribution of the unit deviances for a gamma family, in the same way that the gamma distribution itself describes the distribution of the unit deviances for Gaussian or inverse Gaussian families. The Digamma distribution is so named because it is dual to the gamma distribution in the above sense, and because the \code{digamma function} appears in its mean function. Suppose that \eqn{y} follows a gamma distribution with mean \eqn{\mu} and dispersion parameter \eqn{\phi}, so the variance of \eqn{y} is \eqn{\phi \mu^2}. Write \eqn{d(y,\mu)} for the gamma distribution unit deviance. Then \code{meanval.digamma(-1/phi)} gives the mean of \eqn{d(y,\mu)} and \code{2*d2cumulant.digamma(-1/phi)} gives the variance. } \author{Gordon Smyth} \references{ Smyth, G. K. (1989). Generalized linear models with varying dispersion. \emph{J. R. Statist. Soc. B}, \bold{51}, 47-61. \doi{10.1111/j.2517-6161.1989.tb01747.x} } \examples{ # Test for log-linear dispersion trend in gamma regression y <- rchisq(20,df=1) x <- 1:20 out.gam <- glm(y~x,family=Gamma(link="log")) d <- residuals(out.gam)^2 out.dig <- glm(d~x,family=Digamma(link="log")) summary(out.dig,dispersion=2) } \seealso{ \code{\link{quasi}}, \code{\link{make.link}} } \keyword{models} statmod/man/matvec.Rd0000644000176200001440000000161111161616416014250 0ustar liggesusers\name{matvec} \alias{matvec} \alias{vecmat} \title{Multiply a Matrix by a Vector} \description{Multiply the rows or columns of a matrix by the elements of a vector.} \usage{ matvec(M, v) vecmat(v, M) } \arguments{ \item{M}{numeric matrix, or object which can be coerced to a matrix.} \item{v}{numeric vector, or object which can be coerced to a vector. Length should match the number of columns of \code{M} (for \code{matvec}) or the number of rows of \code{M} (for \code{vecmat})} } \value{A matrix of the same dimensions as \code{M}.} \details{ \code{matvec(M,v)} is equivalent to \code{M \%*\% diag(v)} but is faster to execute. Similarly \code{vecmat(v,M)} is equivalent to \code{diag(v) \%*\% M} but is faster to execute. } \examples{ A <- matrix(1:12,3,4) A matvec(A,c(1,2,3,4)) vecmat(c(1,2,3),A) } \author{Gordon Smyth} \keyword{array} \keyword{algebra} statmod/man/mscale.Rd0000644000176200001440000000234411362711554014243 0ustar liggesusers\name{mscale} \alias{mscale} \title{M Scale Estimation} \description{ Robust estimation of a scale parameter using Hampel's redescending psi function. } \usage{ mscale(u, na.rm=FALSE) } \arguments{ \item{u}{numeric vector of residuals.} \item{na.rm}{logical. Should missing values be removed?} } \value{numeric constant giving the estimated scale.} \details{ Estimates a scale parameter or standard deviation using an M-estimator with 50\% breakdown. This means the estimator is highly robust to outliers. If the input residuals \code{u} are a normal sample, then \code{mscale(u)} should be equal to the standard deviation. } \author{Gordon Smyth} \references{ Yohai, V. J. (1987). High breakdown point and high efficiency robust estimates for regression. \emph{Ann. Statist.} 15, 642-656. Stromberg, A. J. (1993). Computation of high breakdown nonlinear regression parameters. \emph{J. Amer. Statist. Assoc.} 88, 237-244. Smyth, G. K., and Hawkins, D. M. (2000). Robust frequency estimation using elemental sets. \emph{Journal of Computational and Graphical Statistics} 9, 196-214. } %\seealso{ %\code{\link{rho.hampel}}, \code{\link{psi.hampel}} %} \examples{ u <- rnorm(100) sd(u) mscale(u) } statmod/man/mixedmodel.Rd0000644000176200001440000001232413604252260015120 0ustar liggesusers\name{mixedModel2} \alias{mixedModel2} \alias{mixedModel2Fit} \alias{randomizedBlock} \alias{randomizedBlockFit} \title{Fit Mixed Linear Model with 2 Error Components} \description{ Fits a mixed linear model by REML. The linear model contains one random factor apart from the unit errors. } \usage{ mixedModel2(formula, random, weights=NULL, only.varcomp=FALSE, data=list(), subset=NULL, contrasts=NULL, tol=1e-6, maxit=50, trace=FALSE) mixedModel2Fit(y, X, Z, w=NULL, only.varcomp=FALSE, tol=1e-6, maxit=50, trace=FALSE) randomizedBlock(formula, random, weights=NULL, only.varcomp=FALSE, data=list(), subset=NULL, contrasts=NULL, tol=1e-6, maxit=50, trace=FALSE) randomizedBlockFit(y, X, Z, w=NULL, only.varcomp=FALSE, tol=1e-6, maxit=50, trace=FALSE) } \arguments{ The arguments \code{formula}, \code{weights}, \code{data}, \code{subset} and \code{contrasts} have the same meaning as in \code{lm}. The arguments \code{y}, \code{X} and \code{w} have the same meaning as in \code{lm.wfit}. \item{formula}{formula specifying the fixed model.} \item{random}{vector or factor specifying the blocks corresponding to random effects.} \item{weights}{optional vector of prior weights.} \item{only.varcomp}{logical value, if \code{TRUE} computation of standard errors and fixed effect coefficients will be skipped} \item{data}{an optional data frame containing the variables in the model.} \item{subset}{an optional vector specifying a subset of observations to be used in the fitting process.} \item{contrasts}{an optional list. See the \code{contrasts.arg} argument of \code{model.matrix.default}.} \item{tol}{small positive numeric tolerance, passed to \code{glmgam.fit}} \item{maxit}{maximum number of iterations permitted, passed to \code{glmgam.fit}} \item{trace}{logical value, passed to \code{glmgam.fit}. If \code{TRUE} then working estimates will be printed at each iteration.} \item{y}{numeric response vector} \item{X}{numeric design matrix for fixed model} \item{Z}{numeric design matrix for random effects} \item{w}{optional vector of prior weights} } \details{ Note that \code{randomizedBlock} and \code{mixedModel2} are alternative names for the same function. This function fits the model \eqn{y=Xb+Zu+e} where \eqn{b} is a vector of fixed coefficients and \eqn{u} is a vector of random effects. Write \eqn{n} for the length of \eqn{y} and \eqn{q} for the length of \eqn{u}. The random effect vector \eqn{u} is assumed to be normal, mean zero, with covariance matrix \eqn{\sigma^2_uI_q} while \eqn{e} is normal, mean zero, with covariance matrix \eqn{\sigma^2I_n}. If \eqn{Z} is an indicator matrix, then this model corresponds to a randomized block experiment. The model is fitted using an eigenvalue decomposition that transforms the problem into a Gamma generalized linear model. To the knowledge of the author, this is an original and unpublished approach to the problem of fitting mixed models. Note that the block variance component \code{varcomp[2]} is not constrained to be non-negative. It may take negative values corresponding to negative intra-block correlations. However the correlation \code{varcomp[2]/sum(varcomp)} must lie between \code{-1} and \code{1}. Missing values in the data are not allowed. This function is in principle equivalent to \code{lme(fixed=formula,random=~1|random)} except that the block variance component is not constrained to be non-negative. If the block variance component is non-negative, then this function is faster and more accurate than \code{lme} for small to moderate size data sets but slower than \code{lme} when the number of observations is large. This function tends to be fast and reliable, compared to competitor functions that fit randomized block models, when then number of observations is small, say no more than 200. However it becomes quadratically slow as the number of observations increases because of the need to compute two singular value decompositions of order nearly equal to the number of observations, although this can be limited to only one decomposition if \code{only.varcomp = TRUE}). For these reasons, this function is a good choice when fitting large numbers of mixed models to small datasets but is not optimal as currently implemented for fitting mixed models to very large data sets. } \value{ A list with the components: \item{varcomp}{numeric vector of length two containing the residual and block components of variance.} \item{se.varcomp}{standard errors for the variance components (if \code{only.varcomp=FALSE}).} \item{coefficients}{numeric vector of fixed coefficients (if \code{only.varcomp=FALSE}).} \item{se.coefficients}{standard errors for the fixed coefficients (if \code{only.varcomp=FALSE}).} } \author{Gordon Smyth} \references{ Venables, W., and Ripley, B. (2002). \emph{Modern Applied Statistics with S-Plus}, Springer. } \seealso{ \code{\link{glmgam.fit}}, \code{\link[nlme:lme]{lme}}, \code{\link{lm}}, \code{\link{lm.fit}} } \examples{ # Compare with first data example from Venable and Ripley (2002), # Chapter 10, "Linear Models" library(MASS) data(petrol) out <- mixedModel2(Y~SG+VP+V10+EP, random=No, data=petrol) cbind(varcomp=out$varcomp,se=out$se.varcomp) } \keyword{regression} statmod/DESCRIPTION0000644000176200001440000000326215071672342013445 0ustar liggesusersPackage: statmod Version: 1.5.1 Date: 2025-10-08 Title: Statistical Modeling Authors@R: c(person(given = "Gordon", family = "Smyth", role = c("cre", "aut"), email = "smyth@wehi.edu.au"), person(given = "Lizhong", family = "Chen", role = "aut"), person(given = "Yifang", family = "Hu", role = "ctb"), person(given = "Peter", family = "Dunn", role = "ctb"), person(given = "Belinda", family = "Phipson", role = "ctb"), person(given = "Yunshun", family = "Chen", role = "ctb")) Maintainer: Gordon Smyth Depends: R (>= 3.0.0) Imports: stats, graphics Suggests: MASS, tweedie Description: A collection of algorithms and functions to aid statistical modeling. Includes limiting dilution analysis (aka ELDA), growth curve comparisons, mixed linear models, heteroscedastic regression, inverse-Gaussian probability calculations, Gauss quadrature and a secure convergence algorithm for nonlinear models. Also includes advanced generalized linear model functions including Tweedie and Digamma distributional families, secure convergence and exact distributional calculations for unit deviances. License: GPL-2 | GPL-3 NeedsCompilation: yes Packaged: 2025-10-09 07:32:48 UTC; smyth Author: Gordon Smyth [cre, aut], Lizhong Chen [aut], Yifang Hu [ctb], Peter Dunn [ctb], Belinda Phipson [ctb], Yunshun Chen [ctb] Repository: CRAN Date/Publication: 2025-10-09 08:40:02 UTC