statmod/0000755000176200001440000000000014355770454011743 5ustar liggesusersstatmod/NAMESPACE0000644000176200001440000000272714352425032013154 0ustar liggesusers# Calling the dynamic library useDynLib(statmod, .registration=TRUE) importFrom("graphics", "abline", "legend", "lines", "plot", "points") importFrom("stats", "Gamma", "binomial", "chisq.test", "dbinom", "fisher.test", "fitted", "glm", "glm.fit", ".lm.fit", "lm.fit", "lm.wfit", "make.link", "median", "model.matrix", "model.response", "model.weights", "p.adjust", "pbeta", "pbinom", "pchisq", "pgamma", "pnorm", "ppois", "printCoefmat", "qchisq", "qgamma", "qnorm", "quantile", "quasi", "rbinom", "rchisq", "rnorm", "residuals", "runif", "var", "weighted.mean") export("canonic.digamma", "compareGrowthCurves", "compareTwoGrowthCurves", "cumulant.digamma", "d2cumulant.digamma", "Digamma", "dinvgauss", "elda", "eldaOneGroup", "expectedDeviance", "fitNBP", "forward", "gauss.quad", "gauss.quad.prob", "glm.scoretest", "glmgam.fit", "glmnb.fit", "hommel.test", "limdil", "logmdigamma", "matvec", "meanT", "meanval.digamma", "mixedModel2", "mixedModel2Fit", "mscale", "permp", "pinvgauss", "plotGrowthCurves", "power.fisher.test", "qinvgauss", "qres.binom", "qres.default", "qres.gamma", "qres.invgauss", "qres.nbinom", "qres.pois", "qres.tweedie", "qresid", "qresiduals", "randomizedBlock", "randomizedBlockFit", "remlscore", "remlscoregamma", "rinvgauss", "sage.test", "tweedie", "unitdeviance.digamma", "varfun.digamma", "vecmat") S3method(print,limdil) S3method(plot,limdil) statmod/data/0000755000176200001440000000000014350043765012645 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/man/0000755000176200001440000000000014352257527012514 5ustar liggesusersstatmod/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/gauss.quad.prob.Rd0000644000176200001440000000524614275421010016006 0ustar liggesusers\name{gauss.quad.prob} \alias{gauss.quad.prob} \title{Gaussian Quadrature with Probability Distributions} \description{Calculate nodes and weights for Gaussian quadrature in terms of probability distributions.} \usage{ gauss.quad.prob(n, dist = "uniform", l = 0, u = 1, mu = 0, sigma = 1, alpha = 1, beta = 1) } \arguments{ \item{n}{number of nodes and weights} \item{dist}{distribution that Gaussian quadrature is based on, one of \code{"uniform"}, \code{"normal"}, \code{"beta"} or \code{"gamma"}} \item{l}{lower limit of uniform distribution} \item{u}{upper limit of uniform distribution} \item{mu}{mean of normal distribution} \item{sigma}{standard deviation of normal distribution} \item{alpha}{positive shape parameter for gamma distribution or first shape parameter for beta distribution} \item{beta}{positive scale parameter for gamma distribution or second shape parameter for beta distribution} } \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{ This is a rewriting and simplification of \code{gauss.quad} in terms of probability distributions. The probability interpretation is explained by Smyth (1998). For details on the underlying quadrature rules, see \code{\link{gauss.quad}}. The expected value of \code{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 the distribution of \code{X} are as follows: Uniform on \code{(l,u)}. Normal with mean \code{mu} and standard deviation \code{sigma}. Beta with density \code{x^(alpha-1)*(1-x)^(beta-1)/B(alpha,beta)} on \code{(0,1)}. Gamma with density \code{x^(alpha-1)*exp(-x/beta)/beta^alpha/gamma(alpha)}. } \references{ 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} } \author{Gordon Smyth, using Netlib Fortran code \url{https://netlib.org/go/gaussq.f}, and including corrections suggested by Spencer Graves} \seealso{ \code{\link{gauss.quad}}, \code{\link{integrate}} } \examples{ # the 4th moment of the standard normal is 3 out <- gauss.quad.prob(10,"normal") sum(out$weights * out$nodes^4) # the expected value of log(X) where X is gamma is digamma(alpha) out <- gauss.quad.prob(32,"gamma",alpha=5) sum(out$weights * log(out$nodes)) } \keyword{math} 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/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/qresiduals.Rd0000644000176200001440000000565614046200500015146 0ustar liggesusers\name{qresiduals} \alias{qresiduals} \alias{qresid} \alias{qres.binom} \alias{qres.pois} \alias{qres.nbinom} \alias{qres.gamma} \alias{qres.invgauss} \alias{qres.tweedie} \alias{qres.default} \title{Randomized Quantile Residuals} \description{ Compute randomized quantile residuals for generalized linear models.} \usage{ qresiduals(glm.obj,dispersion=NULL) qresid(glm.obj,dispersion=NULL) qres.binom(glm.obj) qres.pois(glm.obj) qres.nbinom(glm.obj) qres.gamma(glm.obj,dispersion=NULL) qres.invgauss(glm.obj,dispersion=NULL) qres.tweedie(glm.obj,dispersion=NULL) qres.default(glm.obj,dispersion=NULL) } \arguments{ \item{glm.obj}{Object of class \code{glm}. The generalized linear model family is assumed to be binomial for \code{qres.binom}, poisson for \code{qres.pois}, negative binomial for \code{qres.nbinom}, Gamma for \code{qres.gamma}, inverse Gaussian for \code{qres.invgauss} or tweedie for \code{qres.tweedie}.} \item{dispersion}{a positive real number. Specifies the value of the dispersion parameter for a Gamma or inverse Gaussian generalized linear model if known. If \code{NULL}, the dispersion will be estimated by its Pearson estimator.} } \value{Numeric vector of standard normal quantile residuals.} \details{ Quantile residuals are based on the idea of inverting the estimated distribution function for each observation to obtain exactly standard normal residuals. In the case of discrete distributions, such as the binomial and Poisson, some randomization is introduced to produce continuous normal residuals. Quantile residuals are the residuals of choice for generalized linear models in large dispersion situations when the deviance and Pearson residuals can be grossly non-normal. Quantile residuals are the only useful residuals for binomial or Poisson data when the response takes on only a small number of distinct values. } \references{ Dunn, K. P., and Smyth, G. K. (1996). Randomized quantile residuals. \emph{Journal of Computational and Graphical Statistics} \bold{5}, 1-10. \url{http://www.statsci.org/smyth/pubs/residual.html} 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} } \author{Gordon Smyth} \seealso{ \code{\link{residuals.glm}} } \examples{ # Poisson example: quantile residuals show no granularity y <- rpois(20,lambda=4) x <- 1:20 fit <- glm(y~x, family=poisson) qr <- qresiduals(fit) qqnorm(qr) abline(0,1) # Gamma example: # Quantile residuals are nearly normal while usual resids are not y <- rchisq(20, df=1) fit <- glm(y~1, family=Gamma) qr <- qresiduals(fit, dispersion=2) qqnorm(qr) abline(0,1) # Negative binomial example: if(require("MASS")) { fit <- glm(Days~Age,family=negative.binomial(2),data=quine) summary(qresiduals(fit)) fit <- glm.nb(Days~Age,link=log,data = quine) summary(qresiduals(fit)) } } \keyword{regression} 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/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/invgauss.Rd0000644000176200001440000001111513542612007014625 0ustar liggesusers\name{invgauss} \alias{InverseGaussian} \alias{dinvgauss} \alias{pinvgauss} \alias{qinvgauss} \alias{rinvgauss} \title{Inverse Gaussian Distribution} \description{ Density, cumulative probability, quantiles and random generation for the inverse Gaussian distribution. } \usage{ dinvgauss(x, mean=1, shape=NULL, dispersion=1, log=FALSE) pinvgauss(q, mean=1, shape=NULL, dispersion=1, lower.tail=TRUE, log.p=FALSE) qinvgauss(p, mean=1, shape=NULL, dispersion=1, lower.tail=TRUE, log.p=FALSE, maxit=200L, tol=1e-14, trace=FALSE) rinvgauss(n, mean=1, shape=NULL, dispersion=1) } \arguments{ \item{x,q}{vector of quantiles.} \item{p}{vector of probabilities.} \item{n}{sample size. If \code{length(n)} is larger than 1, then \code{length(n)} random values are returned.} \item{mean}{vector of (positive) means.} \item{shape}{vector of (positive) shape parameters.} \item{dispersion}{vector of (positive) dispersion parameters. Ignored if \code{shape} is not \code{NULL}, in which case \code{dispersion=1/shape}.} \item{lower.tail}{logical; if \code{TRUE}, probabilities are P(Xq).} \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/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/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/glmgam.Rd0000644000176200001440000000414314046200342014230 0ustar liggesusers\name{glmgam.fit} \alias{glmgam.fit} \title{Fit Gamma Generalized Linear Model by Fisher Scoring with Identity Link} \description{ Fit a generalized linear model with secure convergence. } \usage{ glmgam.fit(X, y, coef.start = NULL, tol = 1e-6, maxit = 50, 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{coef.start}{numeric vector of starting values for the regression coefficients} \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, similar 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{glmgam.fit} is in principle equivalent to \code{glm.fit(X,y,family=Gamma(link="identity"))} but with much more secure convergence. } \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{ \code{glmgam.fit} is called by \code{\link{mixedModel2Fit}}. \code{\link{glm}} is the standard glm fitting function in the stats package. } \examples{ y <- rgamma(10, shape=5) X <- cbind(1, 1:10) fit <- glmgam.fit(X, y, trace=TRUE) } \keyword{regression} statmod/man/remlscor.Rd0000644000176200001440000000474314275417171014636 0ustar liggesusers\name{remlscore} \alias{remlscore} \title{REML for Heteroscedastic Regression} \description{ Fits a heteroscedastic regression model using residual maximum likelihood (REML). } \usage{ remlscore(y, X, Z, 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{trace}{Logical variable. If true then output diagnostic information at each iteration.} \item{tol}{Convergence tolerance} \item{maxit}{Maximum number of iterations allowed} } \value{ List with the following components: \item{beta}{vector of regression coefficients for predicting the mean} \item{se.beta}{vector of standard errors for beta} \item{gamma}{vector of regression coefficients for predicting the variance} \item{se.gam}{vector of standard errors for gamma} \item{mu}{estimated means} \item{phi}{estimated variances} \item{deviance}{minus twice the REML log-likelihood} \item{h}{numeric vector of leverages} \item{cov.beta}{estimated covariance matrix for beta} \item{cov.gam}{estimated covarate matrix for gamma} \item{iter}{number of iterations used} } \details{ Write \eqn{\mu_i=E(y_i)}{mu_i = E(y_i)} and \eqn{\sigma^2_i=\mbox{var}(y_i)}{sigma_i^2 = var(y_i)} for the expectation and variance of the \eqn{i}{i'}th response. We assume the heteroscedastic regression model \deqn{\mu_i=\bold{x}_i^T\bold{\beta}}{mu_i = x_i^T beta} \deqn{\log(\sigma^2_i)=\bold{z}_i^T\bold{\gamma},}{log(sigma_i^2 = z_i^T gamma ,} where \eqn{\bold{x}_i}{x_i} and \eqn{\bold{z}_i}{z_i} are vectors of covariates, and \eqn{\bold{\beta}}{beta} and \eqn{\bold{\gamma}}{gamma} are vectors of regression coefficients affecting the mean and variance respectively. Parameters are estimated by maximizing the REML likelihood using REML scoring as described in Smyth (2002). } \references{ Smyth, G. K. (2002). An efficient algorithm for REML in heteroscedastic regression. \emph{Journal of Computational and Graphical Statistics} \bold{11}, 836-847. \doi{10.1198/106186002871} } \author{Gordon Smyth} \examples{ data(welding) attach(welding) y <- Strength # Reproduce results from Table 1 of Smyth (2002) 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 <- remlscore(y,X,Z) cbind(Estimate=out$gamma,SE=out$se.gam) } \keyword{regression} statmod/man/hommel.test.Rd0000644000176200001440000000223111161616416015227 0ustar liggesusers\name{hommel.test} \alias{hommel.test} \title{Test Multiple Comparisons Using Hommel's Method} \description{Given a set of p-values and a test level, returns vector of test results for each hypothesis.} \usage{hommel.test(p, alpha=0.05) } \arguments{ \item{p}{numeric vector of p-values} \item{alpha}{numeric value, desired significance level} } \value{logical vector indicating whether each hypothesis is accepted} \details{ This function implements the multiple testing procedure of Hommel (1988). Hommel's method is also implemented as an adjusted p-value method in the function \code{p.adjust} but the accept/reject approach used here is faster. } \references{ Hommel, G. (1988). A stagewise rejective multiple test procedure based on a modified Bonferroni test. \emph{Biometrika}, \bold{75}, 383-386. Shaffer, J. P. (1995). Multiple hypothesis testing. \emph{Annual Review of Psychology} \bold{46}, 561-576. (An excellent review of the area.) } \author{Gordon Smyth} \seealso{ \code{\link[stats:p.adjust]{p.adjust}} } \examples{ p <- sort(runif(100))[1:10] cbind(p,p.adjust(p,"hommel"),hommel.test(p)) } \keyword{htest} 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/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/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/man/permp.Rd0000644000176200001440000000540014350236233014112 0ustar liggesusers\name{permp} \alias{permp} \title{Exact permutation p-values} \description{ Calculates exact p-values for permutation tests when permutations are randomly drawn with replacement. } \usage{ permp(x, nperm, n1, n2, total.nperm=NULL, method="auto", twosided=TRUE) } \arguments{ \item{x}{number of permutations that yielded test statistics at least as extreme as the observed data. May be a vector or an array of values.} \item{nperm}{total number of permutations performed.} \item{n1}{sample size of group 1. Not required if \code{total.nperm} is supplied.} \item{n2}{sample size of group 2. Not required if \code{total.nperm} is supplied.} \item{total.nperm}{total number of permutations allowable from the design of the experiment.} \item{method}{character string indicating computation method. Possible values are \code{"exact"}, \code{"approximate"} or \code{"auto"}.} \item{twosided}{logical, is the test two-sided and symmetric between the two groups?} } \details{ This function can be used for calculating exact p-values for permutation tests where permutations are sampled with replacement, using theory and methods developed by Phipson and Smyth (2010). The input values are the total number of permutations done (\code{nperm}) and the number of these that were considered at least as extreme as the observed data (\code{x}). \code{total.nperm} is the total number of distinct values of the test statistic that are possible. This is generally equal to the number of possible permutations, unless a two-sided test is conducted with equal sample sizes, in which case \code{total.nperm} is half the number of permutations, because the test statistic must then be symmetric in the two groups. Usually \code{total.nperm} is computed automatically from \code{n1} and \code{n2}, but can also be supplied directly by the user. When \code{method="exact"}, the p-values are computed to full machine precision by summing a series terms. When \code{method="approximate"}, an approximation is used that is faster and uses less memory. If \code{method="auto"}, the exact calculation is used when \code{total.nperm} is less than or equal to 10,000 and the approximation is used otherwise. } \value{ vector or array of p-values, of same dimensions as \code{x} } \author{Belinda Phipson and Gordon Smyth} \references{ 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}. } \examples{ x <- 0:5 # Both calls give same results permp(x=x, nperm=99, n1=6, n2=6) permp(x=x, nperm=99, total.nperm=462) } \keyword{htest} statmod/man/glmscoretest.Rd0000644000176200001440000001130514046200424015476 0ustar liggesusers\name{glm.scoretest} \alias{glm.scoretest} \title{Score Test for Adding a Covariate to a GLM} \description{ Computes score test statistics (z-statistics) for adding covariates to a generalized linear model. } \usage{ glm.scoretest(fit, x2, dispersion=NULL) } \arguments{ \item{fit}{generalized linear model fit object, of class \code{\link{glm}}.} \item{x2}{vector or matrix with each column a covariate to be added.} \item{dispersion}{the dispersion for the generalized linear model family.} } \details{ Rao's score test is a type of asymptotic test that is an alternative to Wald tests or likelihood ratio tests (LRTs) (Dunn and Smyth, 2018). Wald tests are computed by dividing parameter estimates by their standard errors. LRTs are computed from differences in the log-likihoods between the null and alternative hypotheses. Score tests are computed from log-likelihood derivatives. All three types of tests (Wald, score and LRT) are asymptotically equivalent under ideal circumstances, but the score and LRT tests are invariant under-reparametrization whereas Wald tests are not. One of the main differences between the tests is the need for estimation of parameters under the null and alternative hypotheses. Wald tests require maximum likelihood estimates (MLEs) to be computed only under the alternative hypothesis, LRT tests require both the null and alternative models to be fitted, while score tests require only the null hypothesis to be fitted. When a generalized linear model (GLM) is fitted in R using the \code{glm} function, the \code{summary()} function presents Wald tests for all the coefficients in the linear model while \code{anova()} is able to compute likelihood ratio tests. GLM output in R has historically not included score tests, although score tests can be a very computationally coefficient choice when one wants to test for many potential additional covariates being added to a relatively simple null model. A number of well known Pearson chisquare statistics, including goodness of fit statistics and the Pearson test for independence in a contingency table can be derived as score tests (Smyth, 2003; Dunn and Smyth, 2018). This function computes score test statistics for adding a single numerical covariate to a GLM, given the \code{glm} output for the null model. It makes very efficient use of the quantities already stored in the GLM fit object. A computational formula for the score test statistics is given in Section 7.2.6 of Dunn and Smyth (2018). The dispersion parameter is treated as for \code{\link{summary.glm}}. If \code{NULL}, the Pearson estimator is used, except for the binomial, Poisson and negative binomial families, for which the dispersion is one. Note that the \code{anova.glm} function in the stats package has offered a Rao score test option since 2011, but it requires model fits under the alternative as well as the null hypothesis, which does not take advantage of the computational advantage of score test. The \code{glm.scoretest} is more efficient as it does not require a full model fit. On the other hand, \code{anova.glm} can compute score tests for factors and multiple covariates, which \code{glm.scoretest} does not currently do. } \value{ numeric vector containing the z-statistics, one for each covariate. The z-statistics can be treated as standard normal under the null hypothesis. } \author{Gordon Smyth} \seealso{ \code{\link{glm}}, \code{\link{add1}}, \code{\link{anova.glm}} } \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} Lovison, G (2005). On Rao score and Pearson X^2 statistics in generalized linear models. \emph{Statistical Papers}, 46, 555-574. Pregibon, D (1982). Score tests in GLIM with applications. In \emph{GLIM82: Proceedings of the International Conference on Generalized Linear Models}, R Gilchrist (ed.), Lecture Notes in Statistics, Volume 14, Springer, New York, pages 87-97. Smyth, G. K. (2003). Pearson's goodness of fit statistic as a score test statistic. In: \emph{Science and Statistics: A Festschrift for Terry Speed}, D. R. Goldstein (ed.), IMS Lecture Notes - Monograph Series, Volume 40, Institute of Mathematical Statistics, Beachwood, Ohio, pages 115-126. \url{http://www.statsci.org/smyth/pubs/goodness.pdf} } \examples{ # Pearson's chisquare test for independence # in a contingency table is a score test. # First the usual test y <- c(20,40,40,30) chisq.test(matrix(y,2,2), correct=FALSE) # Now same test using glm.scoretest a <- gl(2,1,4) b <- gl(2,2,4) fit <- glm(y~a+b, family=poisson) x2 <- c(0,0,0,1) z <- glm.scoretest(fit, x2) z^2 } \keyword{regression} 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/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/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/forward.Rd0000644000176200001440000000211712102143077014431 0ustar liggesusers\name{forward} \alias{forward} \title{Forward Selection of Covariates for Multiple Regression} \description{ Fit a multi-group negative-binomial model to SAGE data, with Pearson estimation of the common overdispersion parameter. } \usage{ forward(y, x, xkept=NULL, intercept=TRUE, nvar=ncol(x)) } \arguments{ \item{y}{numeric response vector.} \item{x}{numeric matrix of covariates, candidates to be added to the regression.} \item{xkept}{numeric matrix of covariates to be included in the starting regression.} \item{intercept}{logical, should an intercept be added to \code{xkept}?} \item{nvar}{integer, number of covariates from \code{x} to add to the regression.} } \details{ This function has the advantage that \code{x} can have many more columns than the length of \code{y}. } \value{ Integer vector of length \code{nvar}, giving the order in which columns of \code{x} are added to the regression. } \author{Gordon Smyth} \seealso{ \code{\link{step}} } \examples{ y <- rnorm(10) x <- matrix(rnorm(10*5),10,5) forward(y,x) } \keyword{regression} statmod/man/expectedDeviance.Rd0000644000176200001440000001054014352700503016226 0ustar liggesusers\name{expectedDeviance} \alias{expectedDeviance} \title{Expected Value of Scaled Unit Deviance for Linear Exponential Families} \description{ Expected value and variance of the scaled unit deviance for common generalized linear model families. } \usage{ expectedDeviance(mu, family="binomial", binom.size, nbinom.size, gamma.shape) } \arguments{ \item{mu}{numeric vector or matrix giving mean of response variable.} \item{family}{character string indicating the linear exponential family. Possible values are \code{"binomial"},\code{"gaussian"}, \code{"Gamma"}, \code{"inverse.gaussian"}, \code{"poisson"} or \code{"negative.binomial"}.} \item{binom.size}{integer vector giving the number of binomial trials when \code{family = "binomial"}. Equivalent to the \code{"size"} argument of \code{pbinom}.} \item{nbinom.size}{numeric vector giving the negative binomial size parameter when \code{family = "negative.binomial"}, such that the variance of the response variable is \code{mu + mu^2 / nbinom.size}. Equivalent to the \code{"size"} parameter of \code{pnbinom}.} \item{gamma.shape}{numeric vector giving the gamma shape parameter when \code{family = "Gamma"}, such that the variance of the response variable is \code{mu^2 / gamma.shape}. Equivalent to the \code{"shape"} parameter of \code{pgamma}.} } \details{ For a generalized linear model (GLM), the scaled unit deviances can be computed using \code{d <- f$dev.resids(y, mu, wt=1/phi)} where \code{f} is the GLM family object, \code{y} is the response variable, \code{mu} is the vector of means and \code{phi} is the vector of GLM dispersions (incorporating any prior weights). The scaled unit deviances are often treated as being chiquare distributed on 1 df, so the mean should be 1 and the variance should be 2. This distribution result only holds however when the saddlepoint approximation is accurate for the response variable distribution (Dunn and Smyth, 2018). In other cases, the expected value and variance of the unit deviances can be far from the nominal values. The \code{expectedDeviance} function returns the exact mean and variance of the unit deviance for the usual GLM familes assuming that \code{mu} is the true mean and \code{phi} is the true dispersion. When \code{family} is \code{"poisson"}, \code{"binomial"} or \code{"negative.binomial"}, the expected values and variances are computed using Chebyshev polynomial approximations. When \code{family = "Gamma"}, the function uses exact formulas derived by Smyth (1989). } \value{ A list with the components \item{mean}{expected values} \item{variance}{variances} both of which have the same length and dimensions as the input \code{mu}. } \author{Lizong Chen and Gordon Smyth} \references{ Dunn PK, Smyth GK (2018). \emph{Generalized linear models with examples in R}. Springer, New York, NY. \doi{10.1007/978-1-4419-0118-7} 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{ # Poisson example lambda <- 3 nsim <- 1e4 y <- rpois(nsim, lambda=lambda) d <- poisson()$dev.resids(y=y, mu=rep(lambda,nsim), wt=1) c(mean=mean(d), variance=var(d)) unlist(expectedDeviance(mu=lambda, family="poisson")) # binomial example n <- 10 p <- 0.01 y <- rbinom(nsim, prob=p, size=n) d <- binomial()$dev.resids(y=y/n, mu=rep(p,nsim), wt=n) c(mean=mean(d), variance=var(d)) unlist(expectedDeviance(mu=p, family="binomial", binom.size=n)) # gamma example alpha <- 5 beta <- 2 y <- beta * rgamma(1e4, shape=alpha) d <- Gamma()$dev.resids(y=y, mu=rep(alpha*beta,n), wt=alpha) c(mean=mean(d), variance=var(d)) unlist(expectedDeviance(mu=alpha*beta, family="Gamma", gamma.shape=alpha)) # negative binomial example library(MASS) mu <- 10 phi <- 0.2 y <- rnbinom(nsim, mu=mu, size=1/phi) f <- MASS::negative.binomial(theta=1/phi) d <- f$dev.resids(y=y, mu=rep(mu,nsim), wt=1) c(mean=mean(d), variance=var(d)) unlist(expectedDeviance(mu=mu, family="negative.binomial", nbinom.size=1/phi)) # binomial expected deviance tends to zero for p small: p <- seq(from=0.001,to=0.11,len=200) ed <- expectedDeviance(mu=p,family="binomial",binom.size=10) plot(p,ed$mean,type="l") } \seealso{ \code{\link{family}}, \code{\link{meanval.digamma}}, \code{\link{d2cumulant.digamma}}. } \keyword{distributions} statmod/man/elda.Rd0000644000176200001440000001631514275417564013721 0ustar liggesusers\name{elda} \alias{elda} \alias{limdil} \alias{eldaOneGroup} \alias{limdil.class} \alias{limdil-class} \title{Extreme Limiting Dilution Analysis} \description{ Fit single-hit model to a dilution series using complementary log-log binomial regression. } \usage{ elda(response, dose, tested=rep(1,length(response)), group=rep(1,length(response)), observed=FALSE, confidence=0.95, test.unit.slope=FALSE) limdil(response, dose, tested=rep(1,length(response)), group=rep(1,length(response)), observed=FALSE, confidence=0.95, test.unit.slope=FALSE) eldaOneGroup(response, dose, tested, observed=FALSE, confidence=0.95, tol=1e-8, maxit=100, trace=FALSE) } \arguments{ \item{response}{numeric vector giving number of positive cases out of \code{tested} trials. Should take non-negative integer values.} \item{dose}{numeric vector of expected number of cells in assay. Values must be positive.} \item{tested}{numeric vector giving number of trials at each dose. Should take integer values.} \item{group}{vector or factor giving group to which the response belongs.} \item{observed}{logical, is the actual number of cells observed?} \item{confidence}{numeric level for confidence interval. Should be strictly between 0 and 1.} \item{test.unit.slope}{logical, should the adequacy of the single-hit model be tested?} \item{tol}{convergence tolerance.} \item{maxit}{maximum number of Newton iterations to perform.} \item{trace}{logical, if \code{TRUE} then iterim results are output at each iteration.} } \details{ \code{elda} and \code{limdil} are alternative names for the same function. (\code{limdil} was the older name before the 2009 paper by Hu and Smyth.) \code{eldaOneGroup} is a lower-level function that does the computations when there is just one group, using a globally convergent Newton iteration. It is called by the other functions. These functions implement maximum likelihood analysis of limiting dilution data using methods proposed by Hu and Smyth (2009). The functions gracefully accommodate situations where 0\% or 100\% of the assays give positive results, which is why we call it "extreme" limiting dilution analysis. The functions provide the ability to test for differences in stem cell frequencies between groups, and to test goodness of fit in a number of ways. The methodology has been applied to the analysis of stem cell assays (Shackleton et al, 2006). The statistical method is explained by Hu and Smyth (2009). A binomial generalized linear model is fitted for each group with cloglog link and offset \code{log(dose)}. If \code{observed=FALSE}, a classic Poisson single-hit model is assumed, and the Poisson frequency of the stem cells is the \code{exp} of the intercept. If \code{observed=TRUE}, the values of \code{dose} are treated as actual cell numbers rather than expected values. This doesn't change the generalized linear model fit, but it does change how the frequencies are extracted from the estimated model coefficient (Hu and Smyth, 2009). The confidence interval is a Wald confidence interval, unless the responses are all negative or all positive, in which case Clopper-Pearson intervals are computed. If \code{group} takes several values, then separate confidence intervals are computed for each group. In this case a likelihood ratio test is conducted for differences in active cell frequencies between the groups. These functions compute a number of different tests of goodness of fit. One test is based on the coefficient for \code{log(dose)} in the generalized linear model. The nominal slope is 1. A slope greater than one suggests a multi-hit model in which two or more cells are synergistically required to produce a positive response. A slope less than 1 suggests some sort of cell interference. Slopes less than 1 can also be due to heterogeneity of the stem cell frequency between assays. \code{elda} conducts likelihood ratio and score tests that the slope is equal to one. Another test is based on the coefficient for \code{dose}. This idea is motivated by a suggestion of Gart and Weiss (1967), who suggest that heterogeneity effects are more likely to be linear in \code{dose} than \code{log(dose)}. These functions conducts score tests that the coefficient for \code{dose} is non-zero. Negative values for this test suggest heterogeneity. These functions produce objects of class \code{"limdil"}. There are \code{\link[=print.limdil]{print}} and \code{\link[=plot.limdil]{plot}} methods for \code{"limdil"} objects. } \value{ \code{elda} and \code{limdil} produce an object of class \code{"limdil"}. This is a list with the following components: \item{CI}{numeric matrix giving estimated stem cell frequency and lower and upper limits of Wald confidence interval for each group} \item{test.difference}{numeric vector giving chisquare likelihood ratio test statistic and p-value for testing the difference between groups} \item{test.slope.wald}{numeric vector giving wald test statistics and p-value for testing the slope of the offset equal to one} \item{test.slope.lr}{numeric vector giving chisquare likelihood ratio test statistics and p-value for testing the slope of the offset equal to one} \item{test.slope.score.logdose}{numeric vector giving score test statistics and p-value for testing multi-hit alternatives} \item{test.slope.score.dose}{numeric vector giving score test statistics and p-value for testing heterogeneity} \item{response}{numeric of integer counts of positive cases, out of \code{tested} trials} \item{tested}{numeric vector giving number of trials at each dose} \item{dose}{numeric vector of expected number of cells in assay} \item{group}{vector or factor giving group to which the response belongs} \item{num.group}{number of groups} } \author{Yifang Hu and Gordon Smyth} \references{ Hu, Y, and Smyth, GK (2009). ELDA: Extreme limiting dilution analysis for comparing depleted and enriched populations in stem cell and other assays. \emph{Journal of Immunological Methods} 347, 70-78. \doi{10.1016/j.jim.2009.06.008} \url{http://www.statsci.org/smyth/pubs/ELDAPreprint.pdf} Shackleton, M., Vaillant, F., Simpson, K. J., Stingl, J., Smyth, G. K., Asselin-Labat, M.-L., Wu, L., Lindeman, G. J., and Visvader, J. E. (2006). Generation of a functional mammary gland from a single stem cell. \emph{Nature} 439, 84-88. \doi{10.1038/nature04372} Gart, JJ, and Weiss, GH (1967). Graphically oriented tests for host variability in dilution experiments. \emph{Biometrics} 23, 269-284. } \seealso{ \code{\link{plot.limdil}} and \code{\link{print.limdil}} are methods for \code{limdil} class objects. A web interface to this function is available at \url{https://bioinf.wehi.edu.au/software/elda/}. } \examples{ # When there is one group Dose <- c(50,100,200,400,800) Responses <- c(2,6,9,15,21) Tested <- c(24,24,24,24,24) out <- elda(Responses,Dose,Tested,test.unit.slope=TRUE) out plot(out) # When there are four groups Dose <- c(30000,20000,4000,500,30000,20000,4000,500,30000,20000,4000,500,30000,20000,4000,500) Responses <- c(2,3,2,1,6,5,6,1,2,3,4,2,6,6,6,1) Tested <- c(6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6) Group <- c(1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4) elda(Responses,Dose,Tested,Group,test.unit.slope=TRUE) } \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/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/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/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/DESCRIPTION0000644000176200001440000000172514355770454013456 0ustar liggesusersPackage: statmod Version: 1.5.0 Date: 2022-12-28 Title: Statistical Modeling Author: Gordon Smyth [cre, aut], Lizhong Chen [aut], Yifang Hu [ctb], Peter Dunn [ctb], Belinda Phipson [ctb], Yunshun Chen [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: 2022-12-28 00:45:50 UTC; smyth Repository: CRAN Date/Publication: 2023-01-06 10:00:12 UTC statmod/build/0000755000176200001440000000000014352710676013037 5ustar liggesusersstatmod/build/partial.rdb0000644000176200001440000000007414352710676015165 0ustar liggesusers‹‹àb```b`a’Ì ¦0°0 FN Íš—˜›Z d@$þ²w7statmod/tests/0000755000176200001440000000000014352244731013074 5ustar liggesusersstatmod/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/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/src/0000755000176200001440000000000014352707002012514 5ustar liggesusersstatmod/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(mu #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/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/R/0000755000176200001440000000000014352424025012127 5ustar liggesusersstatmod/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/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/MD50000644000176200001440000000575114355770454012263 0ustar liggesusers39cf2b184bce9c70ee036e9973c26022 *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 f01682ffd9d5582c0d3b8a226f3c2b16 *build/partial.rdb e600a474fedf570b1913b278022d46bf *data/welding.rdata 12b53c3de6776dbc33ac3a0e098f033a *inst/CITATION eaa5c32179b702cef7a42369c612a276 *inst/NEWS b2c27582e0b5e69cfbe9284ee0741f5c *man/digammaf.Rd e7b573a3f838a766401a8f636248657d *man/elda.Rd 8fa004dbfee84c8c70899ecc368202e0 *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 652e1e97a32a0245081a562199c101fc *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/inst/0000755000176200001440000000000014350043765012711 5ustar liggesusersstatmod/inst/CITATION0000644000176200001440000000661713055233560014053 0ustar liggesuserscitHeader("To cite statmod in publications, please use the appropriate journal reference as given on the function help page. Usually this will be one of the following:") citEntry( entry = "article", author = "Goknur Giner and Gordon K. Smyth", year = 2016, title = "statmod: probability calculations for the inverse Gaussian distribution", journal = "R Journal", volume = 8, number = 1, pages = "339-351", textVersion = "Giner, G, and Smyth, GK (2016). statmod: probability calculations for the inverse Gaussian distribution. R Journal 8(1), 339-351. (pinvgauss, qinvgauss, dinvguass and rinvgauss functions)" ) citEntry( entry = "article", author = "Belinda Phipson and Gordon K. Smyth", year = 2010, title = "Permutation p-values should never be zero: calculating exact p-values when permutations are randomly drawn", journal = "Statistical Applications in Genetics and Molecular Biology", volume = 9, number = 1, pages = "Article 39", textVersion = "Phipson B, and Smyth GK (2010). Permutation p-values should never be zero: calculating exact p-values when permutations are randomly drawn. Statistical Applications in Genetics and Molecular Biology, Volume 9, Issue 1, Article 39. (permp function)" ) citEntry( entry = "article", author = "Yifang Hu and Gordon K. Smyth", year = 2009, title = "ELDA: extreme limiting dilution analysis for comparing depleted and enriched populations in stem cell and other assays", journal = "Journal of Immunological Methods", volume = 347, number = 1, pages = "70-78", textVersion = "Hu, Y, and Smyth, GK (2009). ELDA: Extreme limiting dilution analysis for comparing depleted and enriched populations in stem cell and other assays. Journal of Immunological Methods 347, 70-78. (elda and limdil functions)" ) citEntry( entry = "article", author = "Gordon K. Smyth", title = "Optimization and nonlinear equations", journal = "Encyclopedia of Biostatistics", year = 2005, publisher = "John Wiley and Sons, Ltd", pages = "3088-3095", textVersion = "Smyth, G. K. (1998). Optimization and nonlinear equations. In: Encyclopedia of Biostatistics, P. Armitage and T. Colton (eds.), Wiley, London, pp. 3174-3180. (glmgam.fit, glmnb.fit and fitNBP functions)" ) citEntry( entry = "article", author = "Gordon K. Smyth", title = "Numerical integration", journal = "Encyclopedia of Biostatistics", year = 2005, publisher = "John Wiley and Sons, Ltd", pages = "3088-3095", textVersion = "Smyth, G. K. (1998). Numerical integration. In: Encyclopedia of Biostatistics, P. Armitage and T. Colton (eds.), Wiley, London, pp. 3088-3095. (gauss.quad and gauss.quad.prob functions)" ) citEntry( entry = "article", author = "Gordon K. Smyth", year = 2002, title = "An efficient algorithm for REML in heteroscedastic regression", journal = "Journal of Computational and Graphical Statistics", volume = 11, pages = "836-847", textVersion = "Smyth, G. K. (2002). An efficient algorithm for REML in heteroscedastic regression. Journal of Computational and Graphical Statistics 11, 836-847. (remlscore, randomizedBlock, and mixedModel2 functions)" ) citEntry( entry = "article", author = "Peter K. Dunn and Gordon K. Smyth", year = 1996, title = "Randomized quantile residuals", journal = "J. Comput. Graph. Statist", volume = 5, pages = "236-244", textVersion = "Dunn, P. K., and Smyth, G. K. (1996). Randomized quantile residuals. J. Comput. Graph. Statist., 5, 236-244. (qresid functions)" ) statmod/inst/NEWS0000644000176200001440000004306014352707106013411 0ustar liggesusers28 Dec 2022: statmod 1.5.0 - New function expectedDeviance() to compute expected values and variances of unit deviances for linear exponential families, using C code written by Lizhong Chen. Add Lizhong Chen as package author. - Replace NAMESPACE exportPattern() with export(). - New argument `n0` for compareGrowthCurves() and CompareTwoGrownCurves() to avoid permutation p-values exactly zero. - Add link to Phipson & Smyth postprint on arXiv in help references for permp() and compareGrowthCurves(). 12 Aug 2022: statmod 1.4.37 - Fix mathematic equations in remlscor.Rd. - Explain simulation method of power.fisher.test() in power.Rd. - Update http to https URLs in elda.Rd, gauss.quad.Rd and gauss.quad.prob.Rd. - Change url to doi for reference in elda.Rd. - Add doi for reference in fitNBP.Rd. 10 May 2021: statmod 1.4.36 - Update tweedie() part of statmod-Tests.R - Update reference URLs in elda.Rd, glmgam.Rd, glmnbfit.Rd, glmscoretest.Rd, permp.Rd, qresiduals.Rd, remlscor.Rd, tweedie.Rd - Reformat usage lines for gauss.quad and gauss.quad.prob. 25 Aug 2020: statmod 1.4.35 - Fix bug in tweedie(link.power=0) so that the resulting functions $linkinv() and $mu.eta() preserve the attributes of their arguments. 16 Feb 2020: statmod 1.4.34 - Improve the model description provided in the remlscoregamma() help page. - tweedie() now checks whether `var.power` or `link.power` are character strings instead of numeric. If `var.power` is one of the standard family names ("gaussian", "poisson", "gamma" or "inverse.gaussian") or `link.power` is one of the standard link functions ("identity","log","inverse") then the argument is reset to the corresponding numerical value with a message, otherwise an informative error message is given. - Cleaning up of internal code to avoid partial matching of function arguments, attributes or list component names. The automatic package tests are now run with the warnPartialMatchArgs, warnPartialMatchAttr and warnPartialMatchDollar options all set to TRUE. 4 Jan 2020: statmod 1.4.33 - The components returned by mixedModel2Fit() relating to fixed coefficients are now documented explicitly. The help page has been corrected to refer to the argument `only.varcomp` instead of `fixed.estimates`. The vector of `reml.residuals` is no longer part of the output. - The test file has been slightly revised using zapsmall() so ensure that the test output file remains correct for R with ATLAS BLAS. 29 May 2019: statmod 1.4.32 - Bug fix to glmnb.fit() when all the y values are zero. 24 Feb 2019: statmod 1.4.31 - Add Dunn & Smyth (2018) GLM book as a reference for glm.scoretest() and Randomized Quantile Residuals. Rewrite the Details section of the glm.scoretest help page. - Update minimum version of R to 3.0.0 in DESCRIPTION file. 16 June 2017: statmod 1.4.30 - Bug fix to qinvgauss(). In some case the gamma approximation used for small right tail probabilities was taking the initial value outside the domain of convergence. 27 February 2017: statmod 1.4.29 - rinvgauss() now accurately handles large or infinite values for the mean or dispersion. 26 February 2017: statmod 1.4.28 - R_registerRoutines is now used to register the Fortran subroutine gaussq2. - pinvgauss() and qinvgauss() now use a gamma approximation when the coefficient of variation is very small. 17 December 2016: statmod 1.4.27 - qinvgauss() now supports mean=Inf. 28 August 2016: statmod 1.4.26 - Fortran function gaussq2 updated to Fortran 77. 5 August 2016: statmod 1.4.25 - Add CITATION file. - pinvgauss() now uses an asymptotic approximation to compute right tail probabilities for extreme large quantiles. This allows it to give correct right tail probabilities for virtually any quantile. - Fix to qinvgauss() to avoid NA values when computing extreme tail quantiles where the inverse Gaussian density is subject to floating underflow. - Bug fix to qresiduals() and qresid.invgauss() for the inverse Guassian distribution. 2 February 2016: statmod 1.4.24 - speedup for rinvgauss() by replacing rchisq() with rnorm() and rbinom() with runif(). - speedup for qinvgauss() by using qgamma as starting approximation for very small right tail probabilities, and inverse chisq as starting approximation for very small left tail probabilities. - qinvgauss() now computes Newton step using log probabilities and a Taylor series expansion for small steps. This improves accuracy in extreme cases. The stopping criterion for the Newton iteration has been revised. - Bug fix to dinvgauss(), pinvgauss() and qinvgauss() which were not preserving attributes of the first argument. 30 December 2015: statmod 1.4.23 - qinvgauss() has been improved to return best achievable machine accuracy. It now checks for backtracking of the Newton iteration. - dinvgauss() and pinvgauss() now check for a wider range of special cases. This allows them to give valid results in some cases for infinite or missing parameter values and for x outside the support of the distribution. 26 October 2015: statmod 1.4.22 - Functions needed from the stats and graphics packages are now explicitly imported into the package NAMESPACE. 30 March 2015: statmod 1.4.21 - qinvgauss() now treats input arguments of different lengths or NA parameter values more carefully. - elda() now gracefully removes structural zeros, i.e., rows where the number of cells or the number of assays is zero. - S3 print and plot methods for "limdil" class now registered. - Use of require("tweedie") in the qres.tweedie() code replaced by requireNameSpace("tweedie"). 31 May 2014: statmod 1.4.20 - Considerable work on the inverse Gaussian functions dinvgauss(), pinvgauss(), qinvgauss() and rinvgauss(). The parameter arguments are changed to mean, shape and dispersion instead of mu and lambda. The functions now include arguments lower.tail and log.p, meaning that right-tailed probabilities can be used and probabilities can be specified on the log-scale. Good numerical precision is maintained in these cases. The functions now respect attributes, so that a matrix argument for example will produce a matrix result. Checking is now done for missing values and invalid parameter values on an element-wise basis. A technical report has been written to describe the methodology behind qinvgauss(). - Change to qresid.invgauss() to compute extreme tail residuals accurately. (This introduced a bug that was fixed in version 1.4.25.) - This file has been renamed to NEWS instead of changelog.txt. - The introductory help page previously called 1.Introduction is now named statmod-package. 13 April 2014: statmod 1.4.19 - qinvgauss() now uses a globally convergent Newton iteration, which produces accurate values for a greater range of parameter values. - glmnb.fit() now supports weights. 27 September 2013: statmod 1.4.18 - Update reference for permp(). - bug fix to elda() so that it returns NA for the tests instead of giving an error when the Fisher information for the slope isNA. - Exact roles of authors specified in DESCRIPTION file. - All usage lines in help files wrapped at 90 characters to ensure that code is not truncated in pdf manual. 30 January 2013: statmod 1.4.17 - new function eldaOneGroup() to conduct limiting dilution analysis when there is only one treatment group. This function implements a globally convergent Newton iteration to avoid occasional problems with lack of convergence of the usual glm calculations. - elda() (aka limdil) now call eldaOneGroup() to get confidence intervals and score tests. This improves the numerical reliability of the function. - more detail added to the elda() help page about the interpretations of the goodness of fit tests. - new function forward() for forward selection in multiple regression with an unlimited number of candidate covariates. - license upgraded to GPL from LGPL. 28 September 2012: statmod 1.4.16 - gauss.quad() and gauss.quad.prob() now use Fortran to solve tridiagonal eigenvalue problem, with considerable gain in speed. Updates to references for the same two functions. - Formatting of gauss.quad test output to ensure agreement between Unix and Windows. - mixedModel2 test code no longer prints REML residuals, because these are not reproducible between Windows and Unix. 6 August 2012: statmod 1.4.15 - improvements to glmnb.fit() to make it more numerically robust. - use of lgamma() in gauss.quad() to avoid floating overflows with kind="jacobi". 19 November 2011: statmod 1.4.14 - power.fisher.test() now accepts a new argument alternative which indicates the rejection region. 25 October 2011: statmod 1.4.13 - bug fix to glmnb.fit() when dispersion is a vector argument. 18 October 2011: statmod 1.4.12 - glmnb.fit() now accepts vector dispersion argument. - change to residual returned by tweedie glms when var.power=2 and y==0. In this case the theoretical residual is -Inf. The value returned by the tweedie family is finite, but smaller than previous. 29 June 2011: statmod 1.4.11 - updates to help page for sage.test 21 April 2011: statmod 1.4.10 - bug fix to glmnb.fit(). 9 March 2011: statmod 1.4.9 - bug fix to glmnb.fit(). - bug correction to sage.test() when library sizes are equal. The p-values returned change slightly. 3 November 2010: statmod 1.4.8 - new function glmnb.fit(), which implements Levenberg-modified Fisher scoring to fit a negative binomial generalized linear model with log-link. 28 May 2010: statmod 1.4.7 - permp() now has two new arguments 'method' and 'twosided'. The function now provides both exact and approximate methods for computing permutation p-values. 19 April 2010: statmod 1.4.6 - psi.hampel() and rho.hampel() renamed to .psi.hampel and .rho.hampel and removed from export function list. 16 April 2010: statmod 1.4.5 - new function mscale() which is the robust estimation of a scale parameter using Hampel's redescending psi function. - new function psi.hampel() which is the Hampel's redescending psi function. - new function rho.hampel() which is the integral of Hampel's redescending psi function. 30 March 2010: statmod 1.4.4 - remlscore() now returns a component iter giving the number of iterations used. 18 February 2010: statmod 1.4.3 - new function permp() which calculates exact p-values for permutation tests when permutations are sampled with replacement. 5 January 2010: statmod 1.4.2 - new argument 'dispersion' for glm.scoretest(), allowing the user to set a known value for the dispersion parameter. - ensure chisq values from limdil() remain positive, even when small. - correct the format of chisq value in print.limdil(). 29 Sep 2009: statmod 1.4.1 - fixes to documentation links to other packages - bug fix to glmgam.fit() when there are exact zeros in the data or fitted values. - add more goodness of fit tests to elda(). - improvements to print.limdil method. - argument log added to dinvgauss(), giving the option of returning the density on the log-scale. 6 May 2009: statmod 1.4.0 - new function glm.scoretest() to compute likelihood score tests for terms in generalized linear models. - Improvements to elda() and print.limdil() to avoid glm fits in extreme data situations with 0% or 100% positive response, improving speed and avoiding warnings. - Improvements to print.limdil method. - New function .limdil.allpos(). It calculates lower bound of the limdil confidence interval when all tests respond by using a globally convergent Newton interation. - Modify limdil() on lower bound of the confidence interval when all tests respond. - New methods print.limdil and plot.limdil for limdil objects. - The output from limdil() is now a limdil class object. - Added \eqn{} markup to equations in pinvgauss.Rd remlscor.Rd and remlscorgamma.Rd. - Elso et al (2004) reference added to compareGrowthCurves help page. 18 November 2008: statmod 1.3.8 - qres.nbinom now works in more situations. It now accepts a model fit from MASS::glm.nb or a model fit using MASS:negative.binomial() when the theta argument is unnamed. Previously the theta argument had to be named, as in negative.binomial(theta=2). 20 July 2008: statmod 1.3.7 - reference added to help page for compareGrowthCurves() - the saved output from the automatic tests updated for R 2.7.1 07 April 2008: statmod 1.3.6 - fixes to limdil() on estimate and upper bound of the confidence interval when all cells respond to all tests. - bug fix in limdil() which produced wrong calculation of the upper bound and lower bound of the confidence interval when there are more than one group and no cells responds or all cells respond to all tests in one of the groups. 24 March 2008: statmod 1.3.5 - The function remlscoregamma(), removed in 2004, restored to the package with updated references. 11 February 2008: statmod 1.3.4 - bug fix in limdil() which produced error when calculating the confidence intervals of multiple groups and all cells respond in one of the groups. 12 January 2008: statmod 1.3.3 - the limdil function now has the capability to handle and compare multiple experiments or groups. 24 September 2007: statmod 1.3.1 - non-ascii European characters removed from Rd files - Shackleton reference added to limdil.Rd - fixed some non-matched brackets in other Rd files 15 October 2006: statmod 1.3.0 - package now has a NAMESPACE which simply exports all objects - new function fitNBP() - new function plotGrowthCurves() 4 January 2006: statmod 1.2.4 - fixes to gauss.quad.prob when n=1 or n=2 12 December 2005: statmod 1.2.3 - remlscore() was failing when rank of X was only 1, now fixed. 20 October 2005: statmod 1.2.2 - mixedModel2Fit() now outputs REML residuals - randomizedBlock() & randomizedBlockFit() renamed to mixedModel2() & mixedModel2Fit() 4 July 2005: statmod 1.2.1 - remlscore() now outputs covariance matrices for estimated coefficients - redundant copy of randomizedBlockFit() removed 22 June 2005: statmod 1.2.0 - /inst/doc/index.html created - change log (this file) moved to /inst/doc directory of package - new function limdil() 14 June 2005: statmod 1.1.1 - change to rinvgauss() to avoid numerical problems with subtractive cancellation when lambda<