arm/0000755000176200001440000000000014602517552011040 5ustar liggesusersarm/NAMESPACE0000644000176200001440000000630614301551502012251 0ustar liggesusersimportFrom(graphics, "abline", "axis", "box", "image", "layout", "lines", "par", "plot", "points", "polygon", "rect", "segments", "text", "title") importFrom(grDevices, "gray", "heat.colors", "rainbow") importFrom(methods, "as", "getMethod", "new", "setClass", "setOldClass", "show", "signature") importFrom(utils, "packageDescription", "read.fwf") importFrom(Matrix, "t", "crossprod", "tcrossprod", "colMeans", "Diagonal", "solve" ) importFrom(stats, ".getXlevels", ".checkMFClasses", "AIC", "as.formula", "binomial", "coefficients", "coef", "contrasts<-", "cor", "dcauchy", "delete.response", "deviance", "dlogis", "dnorm", "dt", "family", "fitted", "formula", "gaussian", "glm.control", "is.empty.model", "lm.fit", "logLik", "model.extract", "model.frame", "model.matrix", "model.matrix.default", "model.offset", "model.response", "model.weights", "na.exclude", "na.omit", "na.pass", "napredict", "optim", "predict", "pcauchy", "plogis", "pnorm", "qt", "rchisq", "rgamma", "rnorm", "sd", "terms", "terms.formula", "var", "vcov", "weighted.mean") importFrom(coda, "nvar", "varnames", "nchain" ) importFrom(MASS, "polr", "mvrnorm" ) importFrom(nlme, "fixef", "ranef", "VarCorr" ) importFrom(lme4, "getME", "isREML", "refitML" ) importFrom(abind, "abind") exportClasses( "balance", "bayesglm", "bayespolr", "sim", "sim.merMod" ) exportMethods( "coefplot", "display", "mcsamp", "se.coef", "sim", "print", "show", "standardize", "traceplot" ) export( "extractDIC", "balance", "bayesglm", "bayesglm.fit", "bayespolr", "binnedplot", "binned.resids", "coefplot", "coefplot.default", "contr.bayes.ordered", "contr.bayes.unordered", "corrplot", "display", "discrete.histogram", "discrete.hist", "fround", "G", "go", "invlogit", "logit", "matching", "mcsamp", "model.matrixBayes", "multicomp.plot", "mcplot", "pfround", "read.columns", "rescale", "residual.plot", "se.coef", "se.fixef", "se.ranef", "sigma.hat", "sim", "traceplot", "triangleplot" ) S3method(extractDIC, merMod) S3method(print, GO) S3method(plot, balance) S3method(print, balance) S3method(predict, bayesglm) S3method(coef, sim) S3method(coef, sim.polr) S3method(coef, sim.merMod) S3method(fitted, sim.merMod) S3method(fixef, sim.merMod) S3method(ranef, sim.merMod) S3method(sigma.hat, lm) S3method(sigma.hat, glm) S3method(sigma.hat, merMod) S3method(sigma.hat, sim) S3method(sigma.hat, sim.merMod) arm/README.md0000644000176200001440000000011713651440121012304 0ustar liggesusers# arm ARM: Data Analysis Using Regression and Multilevel/Hierarchical Models arm/data/0000755000176200001440000000000013737170721011752 5ustar liggesusersarm/data/lalonde.rda0000644000176200001440000001371013651440121014047 0ustar liggesusers ] xUEPieYFZWuUqi(PQ@d&F}iYbH $$F AgZyΫ:\{{a[<:U{Zh۲ILlScX?~W~K̄cbb^˶1$\1 dޭcɈ>G*Wzd/Z?0qAI^qѧƩƣ+^TGv}I5vH;vI¥1$N+?PCi)W5T.>^GWbK[Qˢf{~_ *OU;G}E}$K#[Oa/Kj(=He/WvyH{eGe+#׏Wݜ!)Ƒr5Tt_(=jjg@CyAðODs?zvʟJWSvxJUDZů8RN>2iܣyuCYw/iunSqN?=gи@q?z^P|G4@u(Rw RߓvIw'nD*[_WrZI9UxmH9wG"]I{+Wzxn%='e_wNzXM[]I~xhZNIGFu&yuF|Y'+P:VIu QhѾ#[g:V +:t}.4 WbI޿)Z꣍~OGih M}N "/}P{屆P}_jjui\b?Z4э#߭EzϞ.{EϹ)hS_;~}/ -}V)~}'*]CO`hiH :^}Gcޥ?P)Rvk쉴kW_=lISQ>\gVz8µK߁zWR!Wg;KC~˗&;~::ۋ7 `~sE-{ӹa{'vI}[S> 6tn>%x\_֡kA|ҳtQ<12 ny'gpnrfZ4H %$qF$ s̈́IͩpY|-⥐_Z2\XxՂ,Y}?x~돂'CrؗR SC ! D-۩y OL+:.ki_ |-0->63Se\:i'ϲFڷG΃/'CRNr]/M> ^#X{\cH}ρv%w/U=/]4yuvd;?y"~x^EjlX1̯c}'1#'^LնK$|IĬig|c쮠wL2׈׋h1'-+wb? -}O,:#ATgŒ"_:YKײo݊xj#_u q^os@|_' ;p}6ԗ2) |:4K;q?I 6.?lNsBfGwn{Ƴm9"p zr?9'1t];!^ 'Aɸ>ҞDZ|>B_rFD?|)Hy6?0 ߐ*<_3ՒC٘dyF۽p/Q^ I[3OޯKp( zk}Z? BT}%[E{-?mn!Qʝ-`\,}ˆz}q`3_x˥WR=/{^ͻgG[ߧj.x}` o uO]8eah {9{ZWwolLFvCy\'ݚY`Ǻ֞/mO sr]8F¾(-,{̓p{ɴ>x.=cΰ_59˞-p/>,hתLߗtyًLJrl>7v_qͼx,r]vHXoͼ:]s|ހM˓_~ArH50sOC88PllwpyGs$:`tعL=pˤ _/m|\3_EEy>4ۅv+OLywJzrNvk P EKȺ^v+et%+{(|'U\MPq4kxY@^ϻlJΗ~{eOrce ^BK!e7ߏ^-mXcg0]x3v(,8Q(fh{A>K_9Veߎx[`n.2JM=i'֜կ`y'0x=+O-zXzo:wA_T9=;뀗W 6^힫*vd|"ē-pn87.<xeE"qcO7x^x%8La_lO+:;4> ƛy|s9;?1ɲoXʴK8ߙ:K[s_mkzȸҼ+R2u})|y9<#6~+-Sׂ'1}ou\ 9u9N)jIs&G`nYo?Ӻ9/n+LcwLrϿ@\X4:>{*f>/MGрqmOq8 ]sG`n5Wt\]ꎗճT9wy߳-mo ᆳ[C >X fW}׎hi,miK[RM Vn*nyᎯ:/h_"߾ҖINL{=Җ-cd 1=[Җd';Nv٩_i]50~dCk߯Uicƌ:J}l\¨Uœc'O <_>>aҤcFMxf'&ƸZZ8U7=ͧL0|ŤgQh_W4qzPʛ(M\-MXGOOL?qd'~r'~'4Lc04Lc04\cp5\cp5\cpah Cc041 ah Cc85Sc85Sc85Sc85Sc85Sc4Kc4Kc4Kc4Kc4Kc5[c5[c=D[c5Fn^^^^^ѳ'>:#GG7>z@49́hDs @4h 1Dc!C4h 8qD#G4h8qD3@4 D3@4 D3@4'9͉hNDs"ќD4'9ͅh.Ds! \B4ͅh.Ds#܈F4 7͍h}nD =100$, nclass=floor(sqrt(length(x))); if $10= 2.1.0).} \item{drop.unused.levels}{default \code{TRUE}, if \code{FALSE}, it interpolates the intermediate values if the data have integer levels.} \item{prior.mean}{prior mean for the coefficients: default is 0. Can be a vector of length equal to the number of predictors (not counting the intercepts). If it is a scalar, it is expanded to the length of this vector.} \item{prior.scale}{prior scale for the coefficients: default is 2.5. Can be a vector of length equal to the number of predictors (not counting the intercepts). If it is a scalar, it is expanded to the length of this vector.} \item{prior.df}{for t distribution: default is 1 (Cauchy). Set to \code{Inf} to get normal prior distributions. Can be a vector of length equal to the number of predictors (not counting the intercepts). If it is a scalar, it is expanded to the length of this vector.} \item{prior.counts.for.bins}{default is \code{NULL}, which will augment the data by giving each cut point a \code{1/levels(y)}. To use a noninformative prior, assign prior.counts.for.bins = 0. If it is a scalar, it is expanded to the number of levels of y.} \item{min.prior.scale}{Minimum prior scale for the coefficients: default is 1e-12.} \item{scaled}{if \code{scaled = TRUE}, then the prior distribution is rescaled. Can be a vector of length equal to the number of cutpoints (intercepts). If it is a scalar, it is expanded to the length of this vector.} \item{maxit}{integer giving the maximal number of IWLS iterations, default is 100. This can also be controlled by \code{control}.} \item{print.unnormalized.log.posterior}{display the unnormalized log posterior likelihood for bayesglm fit, default=\code{FALSE}} } \details{ The program is a simple alteration of \code{\link[MASS]{polr}} in \code{VR} version 7.2-31 that augments the loglikelihood with the log of the t prior distributions for the coefficients. We use Student-t prior distributions for the coefficients. The prior distributions for the intercepts (the cutpoints) are set so they apply to the value when all predictors are set to their mean values. If scaled=TRUE, the scales for the prior distributions of the coefficients are determined as follows: For a predictor with only one value, we just use \code{prior.scale}. For a predictor with two values, we use prior.scale/range(x). For a predictor with more than two values, we use prior.scale/(2*sd(x)). } \value{ See \code{polr} for details. \item{prior.mean}{prior means for the cofficients.} \item{prior.scale}{prior scales for the cofficients.} \item{prior.df}{prior dfs for the cofficients.} \item{prior.counts.for.bins}{prior counts for the cutpoints.} } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn}; Maria Grazia Pittau \email{grazia@stat.columbia.edu} } \seealso{\code{\link{bayesglm}}, \code{\link[MASS]{polr}} } \examples{ M1 <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display (M1) M2 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.scale=Inf, prior.df=Inf) # Same as M1 display (M2) M3 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display (M3) M4 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.scale=2.5, prior.df=1) # Same as M3 display (M4) M5 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.scale=2.5, prior.df=7) display (M5) M6 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.scale=2.5, prior.df=Inf) display (M6) # Assign priors M7 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.mean=rep(0,6), prior.scale=rep(2.5,6), prior.df=c(1,1,1,7,7,7)) display (M7) #### Another example y <- factor (rep (1:10,1:10)) x <- rnorm (length(y)) x <- x - mean(x) M8 <- polr (y ~ x) display (M8) M9 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=0) display (M9) # same as M1 M10 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=10000) display (M10) #### Another example y <- factor (rep (1:3,1:3)) x <- rnorm (length(y)) x <- x - mean(x) M11 <- polr (y ~ x) display (M11) M12 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=0) display (M12) # same as M1 M13 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=1) display (M13) M14 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=10) display (M14) } \keyword{models} \keyword{methods} \keyword{regression} arm/man/traceplot.Rd0000644000176200001440000000250713014470370014073 0ustar liggesusers\name{traceplot} %\docType{genericFunction} \alias{traceplot} \alias{traceplot.default} \alias{traceplot,mcmc.list-method} \alias{traceplot,bugs-method} \title{Trace plot of \sQuote{bugs} object} \usage{ \S4method{traceplot}{bugs}( x, mfrow = c( 1, 1 ), varname = NULL, match.head = TRUE, ask = TRUE, col = rainbow( x$n.chains ), lty = 1, lwd = 1, \dots) } \arguments{ \item{x}{A bugs object} \item{mfrow}{graphical parameter (see \code{par})} \item{varname}{vector of variable names to plot} \item{match.head}{ matches the variable names by the beginning of the variable names in bugs object} \item{ask}{logical; if \code{TRUE}, the user is \emph{ask}ed before each plot, see \code{par(ask=.)}.} \item{col}{graphical parameter (see \code{par})} \item{lty}{graphical parameter (see \code{par})} \item{lwd}{graphical parameter (see \code{par})} \item{\dots}{further graphical parameters} } \description{ Displays a plot of iterations \emph{vs.} sampled values for each variable in the chain, with a separate plot per variable. } \author{ Masanao Yajima \email{yajima@stat.columbia.edu}. Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{ \code{\link[coda]{densplot}}, \code{\link[coda]{plot.mcmc}}, \code{\link[coda]{traceplot}} } \keyword{hplot} arm/man/mcsamp.Rd0000644000176200001440000001101213707327672013364 0ustar liggesusers\name{mcsamp} %\docType{genericFunction} \alias{mcsamp} \alias{mcsamp.default} \alias{mcsamp,merMod-method} %\alias{mcsamp,glmer-method} \title{Generic Function to Run \sQuote{mcmcsamp()} in lme4} \description{ The quick function for MCMC sampling for lmer and glmer objects and convert to Bugs objects for easy display. } \usage{ \method{mcsamp}{default}(object, n.chains=3, n.iter=1000, n.burnin=floor(n.iter/2), n.thin=max(1, floor(n.chains * (n.iter - n.burnin)/1000)), saveb=TRUE, deviance=TRUE, make.bugs.object=TRUE) \S4method{mcsamp}{merMod} (object, ...) %\S4method{mcsamp}{glmer} (object, ...) } \arguments{ \item{object}{\code{mer} objects from \code{lme4}} \item{n.chains}{number of MCMC chains} \item{n.iter}{number of iteration for each MCMC chain} \item{n.burnin}{number of burnin for each MCMC chain, Default is \code{n.iter/2}, that is, discarding the first half of the simulations.} \item{n.thin}{keep every kth draw from each MCMC chain. Must be a positive integer. Default is \code{max(1, floor(n.chains * (n.iter-n.burnin) / 1000))} which will only thin if there are at least 2000 simulations.} \item{saveb}{if 'TRUE', causes the values of the random effects in each sample to be saved.} \item{deviance}{compute deviance for \code{mer} objects. Only works for \code{\link[lme4]{lmer}} object} \item{make.bugs.object}{tranform the output into bugs object, default is TRUE} \item{\ldots}{further arguments passed to or from other methods.} } \details{ This function generates a sample from the posterior distribution of the parameters of a fitted model using Markov Chain Monte Carlo methods. It automatically simulates multiple sequences and allows convergence to be monitored. The function relies on \code{mcmcsamp} in \code{lme4}. } \value{ An object of (S3) class '"bugs"' suitable for use with the functions in the "R2WinBUGS" package. } \references{Andrew Gelman and Jennifer Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2006. Douglas Bates and Deepayan Sarkar, lme4: Linear mixed-effects models using S4 classes. } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{ys463@columbia.edu} } \seealso{\code{\link{display}}, \code{\link[lme4]{lmer}}, \code{\link{sim}} } \examples{ ## Here's a simple example of a model of the form, y = a + bx + error, ## with 10 observations in each of 10 groups, and with both the intercept ## and the slope varying by group. First we set up the model and data. ## # group <- rep(1:10, rep(10,10)) # group2 <- rep(1:10, 10) # mu.a <- 0 # sigma.a <- 2 # mu.b <- 3 # sigma.b <- 4 # rho <- 0.56 # Sigma.ab <- array (c(sigma.a^2, rho*sigma.a*sigma.b, # rho*sigma.a*sigma.b, sigma.b^2), c(2,2)) # sigma.y <- 1 # ab <- mvrnorm (10, c(mu.a,mu.b), Sigma.ab) # a <- ab[,1] # b <- ab[,2] # d <- rnorm(10) # # x <- rnorm (100) # y1 <- rnorm (100, a[group] + b*x, sigma.y) # y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) # y3 <- rnorm (100, a[group] + b[group]*x + d[group2], sigma.y) # y4 <- rbinom(100, 1, prob=invlogit(a[group] + b*x + d[group2])) # ## ## Then fit and display a simple varying-intercept model: # # M1 <- lmer (y1 ~ x + (1|group)) # display (M1) # M1.sim <- mcsamp (M1) # print (M1.sim) # plot (M1.sim) ## ## Then the full varying-intercept, varying-slope model: ## # M2 <- lmer (y1 ~ x + (1 + x |group)) # display (M2) # M2.sim <- mcsamp (M2) # print (M2.sim) # plot (M2.sim) ## ## Then the full varying-intercept, logit model: ## # M3 <- lmer (y2 ~ x + (1|group), family=binomial(link="logit")) # display (M3) # M3.sim <- mcsamp (M3) # print (M3.sim) # plot (M3.sim) ## ## Then the full varying-intercept, varying-slope logit model: ## # M4 <- lmer (y2 ~ x + (1|group) + (0+x |group), # family=binomial(link="logit")) # display (M4) # M4.sim <- mcsamp (M4) # print (M4.sim) # plot (M4.sim) # ## ## Then non-nested varying-intercept, varying-slop model: ## # M5 <- lmer (y3 ~ x + (1 + x |group) + (1|group2)) # display(M5) # M5.sim <- mcsamp (M5) # print (M5.sim) # plot (M5.sim) } \keyword{models} \keyword{methods} arm/man/display.Rd0000644000176200001440000001162413014470370013543 0ustar liggesusers\name{display} %\docType{genericFunction} \alias{display} \alias{display,lm-method} \alias{display,bayesglm-method} %\alias{display,bayesglm.h-method} \alias{display,glm-method} \alias{display,merMod-method} \alias{display,polr-method} \alias{display,svyglm-method} \title{Functions for Processing lm, glm, mer, polr and svyglm Output} \description{This generic function gives a clean printout of lm, glm, mer, polr and svyglm objects.} \usage{ display (object, ...) \S4method{display}{lm}(object, digits=2, detail=FALSE) \S4method{display}{bayesglm}(object, digits=2, detail=FALSE) %\S4method{display}{bayesglm.h}(object, digits=2, detail=FALSE) \S4method{display}{glm}(object, digits=2, detail=FALSE) \S4method{display}{merMod}(object, digits=2, detail=FALSE) \S4method{display}{polr}(object, digits=2, detail=FALSE) \S4method{display}{svyglm}(object, digits=2, detail=FALSE) } \arguments{ \item{object}{The output of a call to lm, glm, mer, polr, svyglm or related regressions function with n data points and k predictors.} \item{...}{further arguments passed to or from other methods.} \item{digits}{number of significant digits to display.} \item{detail}{defaul is \code{FALSE}, if \code{TRUE}, display p-values or z-values} } \details{This generic function gives a clean printout of lm, glm, mer and polr objects, focusing on the most pertinent pieces of information: the coefficients and their standard errors, the sample size, number of predictors, residual standard deviation, and R-squared. Note: R-squared is automatically displayed to 2 digits, and deviances are automatically displayed to 1 digit, no matter what. } \value{Coefficients and their standard errors, the sample size, number of predictors, residual standard deviation, and R-squared} \references{Andrew Gelman and Jennifer Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2006.} \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn}; Maria Grazia Pittau \email{grazia@stat.columbia.edu} } \note{Output are the model, the regression coefficients and standard errors, and the residual sd and R-squared (for a linear model), or the null deviance and residual deviance (for a generalized linear model). } \seealso{\code{\link[base]{summary}}, \code{\link[stats]{lm}}, \code{\link[stats]{glm}}, \code{\link[lme4]{lmer}}, \code{\link[MASS]{polr}}, \code{\link[survey]{svyglm}} } \examples{ # Here's a simple example of a model of the form, y = a + bx + error, # with 10 observations in each of 10 groups, and with both the # intercept and the slope varying by group. First we set up the model and data. group <- rep(1:10, rep(10,10)) group2 <- rep(1:10, 10) mu.a <- 0 sigma.a <- 2 mu.b <- 3 sigma.b <- 4 rho <- 0.56 Sigma.ab <- array (c(sigma.a^2, rho*sigma.a*sigma.b, rho*sigma.a*sigma.b, sigma.b^2), c(2,2)) sigma.y <- 1 ab <- mvrnorm (10, c(mu.a,mu.b), Sigma.ab) a <- ab[,1] b <- ab[,2] d <- rnorm(10) x <- rnorm (100) y1 <- rnorm (100, a[group] + b*x, sigma.y) y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) y3 <- rnorm (100, a[group] + b[group]*x + d[group2], sigma.y) y4 <- rbinom(100, 1, prob=invlogit(a[group] + b*x + d[group2])) # display a simple linear model M1 <- lm (y1 ~ x) display (M1) M1.sim <- sim(M1, n.sims=2) # display a simple logit model M2 <- glm (y2 ~ x, family=binomial(link="logit")) display (M2) M2.sim <- sim(M2, n.sims=2) # Then fit and display a simple varying-intercept model: M3 <- lmer (y1 ~ x + (1|group)) display (M3) M3.sim <- sim(M3, n.sims=2) # Then the full varying-intercept, varying-slope model: M4 <- lmer (y1 ~ x + (1 + x |group)) display (M4) M4.sim <- sim(M4, n.sims=2) # Then the full varying-intercept, logit model: M5 <- glmer (y2 ~ x + (1|group), family=binomial(link="logit")) display (M5) M5.sim <- sim(M5, n.sims=2) # Then the full varying-intercept, varying-slope logit model: M6 <- glmer (y2 ~ x + (1|group) + (0 + x |group), family=binomial(link="logit")) display (M6) M6.sim <- sim(M6, n.sims=2) # Then non-nested varying-intercept, varying-slop model: M7 <- lmer (y3 ~ x + (1 + x |group) + (1|group2)) display(M7) M7.sim <- sim(M7, n.sims=2) # Then the ordered logit model from polr M8 <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display(M8) M9 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display(M9) } \keyword{manip} \keyword{methods} arm/DESCRIPTION0000644000176200001440000000330614602517552012550 0ustar liggesusersPackage: arm Version: 1.14-4 Date: 2024-4-1 Title: Data Analysis Using Regression and Multilevel/Hierarchical Models Authors@R: c(person("Andrew", "Gelman", role = "aut", email = "gelman@stat.columbia.edu"), person("Yu-Sung", "Su", role = c("aut", "cre"), email = "suyusung@tsinghua.edu.cn", comment = c(ORCID = "0000-0001-5021-8209")), person("Masanao", "Yajima", role = "ctb", email = "yajima@bu.edu"), person("Jennifer", "Hill", role = "ctb", email = "jennifer.hill@nyu.edu"), person("Maria Grazia", "Pittau", role = "ctb", email = "grazia@stat.columbia.edu"), person("Jouni", "Kerman", role = "ctb", email = "jouni@kerman.com"), person("Tian", "Zheng", role = "ctb", email = "tzheng@stat.columbia.edu"), person("Vincent", "Dorie", role = "ctb", email = "vjd4@nyu.edu") ) Author: Andrew Gelman [aut], Yu-Sung Su [aut, cre] (), Masanao Yajima [ctb], Jennifer Hill [ctb], Maria Grazia Pittau [ctb], Jouni Kerman [ctb], Tian Zheng [ctb], Vincent Dorie [ctb] Maintainer: Yu-Sung Su BugReports: https://github.com/suyusung/arm/issues/ Depends: R (>= 3.1.0), MASS, Matrix (>= 1.0), stats, lme4 (>= 1.0) Imports: abind, coda, graphics, grDevices, methods, nlme, utils Description: Functions to accompany A. Gelman and J. Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2007. License: GPL (> 2) URL: https://CRAN.R-project.org/package=arm NeedsCompilation: no Packaged: 2024-04-01 10:51:23 UTC; yusung Repository: CRAN Date/Publication: 2024-04-01 11:50:02 UTC arm/CHANGELOG0000644000176200001440000003474614301551626012264 0ustar liggesusers2022-8-25 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.13.1 * NAMESPACE: import solve from Matrix * R/simmer: comment out solveFun(), and use solve from Matrix direclty 2021-10-15 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.12-2 * man/lalonde.Rd: fixed the link to lalonde data (from http to https) 2021-10-08 Marius Barth * DESCRIPTION: (Version, Date): removed the Hmisc package from Imports field * NAMESPACE: Do not import wtd.var from Hmisc, anymore (this is to increase crossplatform compatibility) * R/balance.R: Replace call to Hmisc::wtd.var() with call to stats::cov.wt() 2020-7-27 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.11-2 * NAMESPACE: import weighted.mean from stats and wtd.var from Hmisc * R/balance: new balance, print.balance, plot.balance function * R/matching: new matching function * man/balance: new description to new functions 2020-4-27 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.11-0 * NAMESPACE: import setClass from methods (BUGS reported by Henrik) 2018-4-12 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.10-1 * R/bayesglm: fix a bug where scale=TRUE the prior.scale miscount the nvars. * R/sim.glm: improve the speed. * man/standardized: fix a typo in the example 2016-11-24 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.9-3 * DESCRIPTION: new description, and change http to https in URL 2016-9-4 Yu-Sung Su * DESCRIPTION: add BugReports and change LICENSE to GPL >=3, fix Vincent's name (spelling error, sorry Vincent!) ======= 2016-9-2 Yu-Sung Su * DESCRIPTION: add BugReports and change LICENSE to GPL >=3 * Doc fix Vincent's name 2016-8-21 Yu-Sung Su * DESCRIPTION (Version, Date): 1.9-1 * NAMESPACE: import show from methods 2015-7-7 Yu-Sung Su * DESCRIPTION (Version, Date): 1.8-6 * NAMESPACE: import more from base packages (new R rules) 2015-5-3 Yu-Sung Su * DESCRIPTION (Version, Date): 1.8-5 * R/bayesglm: fix a missing line in the re-factorization of bayesglm.fit, when scaled=TRUE, and a column of X takes on more than two values, than prior.scale = prior.scale /(sd(x)*2). 2015-4-7 Yu-Sung Su * DESCRIPTION (Version, Date): 1.8-4 * R/sigma.hat: sigma.hat changed to S3 function. * R/fitted: changed to S3 function * R/coef: coef, fixef, ranef, changed to S3 function 2015-3-31 Yu-Sung Su * DESCRIPTION (Version, Date): 1.8-03 * R/bayesglm: revert back to a more straightforward coding, easier for debugging. * R/bayespolr: check n.iter to maxit, and pass it through control. 2014-8-27 Yu-Sung Su * DESCRIPTION (Version, Date): 1.7-07 * R/readColumns: add read.columns() * R/sim: fix a bug in the name calling of beta.hat * man/readColumns: add description for read.columns() * NAMESPACE: export read.columns * DESCRIPTION: remove foreign and R2WinBUGS from suggests 2014-8-1 Yu-Sung Su * DESCRIPTION (Version, Date): 1.7-05 (thanks to Dr. Martyn Plummer's contribution) * R/bayesglm: fix several bugs in bayesglm * R/display: change the display for bayesglm to fit the changes stated above. * man/bayesglm: 1. change M2 and M7 example codes to make them equivalent to M1 and M3. 2. change the description for prior.scale for the gaussian family. * DESCRIPTION: remove foreign and R2WinBUGS from suggests 2014-4-27 Yu-Sung Su * DESCRIPTION (Version, Date): 1.7-03 * R/bayesglm: revert back to the use of lm.fit to lm.wfit; put a stop when dispersion goes Inf 2014-4-24 Yu-Sung Su * DESCRIPTION (Version, Date): 1.7-02 * R/simmer.R: simmer attaches names to fixed effects * R/fitted: fitted uses correct observational weights for glmms * R/bayesglm: use change the use of lm.fit to lm.wfit. 2013-11-25 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-10 * make changes that fit to oldrelease R. * R/se.ranef, se.coef: change postVar to condVar 2013-9-23 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-09 * start supporting new lme4 2013-9-23 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-09 * start supporting new lme4 2013-8-22 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-07 * revert back to 1.6-07, stop supporting the new lme4. * R/bayesglm: fix various bugs 2013-8-21 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-08 * clean up DESCRIPTION and NAMESPACE 2013-7-12 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-07 * made various change to adjust the new lme4 * currently, sim.mer is not working, waiting for revision. 2013-5-9 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-06 * NAMESPACE: export new method fitted() for sim.mer * R/fitted: add fitted() for sim.mer object * man/sim: add description for fitted() for sim.mer object * R/bayesglm fix a bug in bayesglm() in "subset" 2013-3-8 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-05 * NAMESPACE: export logit() 2013-2-27 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-04 * R/coefplot: fix a bug when the formula does not have an intercept * man/bayesglm: fix a coding error for weights in the bayesglm.fit 2013-2-20 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-03, add import from survey package * R/AllClass: set old class svyglm. * R/display: add svyglm method * R/coefplot: fix a bug when the formula does not have an intercept * man/display: add svyglm method 2013-1-5 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-01 * R/bayesglm: fix an issue in updating start in the loop 2012-10-13 Yu-Sung Su * R/coefplot: fix an issue in coefplot. No longer reset par when exit. * R/bayesglm: fix an issue in dev and family$state$valideta, family$state$mu 2012-10-03 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-08 * R/bayesglm: fix various bugs in bayesglm 2012-09-26 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-07 * R/balance: handle the situation when the formula in pscore.fit is not directly express. 2012-09-20 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-06 * R/bayesglm: stop using .Fortran() here. 2012-06-6 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-05 * man/bayesglm: add predictLM * R/bayesglm: add predict.bayesglm, predictLM to fit with model.matrixBayes 2012-04-27 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-04 * man/bayesglm: rewrite the description for the option scaled. 2012-03-3 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-03 * DESCRIPTION: add foreign as the required package * R/simmer: new sim() for mer class 2012-01-19 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-01 * R/mcsamp: add mcsamp() back, though it is not working. * R/AllGeneric: set coef, print, as generic to pass the check 2011-11-21 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-14 * R/.onAttach: fix the NOTE issue 2011-06-19 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-13 * R/coefplot: fix margin control. 2011-06-11 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-12 * R/bayespolr: add min.prior.scale * R/binnedplot: add nclass > 1 check * man/bayespolr: add min.prior.scale 2011-05-25 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-11 * R/bayesglm: fix a bug when there are some observation-weights that are zero. 2011-05-9 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-10 * R/display: fix a bug in display.lm that fails to print out se. 2011-05-8 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-09 * R/binnedplot: fix a bug of no sd when binnedplot only get one point. 2011-04-24 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-08 * display: now return objects after displaying the fitted model. * sigma.hat: fix a bug in sigma.hat for mer 2011-03-1 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-07 * AllClass: add sim.polr class * coef: add coef() for sim.polr * sim: add sim() for polr 2011-03-1 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-06 * NAMESPACE: export distcrete.histogram 2011-02-23 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-04 * R/binnedplot: pass addition graphical parameters to the function. 2011-02-15 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-03 * R/sim: fix a bug in sim.glm() when there is only an intercept as a predictor. (discovered by Barnes Benjamin) 2011-02-14 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-02 * R/bayesglm: fix some dimension issues when NCOL(x.nobs)==1 2011-02-05 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-01 * R/load.first: lib --> lib.loc in packageDescription 2010-11-20 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-08 * R/simmer: samples directly from the posterior of the fixed and random effects, given sigma and Sigma 2010-10-24 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-07 add new methods for sim object, coef, fixef, ranef and sigm.hat 2010-9-24 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-06 * R/bayesglm: fix a bug when a model of one predictor with no intercept is fitted * man/several: CRAN no longer alows genericFunction docType 2010-6-28 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-05 * R/extractDIC: add s3 methods for extractDIC and extractAIC for the mer class * Rd/extractDIC 2010-1-21 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-04 * R/standardize: add polr method * Rd/standardize: change the example code to make M1 and M2 equivalent. 2010-1-15 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-03 * R/balanceplot: fix a bug in balance(), take out the intercept 2010-1-11 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-02 * R/bayesglm: new bayesglm.fit (written by Daniel Lee) 2010-1-8 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-01. * R/bayesglm: a bug in x.matrix augmentation 2009-12-30 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-13. * R/bayesglm: smarter use of x matrix to save memory usage 2009-12-12 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-12. * R/simmer: use of sparse matrix in sim.mer 2009-12-08 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-11; add abind pacakge dependencyR * R/simmer: new sim functions for "mer" class 2009-11-22 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-10. * NAMESPACE: export logit 2009-4-29 Yu-Sung Su * R/display: fix format inconsistency in sprintf (fround) 2009-4-13 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-9. * R/macthing: fix a bug in matching replace=TRUE 2009-3-31 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-8. * R/display: add option detail 2009-3-1 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-7. * R/display: fix a bug in display.mer 2009-2-26 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-6. * R/display: print out t-value, z-value, p-value 2009-2-20 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-5. * R/load.first: no longer set default digit=2 2009-2-17 Yu-Sung Su * NAMESPACE: export binned.resids 2009-2-4 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-4, no longer need car * R/load.first: car is no longer required 2009-2-1 Yu-Sung Su * man/coefplot: fixed doc error * man/sim: fixed doc error 2009-1-30 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-3. * R/coefplot: fixed margin bugs in coefplot.default 2009-1-29 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-2. * R/sim: for mer method, add option ranef. Users choose to return sim.ranef or not. 2009-1-28 Yu-Sung Su * man: first attempt to clean up help files to comply the new rule. in particular, use \dQuote and \sQuote for "" and ''. * man/bayesglm: update reference * man/bayespolr: update reference 2009-1-22 Yu-Sung Su * man/rescale: update reference. * man/standardize: update reference. 2009-1-16 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-1. * NAMESPACE: export S4 method for standardize * man/standardize: add description for S4 methods. * R/AllGeneric: add a generic function for standardize * R/standardize: add standardize.default, S4 methods for lm, glm and mer. 2009-1-03 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-0. arm/R/0000755000176200001440000000000014570331374011241 5ustar liggesusersarm/R/AllClass.R0000644000176200001440000000411113014470370013047 0ustar liggesuserssetOldClass("family") setOldClass("mcmc.list") setOldClass("polr") setOldClass("bugs") setOldClass("svyglm") setClass("balance", representation( rawdata = "data.frame", matched = "data.frame", factor = "logical") ) setClass("bayesglm", representation( formula = "formula", family = "family", prior.mean = "numeric", prior.scale = "numeric", prior.df = "numeric"), contains = "glm" ) #setClass("bayesglm.h", # representation( # formula = "formula", # family = "family", # prior.mean = "numeric", # prior.scale = "numeric", # prior.df = "numeric", # batch = "numeric"), # contains = "bayesglm" #) #setClass("polr", # representation( # formula = "formula", # Hess = "logical", # method = "character" ## prior.mean = "numeric", ## prior.scale = "numeric", ## prior.df = "numeric", ## prior.mean.for.cutpoints = "numeric", ## prior.scale.for.cutpoints = "numeric", ## prior.df.for.cutpoints = "numeric" # ), # contains="oldClass" #) setClass("bayespolr", representation( formula = "formula", Hess = "logical", method = "character", prior.mean = "numeric", prior.scale = "numeric", prior.df = "numeric", prior.mean.for.cutpoints = "numeric", prior.scale.for.cutpoints = "numeric", prior.df.for.cutpoints = "numeric"), contains = "polr" ) setClass("sim", representation( coef = "matrix", sigma = "numeric") ) setClass("sim.polr", representation( coef = "matrix", zeta = "matrix") ) setClass("sim.merMod", representation( fixef = "matrix", ranef = "list", sigma = "ANY") ) setClass("GO") arm/R/bayesglm.R0000644000176200001440000007120013263604567013174 0ustar liggesusersbayesglm <- function (formula, family = gaussian, data, weights, subset, na.action, start = NULL, etastart, mustart, offset, control = list(...), model = TRUE, method = "glm.fit", x = FALSE, y = TRUE, contrasts = NULL, drop.unused.levels = TRUE, prior.mean = 0, prior.scale = NULL, prior.df = 1, prior.mean.for.intercept = 0, prior.scale.for.intercept = NULL, prior.df.for.intercept = 1, min.prior.scale = 1e-12, scaled = TRUE, keep.order = TRUE, drop.baseline = TRUE, maxit = 100, print.unnormalized.log.posterior = FALSE, Warning = TRUE, ...) { call <- match.call() if (is.character(family)) { family <- get(family, mode = "function", envir = parent.frame()) } if (is.function(family)) { family <- family() } if (is.null(family$family)) { print(family) stop("'family' not recognized") } if (missing(data)) { data <- environment(formula) } mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "subset", "weights", "na.action", "etastart", "mustart", "offset"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- drop.unused.levels mf$na.action <- NULL mf[[1L]] <- quote(stats::model.frame) mf <- eval(mf, parent.frame()) if (identical(method, "model.frame")){ return(mf) } if (!is.character(method) && !is.function(method)){ stop("invalid 'method' argument") } if (identical(method, "glm.fit")){ control <- do.call("glm.control", control) } control$maxit <- maxit mt <- attr(mf, "terms") Y <- model.response(mf, "any") if (length(dim(Y)) == 1L) { nm <- rownames(Y) dim(Y) <- NULL if (!is.null(nm)) { names(Y) <- nm } } X <- if (!is.empty.model(mt)) { model.matrixBayes(object = mt, data = data, contrasts.arg = contrasts, keep.order = keep.order, drop.baseline = drop.baseline) }else { matrix(, NROW(Y), 0L) } weights <- as.vector(model.weights(mf)) if (!is.null(weights) && !is.numeric(weights)) { stop("'weights' must be a numeric vector") } if (!is.null(weights) && any(weights < 0)) { stop("negative weights not allowed") } offset <- as.vector(model.offset(mf)) if (!is.null(offset)) { if (length(offset) != NROW(Y)) stop(gettextf("number of offsets is %d should equal %d (number of observations)", length(offset), NROW(Y)), domain = NA) } mustart <- model.extract(mf, "mustart") etastart <- model.extract(mf, "etastart") fit <- bayesglm.fit(x = X, y = Y, weights = weights, start = start, etastart = etastart, mustart = mustart, offset = offset, family = family, control = control, intercept = attr(mt, "intercept") > 0L, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = prior.mean.for.intercept, prior.scale.for.intercept = prior.scale.for.intercept, prior.df.for.intercept = prior.df.for.intercept, min.prior.scale = min.prior.scale, print.unnormalized.log.posterior = print.unnormalized.log.posterior, scaled = scaled, Warning = Warning) if (length(offset) && attr(mt, "intercept") > 0L) { fit2 <- bayesglm.fit(x = X[, "(Intercept)", drop = FALSE], y = Y, weights = weights, offset = offset, family = family, control = control, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = prior.mean.for.intercept, prior.scale.for.intercept = prior.scale.for.intercept, prior.df.for.intercept = prior.df.for.intercept, min.prior.scale = min.prior.scale, print.unnormalized.log.posterior = print.unnormalized.log.posterior, scaled = scaled, Warning = Warning) if (!fit2$converged){ warning("fitting to calculate the null deviance did not converge -- increase 'maxit'?") } fit$null.deviance <- fit2$deviance } if (model) { fit$model <- mf } fit$na.action <- attr(mf, "na.action") if (x) { fit$x <- X } if (!y) { fit$y <- NULL } fit <- c(fit, list(call = call, formula = formula, terms = mt, data = data, offset = offset, control = control, method = method, contrasts = attr(X, "contrasts"), xlevels = .getXlevels(mt, mf)), keep.order = keep.order, drop.baseline = drop.baseline) class(fit) <- c("bayesglm", "glm", "lm") return(fit) } bayesglm.fit <- function (x, y, weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(), control = list(), intercept = TRUE, prior.mean = 0, prior.scale = NULL, prior.df = 1, prior.mean.for.intercept = 0, prior.scale.for.intercept = NULL, prior.df.for.intercept = 1, min.prior.scale = 1e-12, scaled = TRUE, print.unnormalized.log.posterior = FALSE, Warning = TRUE) { control <- do.call("glm.control", control) x <- as.matrix(x) xnames <- dimnames(x)[[2L]] ynames <- if (is.matrix(y)){ rownames(y) }else{ names(y) } conv <- FALSE nobs <- NROW(y) nvars <- NCOL(x) #=============================== # initialize priors #=============================== if(is.null(prior.scale)){ prior.scale <- 2.5 if(family$link == "probit"){ prior.scale <- prior.scale*1.6 } } if(is.null(prior.scale.for.intercept)){ prior.scale.for.intercept <- 10 if(family$link == "probit"){ prior.scale.for.intercept <- prior.scale.for.intercept*1.6 } } if(intercept){ nvars <- nvars - 1 } if(length(prior.mean)==1L){ prior.mean <- rep(prior.mean, nvars) }else if(length(prior.mean)!=nvars){ stop("invalid length for prior.mean") } if(length(prior.scale)==1L){ prior.scale <- rep(prior.scale, nvars) }else if(length(prior.scale)!=nvars){ stop("invalid length for prior.scale") } if(length(prior.df)==1L){ prior.df <- rep(prior.df, nvars) }else if(length(prior.df)!=nvars){ stop("invalid length for prior.df") } if(intercept){ prior.mean <- c(prior.mean.for.intercept, prior.mean) prior.scale <- c(prior.scale.for.intercept, prior.scale) prior.df <- c(prior.df.for.intercept, prior.df) } if(scaled){ if(family$family=="gaussian"){ prior.scale <- prior.scale*2*sd(y) } prior.scale.0 <- prior.scale if(nvars==0&intercept){ # this is need to reajust nvars when intercept is TRUE nvars <- 1 }else if(intercept){ nvars <- nvars + 1 } for(j in 1:nvars){ x.obs <- x[,j] x.obs <- x.obs[!is.na(x.obs)] num.categories <- length(unique(x.obs)) x.scale <- 1 if(num.categories==2L){ x.scale <- max(x.obs) - min(x.obs) }else if(num.categories>2){ x.scale <- 2*sd(x.obs) } prior.scale[j] <- prior.scale[j]/x.scale if(prior.scale[j] < min.prior.scale){ prior.scale[j] <- min.prior.scale warning("prior scale for varible ", j, " set to min.prior.scale = ", min.prior.scale, "\n") } } } #=================== nvars <- NCOL(x) EMPTY <- nvars == 0 if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) variance <- family$variance linkinv <- family$linkinv if (!is.function(variance) || !is.function(linkinv)) stop("'family' argument seems not to be a valid family object", call. = FALSE) dev.resids <- family$dev.resids aic <- family$aic mu.eta <- family$mu.eta unless.null <- function(x, if.null){ if (is.null(x)) if.null else x } valideta <- unless.null(family$valideta, function(eta) TRUE) validmu <- unless.null(family$validmu, function(mu) TRUE) if (is.null(mustart)) { eval(family$initialize) }else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } if (EMPTY) { eta <- rep.int(0, nobs) + offset if (!valideta(eta)) stop("invalid linear predictor values in empty model", call. = FALSE) mu <- linkinv(eta) if (!validmu(mu)) stop("invalid fitted means in empty model", call. = FALSE) dev <- sum(dev.resids(y, mu, weights)) w <- ((weights * mu.eta(eta)^2)/variance(mu))^0.5 residuals <- (y - mu)/mu.eta(eta) good <- rep_len(TRUE, length(residuals)) boundary <- conv <- TRUE coef <- numeric() iter <- 0L } else { coefold <- NULL eta <- if (!is.null(etastart)){ etastart }else if (!is.null(start)){ if (length(start) != nvars){ if(start==0&length(start)==1){ start <- rep(0, nvars) offset + as.vector(ifelse((NCOL(x) == 1L), x*start, x %*% start)) }else{ stop(gettextf("length of 'start' should equal %d and correspond to initial coefs for %s", nvars, paste(deparse(xnames), collapse = ", ")), domain = NA) } } else { coefold <- start offset + as.vector(if (NCOL(x) == 1L) x * start else x %*% start) } }else{ family$linkfun(mustart) } mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("cannot find valid starting values: please specify some", call. = FALSE) devold <- sum(dev.resids(y, mu, weights)) boundary <- conv <- FALSE #====================================== # initialize prior.sd #====================================== prior.sd <- prior.scale #===================================== dispersion <- ifelse((family$family %in% c("poisson", "binomial")), 1, var(y)/10000) dispersionold <- dispersion for (iter in 1L:control$maxit) { good <- weights > 0 varmu <- variance(mu)[good] if (anyNA(varmu)) stop("NAs in V(mu)") if (any(varmu == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) if (all(!good)) { conv <- FALSE warning(gettextf("no observations informative at iteration %d", iter), domain = NA) break } z <- (eta - offset)[good] + (y - mu)[good]/mu.eta.val[good] w <- sqrt((weights[good] * mu.eta.val[good]^2)/variance(mu)[good]) ngoodobs <- as.integer(nobs - sum(!good)) #====================== # data augmentation #========================= # coefs.hat <- rep(0, NCOL(x)) # why do we need coefs.hat here? SU 2015.3.30 x.star <- rbind(x, diag(NCOL(x))) if(intercept&scaled){ x.star[nobs+1,] <- colMeans(x) } z.star <- c (z, prior.mean) w.star <- c (w, sqrt(dispersion)/prior.sd) #================================================= good.star <- c (good, rep(TRUE,NCOL(x))) ngoodobs.star <- ngoodobs + NCOL(x) #fit <- .Call(C_Cdqrls, x.star[good, , drop = FALSE] * # w.star, z.star * w.star, min(1e-07, control$epsilon/1000), # check = FALSE) fit <- lm.fit(x = x.star[good.star,,drop=FALSE]*w.star, y = z.star*w.star) if (any(!is.finite(fit$coefficients))) { conv <- FALSE warning(gettextf("non-finite coefficients at iteration %d", iter), domain = NA) break } start[fit$qr$pivot] <- coefs.hat <- fit$coefficients fit$qr$qr <- as.matrix (fit$qr$qr) V.coefs <- chol2inv(fit$qr$qr[1:NCOL(x.star), 1:NCOL(x.star), drop = FALSE]) if (family$family == "gaussian" & scaled){ prior.scale <- prior.scale.0 } prior.sd <- ifelse(prior.df == Inf, prior.scale, sqrt(((coefs.hat - prior.mean)^2 + diag(V.coefs)*dispersion + prior.df * prior.scale^2)/(1 + prior.df))) start[fit$qr$pivot] <- fit$coefficients eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) dev <- sum(dev.resids(y, mu, weights)) if (!(family$family %in% c("poisson", "binomial"))) { mse.resid <- mean((w * (z - x %*% coefs.hat))^2) mse.uncertainty <- mean(rowSums(( x %*% V.coefs ) * x)) * dispersion # faster dispersion <- mse.resid + mse.uncertainty } if (control$trace) cat("Deviance = ", dev, " Iterations - ", iter, "\n", sep = "") boundary <- FALSE if (!is.finite(dev)) { if (is.null(coefold)) stop("no valid set of coefficients has been found: please supply starting values", call. = FALSE) warning("step size truncated due to divergence", call. = FALSE) ii <- 1 while (!is.finite(dev)) { if (ii > control$maxit) stop("inner loop 1; cannot correct step size", call. = FALSE) ii <- ii + 1 start <- (start + coefold)/2 eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) dev <- sum(dev.resids(y, mu, weights)) } boundary <- TRUE if (control$trace) cat("Step halved: new deviance = ", dev, "\n", sep = "") } if (!(valideta(eta) && validmu(mu))) { if (is.null(coefold)) stop("no valid set of coefficients has been found: please supply starting values", call. = FALSE) warning("step size truncated: out of bounds", call. = FALSE) ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; cannot correct step size", call. = FALSE) ii <- ii + 1 start <- (start + coefold)/2 eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) } boundary <- TRUE dev <- sum(dev.resids(y, mu, weights)) if (control$trace) cat("Step halved: new deviance = ", dev, "\n", sep = "") } #=============================== # print unnormalized log posterior #================================ if (family$family == "binomial" && print.unnormalized.log.posterior) { logprior <- sum(dt(coefs.hat, prior.df, prior.mean, log = TRUE)) xb <- invlogit( x %*% coefs.hat ) loglikelihood <- sum( log( c( xb[ y == 1 ], 1 - xb[ y == 0 ] ) ) ) cat( "log prior: ", logprior, ", log likelihood: ", loglikelihood, ", unnormalized log posterior: ", loglikelihood +logprior, "\n" ,sep="") } #================================ if (iter > 1 & abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon & abs(dispersion - dispersionold)/(0.1 + abs(dispersion)) < control$epsilon) { conv <- TRUE coef <- start break }else { devold <- dev dispersionold <- dispersion coef <- coefold <- start } } if (!conv){ warning("algorithm did not converge", call. = FALSE) } if (boundary){ warning("algorithm stopped at boundary value", call. = FALSE) } eps <- 10 * .Machine$double.eps if (family$family == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)){ warning("fitted probabilities numerically 0 or 1 occurred", call. = FALSE) } } if (family$family == "poisson") { if (any(mu < eps)){ warning("fitted rates numerically 0 occurred", call. = FALSE) } } if (fit$rank < nvars){ coef[fit$qr$pivot][seq.int(fit$rank + 1, nvars)] <- NA } xxnames <- xnames[fit$qr$pivot] residuals <- rep.int(NA, nobs) residuals[good] <- z - (eta - offset)[good] fit$qr$qr <- as.matrix(fit$qr$qr) nr <- min(sum(good), nvars) if (nr < nvars) { Rmat <- diag(nvars) Rmat[1L:nr, 1L:nvars] <- fit$qr$qr[1L:nr, 1L:nvars] } else Rmat <- fit$qr$qr[1L:nvars, 1L:nvars] Rmat <- as.matrix(Rmat) Rmat[row(Rmat) > col(Rmat)] <- 0 names(coef) <- xnames colnames(fit$qr$qr) <- xxnames dimnames(Rmat) <- list(xxnames, xxnames) } names(residuals) <- ynames names(mu) <- ynames names(eta) <- ynames wt <- rep.int(0, nobs) wt[good] <- w^2 names(wt) <- ynames names(weights) <- ynames names(y) <- ynames wtdmu <- if (intercept){ sum(weights * y)/sum(weights) } else{ linkinv(offset) } nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) rank <- if (EMPTY) { 0 } else{ fit$rank } resdf <- n.ok - rank aic.model <- aic(y, n.ok, mu, weights, dev) + 2 * rank list(coefficients = coef, residuals = residuals, fitted.values = mu, effects = if (!EMPTY) fit$effects, R = if (!EMPTY) Rmat, rank = rank, qr = if (!EMPTY) structure(getQr(fit)[c("qr", "rank", "qraux", "pivot", "tol")], class = "qr"), family = family, linear.predictors = eta, deviance = dev, aic = aic.model, null.deviance = nulldev, iter = iter, weights = wt, prior.weights = weights, df.residual = resdf, df.null = nulldf, y = y, converged = conv, boundary = boundary, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.sd = prior.sd, dispersion = dispersion) } setMethod("print", signature(x = "bayesglm"), function(x, digits=2) display(object=x, digits=digits)) setMethod("show", signature(object = "bayesglm"), function(object) display(object, digits=2)) predict.bayesglm <- function (object, newdata = NULL, type = c("link", "response", "terms"), se.fit = FALSE, dispersion = NULL, terms = NULL, na.action = na.pass, ...) { type <- match.arg(type) na.act <- object$na.action object$na.action <- NULL if (!se.fit) { if (missing(newdata)) { pred <- switch(type, link = object$linear.predictors, response = object$fitted.values, terms = predictLM(object, se.fit = se.fit, scale = 1, type = "terms", terms = terms)) if (!is.null(na.act)) pred <- napredict(na.act, pred) } else { pred <- predictLM(object, newdata, se.fit, scale = 1, type = ifelse(type == "link", "response", type), terms = terms, na.action = na.action) switch(type, response = { pred <- family(object)$linkinv(pred) }, link = , terms = ) } } else { if (inherits(object, "survreg")) dispersion <- 1 if (is.null(dispersion) || dispersion == 0) dispersion <- summary(object, dispersion = dispersion)$dispersion residual.scale <- as.vector(sqrt(dispersion)) pred <- predictLM(object, newdata, se.fit, scale = residual.scale, type = ifelse(type == "link", "response", type), terms = terms, na.action = na.action) fit <- pred$fit se.fit <- pred$se.fit switch(type, response = { se.fit <- se.fit * abs(family(object)$mu.eta(fit)) fit <- family(object)$linkinv(fit) }, link = , terms = ) if (missing(newdata) && !is.null(na.act)) { fit <- napredict(na.act, fit) se.fit <- napredict(na.act, se.fit) } pred <- list(fit = fit, se.fit = se.fit, residual.scale = residual.scale) } pred } predictLM <- function (object, newdata, se.fit = FALSE, scale = NULL, df = Inf, interval = c("none", "confidence", "prediction"), level = 0.95, type = c("response", "terms"), terms = NULL, na.action = na.pass, pred.var = res.var/weights, weights = 1, ...) { tt <- terms(object) keep.order <- object$keep.order drop.baseline <- object$drop.baseline if (!inherits(object, "lm")) warning("calling predict.lm() ...") if (missing(newdata) || is.null(newdata)) { mm <- X <- model.matrix(object) mmDone <- TRUE offset <- object$offset } else { Terms <- delete.response(tt) m <- model.frame(Terms, newdata, na.action = na.action, xlev = object$xlevels) if (!is.null(cl <- attr(Terms, "dataClasses"))) .checkMFClasses(cl, m) X <- model.matrixBayes(Terms, m, contrasts.arg = object$contrasts, keep.order = keep.order, drop.baseline = drop.baseline) offset <- rep(0, nrow(X)) if (!is.null(off.num <- attr(tt, "offset"))) for (i in off.num) offset <- offset + eval(attr(tt, "variables")[[i + 1]], newdata) if (!is.null(object$call$offset)) offset <- offset + eval(object$call$offset, newdata) mmDone <- FALSE } n <- length(object$residuals) p <- object$rank p1 <- seq_len(p) piv <- if (p) getQr(object)$pivot[p1] if (p < ncol(X) && !(missing(newdata) || is.null(newdata))) warning("prediction from a rank-deficient fit may be misleading") beta <- object$coefficients predictor <- drop(X[, piv, drop = FALSE] %*% beta[piv]) if (!is.null(offset)) predictor <- predictor + offset interval <- match.arg(interval) if (interval == "prediction") { if (missing(newdata)) warning("Predictions on current data refer to _future_ responses\n") if (missing(newdata) && missing(weights)) { w <- .weights.default(object) if (!is.null(w)) { weights <- w warning("Assuming prediction variance inversely proportional to weights used for fitting\n") } } if (!missing(newdata) && missing(weights) && !is.null(object$weights) && missing(pred.var)) warning("Assuming constant prediction variance even though model fit is weighted\n") if (inherits(weights, "formula")) { if (length(weights) != 2L) stop("'weights' as formula should be one-sided") d <- if (missing(newdata) || is.null(newdata)) model.frame(object) else newdata weights <- eval(weights[[2L]], d, environment(weights)) } } type <- match.arg(type) if (se.fit || interval != "none") { res.var <- if (is.null(scale)) { r <- object$residuals w <- object$weights rss <- sum(if (is.null(w)) r^2 else r^2 * w) df <- object$df.residual rss/df } else scale^2 if (type != "terms") { if (p > 0) { XRinv <- if (missing(newdata) && is.null(w)) qr.Q(getQr(object))[, p1, drop = FALSE] else X[, piv] %*% qr.solve(qr.R(getQr(object))[p1, p1]) ip <- drop(XRinv^2 %*% rep(res.var, p)) } else ip <- rep(0, n) } } if (type == "terms") { if (!mmDone) { mm <- model.matrixBayes(object, keep.order = keep.order, drop.baseline = drop.baseline) mmDone <- TRUE } aa <- attr(mm, "assign") ll <- attr(tt, "term.labels") hasintercept <- attr(tt, "intercept") > 0L if (hasintercept) ll <- c("(Intercept)", ll) aaa <- factor(aa, labels = ll) asgn <- split(order(aa), aaa) if (hasintercept) { asgn$"(Intercept)" <- NULL if (!mmDone) { mm <- model.matrixBayes(object, keep.order = keep.order, drop.baseline = drop.baseline) mmDone <- TRUE } avx <- colMeans(mm) termsconst <- sum(avx[piv] * beta[piv]) } nterms <- length(asgn) if (nterms > 0) { predictor <- matrix(ncol = nterms, nrow = NROW(X)) dimnames(predictor) <- list(rownames(X), names(asgn)) if (se.fit || interval != "none") { ip <- matrix(ncol = nterms, nrow = NROW(X)) dimnames(ip) <- list(rownames(X), names(asgn)) Rinv <- qr.solve(qr.R(getQr(object))[p1, p1]) } if (hasintercept) X <- sweep(X, 2L, avx, check.margin = FALSE) unpiv <- rep.int(0L, NCOL(X)) unpiv[piv] <- p1 for (i in seq.int(1L, nterms, length.out = nterms)) { iipiv <- asgn[[i]] ii <- unpiv[iipiv] iipiv[ii == 0L] <- 0L predictor[, i] <- if (any(iipiv > 0L)) X[, iipiv, drop = FALSE] %*% beta[iipiv] else 0 if (se.fit || interval != "none") ip[, i] <- if (any(iipiv > 0L)) as.matrix(X[, iipiv, drop = FALSE] %*% Rinv[ii, , drop = FALSE])^2 %*% rep.int(res.var, p) else 0 } if (!is.null(terms)) { predictor <- predictor[, terms, drop = FALSE] if (se.fit) ip <- ip[, terms, drop = FALSE] } } else { predictor <- ip <- matrix(0, n, 0L) } attr(predictor, "constant") <- if (hasintercept) termsconst else 0 } if (interval != "none") { tfrac <- qt((1 - level)/2, df) hwid <- tfrac * switch(interval, confidence = sqrt(ip), prediction = sqrt(ip + pred.var)) if (type != "terms") { predictor <- cbind(predictor, predictor + hwid %o% c(1, -1)) colnames(predictor) <- c("fit", "lwr", "upr") } else { if (!is.null(terms)) hwid <- hwid[, terms, drop = FALSE] lwr <- predictor + hwid upr <- predictor - hwid } } if (se.fit || interval != "none") { se <- sqrt(ip) if (type == "terms" && !is.null(terms) && !se.fit) se <- se[, terms, drop = FALSE] } if (missing(newdata) && !is.null(na.act <- object$na.action)) { predictor <- napredict(na.act, predictor) if (se.fit) se <- napredict(na.act, se) } if (type == "terms" && interval != "none") { if (missing(newdata) && !is.null(na.act)) { lwr <- napredict(na.act, lwr) upr <- napredict(na.act, upr) } list(fit = predictor, se.fit = se, lwr = lwr, upr = upr, df = df, residual.scale = sqrt(res.var)) } else if (se.fit) list(fit = predictor, se.fit = se, df = df, residual.scale = sqrt(res.var)) else predictor } getQr <- function(x, ...){ if (is.null(r <- x$qr)) stop("lm object does not have a proper 'qr' component.\n Rank zero or should not have used lm(.., qr=FALSE).") r } arm/R/coefplot.R0000644000176200001440000003304613014470370013175 0ustar liggesuserscoefplot.default <- function(coefs, sds, CI=2, lower.conf.bounds, upper.conf.bounds, varnames=NULL, vertical=TRUE, v.axis=TRUE, h.axis=TRUE, cex.var=0.8, cex.pts=0.9, col.pts=1, pch.pts=20, var.las=2, main=NULL, xlab=NULL, ylab=NULL, mar=c(1,3,5.1,2), plot=TRUE, add=FALSE, offset=0.1, ...) { # collect informations if (is.list(coefs)){ coefs <- unlist(coefs) } n.x <- length(coefs) idx <- seq(1, n.x) #bound <- lower.bound if(!missing(lower.conf.bounds)){ if(length(coefs)!=length(lower.conf.bounds)){ stop("Number of conf.bounds does not equal to number of estimates") } } if(!missing(upper.conf.bounds)){ if(length(coefs)!=length(upper.conf.bounds)){ stop("Number of conf.bounds does not equal to number of estimates") } } if(!missing(sds)){ coefs.h <- coefs + CI*sds coefs.l <- coefs - CI*sds est1 <- cbind(coefs - sds, coefs + sds) est2 <- cbind(coefs - 2*sds, coefs + 2*sds) if(!missing(lower.conf.bounds)){ est1[,1] <- lower.conf.bounds CI <- 1 } if(!missing(upper.conf.bounds)){ est1[,2] <- upper.conf.bounds CI <- 1 } }else{ #coefs.h <- upper.conf.bounds #coefs.l <- lower.conf.bounds est1 <- cbind(coefs, coefs) if(!missing(lower.conf.bounds)){ est1[,1] <- lower.conf.bounds CI <- 1 } if(!missing(upper.conf.bounds)){ est1[,2] <- upper.conf.bounds CI <- 1 } } old.par <- par(no.readonly=TRUE) #on.exit(par(old.par)) min.mar <- par('mar') if (is.null(main)){main <- "Regression Estimates"} if (is.null(xlab)){xlab <- ""} if (is.null(ylab)){ylab <- ""} par(mar = mar) if (is.null(varnames)) { maxchar <- 0 } else{ maxchar <- max(sapply(varnames, nchar)) } # add margin to the axis k <- 1/n.x if(plot){ if (vertical){ mar[2] <- max(min.mar[2], trunc(mar[2] + maxchar/10)) + 0.1 par(mar=mar) if(!add){ plot(c(coefs.l, coefs.h), c(idx+k,idx-k), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if (h.axis){ #axis(1) axis(3) } if (v.axis){ axis(2, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(v=0, lty=2) points(coefs, idx, pch=pch.pts, cex=cex.pts, col=col.pts) if (CI==2){ segments (est1[,1], idx, est1[,2], idx, lwd=2, col=col.pts) segments (est2[,1], idx, est2[,2], idx, lwd=1, col=col.pts) } else{ segments (est1[,1], idx, est1[,2], idx, lwd=1, col=col.pts) } } else{ idx <- idx + offset points(coefs, idx, pch=pch.pts, cex=cex.pts, col=col.pts) if (CI==2){ segments (est1[,1], idx, est1[,2], idx, lwd=2, col=col.pts) segments (est2[,1], idx, est2[,2], idx, lwd=1, col=col.pts) } else{ segments (est1[,1], idx, est1[,2], idx, lwd=1, col=col.pts) } } } # end of if vertical else{ # horizontal mar[1] <- max(min.mar[1], trunc(mar[1] + maxchar/10)) + 0.1 par(mar=mar) if(!add){ plot(c(idx+k,idx-k), c(coefs.l, coefs.h), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if (v.axis){ axis(2, las=var.las) #axis(4, las=var.las) } if (h.axis){ axis(1, 1:n.x, varnames[1:n.x], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(h=0, lty=2) points(idx, coefs, pch=pch.pts, cex=cex.pts, col=col.pts) if (CI==2){ segments (idx, est1[,1], idx, est1[,2], lwd=2, col=col.pts) segments (idx, est2[,1], idx, est2[,2], lwd=1, col=col.pts) } else if (CI==1) { segments (idx, est1[,1], idx, est1[,2], lwd=1, col=col.pts) } } else{ idx <- idx + offset points(idx, coefs, pch=pch.pts, cex=cex.pts, col=col.pts) if (CI==2){ segments (idx, est1[,1], idx, est1[,2], lwd=2, col=col.pts) segments (idx, est2[,1], idx, est2[,2], lwd=1, col=col.pts) } else if (CI==1) { segments (idx, est1[,1], idx, est1[,2], lwd=1, col=col.pts) } } } } else{ if (vertical){ mar[2] <- max(min.mar[2], trunc(mar[2] + maxchar/10)) + 0.1 par(mar=mar) plot(c(coefs.l, coefs.h), c(idx+k,idx-k), type="n", axes=F, main="", xlab=xlab, ylab=ylab,...) # if (v.axis){ # axis(2, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, # lty=0, cex.axis=cex.var) # } } else{ # horizontal mar[1] <- max(min.mar[1], trunc(mar[1] + maxchar/10)) + 0.1 par(mar=mar) plot(c(idx+k,idx-k), c(coefs.l, coefs.h), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) #if (h.axis){ # axis(1, 1:n.x, varnames[1:n.x], las=var.las, tck=FALSE, # lty=0, cex.axis=cex.var) # } } } #on.exit(par(old.par)) } setMethod("coefplot", signature(object = "numeric"), function(object, ...) { coefplot.default(object, ...) } ) setMethod("coefplot", signature(object = "lm"), function(object, varnames=NULL, intercept=FALSE, ...) { # collect informations coefs <- summary(object)$coef[,1] sds <- summary(object)$coef[,2] ifelse (is.null(varnames), varnames <- names(coefs), varnames <- varnames) if (length(varnames)!= length(names(coefs))){ stop(message="the length of varnames does not equal the length of predictors. Note: varnames must include a name for constant/intercept") } chk.int <- attr(terms(object), "intercep") if(chk.int & intercept | !chk.int & intercept | !chk.int & !intercept){ intercept <- TRUE coefs <- coefs sds <- sds varnames <- varnames } else if(chk.int & !intercept){ coefs <- coefs[-1] sds <- sds[-1] varnames <- varnames[-1] } # plotting coefplot(coefs, sds, varnames=varnames, ...) } ) setMethod("coefplot", signature(object = "glm"), function(object, varnames=NULL, intercept=FALSE,...) { # collect informations coefs <- summary(object)$coef[,1] sds <- summary(object)$coef[,2] ifelse (is.null(varnames), varnames <- names(coefs), varnames <- varnames) if (length(varnames)!= length(names(coefs))){ stop(message="the length of varnames does not equal the length of predictors. Note: varnames must include a name for constant/intercept") } chk.int <- attr(terms(object), "intercep") if(chk.int & intercept | !chk.int & intercept | !chk.int & !intercept){ intercept <- TRUE coefs <- coefs sds <- sds varnames <- varnames } else if(chk.int & !intercept){ coefs <- coefs[-1] sds <- sds[-1] varnames <- varnames[-1] } # plotting coefplot(coefs, sds, varnames=varnames, ...) } ) setMethod("coefplot", signature(object = "bugs"), function(object, var.idx=NULL, varnames=NULL, CI=1, vertical=TRUE, v.axis=TRUE, h.axis=TRUE, cex.var=0.8, cex.pts=0.9, col.pts=1, pch.pts=20, var.las=2, main=NULL, xlab=NULL, ylab=NULL, plot=TRUE, add=FALSE, offset=.1, mar=c(1,3,5.1,2), ...) { if (is.null(var.idx)){ var.idx <- 1:length(object$summary[,"50%"]) } n.x <- length(var.idx) idx <- 1:n.x coefs <- object$summary[,"50%"][var.idx] if (is.null(varnames)){ varnames <- names(coefs) } if (is.null(main)){main <- "Regression Estimates"} if (is.null(xlab)){xlab <- ""} if (is.null(ylab)){ylab <- ""} min.mar <- par('mar') par(mar=mar) maxchar <- max(sapply(varnames, nchar)) k <- 1/n.x if (CI==1){ CI50.h <- object$summary[,"75%"][var.idx] CI50.l <- object$summary[,"25%"][var.idx] CI50 <- cbind(CI50.l, CI50.h) if (vertical){ mar[2] <- min(min.mar[2], trunc(mar[2] + maxchar/10)) + 0.1 par(mar=mar) if(add){ segments (CI50[,1], idx+offset, CI50[,2], idx+offset, lwd=1, col=col.pts) points(coefs, idx+offset, pch=20, cex=cex.pts, col=col.pts) } else{ plot(c(CI50[,1],CI50[,2]), c(idx+k,idx-k), type="n", axes=F, main=main, xlab=xlab, ylab=ylab, ...) if(plot){ if (h.axis){ axis(3) } if (v.axis){ axis(2, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(v=0, lty=2) segments (CI50[,1], idx, CI50[,2], idx, lwd=1, col=col.pts) points(coefs, idx, pch=20, cex=cex.pts, col=col.pts) } } } else { mar[1] <- min(min.mar[1], trunc(mar[1] + maxchar/10)) + 0.1 par(mar=mar) if(add){ segments (idx+offset, CI50[,1], idx+offset, CI50[,2], lwd=1, col=col.pts) points(idx+offset, coefs, pch=20, cex=cex.pts, col=col.pts) } else{ plot(c(idx+k,idx-k), c(CI50[,1],CI50[,2]), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if(plot){ if (v.axis){ axis(2) } if (h.axis){ axis(1, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(h=0, lty=2) segments (idx, CI50[,1], idx, CI50[,2], lwd=1, col=col.pts) points(idx, coefs, pch=20, cex=cex.pts, col=col.pts) } } } } if (CI==2){ CI50.h <- object$summary[,"75%"][var.idx] CI50.l <- object$summary[,"25%"][var.idx] CI95.h <- object$summary[,"97.5%"][var.idx] CI95.l <- object$summary[,"2.5%"][var.idx] CI50 <- cbind(CI50.l, CI50.h) CI95 <- cbind(CI95.l, CI95.h) if (vertical){ mar[2] <- min(min.mar[2], trunc(mar[2] + maxchar/10)) + 0.1 par(mar=mar) if(add){ segments (CI50[,1], idx+offset, CI50[,2], idx+offset, lwd=2, col=col.pts) segments (CI95[,1], idx+offset, CI95[,2], idx+offset, lwd=1, col=col.pts) points(coefs, idx+offset, pch=20, cex=cex.pts, col=col.pts) } else{ plot(c(CI95[,1],CI95[,2]), c(idx+k,idx-k), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if(plot){ if (h.axis){ axis(3) } if (v.axis){ axis(2, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(v=0, lty=2) segments (CI50[,1], idx, CI50[,2], idx, lwd=2, col=col.pts) segments (CI95[,1], idx, CI95[,2], idx, lwd=1, col=col.pts) points(coefs, idx, pch=20, cex=cex.pts, col=col.pts) } } } else { mar[1] <- min(min.mar[1], trunc(mar[1] + maxchar/10)) + 0.1 par(mar=mar) if(add){ segments (idx+offset, CI50[,1], idx+offset, CI50[,2], lwd=2, col=col.pts) segments (idx+offset, CI95[,1], idx+offset, CI95[,2], lwd=1, col=col.pts) points(idx+offset, coefs, pch=20, cex=cex.pts, col=col.pts) } else{ plot(c(idx+k,idx-k), c(CI95[,1],CI95[,2]), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if(plot){ if (v.axis){ axis(2) } if (h.axis){ axis(1, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(h=0, lty=2) segments (idx, CI50[,1], idx, CI50[,2], lwd=2, col=col.pts) segments (idx, CI95[,1], idx, CI95[,2], lwd=1, col=col.pts) points(idx, coefs, pch=20, cex=cex.pts, col=col.pts) } } } } } ) setMethod("coefplot", signature(object = "polr"), function(object, varnames=NULL,...) { # collect informations coefs <- summary(object)$coef[,1] sds <- summary(object)$coef[,2] ifelse(is.null(varnames), varnames <- names(coefs), varnames <- varnames) # plotting coefplot(coefs, sds, varnames=varnames, ...) } ) arm/R/discrete.histogram.R0000644000176200001440000000616713014470370015164 0ustar liggesusersdiscrete.histogram <- function (x, prob, prob2 = NULL, prob3 = NULL, xlab = "x", xaxs.label = NULL, yaxs.label = NULL, bar.width = NULL, freq = FALSE, prob.col = "blue", prob2.col = "red", prob3.col = "gray", ...) { if (!missing(x) && missing(prob)) { prob <- table(x) x <- sort(unique(x)) } if (length(x) != length(prob)) { stop("Length of 'x' must be the same as the length of 'prob'") } if (!freq) { prob <- prob/sum(prob) prob2 <- prob2/sum(prob2) prob3 <- prob3/sum(prob3) ylab <- "Probability" } else { ylab <- "Count" } if (is.numeric(x)) { x.values <- sort(unique(x)) n.x.values <- length(x.values) if (is.null(bar.width)) { gaps <- x.values[2:n.x.values] - x.values[1:(n.x.values - 1)] bar.width <- min(gaps) * 0.2 } par(mar = c(3, 3, 4, 1), mgp = c(1.7, 0.5, 0), tck = -0.01) plot(range(x) + c(-2, 2) * bar.width, c(0, max(prob, prob2, prob3)), xlab = xlab, ylab = ylab, xaxs = "i", xaxt = "n", yaxs = "i", yaxt = ifelse(is.null(yaxs.label), "s", "n"), bty = "l", type = "n", ...) if (is.null(xaxs.label)) { axis(1, x.values) } else { axis(1, xaxs.label[[1]], xaxs.label[[2]]) } } else { x.values <- unique(x) n.x.values <- length(x.values) if (is.null(bar.width)) { bar.width <- 0.2 } par(mar = c(3, 3, 4, 1), mgp = c(1.7, 0.5, 0), tck = -0.01) plot(c(1, n.x.values) + c(-2, 2) * bar.width, c(0, max(prob, prob2, prob3)), xlab = xlab, ylab = ylab, xaxs = "i", xaxt = "n", yaxs = "i", yaxt = ifelse(is.null(yaxs.label), "s", "n"), bty = "l", type = "n", ...) if (is.null(xaxs.label)) { axis(1, 1:n.x.values, x.values) } else { axis(1, xaxs.label[[1]], xaxs.label[[2]]) } x <- 1:length(x) } if (!is.null(yaxs.label)) { axis(2, yaxs.label[[1]], yaxs.label[[2]]) } offset <- rep(0, 3) if (length(prob2) != 0 & length(prob3) != 0) { offset[1] <- -bar.width offset[2] <- 0 offset[3] <- bar.width } if (length(prob2) > 0 & length(prob3) == 0) { offset[1] <- -bar.width/2 offset[2] <- bar.width/2 offset[3] <- 0 } for (i in 1:length(x)) { polygon(x[i] + c(-1, -1, 1, 1) * bar.width/2 + offset[1], c(0, prob[i], prob[i], 0), border = prob.col, col = prob.col) if (!is.null(prob2)) { polygon(x[i] + c(-1, -1, 1, 1) * bar.width/2 + offset[2], c(0, prob2[i], prob2[i], 0), border = prob2.col, col = prob2.col) } if (!is.null(prob3)) { polygon(x[i] + c(-1, -1, 1, 1) * bar.width/2 + offset[3], c(0, prob3[i], prob3[i], 0), border = prob3.col, col = prob3.col) } } } discrete.hist <- discrete.histogram arm/R/matching.R0000644000176200001440000001104413707226233013154 0ustar liggesusers## 2019 version of matching function matching <- function(z, score, replace=FALSE){ # argument z is the vector of indicators for treatment or control # # argument score is the vector of the propensity scores in the # # same order as z # # THIS FUNCTION REQUIRES THE INFERENTIAL GROUP TO SATISFY Z=1 # # Group satisfying Z=1 will remain intact and matches for them will # # be found from among those satisfying Z=0 # # # # the function (potentially) returns several things # # 1) match.ind: a vector of indices that the corresponding unit is # # matched to. The length is equal to the number of unique IDs # # 2) cnts: shows the number of times each unit will be used in any # # subsequent analyses (1 for each treated unit and number of # # times used as a match for each control unit (equivalently the # # number of treated units it is matched to) # # # # 3a) pairs: indicator for each pair [only available for # # replace=TRUE] # OR # 3b) matches: a matrix capturing which treated observations # were matched to which controls [only for replace=FALSE] # # # Ties are broken through random sampling so set seed if you want # # to replicate results # ##################################################################### n <- length(score) nt <- sum(z) nc <- sum(1-z) ind.t <- c(1:n)[z==1] ind.c <- c(1:n)[z==0] cnts <- rep(0, n) cnts[z==1] = rep(1,nt) scorec <- score[z == 0] scoret <- score[z == 1] # matching with replacement if (replace){ # calculate distances between all pairs of units dist = abs(outer(scoret,scorec,FUN="-")) # find the identify the controls with the minimum distance from # each treated -- if there are ties, randomly pick one mins = apply(dist,1,min) # create a matrix with 1's for control columns matching the minimum # distance for the corresponding treatment rows matches = dist - mins matches[matches!=0] = 1 matches = 1 - matches # if more than one control observation is chosen as a match for a given # treated we randomly chose which column to retain if(sum(matches)>nt){ # figure out which rows and then replace the multiple 1's with one # randomly chosen one for(i in c(1:nt)[apply(matches,1,sum)>1]){ matches_i <- c(1:nc)[matches[i,]==1] nmi <- length(matches_i) matches[i,matches_i] <- sample(c(1,rep(0,nmi-1)),nmi,replace=FALSE) } } # now fill in matched and ind.mt and pairs and counts ind.cm <- matches %*% ind.c # now record counts cnts[z==0] <- apply(matches,2,sum) # match indicators -- shouldn't be used for analysis match.ind <- c(ind.t, ind.cm) out <- list(match.ind = match.ind, cnts = cnts, matches = matches) } # matching *without* replacement if (!replace){ pairs = rep(NA,n) match.ind <- rep(0, n) tally <- 0 for (i in ind.t) { ## DEAL WITH TIES IN A MORE PRINCIPLED WAY? -- can do by adding a second # argument to break ties that is random available <- (1:n)[(z == 0) & (match.ind == 0)] j <- available[order(abs(score[available] - score[i]))[1]] cnts[j] <- 1 match.ind[i] <- j match.ind[j] <- i tally <- tally + 1 pairs[c(i, j)] <- tally } #match.ind <- match.ind[match.ind!=0] out <- list(match.ind = match.ind, cnts = cnts, pairs = pairs) } return(out) } #pscores.fun <- function(treat=Z, outs=Y, covs=X){ # # # N <- nrow(covs) # nouts <- 1 # ncovs <- ncol(covs) # # # # first set up places to store results # res <- matrix(0,nouts,2) # bal <- matrix(0,ncovs,2) # # # # estimate p-scores # dat <- cbind.data.frame(treat=treat,covs) # mod <- glm(dat,family=binomial(link="logit")) # qx <- predict(mod, type="response")#mod$linear # # # ### Now Matching With Replacement # matchout <- matching(z=treat, score=qx, replace=TRUE) # # # ### and treatment effect estimation with robust s.e.'s # wts <- rep(1, N) # wts[treat == 0] <- matchout$cnts # res <- .wls.all2(cbind(rep(1, sum(wts > 0)), treat[wts > 0],covs[wts > 0, ]), wts[wts > 0], outs[wts > 0], treat[wts > 0]) # c(res[3],sqrt(res[2])) #} arm/R/bayespolr.R0000644000176200001440000002533213014470370013361 0ustar liggesusers# New bayespolr() using Kenny's Dirichlet prior distribution bayespolr <- function (formula, data, weights, start, ..., subset, na.action, contrasts = NULL, Hess = TRUE, model = TRUE, method = c("logistic", "probit", "cloglog", "cauchit"), drop.unused.levels = TRUE, prior.mean = 0, prior.scale = 2.5, prior.df = 1, prior.counts.for.bins = NULL, min.prior.scale = 1e-12, scaled = TRUE, maxit = 100, print.unnormalized.log.posterior = FALSE) { logit <- function(p) log(p/(1 - p)) dt.deriv <- function(x, mean, scale, df, log = TRUE, delta = 0.001) { (dt((x + delta - mean)/scale, df, log = log) - dt((x - delta - mean)/scale, df, log = log))/(2 * delta) } fmin <- function(beta) { theta <- beta[pc + 1:q] gamm <- c(-100, cumsum(c(theta[1], exp(theta[-1]))), 100) eta <- offset if (pc > 0) eta <- eta + drop(x %*% beta[1:pc]) pr <- pfun(gamm[y + 1] - eta) - pfun(gamm[y] - eta) if (all(pr > 0)) f <- -sum(wt * log(pr)) else f <- Inf if (pc > 0) f <- f - sum(dt((beta[1:pc] - prior.mean)/prior.scale, prior.df, log = TRUE)) return(f) } gmin <- function(beta) { jacobian <- function(theta) { k <- length(theta) etheta <- exp(theta) mat <- matrix(0, k, k) mat[, 1] <- rep(1, k) for (i in 2:k) mat[i:k, i] <- etheta[i] mat } theta <- beta[pc + 1:q] gamm <- c(-100, cumsum(c(theta[1], exp(theta[-1]))), 100) eta <- offset if (pc > 0) eta <- eta + drop(x %*% beta[1:pc]) pr <- pfun(gamm[y + 1] - eta) - pfun(gamm[y] - eta) p1 <- dfun(gamm[y + 1] - eta) p2 <- dfun(gamm[y] - eta) g1 <- if (pc > 0) t(x) %*% (wt * (p1 - p2)/pr) else numeric(0) xx <- .polrY1 * p1 - .polrY2 * p2 g2 <- -t(xx) %*% (wt/pr) g2 <- t(g2) %*% jacobian(theta) if (pc > 0) g1 <- g1 - dt.deriv(beta[1:pc], prior.mean, prior.scale, prior.df, log = TRUE) if (all(pr > 0)) c(g1, g2) else rep(NA, pc + q) } m <- match.call(expand.dots = FALSE) mf <- match(c("formula", "data", "subset", "weights", "na.action", "etastart", "mustart", "offset"), names(m), 0) m <- m[c(1, mf)] m$drop.unused.levels <- drop.unused.levels method <- match.arg(method) ##### adjust prior.scale for probit #### if (method == "probit"){ prior.scale <- prior.scale*1.6 } ################ for(jj in 1:length(prior.scale)){ if (prior.scale[jj] < min.prior.scale){ prior.scale[jj] <- min.prior.scale warning ("prior scale for variable ", jj, " set to min.prior.scale = ", min.prior.scale,"\n") } } pfun <- switch(method, logistic = plogis, probit = pnorm, cloglog = pgumbel, cauchit = pcauchy) dfun <- switch(method, logistic = dlogis, probit = dnorm, cloglog = dgumbel, cauchit = dcauchy) if (is.matrix(eval.parent(m$data))) m$data <- as.data.frame(data) m$start <- m$Hess <- m$method <- m$... <- NULL m[[1]] <- as.name("model.frame") m <- eval.parent(m) Terms <- attr(m, "terms") x <- model.matrix(Terms, m, contrasts) xint <- match("(Intercept)", colnames(x), nomatch = 0) n <- nrow(x) pc <- ncol(x) cons <- attr(x, "contrasts") if (xint > 0) { x <- x[, -xint, drop = FALSE] pc <- pc - 1 } else warning("an intercept is needed and assumed") wt <- model.weights(m) if (!length(wt)) wt <- rep(1, n) offset <- model.offset(m) if (length(offset) <= 1) offset <- rep(0, n) y <- model.response(m) if (!is.factor(y)) stop("response must be a factor") lev <- levels(y) if (length(lev) <= 2) stop("response must have 3 or more levels") y <- unclass(y) q <- length(lev) - 1 Y <- matrix(0, n, q) .polrY1 <- col(Y) == y .polrY2 <- col(Y) == y - 1 if (missing(start)) { q1 <- length(lev)%/%2 y1 <- (y > q1) X <- cbind(Intercept = rep(1, n), x) fit <- switch(method, logistic = bayesglm.fit(X, y1, wt, family = binomial(), offset = offset, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, min.prior.scale = min.prior.scale, scaled = scaled, control = glm.control(maxit=maxit), print.unnormalized.log.posterior = print.unnormalized.log.posterior), probit = bayesglm.fit(X, y1, wt, family = binomial("probit"), offset = offset, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, min.prior.scale = min.prior.scale, scaled = scaled, control = glm.control(maxit=maxit), print.unnormalized.log.posterior = print.unnormalized.log.posterior), cloglog = bayesglm.fit(X, y1, wt, family = binomial("probit"), offset = offset, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, min.prior.scale = min.prior.scale, scaled = scaled, control = glm.control(maxit=maxit), print.unnormalized.log.posterior = print.unnormalized.log.posterior), cauchit = bayesglm.fit(X, y1, wt, family = binomial("cauchit"), offset = offset, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, min.prior.scale = min.prior.scale, scaled = scaled, control = glm.control(maxit=maxit), print.unnormalized.log.posterior = print.unnormalized.log.posterior)) if (!fit$converged) warning("attempt to find suitable starting values failed") coefs <- fit$coefficients if (any(is.na(coefs))) { warning("design appears to be rank-deficient, so dropping some coefs") keep <- names(coefs)[!is.na(coefs)] coefs <- coefs[keep] x <- x[, keep[-1], drop = FALSE] pc <- ncol(x) } spacing <- logit((1:q)/(q + 1)) if (method != "logistic") spacing <- spacing/1.7 gammas <- -coefs[1] + spacing - spacing[q1] thetas <- c(gammas[1], log(diff(gammas))) start <- c(coefs[-1], thetas) } # rep start to have the same length of coef + zeta else if (length(start)==1){ start <- rep(start, (pc+q)) } else if (length(start) != pc + q) stop("'start' is not of the correct length") J <- NCOL(x) # SU: if no x's, no priors for coefs 2008.2.9 if (xint>1) { if (length(prior.mean) == 1) prior.mean <- rep(prior.mean, J) if (length(prior.scale) == 1) { prior.scale <- rep(prior.scale, J) if (scaled == TRUE) { for (j in 1:J) { x.obs <- x[, j] x.obs <- x.obs[!is.na(x.obs)] num.categories <- length(unique(x.obs)) if (num.categories == 2) { prior.scale[j] <- prior.scale[j]/(max(x.obs) - min(x.obs)) } else if (num.categories > 2) { prior.scale[j] <- prior.scale[j]/(2 * sd(x.obs)) } } } } if (length(prior.df) == 1) { prior.df <- rep(prior.df, J) } } # prior for intercept sum(priors.intercpet)=1 if (is.null(prior.counts.for.bins)) { prior.counts.for.bins <- 1/(q+1) } if (length(prior.counts.for.bins) == 1) { prior.counts.for.bins <- rep(prior.counts.for.bins, q+1) } # Augment the data to add prior information y.0 <- y Y.0 <- Y x.0 <- x wt.0 <- wt offset.0 <- offset .polrY1.0 <- .polrY1 .polrY2.0 <- .polrY2 y <- c (y.0, 1:(q+1)) Y <- matrix(0, n+q+1, q) .polrY1 <- col(Y) == y .polrY2 <- col(Y) == y - 1 x <- rbind (x.0, matrix (colMeans(x.0), nrow=(q+1), ncol=J, byrow=TRUE)) wt <- c (wt.0, prior.counts.for.bins) offset <- c (offset, rep(0,q+1)) # Fit the model as before res <- optim(start, fmin, gmin, method = "BFGS", hessian = Hess, ...) # Restore the old variables y <- y.0 Y <- Y.0 x <- x.0 wt <- wt.0 offset <- offset.0 .polrY1 <- .polrY1.0 .polrY2 <- .polrY2.0 # Continue on as before beta <- res$par[seq_len(pc)] theta <- res$par[pc + 1:q] zeta <- cumsum(c(theta[1], exp(theta[-1]))) deviance <- 2 * res$value niter <- c(f.evals = res$counts[1], g.evals = res$counts[2]) names(zeta) <- paste(lev[-length(lev)], lev[-1], sep = "|") if (pc > 0) { names(beta) <- colnames(x) eta <- drop(x %*% beta) } else { eta <- rep(0, n) } cumpr <- matrix(pfun(matrix(zeta, n, q, byrow = TRUE) - eta), , q) fitted <- t(apply(cumpr, 1, function(x) diff(c(0, x, 1)))) dimnames(fitted) <- list(row.names(m), lev) fit <- list(coefficients = beta, zeta = zeta, deviance = deviance, fitted.values = fitted, lev = lev, terms = Terms, df.residual = sum(wt) - pc - q, edf = pc + q, n = sum(wt), nobs = sum(wt), call = match.call(), method = method, convergence = res$convergence, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.counts.for.bins = prior.counts.for.bins, niter = niter) if (Hess) { dn <- c(names(beta), names(zeta)) H <- res$hessian dimnames(H) <- list(dn, dn) fit$Hessian <- H } if (model){ fit$model <- m } fit$na.action <- attr(m, "na.action") fit$contrasts <- cons fit$xlevels <- .getXlevels(Terms, m) class(fit) <- c("bayespolr", "polr") fit } setMethod("print", signature(x = "bayespolr"), function(x, digits= 2) display(object=x, digits=digits)) setMethod("show", signature(object = "bayespolr"), function(object) display(object, digits=2)) arm/R/fround.R0000644000176200001440000000025613014470370012654 0ustar liggesusersfround <- function (x, digits) { format (round (x, digits), nsmall=digits) } pfround <- function (x, digits) { print (fround (x, digits), quote=FALSE) } arm/R/simmer.R0000644000176200001440000001142414301540413012646 0ustar liggesusers# simulations of sigma, fixef, and ranef drawn from a posterior # under a flat prior and conditioned on estimate of ranef covar setMethod("sim", signature(object = "merMod"), function(object, n.sims=100) { applyLeftFactor <- function(decomp, rhs) { c(as.vector(decomp$ul %*% rhs[ranefRange] + decomp$ur %*% rhs[fixefRange]), as.vector(decomp$lr %*% rhs[fixefRange])); } # information is conditional on hyperparameters # information is of [ranef, fixef] getInverseInformationLeftFactor <- function(regression) { Lz <- getME(regression, "L"); Rzx <- getME(regression, "RZX"); Rx <- getME(regression, "RX"); # upper left, lower right, and lower left blocks of left-factor of inverse #solveFunc <- getMethod("solve", signature(a = "CHMfactor", b = "diagonalMatrix")); #Rz.inv <- t(solveFunc(Lz, Diagonal(Lz@Dim[1]), "L")); Rz.inv <- t(solve(Lz, Diagonal(Lz@Dim[1]), system = "L")); Rx.inv <- solve(Rx); Rzx.inv <- -Rz.inv %*% Rzx %*% Rx.inv; # this is me figuring some stuff out. new lmer doesn't permute Zt apparently # #Lz.tmp <- as(Lz, "sparseMatrix"); #P.chol <- as(Lz@perm + 1, "pMatrix"); #Zt <- getME(regression, "Zt"); #W <- Diagonal(numObs, regression@resp$sqrtXwt); ## P.ranef <- getRanefPerm(regression); #Lambdat <- getME(regression, "Lambdat") # t(P.ranef) %*% getME(regression, "Lambdat") %*% P.ranef; #A <- Lambdat %*% Zt; #C <- A %*% W; #L.hyp <- Cholesky(tcrossprod(P.chol %*% C), Imult = 1, LDL = FALSE, perm = FALSE); #L.hyp@perm <- Lz@perm; #L.hyp@type[1] <- 2L; #browser(); #P.ranef <- getRanefPerm(model); #Lambda <- P.ranef %*% getRanefChol(model) %*% t(P.ranef); Lambda <- t(getME(regression, "Lambda")); return(list(ul = Lambda %*% Rz.inv, ur = Lambda %*% Rzx.inv, lr = Rx.inv)); } # assumes p(sigma^2) propto sigma^-2 sampleCommonScale <- function(ignored) { return(sqrt(1 / rgamma(1, 0.5 * numDoF, 0.5 * devcomp$cmp[["pwrss"]]))); } regression <- object; devcomp <- getME(regression, "devcomp"); dims <- devcomp$dims; if (dims[["NLMM"]] != 0L) stop("sim not yet implemented for nlmms"); numObs <- dims[["n"]]; numRanef <- dims[["q"]]; numFixef <- dims[["p"]]; numLevels <- dims[["reTrms"]]; isLinearMixedModel <- dims[["GLMM"]] == 0L && dims[["NLMM"]] == 0L; numEffects <- numRanef + numFixef; numDoF <- numObs - numFixef; # pertain to simulations that we do all as a single vector ranefRange <- 1:numRanef; fixefRange <- numRanef + 1:numFixef; # stuff used to rearrange ranef into usable form groupsPerUniqueFactor <- lapply(regression@flist, levels); factorPerLevel <- attr(regression@flist, "assign"); coefficientNamesPerLevel <- regression@cnms; numCoefficientsPerLevel <- as.numeric(sapply(coefficientNamesPerLevel, length)); numGroupsPerLevel <- as.numeric(sapply(groupsPerUniqueFactor[factorPerLevel], length)); numRanefsPerLevel <- numCoefficientsPerLevel * numGroupsPerLevel; ranefLevelMap <- rep.int(seq_along(numRanefsPerLevel), numRanefsPerLevel); # storage for sims simulatedSD <- if (isLinearMixedModel) { rep(NA, n.sims); } else { NA }; simulatedRanef <- vector("list", numLevels); names(simulatedRanef) <- names(regression@cnms); for (i in 1:numLevels) { simulatedRanef[[i]] <- array(NA, c(n.sims, numGroupsPerLevel[i], numCoefficientsPerLevel[i]), list(NULL, groupsPerUniqueFactor[[factorPerLevel[i]]], coefficientNamesPerLevel[[i]])); } simulatedFixef <- matrix(NA, n.sims, numFixef, dimnames = list(NULL, names(fixef(regression)))); # "b" are the rotated random effects, i.e. what ranef() returns in # a rearranged format. effectsMean <- c(getME(regression, "b")@x, getME(regression, "beta")); effectsCovLeftFactor <- getInverseInformationLeftFactor(regression); for (i in 1:n.sims) { if (isLinearMixedModel) { simulatedSD[i] <- sampleCommonScale(regression); sphericalEffects <- rnorm(numEffects, 0, simulatedSD[i]); } else { sphericalEffects <- rnorm(numEffects); } simulatedEffects <- applyLeftFactor(effectsCovLeftFactor, sphericalEffects) + effectsMean; simulatedFixef[i,] <- simulatedEffects[fixefRange]; rawRanef <- simulatedEffects[ranefRange]; simulatedRanefPerLevel <- split(rawRanef, ranefLevelMap); for (k in 1:numLevels) { simulatedRanef[[k]][i,,] <- matrix(simulatedRanefPerLevel[[k]], ncol = numCoefficientsPerLevel[k], byrow = TRUE); } } ans <- new("sim.merMod", "fixef" = simulatedFixef, "ranef" = simulatedRanef, "sigma" = simulatedSD); return(ans); }); arm/R/multicomp.plot.R0000644000176200001440000000676413014470370014357 0ustar liggesusers#============================================================================== # Multiple Comparison Plot #============================================================================== multicomp.plot <- function(object, alpha=0.05, main = "Multiple Comparison Plot", label = NULL, shortlabel = NULL, show.pvalue = FALSE, label.as.shortlabel = FALSE, label.on.which.axis = 3, col.low = "lightsteelblue", col.same = "white", col.high = "lightslateblue", vertical.line = TRUE, horizontal.line = FALSE, vertical.line.lty = 1, horizontal.line.lty = 1, mar=c(3.5,3.5,3.5,3.5)) { # object check: S4 methods instead?! if (!is.data.frame(object)){ if(is.matrix(object)){ object <- as.data.frame(object) } else stop ( message = "object must be a matrix or a data.frame" ) } ind <- dim( object ) [2] name <- dimnames( object ) [[2]] # label if( is.null( label ) ) { label <- name } else if( length( label ) != ind ) { stop( message = "you must specify all the label" ) } # short label if( !is.null( shortlabel ) && length( shortlabel ) != ind ){ stop( message = "you must specify all the short label" ) } else if( is.null( shortlabel ) && label.as.shortlabel ){ shortlabel <- abbreviate( label, minlength = 2) } ################################ # Calculate bayesian p-value ################################ bayes.pvalue <- matrix( 0, ind, ind ) bayes.signif <- matrix( 0, ind, ind ) for( i in 1:ind ) { for( j in 1:ind ) { bayes.pvalue[i, j] <- .pvalue( object[ , j], object[ , i] ) } } for( i in 1:ind ) { for( j in 1:ind ) { bayes.signif[i, j] <- .is.significant( bayes.pvalue[i, j], alpha = alpha ) } } dimnames( bayes.pvalue ) <- list( label, label ) diag( bayes.signif ) <- 0 dimnames( bayes.signif ) <- list( label, label ) bayes.signif <- bayes.signif [ , ind:1] bayes.pvalue <- bayes.pvalue [ , ind:1] ################################ # Plot ################################ maxchar <- max(sapply(label, nchar)) mar.idx <- label.on.which.axis par(mar=mar) min.mar <- par('mar') if(mar.idx==3){ mar[mar.idx] <- min(min.mar[mar.idx], trunc(mar[mar.idx] + maxchar/3)) + mar[mar.idx] + 0.1 } else { mar[mar.idx] <- min(min.mar[mar.idx], trunc(mar[mar.idx] + maxchar/2)) + 0.1 } par(mar=mar) image( 1:nrow( bayes.signif ), 1:ncol( bayes.signif ), bayes.signif, ylab = "", xlab = "", yaxt = "n", xaxt = "n", col = c( col.low, col.same, col.high ) ) box( "plot" ) axis(2, at = 0, labels = "", las = 1, line = 0, tick = FALSE, xaxs = "i", yaxs = "i" ) axis(mar.idx, at = 1:nrow( bayes.signif ),line = -0.8, las = 2 , cex = 0.3, labels = label, tick = FALSE, xaxs = "i") title( main = main, line = mar[3] - 3 ) for( a in 1:ind ) { if( vertical.line ) { lines( c( a + 0.5, a + 0.5 ), c( 0, ind + 1 ), lty = vertical.line.lty ) } if( horizontal.line ) { lines( c( 0, ind + 1 ), c( a + 0.5, a + 0.5 ), lty = horizontal.line.lty ) } if( !is.null( shortlabel ) ) { for( b in 1:ind ) { if( show.pvalue ){ text( a, b, ( round( bayes.pvalue, 2 ) )[a,b], cex = 0.5 ) } else { text( a, b, shortlabel[ind+1-b], cex = 0.7 ) } } } } invisible( list( pvalue = bayes.pvalue, significant = bayes.signif ) ) } mcplot <- multicomp.plot arm/R/model.matrixBayes.R0000644000176200001440000001470713014470370014754 0ustar liggesusers#setMethod("model.matrix.bayes", signature(object = "bayesglm"), model.matrixBayes <- function(object, data = environment(object), contrasts.arg = NULL, xlev = NULL, keep.order=FALSE, drop.baseline=FALSE,...) { #class(object) <- c("terms", "formula") t <- if( missing( data ) ) { terms( object ) }else{ terms.formula(object, data = data, keep.order=keep.order) } attr(t, "intercept") <- attr(object, "intercept") if (is.null(attr(data, "terms"))){ data <- model.frame(object, data, xlev=xlev) }else { reorder <- match(sapply(attr(t,"variables"), deparse, width.cutoff=500)[-1], names(data)) if (anyNA(reorder)) { stop( "model frame and formula mismatch in model.matrix()" ) } if(!identical(reorder, seq_len(ncol(data)))) { data <- data[,reorder, drop = FALSE] } } int <- attr(t, "response") if(length(data)) { # otherwise no rhs terms, so skip all this if (drop.baseline){ contr.funs <- as.character(getOption("contrasts")) }else{ contr.funs <- as.character(list("contr.bayes.unordered", "contr.bayes.ordered")) } namD <- names(data) ## turn any character columns into factors for(i in namD) if(is.character( data[[i]] ) ) { data[[i]] <- factor(data[[i]]) warning( gettextf( "variable '%s' converted to a factor", i ), domain = NA) } isF <- vapply(data, function(x) is.factor(x) || is.logical(x), NA) isF[int] <- FALSE isOF <- vapply(data, is.ordered, NA) for( nn in namD[isF] ) # drop response if( is.null( attr( data[[nn]], "contrasts" ) ) ) { contrasts( data[[nn]] ) <- contr.funs[1 + isOF[nn]] } ## it might be safer to have numerical contrasts: ## get(contr.funs[1 + isOF[nn]])(nlevels(data[[nn]])) if ( !is.null( contrasts.arg ) && is.list( contrasts.arg ) ) { if ( is.null( namC <- names( contrasts.arg ) ) ) { stop( "invalid 'contrasts.arg' argument" ) } for (nn in namC) { if ( is.na( ni <- match( nn, namD ) ) ) { warning( gettextf( "variable '%s' is absent, its contrast will be ignored", nn ), domain = NA ) } else { ca <- contrasts.arg[[nn]] if( is.matrix( ca ) ) { contrasts( data[[ni]], ncol( ca ) ) <- ca } else { contrasts( data[[ni]] ) <- contrasts.arg[[nn]] } } } } } else { # internal model.matrix needs some variable isF <- FALSE data <- data.frame(x=rep(0, nrow(data))) } #ans <- .Internal( model.matrix( t, data ) ) ans <- model.matrix.default(object=t, data=data) cons <- if(any(isF)){ lapply( data[isF], function(x) attr( x, "contrasts") ) }else { NULL } attr(ans, "contrasts" ) <- cons ans } #) #setMethod("model.matrix.bayes", signature(object = "bayesglm.h"), #model.matrix.bayes.h <- function (object, data = environment(object), # contrasts.arg = NULL, # xlev = NULL, keep.order = FALSE, batch = NULL, ...) #{ # class(object) <- c("formula") # t <- if (missing(data)) { # terms(object) # } # else { # terms(object, data = data, keep.order = keep.order) # } # attr(t, "intercept") <- attr(object, "intercept") # if (is.null(attr(data, "terms"))) { # data <- model.frame(object, data, xlev = xlev) # } # else { # reorder <- match(sapply(attr(t, "variables"), deparse, # width.cutoff = 500)[-1], names(data)) # if (any(is.na(reorder))) { # stop("model frame and formula mismatch in model.matrix()") # } # if (!identical(reorder, seq_len(ncol(data)))) { # data <- data[, reorder, drop = FALSE] # } # } # int <- attr(t, "response") # if (length(data)) { # contr.funs <- as.character(getOption("contrasts")) # contr.bayes.funs <- as.character(list("contr.bayes.unordered", # "contr.bayes.ordered")) # namD <- names(data) # for (i in namD) if (is.character(data[[i]])) { # data[[i]] <- factor(data[[i]]) # warning(gettextf("variable '%s' converted to a factor", i), domain = NA) # } # isF <- sapply(data, function(x) is.factor(x) || is.logical(x)) # isF[int] <- FALSE # isOF <- sapply(data, is.ordered) # if (length(batch) > 1) { # ba <- batch[isF[-1]] # } # else if (length(batch) == 1) { # ba <- rep(batch, length(isF[-1])) # } # else { # ba <- rep(0, length(isF[-1])) # } # iin <- 1 # for (nn in namD[isF]) if (is.null(attr(data[[nn]], "contrasts"))) { # if (ba[[iin]] > 0) { # contrasts(data[[nn]]) <- contr.bayes.funs # } # else { # contrasts(data[[nn]]) <- contr.funs # } # iin <- iin + 1 # } # if (!is.null(contrasts.arg) && is.list(contrasts.arg)) { # if (is.null(namC <- names(contrasts.arg))) { # stop("invalid 'contrasts.arg' argument") # } # for (nn in namC) { # if (is.na(ni <- match(nn, namD))) { # warning(gettextf("variable '%s' is absent, its contrast will be ignored", # nn), domain = NA) # } # else { # ca <- contrasts.arg[[nn]] # if (is.matrix(ca)) { # contrasts(data[[ni]], ncol(ca)) <- ca # } # else { # contrasts(data[[ni]]) <- contrasts.arg[[nn]] # } # } # } # } # } # else { # isF <- FALSE # data <- list(x = rep(0, nrow(data))) # } # ans <- .Internal(model.matrix(t, data)) # cons <- if (any(isF)) { # lapply(data[isF], function(x) attr(x, "contrasts")) # } # else { # NULL # } # attr(ans, "contrasts") <- cons # ans #} ##) arm/R/mcsamp.R0000644000176200001440000001253113014470370012636 0ustar liggesusers# mcsamp function (wrapper for mcmcsamp in lmer()) # Quick function to run mcmcsamp() [the function for MCMC sampling for # lmer objects) and convert to Bugs objects for easy display mcsamp.default <- function (object, n.chains=3, n.iter=1000, n.burnin=floor(n.iter/2), n.thin=max(1, floor(n.chains * (n.iter - n.burnin)/1000)), saveb=TRUE, deviance=TRUE, make.bugs.object=TRUE) { cat("mcsamp() used to be a wrapper for mcmcsamp() in lme4.\nCurrently, mcmcsamp() is no longer available in lme4.\nSo in the meantime, we suggest that users use sim() to get\nsimulated estimates.\n") } #mcsamp.default <- function (object, n.chains=3, n.iter=1000, n.burnin=floor(n.iter/2), # n.thin=max(1, floor(n.chains * (n.iter - n.burnin)/1000)), # saveb=TRUE, deviance=TRUE, make.bugs.object=TRUE) #{ # # if (n.chains<2) stop ("n.chains must be at least 2") # n.keep <- n.iter - n.burnin # first.chain <- mcmcsamp (object, n.iter, saveb=saveb, trans=TRUE, deviance=deviance)[(n.burnin+1):n.iter,] # n.parameters <- ncol(first.chain) # # if (deviance) { # sims <- array (NA, c(n.keep, n.chains, n.parameters+1)) # } # if (!deviance){ # sims <- array (NA, c(n.keep, n.chains, n.parameters)) # } # # pred.names <- attr(terms(object), "term.labels") # par.names <- dimnames(first.chain)[[2]] # par.names <- gsub("b.", "b@", par.names, ignore.case = FALSE, # Su: rename "b.*" to "" # extended = TRUE, perl = FALSE, # fixed = TRUE, useBytes = FALSE) # par.names <- gsub("b@.*", "", par.names, ignore.case = FALSE, # extended = TRUE, perl = FALSE, # fixed = FALSE) # par.names <- par.names[is.na(match(par.names,""))] # name.chk.idx <- as.logical(match(par.names, pred.names, nomatch=0)) # par.names[name.chk.idx] <- paste("beta", par.names[name.chk.idx], sep=".") # # if (saveb){ # b.hat <- se.coef (object) # Su: use se.coef() # n.groupings <- length(b.hat) - 1 # J <- NA # K <- NA # for (m in 1:n.groupings){ # J[m] <- dim(b.hat[[m+1]])[1] # K[m] <- dim(b.hat[[m+1]])[2] # var.names <- paste (abbreviate(names(b.hat)[m+1],4), ".", # unlist (dimnames(b.hat[[m+1]])[2]), sep="") ##sep="." # par.names <- c (par.names, # paste (rep(var.names,J[m]), "[", rep(1:J[m],each=K[m]), "]", sep="")) # } # } # sims[,1,1:n.parameters] <- first.chain # # for (k in 2:n.chains){ # sims[,k,1:n.parameters] <- mcmcsamp (object, n.iter, saveb=saveb, trans=TRUE, deviance=deviance)[(n.burnin+1):n.iter,] # } # # select <- c(rep(FALSE, n.thin-1),TRUE) # sims <- sims[select,,] # # for (j in 1:n.parameters){ # if (pmatch("log(sigma^2)", par.names[j], nomatch=0)){#=="log(sigma^2)"){ # par.names[j] <- "sigma.y" # sims[,,j] <- exp (sims[,,j]/2) # } # else if (pmatch("log(", par.names[j], nomatch=0)){#(substr(par.names[j],1,4)=="log("){ # par.names[j] <- paste ("sigma.", substr(par.names[j], 5, nchar(par.names[j])-1), sep="") # sims[,,j] <- exp (sims[,,j]/2) # } # else if (pmatch("atanh(", par.names[j], nomatch=0)){#(substr(par.names[j],1,6)=="atanh("){ # par.names[j] <- paste ("rho.", substr(par.names[j], 7, nchar(par.names[j])-1), sep="") # sims[,,j] <- tanh (sims[,,j]) # } # #else if (substr(par.names[j],1,4)=="eta."){#(pmatch("eta.", par.names[j], nomatch=0)){#(substr(par.names[j],1,4)=="eta."){ # # par.names[j] <- paste ("", substr(par.names[j], 5, nchar(par.names[j])), sep="") # # par.names[j] <- par.names[j] # #} # else if (pmatch("deviance", par.names[j], nomatch=0)){#(par.names[j]=="deviance"){ # Su: keep par.names for "deviance" # sims[,,n.parameters+1] <- sims[,,j] # sims <- sims[,,-j] # Su: delete deviance value from sims # } ## else { ## } # } # par.names <- gsub("(", "", par.names, ignore.case = FALSE, # extended = TRUE, perl = FALSE, # fixed = TRUE, useBytes = FALSE) # par.names <- gsub(")", "", par.names, ignore.case = FALSE, # extended = TRUE, perl = FALSE, # fixed = TRUE, useBytes = FALSE) # # par.names <- gsub(".Intercept", ".Int", par.names, ignore.case = FALSE, ## extended = TRUE, perl = FALSE, ## fixed = TRUE, useBytes = FALSE) # par.names <- gsub("rescale", "z.", par.names, ignore.case = FALSE, # extended = TRUE, perl = FALSE, # fixed = TRUE, useBytes = FALSE) # # par.names <- par.names[is.na(match(par.names,"deviance"))] # Su: delete par.names for "deviance" # # if (deviance){ # dimnames(sims) <- list (NULL, NULL, c(par.names,"deviance")) # } # if (!deviance){ # dimnames(sims) <- list (NULL, NULL, par.names) # } # if (make.bugs.object){ # return (as.bugs.array (sims, program="lmer", n.iter=n.iter, n.burnin=n.burnin, n.thin=n.thin, DIC=deviance)) # } # else { # return (sims) # } #} # # # setMethod("mcsamp", signature(object = "merMod"), function (object, ...) { mcsamp.default(object, deviance=TRUE, ...) } ) # #setMethod("mcsamp", signature(object = "glmer"), # function (object, ...) #{ # mcsamp.default(object, deviance=FALSE, ...) #} #) arm/R/extractDIC.R0000644000176200001440000000174213014470370013352 0ustar liggesusers extractDIC <- function(fit,...){ UseMethod("extractDIC") } extractDIC.merMod <- function(fit,...){ #REML <- fit@dims["REML"] # llik <- logLik(fit, REML) # dev <- fit@deviance["ML"] # n <- fit@dims["n"] # Dhat <- -2 * (llik) # pD <- dev - Dhat # DIC <- dev + pD[[1]] # names(DIC) <- "DIC" # return(DIC) is_REML <- isREML(fit) llik <- logLik(fit, REML=is_REML) dev <- deviance(refitML(fit)) n <- getME(fit, "devcomp")$dims["n"] Dhat <- -2 * (llik) pD <- dev - Dhat DIC <- dev + pD[[1]] names(DIC) <- "DIC" return(DIC) } # #extractAIC.mer <- function(fit,...){ ## REML <- fit@dims["REML"] ## llik <- logLik(fit, REML) ## AIC <- AIC(llik) ## names(AIC) <- "AIC" ## return(AIC) # L <- logLik(refitML(fit)) # edf <- attr(L,"df") # out <- c(edf,-2*L + k*edf) # return(out) #} arm/R/corrplot.R0000644000176200001440000000212613014470370013221 0ustar liggesusers corrplot <- function(data, varnames=NULL, cutpts=NULL, abs=TRUE, details=TRUE, n.col.legend=5, cex.col=0.7, cex.var=0.9, digits=1, color=FALSE) { # some check! if (is.matrix(data)|is.data.frame(data)){ } else { stop ("Data must be a matrix or a data frame!") } if (sum(sapply(data, FUN=is.character))>0) stop ("Data contains non-numeric variables!") if (n.col.legend > 8) stop ("Suggestion: More than 8 levels of colors is difficult to read!") # prepare correlation matrix if (abs){ z.plot <- abs(cor(data, data, use="pairwise.complete.obs")) } else{ z.plot <- cor(data, data, use="pairwise.complete.obs") } if (is.null(varnames)){ z.names <- dimnames(data)[[2]] } else{ z.names <- varnames } triangleplot(x=z.plot, y=z.names, cutpts=cutpts, details=details, n.col.legend=n.col.legend, cex.col=cex.col, cex.var=cex.var, digits=digits, color=color) } arm/R/bayesglm.h.R0000644000176200001440000006312113014470370013410 0ustar liggesusers## Aug 11, 2007 ## 1. model.matrix.bayes, terms.bayes, contr.bayes.unordered ## & contr.bayes.ordered are in "arm" now. ## 2. bayesglm.h now uses model.matrix.bayes2 in "arm". # #bayesglm.h <- function ( formula, family = gaussian, data, weights, subset, # na.action, start = NULL, etastart, mustart, offset, control = glm.control(...), # model = TRUE, method = "glm.fit", x = FALSE, y = TRUE, contrasts = NULL, # prior.mean = 0, prior.scale = 2.5, prior.df = 1, scaled = TRUE, # prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, # batch=0, batch.mean=NA, batch.sd=NA, # batch.mean.mean=0, batch.mean.scale=prior.scale.for.intercept, batch.mean.df=prior.df, # batch.sd.scale=2.5, batch.sd.df=1, # n.iter = 100, drop.baseline = FALSE, separete.intercept = TRUE, # keep.order=TRUE, batch.mean.known=FALSE, ... ) #{ # call <- match.call() # if (is.character(family)) # family <- get(family, mode = "function", envir = parent.frame()) # if (is.function(family)) # family <- family() # if (is.null(family$family)) { # print(family) # stop("'family' not recognized") # } # if (missing(data)) # data <- environment(formula) # mf <- match.call(expand.dots = FALSE) # m <- match(c("formula", "data", "subset", "weights", "na.action", "etastart", "mustart", "offset"), names(mf), 0) # mf <- mf[c(1, m)] # mf$drop.unused.levels <- TRUE # mf[[1]] <- as.name("model.frame") # mf <- eval(mf, parent.frame()) # switch(method, model.frame = return(mf), glm.fit = 1, stop("invalid 'method': ", method)) # mt <- attr(mf, "terms") # Y <- model.response(mf, "any") # if (length(dim(Y)) == 1) { # nm <- rownames(Y) # dim(Y) <- NULL # if (!is.null(nm)) # names(Y) <- nm # } # if (!drop.baseline){ # X <- if (!is.empty.model(mt)){ # #class(mt) <- c("bayesglm.h", "terms", "formula") # model.matrix.bayes.h( mt, mf, contrasts, keep.order=keep.order, batch=batch ) # } # else matrix(, NROW(Y), 0) # } # else { # X <- if (!is.empty.model(mt)) # model.matrix( mt, mf, contrasts ) # else matrix(, NROW(Y), 0) # } ## if ( length( batch ) == 1 ) { batch <- rep ( batch, ncol( X ) ) } # intercept <- (attr(mt, "intercept") > 0) # if( intercept && length(batch)==1 ){ # batch <- c(0,rep (batch, ncol( X )-1)) # } # else if (length(batch)==1 ) { # batch <- rep (batch, ncol( X )) # } # else if ( length( batch ) > 1 ) { # if( length( batch ) != (length(attr(mt,"term.labels") ))) { # stop( "batch is ether all 0 or must be specified for each of the variables." ) # } # else { # assignVec <- attr( X, "assign" ) # tb <- if ( intercept ) { 0 } else { NULL } # for( bi in 1:length( batch ) ){ # tb<-c( tb,rep( batch[bi], sum( assignVec == bi ) ) ) # } # batch <- tb # } # } # # weights <- model.weights(mf) # offset <- model.offset(mf) # if (!is.null(weights) && any(weights < 0)) # stop("negative weights not allowed") # if (!is.null(offset) && length(offset) != NROW(Y)) # stop(gettextf("number of offsets is %d should equal %d (number of observations)", length(offset), NROW(Y)), domain = NA) # mustart <- model.extract(mf, "mustart") # etastart <- model.extract(mf, "etastart") # # fit <- bayesglm.hierarchical.fit(x = X, y = Y, weights = weights, start = start, # etastart = etastart, mustart = mustart, offset = offset, # family = family, control = glm.control( maxit = n.iter ), # intercept = intercept, prior.mean = prior.mean, # prior.scale = prior.scale, # prior.mean.for.intercept = prior.mean.for.intercept, # prior.scale.for.intercept = prior.scale.for.intercept, # prior.df.for.intercept = prior.df.for.intercept, # prior.df = prior.df, batch = batch, batch.mean=batch.mean, batch.sd = batch.sd, # batch.mean.mean = batch.mean.mean, batch.mean.scale = batch.mean.scale, batch.mean.df = batch.mean.df, # batch.sd.scale = batch.sd.scale, batch.sd.df = batch.sd.df, scaled = scaled ,drop.baseline=drop.baseline, # batch.mean.known = batch.mean.known ) # if (any(offset) && attr(mt, "intercept") > 0) { # cat("bayesglm not yet set up to do deviance comparion here\n") # fit$null.deviance <- bayesglm.hierarchical.fit(x = X[, "(Intercept)", drop = FALSE], # y = Y, weights = weights, offset = offset, family = family, # control = control, intercept = intercept, prior.mean = prior.mean, prior.scale = prior.scale, # prior.mean.for.intercept = prior.mean.for.intercept, # prior.scale.for.intercept = prior.scale.for.intercept, # prior.df.for.intercept = prior.df.for.intercept, # prior.df = prior.df, batch = batch, batch.mean = batch.mean, batch.sd = batch.sd, # batch.mean.mean = batch.mean.mean, batch.mean.scale = batch.mean.scale, batch.mean.df = batch.mean.df, # batch.sd.scale = batch.sd.scale, batch.sd.df = batch.sd.df, scaled = scaled,drop.baseline=drop.baseline, # batch.mean.known = batch.mean.known )$deviance # } # if (model) # fit$model <- mf # fit$na.action <- attr(mf, "na.action") # if (x) # fit$x <- X # if (!y) # fit$y <- NULL # fit <- c(fit, list(call = call, formula = formula, terms = mt, # data = data, offset = offset, control = control, method = method, # contrasts = attr(X, "contrasts"), xlevels = .getXlevels(mt, mf))) # class(fit) <- c("bayesglm.h","glm", "lm") # fit #} # # #bayesglm.hierarchical.fit <- #function (x, y, weights = rep(1, nobs), start = NULL, etastart = NULL, # mustart = NULL, offset = rep(0, nobs), family = gaussian(), # control = glm.control(), prior.mean = 0, prior.scale = 2.5, prior.df = 1, # intercept = TRUE, # prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = prior.df, # batch=0, batch.mean=NA, batch.sd=NA, # batch.mean.mean=0, batch.mean.scale=2.5, batch.mean.df=1, # batch.sd.scale=2.5, batch.sd.df=1, scaled = TRUE, drop.baseline = FALSE, batch.mean.known = TRUE ) #{ # J <- NCOL(x) # if(intercept && length(batch)==1 ){ # batch <- c(0,rep (batch, J-1)) # } # else if (length(batch)==1 ) { # batch <- rep (batch, J) # } # J.0 <- sum (batch==0) # if (J.0 > 0) { # if (length(prior.mean) == 1) { # prior.mean <- rep(prior.mean, J.0) # if(intercept){ # prior.mean[1] <- prior.mean.for.intercept # } # } # else if (length(prior.mean) > 1) { # if( length( prior.mean ) + intercept != J.0 ){ # stop(message="You must specify the prior.mean for each of the variables") # } # } # if (length(prior.scale) == 1) { # prior.scale <- rep(prior.scale, J.0) # if(intercept){ # prior.scale[1] <- prior.scale.for.intercept # } # } # else if (length(prior.scale) > 1) { # if( length( prior.scale ) + intercept != J.0 ){ # stop(message="You must specify the prior.scale for each of the variables") # } # } # if (scaled == TRUE) { # y.scale <- 1 # if (family$family == "gaussian") { # y.obs <- y[!is.na(y)] # num.categories <- length(unique(y.obs)) # if (num.categories == 2) { # y.scale <- max(y.obs) - min(y.obs) # } # else if (num.categories > 2) { # y.scale <- 2 * sd(y.obs) # } # } # for (j in 1:J.0) { # x.obs <- x[,(1:J)[batch==0][j]] # x.obs <- x.obs[!is.na(x.obs)] # num.categories <- length(unique(x.obs)) # x.scale <- 1 # if (num.categories == 2) { # x.scale <- max(x.obs) - min(x.obs) # } # else if (num.categories > 2) { # x.scale <- 2 * sd(x.obs) # } # prior.scale[j] <- prior.scale[j] * y.scale/x.scale # } # if (is.numeric(prior.scale.for.intercept) & intercept) { # prior.scale[1] <- prior.scale.for.intercept * y.scale # } # } # if (length(prior.df) == 1) { # prior.df <- rep(prior.df, J.0) # } # #### Added by Masanao Yajima 8/30 # if (intercept){ # prior.df[1] <- prior.df.for.intercept # } # } # K <- max (batch) # if (K > 0){ # if ( length( batch.mean ) == 1 ) { batch.means <- rep( batch.mean, K ) } # if ( length( batch.sd ) == 1 ) { batch.sds <- rep( batch.sd, K ) } # if ( length( batch.mean.mean ) == 1 ) { batch.mean.mean <- rep( batch.mean.mean, K ) } # if ( length( batch.mean.scale ) == 1 ) { batch.mean.scale <- rep( batch.mean.scale, K ) } # if ( length( batch.mean.df ) == 1 ) { batch.mean.df <- rep( batch.mean.df, K ) } # if ( length( batch.sd.scale ) == 1 ) { batch.sd.scale <- rep( batch.sd.scale, K ) } # if ( length( batch.sd.df ) == 1 ) { batch.sd.df <- rep( batch.sd.df, K ) } # } # x <- as.matrix( x ) # xnames <- dimnames( x )[[2]] # ynames <- if (is.matrix( y ) ) { rownames( y ) } else { names( y ) } # conv <- FALSE # nobs <- NROW( y ) # nvars <- ncol(x) # EMPTY <- nvars == 0 # if ( is.null( weights ) ){ weights<- rep.int( 1, nobs ) } # if ( is.null( offset ) ) { offset <- rep.int( 0, nobs ) } # variance <- family$variance # dev.resids <- family$dev.resids # aic <- family$aic # linkinv <- family$linkinv # mu.eta <- family$mu.eta # if ( !is.function( variance ) || !is.function( linkinv ) ) { stop( "'family' argument seems not to be a valid family object" ) } # valideta <- family$valideta # if ( is.null(valideta)){ valideta <- function( eta ) TRUE } # validmu <- family$validmu # if ( is.null( validmu ) ) { validmu <- function( mu ) TRUE } # if ( is.null( mustart ) ) { eval( family$initialize ) } # else { # mukeep <- mustart # eval( family$initialize ) # mustart <- mukeep # } # if (EMPTY) { # eta <- rep.int( 0, nobs ) + offset # if ( !valideta( eta ) ) { stop( "invalid linear predictor values in empty model" ) } # mu <- linkinv( eta ) # if ( !validmu( mu ) ) { stop( "invalid fitted means in empty model" ) } # dev <- sum( dev.resids( y, mu, weights ) ) # w <- ( ( weights * mu.eta( eta )^2 )/variance( mu ) )^0.5 # residuals <- ( y - mu )/mu.eta( eta ) # good <- rep( TRUE, length( residuals ) ) # boundary <- conv <- TRUE # coef <- numeric( 0 ) # iter <- 0 # } # else { # coefold <- NULL # eta <- if (!is.null(etastart)) { etastart } # else if ( !is.null( start ) ) { # if ( length( start ) != nvars ) { # stop( gettextf( "length of 'start' should equal %d and correspond to initial coefs for %s", # nvars, paste( deparse( xnames ), collapse = ", " ) ), domain = NA ) # } # else { # coefold <- start # offset + as.vector( if ( NCOL( x ) == 1) { x * start } else { crossprod( x, start ) }) # #offset + as.vector( if (NCOL(x) == 1) { x * start } else { x %*% start }) # } # } # else {family$linkfun(mustart)} # mu <- linkinv( eta ) # if ( !( validmu( mu ) && valideta( eta ) ) ) # stop( "cannot find valid starting values: please specify some" ) # devold <- sum( dev.resids(y, mu, weights ) ) # boundary <- conv <- FALSE ## prior.sd <- prior.scale # dispersion <- 1 # dispersionold <- dispersion # # Define s's and initialize sigma's # mu.0 <- prior.mean # s.0 <- prior.scale # nu.0 <- prior.df # sigma.0 <- s.0 # # Count the number of batches and record where mu.batch_k and sigma.batch_k are unknown # sigma.batch <- NULL # sigma.mu.batch <- NULL # if ( K > 0 ) { # batch.mean.unknown <- is.na( batch.mean ) # batch.sd.unknown <- is.na( batch.sd ) # # Create the W matrix # J.plus <- sum( batch > 0 ) # W <- array( 0, c( J, K ) ) # for ( k in 1:K ){ # W[batch == k, k] <- 1 # } # W.plus <- W[batch>0, ] # J.batch <- colSums( W ) # s.batch <- batch.sd.scale # nu.batch <- batch.sd.df # sigma.batch <- s.batch # mu.mu.batch <- batch.mean.mean # s.mu.batch <- batch.mean.scale # sigma.mu.batch <- s.mu.batch # nu.mu.batch <- ifelse( batch.mean.df == Inf, batch.mean.scale, batch.mean.df ) # # Prepare the subtotals for the batches with unknown means # x.plus <- x[ ,batch > 0] # #x.star <- rbind( cbind( x, x.plus %*% W.plus ), diag( J+K ) ) # x.star <- rbind( cbind( x, tcrossprod( x.plus,t( W.plus ) ) ), diag( J+K ) ) # if ( intercept ) { x.star[NROW( x )+1, 1:J] <- colMeans( x ) } # 17 Dec # dimnames( x.star )[[2]] <- c ( dimnames( x )[[2]], paste( "mu.batch.", 1:K, sep="" ) ) # xnames <- dimnames(x.star)[[2]] # } # else { # if K==0 # x.star <- as.matrix( rbind( x, diag( J ) ) ) # } # nvars.star <- ncol(x.star) ## Loop ####### # for ( iter in 1:control$maxit ) { # good <- weights > 0 # varmu <- variance( mu )[good] # if ( any( is.na( varmu ) ) ) { stop( "NAs in V( mu )") } # if ( any( varmu == 0 ) ) { stop( "0s in V( mu )" ) } # mu.eta.val <- mu.eta( eta ) # if ( any( is.na( mu.eta.val[good] ) ) ) { stop( "NAs in d( mu )/d( eta )" ) } # good <- ( weights > 0 ) & ( mu.eta.val != 0 ) # if ( all( !good ) ) { # conv <- FALSE # warning( "no observations informative at iteration ", iter ) # break # } # z <- ( eta - offset )[good] + ( y - mu )[good] / mu.eta.val[good] # w <- sqrt( ( weights[good] * mu.eta.val[good]^2 ) / variance( mu )[good]) # ngoodobs <- as.integer( nobs - sum( !good ) ) # # This is where we augment the data with the prior information # if ( K > 0 ){ # # Added by Masanao Yajima 2007/07/31 # # when there is batch 0 then # if (min(batch)==0){ # z.star <- c( z, mu.0, rep( 0, J.plus ), mu.mu.batch ) # w.star <- c( w, sqrt( dispersion )*c( 1/sigma.0, 1/sigma.batch[batch[batch>0]], 1/sigma.mu.batch ) ) # ngoodobs.star <- ngoodobs + NCOL( x ) + NCOL( W.plus ) # } # # when there is no batch 0 then # else{ # z.star <- c( z, rep( 0, J.plus ), mu.mu.batch ) # w.star <- c( w, sqrt( dispersion ) * c( 1/sigma.batch[batch[batch>0]], 1/sigma.mu.batch ) ) # ngoodobs.star <- ngoodobs + NCOL( x ) + NCOL( W.plus ) # } # } # else { # z.star <- c( z, mu.0 ) # w.star <- c( w, sqrt( dispersion )/sigma.0 ) # ngoodobs.star <- ngoodobs + NCOL( x ) # } # good.star <- c(good, rep( TRUE, J + K ) ) # nvars <- NCOL( x.star ) # if ( intercept ) { # x.star[NROW( x ) + 1, 1:NCOL( x )] <- colMeans(x) # } # fit <- .Fortran( "dqrls", qr = x.star[good.star, ] * w.star, n = ngoodobs.star, # p = nvars, y = w.star * z.star, ny = as.integer( 1 ), tol = min(1e-07, control$epsilon/1000 ), # coefficients = double( nvars ), residuals = double( ngoodobs.star ), effects = double( ngoodobs.star ), # rank = integer( 1 ), pivot = 1:nvars, qraux = double( nvars ), work = double( 2 * nvars ), PACKAGE = "base" ) # if ( any( !is.finite( fit$coefficients ) ) ) { # conv <- FALSE # warning( "non-finite coefficients at iteration ", iter ) # break # } # # coefs.hat <- fit$coefficients # V.coefs <- chol2inv( as.matrix(fit$qr)[1:ncol( x.star ), 1:ncol( x.star ), drop = FALSE] ) # # Now update the prior scale # # Allocate the coefficients to beta.0, alpha, mu.batch # beta.0.index <- 1:J.0 # beta.0.hat <- coefs.hat[beta.0.index] # V.beta.0 <- diag(V.coefs)[beta.0.index] # # Now update the sigma_j's in batch 0 # sigma.0 <- ifelse ( nu.0 == Inf, s.0, sqrt( ( ( beta.0.hat - mu.0 )^2 + V.beta.0 + nu.0 * s.0^2 )/( 1 + nu.0 ) ) ) # if ( K > 0 ) { # alpha.index <- ( J.0 + 1 ):J # mu.batch.index <- ( J + 1 ):( J + K ) # alpha.hat <- coefs.hat[alpha.index] # mu.batch.hat <- coefs.hat[mu.batch.index] # V.alpha <- diag( V.coefs )[alpha.index] *dispersion #### # V.mu.batch <- diag( V.coefs )[mu.batch.index]*dispersion #### # # Now estimate the sigma.batch_k's where unknown # sigma.batch <- if( batch.sd.unknown ) { # #sqrt( ( t( W.plus ) %*% ( alpha.hat^2 + V.alpha ) + nu.batch * s.batch^2 )/( J.batch + nu.batch ) ) # sqrt( ( crossprod(W.plus,( alpha.hat^2 + V.alpha ) ) + nu.batch * s.batch^2 )/( J.batch + nu.batch ) ) # } # else{ sigma.batch } # # # # Now estimate the sigma.mu.batch_k's where mu.batch_k's are unknown # sigma.mu.batch <- if ( batch.mean.unknown ) { # sqrt( ( ( mu.batch.hat - mu.mu.batch )^2 + V.mu.batch + nu.mu.batch * s.mu.batch^2 )/( 1 + nu.mu.batch ) ) # } # else{ sigma.mu.batch} # # } # start[fit$pivot] <- fit$coefficients # #eta <- drop( as.matrix(x.star[1:nrow( x ), ]) %*% start ) # eta <- drop( tcrossprod( t(start), as.matrix(x.star[1:nrow( x ), ]) ) ) # #eta <- drop(x %*% start) # mu <- linkinv( eta <- eta + offset ) # dev <- sum( dev.resids( y, mu, weights ) ) # if ( !( family$family %in% c( "poisson", "binomial" ) ) ) { # #mse.resid <- mean((w * (z - x %*% coefs.hat))^2) # #mse.resid <- mean((w * (z - as.matrix(x.star[1:nrow(x),]) %*% coefs.hat))^2) # mse.resid <- mean( ( w * ( z - tcrossprod( as.matrix( x.star[1:nrow(x),] ),t( coefs.hat ) ) ) )^2 ) # #mse.uncertainty <- mean(diag(x %*% V.coefs %*% t(x))) * dispersion # #mse.uncertainty <- mean( rowSums( ( x.star[1:nrow(x),] %*% V.coefs ) * x.star[1:nrow(x),] ) ) * dispersion # mse.uncertainty <- mean( rowSums( tcrossprod( x.star[1:nrow(x),], V.coefs ) * x.star[1:nrow(x),] ) ) * dispersion # dispersion <- mse.resid + mse.uncertainty # } # if ( control$trace ) { cat("Deviance =", dev, "Iterations -", iter, "\n") } # boundary <- FALSE # if ( !is.finite( dev ) ) { # if ( is.null( coefold ) ) { # stop( "no valid set of coefficients has been found: please supply starting values", call. = FALSE ) # } # warning( "step size truncated due to divergence", call. = FALSE ) # ii <- 1 # while ( !is.finite( dev ) ) { # if ( ii > control$maxit ) { stop( "inner loop 1; cannot correct step size" ) } # ii <- ii + 1 # start <- ( start + coefold )/2 # #eta <- drop( x %*% start ) # eta <- drop( crossprod( x, start) ) # mu <- linkinv( eta <- eta + offset ) # dev <- sum( dev.resids( y, mu, weights ) ) # } # boundary <- TRUE # if ( control$trace ){ cat( "Step halved: new deviance =", dev, "\n" ) } # } # if ( !( valideta( eta ) && validmu( mu ) ) ) { # if ( is.null( coefold ) ) { # stop("no valid set of coefficients has been found: please supply starting values", call. = FALSE) # } # warning("step size truncated: out of bounds", call. = FALSE) # ii <- 1 # while ( !(valideta( eta ) && validmu( mu ) ) ) { # if ( ii > control$maxit ) { # stop("inner loop 2; cannot correct step size") # } # ii <- ii + 1 # start <- ( start + coefold )/2 # #eta <- drop( x %*% start ) # eta <- drop( crossprod(x, start ) ) # mu <- linkinv( eta <- eta + offset ) # } # boundary <- TRUE # dev <- sum( dev.resids( y, mu, weights ) ) # if ( control$trace ) { cat( "Step halved: new deviance =", dev, "\n" ) } # } # # Convergence Check # if (iter > 1 & abs( dev - devold )/( 0.1 + abs( dev ) ) < control$epsilon # & abs( dispersion - dispersionold)/( 0.1 + abs( dispersion ) ) < control$epsilon ) { # conv <- TRUE # coef <- start # break # } # else { # devold <- dev # dispersionold <- dispersion # coef <- coefold <- start # } # # } ## End of Loop ####### # if ( !conv ) { warning( "algorithm did not converge" ) } # if ( boundary ) { warning( "algorithm stopped at boundary value" ) } # eps <- 10 * .Machine$double.eps # if ( family$family == "binomial" ) { # if ( any( mu > 1 - eps ) || any( mu < eps ) ) { warning( "fitted probabilities numerically 0 or 1 occurred" ) } # } # if ( family$family == "poisson" ) { # if ( any(mu < eps ) ) { warning( "fitted rates numerically 0 occurred" ) } # } # if( drop.baseline==TRUE ){ # if ( fit$rank < nvars ) { # coef[fit$pivot][seq( fit$rank + 1, nvars )] <- NA # } # } # xxnames <- xnames[fit$pivot] # residuals <- rep.int( NA, nobs ) # residuals[good] <- z - ( eta - offset )[good] # fit$qr <- as.matrix( fit$qr ) # nr <- min( sum( good ), nvars ) # if ( nr < nvars ) { # Rmat <- diag( nvars ) # Rmat[1:nr, 1:nvars] <- fit$qr[1:nr, 1:nvars] # } # else { # Rmat <- fit$qr[1:nvars, 1:nvars] # } # Rmat <- as.matrix( Rmat ) # Rmat[ row( Rmat ) > col( Rmat ) ] <- 0 # names( coef ) <- xnames # colnames( fit$qr ) <- xxnames # dimnames( Rmat ) <- list( xxnames, xxnames ) # } # names( residuals ) <- ynames # names( mu ) <- ynames # names( eta ) <- ynames # wt <- rep.int(0, nobs) # wt[good] <- w^2 # names( wt ) <- ynames # names( weights ) <- ynames # names( y ) <- ynames # wtdmu <- if ( intercept ) { sum( weights * y )/sum( weights )} else linkinv( offset ) # nulldev <- sum( dev.resids( y, wtdmu, weights ) ) # n.ok <- nobs - sum( weights == 0 ) # nulldf <- n.ok - as.integer( intercept ) # rank <- if ( EMPTY ) { 0 } else { fit$rank } # resdf <- n.ok - rank # aic.model <- aic(y, n, mu, weights, dev) + 2 * rank # list( coefficients = coef, residuals = residuals, fitted.values = mu, # effects = if ( !EMPTY ) fit$effects, R = if ( !EMPTY ) Rmat, rank = rank, # qr = if ( !EMPTY ) structure(fit[c( "qr", "rank", "qraux", "pivot", "tol" )], class = "qr" ), # family = family, linear.predictors = eta, deviance = dev, aic = aic.model, # null.deviance = nulldev, iter = iter, weights = wt, prior.weights = weights, # df.residual = resdf, df.null = nulldf, y = y, converged = conv, boundary = boundary, # prior.mean = prior.mean, prior.scale = prior.scale, # prior.df = prior.df, prior.sd = sigma.0, dispersion = dispersion, # batch=batch, batch.mean=batch.mean, batch.sd=batch.sd, # batch.mean.mean=batch.mean.mean, batch.mean.scale=batch.mean.scale, batch.mean.df =batch.mean.df, # batch.sd.scale=batch.sd.scale, batch.sd.df=batch.sd.df, # sigma.0=sigma.0, sigma.batch=sigma.batch, sigma.mu.batch=sigma.mu.batch ) #} # #setMethod("print", signature(x = "bayesglm.h"), # function(x, digits=2) display(object=x, digits=2)) #setMethod("show", signature(object = "bayesglm.h"), # function(object) display(object, digits=2)) arm/R/contrasts.bayes.R0000644000176200001440000000407413014470370014503 0ustar liggesuserscontr.bayes.ordered <- function ( n, scores = 1:n, contrasts = TRUE ) { make.poly <- function( n, scores ) { y <- scores - mean( scores ) X <- outer( y, seq_len( n ) - 1, "^" ) QR <- qr( X ) z <- QR$qr z <- z *( row( z ) == col( z ) ) raw <- qr.qy( QR, z ) Z <- sweep( raw, 2, apply( raw, 2, function( x ) sqrt( sum( x^2 ) ) ), "/" ) colnames( Z ) <- paste( "^", 1:n - 1, sep="" ) Z } if ( is.numeric( n ) && length( n ) == 1 ) { levs <- 1:n } else { levs <- n n <- length( levs ) } if ( n < 2 ) { stop( gettextf( "contrasts not defined for %d degrees of freedom", n - 1 ), domain = NA ) } if ( n > 95 ) { stop( gettextf( "orthogonal polynomials cannot be represented accurately enough for %d degrees of freedom", n-1 ), domain = NA ) } if ( length( scores ) != n ) { stop( "'scores' argument is of the wrong length" ) } if ( !is.numeric( scores ) || any( duplicated( scores ) ) ) { stop("'scores' must all be different numbers") } contr <- make.poly( n, scores ) if ( contrasts ) { dn <- colnames( contr ) dn[2:min( 4, n )] <- c( ".L", ".Q", ".C" )[1:min( 3, n-1 )] colnames( contr ) <- dn contr[, , drop = FALSE] } else { contr[, 1] <- 1 contr } } contr.bayes.unordered <- function(n, base = 1, contrasts = TRUE) { if( is.numeric( n ) && length( n ) == 1) { if( n > 1 ) { levs <- 1:n } else stop( "not enough degrees of freedom to define contrasts" ) } else { levs <- n n <- length( n ) } contr <- array( 0, c(n, n), list( levs, levs ) ) diag( contr ) <- 1 if( contrasts ) { if( n < 2 ) { stop( gettextf( "contrasts not defined for %d degrees of freedom", n - 1 ), domain = NA ) } if( base < 1 | base > n ){ stop( "baseline group number out of range" ) } contr <- contr[, , drop = FALSE] } contr } arm/R/se.coef.R0000644000176200001440000000724313014470370012704 0ustar liggesuserssetMethod("se.coef", signature(object = "lm"), function(object) { object.class <- class(object)[[1]] sqrt (diag(vcov(object))) } ) setMethod("se.coef", signature(object = "glm"), function(object) { object.class <- class(object)[[1]] sqrt (diag(vcov(object))) } ) #setMethod("se.coef", signature(object = "mer"), # function(object) # { # # if (sum(unlist(lapply(object@bVar, is.na)))>0){ ## object@call$control <- list(usePQL=TRUE) ## object <- lmer(object@call$formula) ## } # #ngrps <- lapply(object@flist, function(x) length(levels(x))) # fcoef <- fixef(object) # #sc <- attr (VarCorr (object), "sc") # corF <- vcov(object)@factors$correlation # se.unmodeled <- NULL # se.unmodeled[[1]] <- corF@sd # names (se.unmodeled) <- "unmodeled" # # #coef <- ranef (object) # #estimate <- ranef(object, postVar=TRUE) # coef <- ranef(object, postVar=TRUE) # se.bygroup <- coef #ranef( object, postVar = TRUE ) # n.groupings <- length (coef) # # for (m in 1:n.groupings){ # vars.m <- attr (coef[[m]], "postVar") # K <- dim(vars.m)[1] # J <- dim(vars.m)[3] # se.bygroup[[m]] <- array (NA, c(J,K)) # for (j in 1:J){ # se.bygroup[[m]][j,] <- sqrt(diag(as.matrix(vars.m[,,j]))) # } ## se.bygroup[[m]] <- se.bygroup[[m]]*sc # names.full <- dimnames (ranef(object)[[m]]) # dimnames (se.bygroup[[m]]) <- list (names.full[[1]], # names.full[[2]]) # } # #names(se.bygroup) <- names(ngrps) # ses <- c (se.unmodeled, se.bygroup) # return (ses) # } #) setMethod("se.coef", signature(object = "merMod"), function(object) { #ngrps <- lapply(object@flist, function(x) length(levels(x))) fcoef <- fixef(object) #sc <- attr (VarCorr (object), "sc") corF <- vcov(object)@factors$correlation se.unmodeled <- NULL se.unmodeled[[1]] <- corF@sd names (se.unmodeled) <- "fixef"#"unmodeled" #coef <- ranef (object) #estimate <- ranef(object, postVar=TRUE) coef <- ranef(object, condVar=TRUE) se.bygroup <- coef #ranef( object, postVar = TRUE ) n.groupings <- length (coef) for (m in 1:n.groupings){ vars.m <- attr (coef[[m]], "postVar") K <- dim(vars.m)[1] J <- dim(vars.m)[3] se.bygroup[[m]] <- array (NA, c(J,K)) for (j in 1:J){ se.bygroup[[m]][j,] <- sqrt(diag(as.matrix(vars.m[,,j]))) } # se.bygroup[[m]] <- se.bygroup[[m]]*sc names.full <- dimnames (coef[[m]]) dimnames (se.bygroup[[m]]) <- list (names.full[[1]], names.full[[2]]) } #names(se.bygroup) <- names(ngrps) ses <- c (se.unmodeled, se.bygroup) return (ses) } ) se.fixef <- function (object){ #object <- summary (object) fcoef.name <- names(fixef(object)) corF <- vcov(object)@factors$correlation ses <- corF@sd names(ses) <- fcoef.name return (ses) } se.ranef <- function (object){ #ngrps <- lapply(object@flist, function(x) length(levels(x))) se.bygroup <- ranef( object, condVar = TRUE ) n.groupings<- length( se.bygroup ) for( m in 1:n.groupings ) { vars.m <- attr( se.bygroup[[m]], "postVar" ) K <- dim(vars.m)[1] J <- dim(vars.m)[3] names.full <- dimnames(se.bygroup[[m]]) se.bygroup[[m]] <- array(NA, c(J, K)) for (j in 1:J) { se.bygroup[[m]][j, ] <- sqrt(diag(as.matrix(vars.m[, , j]))) } dimnames(se.bygroup[[m]]) <- list(names.full[[1]], names.full[[2]]) } return(se.bygroup) } arm/R/binnedplot.R0000644000176200001440000000467413014470370013525 0ustar liggesusers# ==================================================================== # Functions for plotting the binned residuals # ==================================================================== binnedplot <- function(x, y, nclass=NULL, xlab="Expected Values", ylab="Average residual", main="Binned residual plot", cex.pts=0.8, col.pts=1, col.int="gray", ...) { n <- length(x) if (is.null(nclass)){ if (n >= 100){ nclass=floor(sqrt(length(x))) } if (n > 10 & n < 100){ nclass=10 } if (n <=10){ nclass=floor(n/2) } } aa <- data.frame(binned.resids (x, y, nclass)$binned) plot(range(aa$xbar), range(aa$ybar, aa$X2se, -aa$X2se, na.rm=TRUE), xlab=xlab, ylab=ylab, type="n", main=main, ...) abline (0,0, lty=2) lines (aa$xbar, aa$X2se, col=col.int) lines (aa$xbar, -aa$X2se, col=col.int) points (aa$xbar, aa$ybar, pch=19, cex=cex.pts, col=col.pts) } binned.resids <- function (x, y, nclass=floor(sqrt(length(x)))){ breaks.index <- floor(length(x)*(1:(nclass-1))/nclass) if(any(breaks.index==0)) nclass <- 1 x.sort <- sort(x) breaks <- -Inf if(nclass > 1){ for (i in 1:(nclass-1)){ x.lo <- x.sort[breaks.index[i]] x.hi <- x.sort[breaks.index[i]+1] if (x.lo==x.hi){ if (x.lo==min(x)){ x.lo <- -Inf } else { x.lo <- max (x[x 1) sd(y[items]) else 0 output <- rbind (output, c(xbar, ybar, n, x.range, 2*sdev/sqrt(n))) } colnames (output) <- c("xbar", "ybar", "n", "x.lo", "x.hi", "2se") #output <- output[output[,"sdev"] != 0,] return (list (binned=output, xbreaks=xbreaks)) } arm/R/AllInternal.R0000644000176200001440000001712614602472324013575 0ustar liggesusers# some useful little functions #.round <- base:::round sd.scalar <- function (x, ...) {sqrt(var(as.vector(x), ...))} wmean <- function (x, w, ...) {mean(x*w, ...)/mean(w, ...)} logit <- function (x) {log(x/(1-x))} .untriangle <- function (x) {x + t(x) - x*diag(nrow(as.matrix(x)))} # new functions! as.matrix.VarCorr <- function (x, ..., useScale, digits){ # VarCorr function for lmer objects, altered as follows: # 1. specify rounding # 2. print statement at end is removed # 3. reMat is returned # 4. last line kept in reMat even when there's no error term sc <- attr(x, "sc")[[1]] if(is.na(sc)) sc <- 1 # recorr <- lapply(varc, function(el) el@factors$correlation) recorr <- lapply(x, function(el) attr(el, "correlation")) #reStdDev <- c(lapply(recorr, slot, "sd"), list(Residual = sc)) reStdDev <- c(lapply(x, function(el) attr(el, "stddev")), list(Residual = sc)) reLens <- unlist(c(lapply(reStdDev, length))) reMat <- array('', c(sum(reLens), 4), list(rep('', sum(reLens)), c("Groups", "Name", "Variance", "Std.Dev."))) reMat[1+cumsum(reLens)-reLens, 1] <- names(reLens) reMat[,2] <- c(unlist(lapply(reStdDev, names)), "") # reMat[,3] <- format(unlist(reStdDev)^2, digits = digits) # reMat[,4] <- format(unlist(reStdDev), digits = digits) reMat[,3] <- fround(unlist(reStdDev)^2, digits) reMat[,4] <- fround(unlist(reStdDev), digits) if (any(reLens > 1)) { maxlen <- max(reLens) corr <- do.call("rbind", lapply(recorr, function(x, maxlen) { x <- as(x, "matrix") # cc <- format(round(x, 3), nsmall = 3) cc <- fround (x, digits) cc[!lower.tri(cc)] <- "" nr <- dim(cc)[1] if (nr >= maxlen) return(cc) cbind(cc, matrix("", nr, maxlen-nr)) }, maxlen)) colnames(corr) <- c("Corr", rep("", maxlen - 1)) reMat <- cbind(reMat, rbind(corr, rep("", ncol(corr)))) } # if (!useScale) reMat <- reMat[-nrow(reMat),] if (useScale<0) reMat[nrow(reMat),] <- c ("No residual sd", rep("",ncol(reMat)-1)) return (reMat) } # rwish and dwish functions stolen from Martin and Quinn's MCMCpack rwish <- function (v, S){ if (!is.matrix(S)) S <- matrix(S) if (nrow(S) != ncol(S)) { stop(message = "S not square in rwish().\n") } if (v < nrow(S)) { stop(message = "v is less than the dimension of S in rwish().\n") } p <- nrow(S) CC <- chol(S) Z <- matrix(0, p, p) diag(Z) <- sqrt(rchisq(p, v:(v - p + 1))) if (p > 1) { pseq <- 1:(p - 1) Z[rep(p * pseq, pseq) + unlist(lapply(pseq, seq))] <- rnorm(p * (p - 1)/2) } return(crossprod(Z %*% CC)) } dwish <- function (W, v, S) { if (!is.matrix(S)) S <- matrix(S) if (nrow(S) != ncol(S)) { stop(message = "W not square in dwish()\n\n") } if (!is.matrix(W)) S <- matrix(W) if (nrow(W) != ncol(W)) { stop(message = "W not square in dwish()\n\n") } if (nrow(S) != ncol(W)) { stop(message = "W and X of different dimensionality in dwish()\n\n") } if (v < nrow(S)) { stop(message = "v is less than the dimension of S in dwish()\n\n") } k <- nrow(S) gammapart <- 1 for (i in 1:k) { gammapart <- gammapart * gamma((v + 1 - i)/2) } denom <- gammapart * 2^(v * k/2) * pi^(k * (k - 1)/4) detS <- det(S) detW <- det(W) hold <- solve(S) %*% W tracehold <- sum(hold[row(hold) == col(hold)]) num <- detS^(-v/2) * detW^((v - k - 1)/2) * exp(-1/2 * tracehold) return(num/denom) } # no visible binding~~~~~~~~~~~~~~~ # functions used to pass the check for bayespolr pgumbel <- function(q, loc = 0, scale = 1, lower.tail = TRUE) { q <- (q - loc)/scale p <- exp(-exp(-q)) if (!lower.tail) 1 - p else p } dgumbel <- function (x, loc = 0, scale = 1, log = FALSE) { d <- log(1/scale) - x - exp(-x) if (!log) exp(d) else d } # defin n to pass the bayesglm.fit and bayesglm.h.fit check n <- NULL # for mcplot .pvalue <- function ( v1, v2 ){ mean( ( sign( v1 - v2 ) + 1 ) / 2 ) } .is.significant <- function ( p, alpha = 0.05 ){ significant <- 0 + ( p > ( 1 - alpha ) ) - ( p < alpha ) return( significant ) } .weights.default <- function (object, ...) { wts <- object$weights if (is.null(wts)) wts else napredict(object$na.action, wts) } #.sweep.inv <- function(G){ # # sweeps a symmetric matrix on all positions # # (so inverts the matrix) # for(i in 1:nrow(G)) { # G <- .sweep.oper(G, i) # } # G #} # #.sweep.oper <- function(G = theta, k = 1.){ # # k is the sweep position # p <- dim(G)[1.] # H <- G # #first do generic elements (those that don't involve k) # H[] <- 0. # tmp <- matrix(G[, k], p, 1.) %*% matrix(G[, k], 1., p) # #now replace the row and col with index=k # H <- G - tmp/G[k, k] # H[, k] <- G[, k]/G[k, k] # #now replace the (k,k) diagonal element # H[k, ] <- G[, k]/G[k, k] # # and we're done # H[k, k] <- -1./G[k, k] # H #} # # #.wls.all2 <- function(X, w = wts, Y = y, treat = Trt) #{ # # # # This produces coefficient estimates and both standard and robust variances # # estimates for regression with weights # # the standard variance corresponds to a situation where an observation represents # # the mean of w observations # # the robust variance corresponds to a situation where weights represent # # probability or sampling weights # # # # first put together the necessary data inputs # # # nunits <- sum(w > 0) # k <- ncol(X) # ## now the weights, properly normed # wn <- w * (nunits/sum(w)) # W <- diag(wn * (nunits/sum(wn))) # # # # x prime x inverse (including weights) # vhat <- - .sweep.inv((t(X) %*% W %*% X)) # # # # estimated regression coefficients and variance for just the treatment coefficient # b <- vhat %*% t(X) %*% W %*% Y # MSE <- c(t(Y) %*% W %*% Y - t(b) %*% t(X) %*% W %*% Y)/(nunits - k) # var.std <- (vhat * MSE)[2, 2] # # # ###### now for the robust variance calculations # # now a matrix where each row represents the contribution to the score # # for each observation # U <- c((Y - X %*% b) * wn) * X # # finite sample adjustment # qc <- nunits/(nunits - 2) # # the sum of outer products of each of the above score contributions for # # each person is calculated here # prodU <- array(0, c(k, k, nunits)) # for(i in 1:nunits) { # prodU[, , i] <- outer(U[i, ], U[i, ]) # } # # putting it all together... # Vrob <- qc * vhat %*% apply(prodU, c(1, 2), sum) %*% vhat # # and we pull off the variance just for the treatment effect # var.rob <- Vrob[2, 2] # ############### # results <- c(var.std, var.rob, b[2]) # results #} arm/R/sim.R0000644000176200001440000001275313263577474012177 0ustar liggesuserssetMethod("sim", signature(object = "lm"), function(object, n.sims=100) { object.class <- class(object)[[1]] summ <- summary (object) coef <- summ$coef[,1:2,drop=FALSE] dimnames(coef)[[2]] <- c("coef.est","coef.sd") sigma.hat <- summ$sigma beta.hat <- coef[,1,drop = FALSE] V.beta <- summ$cov.unscaled n <- summ$df[1] + summ$df[2] k <- summ$df[1] sigma <- rep (NA, n.sims) beta <- array (NA, c(n.sims,k)) dimnames(beta) <- list (NULL, rownames(beta.hat)) for (s in 1:n.sims){ sigma[s] <- sigma.hat*sqrt((n-k)/rchisq(1,n-k)) beta[s,] <- MASS::mvrnorm (1, beta.hat, V.beta*sigma[s]^2) } ans <- new("sim", coef = beta, sigma = sigma) return (ans) } ) setMethod("sim", signature(object = "glm"), function(object, n.sims=100) { object.class <- class(object)[[1]] summ <- summary (object, correlation=TRUE, dispersion = object$dispersion) coef <- summ$coef[,1:2,drop=FALSE] dimnames(coef)[[2]] <- c("coef.est","coef.sd") beta.hat <- coef[,1,drop=FALSE] sd.beta <- coef[,2,drop=FALSE] corr.beta <- summ$corr n <- summ$df[1] + summ$df[2] k <- summ$df[1] V.beta <- corr.beta * array(sd.beta,c(k,k)) * t(array(sd.beta,c(k,k))) #beta <- array (NA, c(n.sims,k)) # dimnames(beta) <- list (NULL, dimnames(beta.hat)[[1]]) # for (s in 1:n.sims){ # beta[s,] <- MASS::mvrnorm (1, beta.hat, V.beta) # } beta <- MASS::mvrnorm (n.sims, beta.hat, V.beta) # Added by Masanao beta2 <- array (0, c(n.sims,length(coefficients(object)))) dimnames(beta2) <- list (NULL, names(coefficients(object))) beta2[,dimnames(beta2)[[2]]%in%dimnames(beta)[[2]]] <- beta # Added by Masanao sigma <- rep (sqrt(summ$dispersion), n.sims) ans <- new("sim", coef = beta2, sigma = sigma) return(ans) } ) setMethod("sim", signature(object = "polr"), function(object, n.sims=100){ x <- as.matrix(model.matrix(object)) coefs <- coef(object) k <- length(coefs) zeta <- object$zeta Sigma <- vcov(object) if(n.sims==1){ parameters <- t(MASS::mvrnorm(n.sims, c(coefs, zeta), Sigma)) }else{ parameters <- MASS::mvrnorm(n.sims, c(coefs, zeta), Sigma) } ans <- new("sim.polr", coef = parameters[,1:k,drop=FALSE], zeta = parameters[,-(1:k),drop=FALSE]) return(ans) }) #setMethod("sim", signature(object = "mer"), # function(object, n.sims=100) # { # #object <- summary(object) ## if (lapply(object@bVar,sum)<=0|sum(unlist(lapply(object@bVar, is.na)))>0){ ## object@call$control <- list(usePQL=TRUE) ## object <- lmer(object@call$formula) # #} # #sc <- attr (VarCorr (object), "sc") # # simulate unmodeled coefficients # # fcoef <- fixef(object) # corF <- vcov(object)@factors$correlation # se.unmodeled <- corF@sd # V.beta <- (se.unmodeled %o% se.unmodeled) * as.matrix(corF) # beta.unmodeled <- NULL # if (length (fcoef) > 0){ # beta.unmodeled[[1]] <- mvrnorm (n.sims, fcoef, V.beta) # names (beta.unmodeled) <- "unmodeled" # } # # simulate coefficients within groups # #coef <- ranef (object) # #estimate <- ranef(object, postVar=TRUE) # #vars <- object@bVar # #beta.bygroup <- vars # # sc <- attr (VarCorr (object), "sc") # coef <- ranef(object, postVar=TRUE) # beta.bygroup <- c(coef) # n.groupings <- length (coef) # for (m in 1:n.groupings){ # #vars.m <- vars[[m]] # vars.m <- attr (coef[[m]], "postVar") # K <- dim(vars.m)[1] # J <- dim(vars.m)[3] # beta.bygroup[[m]] <- array (NA, c(n.sims, J, K)) # bhat <- coef[[m]] # for (j in 1:J){ # V.beta <- untriangle(vars.m[,,j])#*sc^2 # beta.bygroup[[m]][,j,] <- mvrnorm (n.sims, bhat[j,], V.beta) # } # dimnames (beta.bygroup[[m]]) <- c (list(NULL), dimnames(bhat)) # } # betas <- c (beta.unmodeled, beta.bygroup) # return (betas) # } #) #setMethod("sim", signature(object = "mer"), # function(object, n.sims=100, ranef=TRUE) # { # # simulate unmodeled coefficients # fcoef <- fixef(object) # corF <- vcov(object)@factors$correlation # se.unmodeled <- corF@sd # V.beta <- (se.unmodeled %o% se.unmodeled) * as.matrix(corF) # beta.unmodeled <- NULL # if (length (fcoef) > 0){ # beta.unmodeled[[1]] <- mvrnorm (n.sims, fcoef, V.beta) # names (beta.unmodeled) <- "fixef"#"unmodeled" # coef <- beta.unmodeled # } # if(ranef){ # # simulate coefficients within groups # sc <- attr (VarCorr (object), "sc") # scale # #coef <- ranef (object) # #estimate <- ranef(object, postVar=TRUE) # coef <- ranef(object, postVar=TRUE) # beta.bygroup <- coef # n.groupings <- length (coef) # for (m in 1:n.groupings){ # bhat <- as.matrix(coef[[m]]) # to suit the use of mvrnorm # vars.m <- attr (coef[[m]], "postVar") # K <- dim(vars.m)[1] # J <- dim(vars.m)[3] # beta.bygroup[[m]] <- array (NA, c(n.sims, J, K)) # for (j in 1:J){ # V.beta <- .untriangle(vars.m[,,j])#*sc^2 # beta.bygroup[[m]][,j,] <- mvrnorm (n.sims, bhat[j,], V.beta) # } # dimnames (beta.bygroup[[m]]) <- c (list(NULL), dimnames(bhat)) # } # coef <- c (beta.unmodeled, beta.bygroup) # } # return (coef) # } #) arm/R/invlogit.R0000644000176200001440000000020713014470370013206 0ustar liggesusers#R function for the logistic function logit <- function (x) { log(x/(1-x)) } invlogit <- function (x) { 1/(1+exp(-x)) } arm/R/traceplot.R0000644000176200001440000000407013014470370013352 0ustar liggesusers#traceplot.default <- function(x, ...) coda::traceplot # ======================================================================== # function for trace plot # ======================================================================== #setMethod("traceplot", signature(x = "mcmc.list"), # function (x, smooth = TRUE, col = 1:6, type = "l", ylab = "", ...) #{ # args <- list(...) # for (j in 1:nvar(x)) { # xp <- as.vector(time(x)) # yp <- if (nvar(x) > 1) # x[, j, drop = TRUE] # else x # yp <- do.call("cbind", yp) # matplot(xp, yp, xlab = "Iterations", ylab = ylab, type = type, # col = col, ...) # if (!is.null(varnames(x)) && is.null(list(...)$main)) # title(paste("Trace of", varnames(x)[j])) # if (smooth) { # scol <- rep(col, length = nchain(x)) # for (k in 1:nchain(x)) lines(lowess(xp, yp[, k]), # col = scol[k]) # } # } #} #) # setMethod("traceplot", signature(x = "bugs"), function( x, mfrow = c( 1, 1 ), varname = NULL, match.head = TRUE, ask = TRUE, col = rainbow( x$n.chains ), lty = 1, lwd = 1, ... ) { par( mfrow = mfrow ) par( ask = ask ) n.chain <- x$n.chains n.keep <- x$n.keep bugs.array <- x$sims.array varnamelist <- gsub( "\\[.*\\]","", dimnames( bugs.array )[[3]], fixed = FALSE ) if( is.null( varname ) ){ varname <- ".*" } if( match.head ) { varname <- paste( "^", varname, sep="" ) } index <- unlist( sapply( varname, function( x ){ grep( x, varnamelist ) } ) ) n.var <- length( index ) for( j in index ) { range.x <- c( 1, n.keep ) range.y <- range( bugs.array[,,j] ) v.name <- dimnames( bugs.array )[[3]][j] plot( range.x, range.y, type = "n", main = v.name, xlab = "iteration", ylab = v.name, xaxt = "n", xaxs = "i", ... ) for( i in 1:n.chain ) { x.cord <- 1:n.keep y.cord <- bugs.array[,i,j] lines( x.cord , y.cord , col = col[i], lty = lty, lwd = lwd ) } axis( 1, at = seq(0, n.keep, n.keep*0.1), tick = TRUE ) } } ) arm/R/readColumns.R0000644000176200001440000000044313014470370013631 0ustar liggesusersread.columns <- function (filename, columns){ start <- min(columns) length <- max(columns) - start + 1 if (start == 1) { return(read.fwf(filename, widths = length)) } else { return(read.fwf(filename, widths = c(start - 1, length))[, 2]) } } arm/R/residual.plot.R0000644000176200001440000000225213014470370014142 0ustar liggesusers# ============================================================================== # residual plot for the observed values # ============================================================================== residual.plot <- function ( Expected, Residuals, sigma, main = deparse(substitute( Expected )), col.pts = "blue", col.ctr = "red", col.sgm = "black", cex = 0.5, gray.scale = FALSE, xlab="Predicted", ylab="Residuals", ... ) { if( gray.scale == TRUE ) { col.pts <- "black"; col.ctr <- "black"; col.sgm <- "gray60"; } plot( Expected[!is.na( Residuals )], Residuals[ !is.na( Residuals ) ], xlab = xlab, ylab = ylab, main = main, col = col.pts, pch = 19, cex = cex, ... ); #mtext( "Residuals vs Predicted", 3, cex= 0.6 ) #, adj=1 ); # add the zero line for clarity abline ( h = 0, lty = "dashed", col = col.ctr ); # residual s.e. resid.se <- sigma; # Add two-standard-error lines abline ( h = 2*resid.se, lty = "dashed", col = col.sgm ); abline ( h = -2*resid.se, lty = "dashed", col = col.sgm ); } arm/R/standardize.R0000644000176200001440000000673513014470370013677 0ustar liggesusersstandardize.default <- function(call, unchanged=NULL, standardize.y=FALSE, binary.inputs="center"){ form <- call$formula varnames <- all.vars (form) n.vars <- length (varnames) # # Decide which variables will be unchanged # transform <- rep ("leave.alone", n.vars) if (standardize.y) { transform[1] <- "full" } for (i in 2:n.vars){ v <- varnames[i] if (is.null(call$data)) { thedata <- get(v) } else { thedata <- get(as.character(call$data))[[v]] } if (is.na(match(v,unchanged))){ num.categories <- length (unique(thedata[!is.na(thedata)])) if (num.categories==2){ transform[i] <- binary.inputs } else if (num.categories>2 & is.numeric(thedata)){ transform[i] <- "full" } } } # # New variable names: # prefix with "c." if centered or "z." if centered and scaled # varnames.new <- ifelse (transform=="leave.alone", varnames, ifelse (transform=="full", paste ("z", varnames, sep="."), paste ("c", varnames, sep="."))) transformed.variables <- (1:n.vars)[transform!="leave.alone"] #Define the new variables if (is.null(call$data)) { for (i in transformed.variables) { assign(varnames.new[i], rescale(get(varnames[i]), binary.inputs)) } } else { newvars <- NULL for (i in transformed.variables) { assign(varnames.new[i], rescale(get(as.character(call$data))[[varnames[i]]], binary.inputs)) newvars <- cbind(newvars, get(varnames.new[i])) } assign(as.character(call$data), cbind(get(as.character(call$data)), newvars)) } # Now call the regression with the new variables call.new <- call L <- sapply (as.list (varnames.new), as.name) names(L) <- varnames call.new$formula <- do.call (substitute, list (form, L)) formula <- as.character (call.new$formula) if (length(formula)!=3) stop ("formula does not have three components") formula <- paste (formula[2],formula[1],formula[3]) formula <- gsub ("factor(z.", "factor(", formula, fixed=TRUE) formula <- gsub ("factor(c.", "factor(", formula, fixed=TRUE) call.new$formula <- as.formula (formula) return (eval (call.new)) } setMethod("standardize", signature(object = "lm"), function(object, unchanged=NULL, standardize.y=FALSE, binary.inputs="center") { call <- object$call out <- standardize.default(call=call, unchanged=unchanged, standardize.y=standardize.y, binary.inputs=binary.inputs) return(out) } ) setMethod("standardize", signature(object = "glm"), function(object, unchanged=NULL, standardize.y=FALSE, binary.inputs="center") { call <- object$call out <- standardize.default(call=call, unchanged=unchanged, standardize.y=standardize.y, binary.inputs=binary.inputs) return(out) } ) setMethod("standardize", signature(object = "polr"), function(object, unchanged=NULL, standardize.y=FALSE, binary.inputs="center") { call <- object$call out <- standardize.default(call=call, unchanged=unchanged, standardize.y=standardize.y, binary.inputs=binary.inputs) return(out) } ) setMethod("standardize", signature(object = "merMod"), function(object, unchanged=NULL, standardize.y=FALSE, binary.inputs="center") { call <- object@call out <- standardize.default(call=call, unchanged=unchanged, standardize.y=standardize.y, binary.inputs=binary.inputs) return(out) } ) arm/R/go.R0000644000176200001440000000375413014470370011772 0ustar liggesusers # Name: go(..., add=FALSE,timer=FALSE) # Description: Like source() but recalls the last source file names by default. Multiple source files can be specified. # Parameters: ... = list of filenames as character strings; # add = add these names to the current list? if replace, then FALSE # Note: does not pass parameters to source() # Example: go('myprog') # will run source('myprog.r') # go() # will run source('myprog.r') again # go('somelib',add=TRUE) # will run source('myprog.r') and source('somelib.r') # go('myprog','somelib') # same as above # go('mytest') # will run source('mytest') only # go() # runs source('mytest') again # Reference: jouni@kerman.com, kerman@stat.columbia.edu # Modified: 2004-06-22 # go <- function(..., add=FALSE, timer=FALSE) { last.sources <- getOption(".Last.Source") sources <- unlist(list(...)) if (length(sources)<1) { sources <- last.sources } else if (add) { sources <- c(last.sources,sources) } if (length(sources)<1) { return(cat("Usage: go('sourcefile', 'sourcefile2', ..., add=?, timer=?)\n")) } options(".Last.Source"=sources) cat("Source file(s): ",sources,"\n") yy <- NULL for (src in sources) { if (is.na(src)) { next } if (!file.exists(src)) { src2 <- paste(src, ".R", sep="") if (file.exists(src2)) src <- src2 else { cat("source('",src,"') : file does not exist.\n",sep='') next } } cat("source('",src,"')\n",sep="") if (timer) cat("source('",src,"') : ",max(na.omit(system.time(source(src)))), " seconds elapsed.\n", sep='') else yy[[src]] <- source(src) } invisible(yy) } # By entering "G" on the console, go() is run. This is faster than typing "go()"... print.GO <- function(x,...) {go()} G <- structure(NA, class="GO") #class(G) <- "GO" # end of go.R arm/R/balance.R0000644000176200001440000002152414301551502012742 0ustar liggesusers# balance function after 2019 balance <- function (rawdata, treat, matched, estimand="ATT") #factor = TRUE) { # rawdata: the full covariate dataset # treat: the vector of treatment assignments for the full dataset # matched: vector of weights to apply to the full dataset to create the # restructured data: # --for matching without replacement these will all be 0's and 1's # --for one-to-one matching with replacement these will all be non-negative # integers # --for IPTW or more complicated matching methods these could be any # non-negative numbers # estimand: can either be ATT, ATC, or ATE #require("Hmisc") if(missing(rawdata)) stop("rawdata is required") if(missing(matched)) stop("argument matched is required") if(missing(treat)) stop("treatment vector (treat) is required") cat("Balance diagnostics assume that the estimand is the",estimand,"\n") # #raw.dat <- data.frame(rawdata, treat = treat) covnames <- colnames(rawdata) if (is.null(covnames)){ cat("No covariate names provided. Generic names will be generated.") covnames = paste("v",c(1:ncol(rawdata)),sep="") } K <- length(covnames) diff.means <- matrix(NA, K, 5) var.t <- numeric(K) var.c <- numeric(K) std.denom <- numeric(K) binary <- rep(1,K) # # First we calculate balance on the RAW DATA # Columns are (1) treat mean, (2) control mean, (3) diff in means, (4) abs std diff, # (5) ratio of sds for (i in 1:K) { # separate means by group diff.means[i, 1] <- mean(rawdata[treat==1, i]) diff.means[i, 2] <- mean(rawdata[treat==0, i]) # separate variances by group == only used as input to calculations below var.t[i] <- var(rawdata[(treat == 1), i]) var.c[i] <- var(rawdata[(treat == 0), i]) # denominator in standardized difference calculations if(estimand=="ATE"){std.denom[i] <- sqrt((var.t[i]+var.c[i])/2)} else{ std.denom[i] <- ifelse(estimand=="ATT",sqrt(var.t[i]),sqrt(var.c[i])) } # difference in means diff.means[i, 3] <- diff.means[i, 1] - diff.means[i, 2] # standardized difference in means (sign intact) diff.means[i, 4] <- abs(diff.means[i, 3]/std.denom[i]) if(length(unique(rawdata[,covnames[i]]))>2){ binary[i] = 0 } } #ifelse(estimand="ATT",sqrt(var.c[i]/var.t[i]),sqrt(var.t[i]/var.c[i])) # dimnames(diff.means) <- list(covnames[-(K + 1)], c("treat", "control", "unstd.diff", # "abs.std.diff", "ratio")) # diff.means[is.na(diff.means)] = "--" #maybe only worry about in print function dimnames(diff.means) <- list(covnames, c("treat", "control", "unstd.diff", "abs.std.diff", "ratio")) # Now we calculate balance on the restructured data diff.means.matched = matrix(NA, K, 5) # for (i in 1:K) { wts0 <- matched[treat==0] # separate means by group diff.means.matched[i, 1] <- mean(rawdata[treat == 1, i]) diff.means.matched[i, 2] <- weighted.mean(rawdata[treat==0, i],w=wts0) # separate variances by group == only used as input to calculations below # these overwrite the variance above var.t[i] <- var(rawdata[treat == 1, i]) var.c[i] <- as.numeric(stats::cov.wt(rawdata[treat == 0, i, drop = FALSE], wt = wts0)$cov) # difference in means diff.means.matched[i, 3] <- diff.means.matched[i, 1] - diff.means.matched[i, 2] # absolute standardized difference in means (denominator is stolen from # calculations on raw data above) diff.means.matched[i, 4] <- abs(diff.means.matched[i, 3])/std.denom[i] if(length(unique(rawdata[,covnames[i]]))>2){ # just for binary # ratio of sds (treat over control: should we change to comparison over inferential) diff.means.matched[i, 5] <- sqrt(var.c[i]/var.t[i]) } } #dimnames(diff.means.matched) <- list(covnames[-(K + 1)], c("treat", "control", "unstd.diff", # "abs.std.diff", "ratio")) dimnames(diff.means.matched) <- list(covnames, c("treat", "control", "unstd.diff", "abs.std.diff", "ratio")) # out <- list(diff.means.raw = diff.means, diff.means.matched = diff.means.matched, covnames = covnames, binary = binary) class(out) <- "balance" return(out) } print.balance <- function(x, ..., combined=FALSE, digits= 2) { if(combined==FALSE){ cat("Balance Statistics for Unmatched Data\n") cat("--\n") print(round(x$diff.means.raw, digits=digits)) cat("--\n") cat("\n") cat("Balance Statistics for Matched Data\n") cat("--\n") print(round(x$diff.means.matched, digits=digits), na.print="--") cat("--\n") cat("\n") } else{ cat("Balance Statistics\n") cat("--\n") print(round(cbind(x$diff.means.raw,x$diff.matched.raw)[,c(4,9,5,10)], digits=digits), na.print="--") } } ### NEXT NEED TO FIGURE OUT HOW TO REVERSE THE ORDER OF THE COVARIATES plot.balance <- function(x, longcovnames=NULL, which.covs="mixed", v.axis=TRUE, cex.main=1, cex.vars=1, cex.pts=1, mar=c(4, 3, 5.1, 2), plot=TRUE, x.max = NULL,...) { # if which.covs = mixed then it plots all as std diffs # if which.covs = binary it only plots binary and as abs unstd diffs # if which.covs = cont it only plots non-binary and as abs std diffs # covnames <- x$covnames if(!is.null(x.max)){ x.range = c(0,x.max) } # if(which.covs=="binary") { # cat("condition satisfied \n") # } # if plotting all, then use the standardized diff for all if(which.covs == "mixed"){ pts <- x$diff.means.raw[,4] # before matched.dat pts2 <- x$diff.means.matched[,4] # after matched K <- length(pts) idx <- 1:K main="Absolute Standardized Difference in Means" } #if plotting just binary use the unstandardized difference # for the plot make it the absolute value of if(which.covs == "binary"){ pts <- abs(x$diff.means.raw[x$binary==TRUE,3]) # before matched.dat pts2 <- abs(x$diff.means.matched[x$binary==TRUE,3]) # after matched K <- length(pts) idx <- 1:K main="Absolute Difference in Means" covnames = covnames[x$binary==TRUE] } #if plotting just continuous use the standardized difference if(which.covs == "cont"){ pts <- x$diff.means.raw[x$binary==FALSE,4] # before matched pts2 <- x$diff.means.matched[x$binary==FALSE,4] # after matched K <- length(pts) idx <- 1:K main="Absolute Standardized Difference in Means" covnames = covnames[x$binary==FALSE] } cat(pts,"\n") # tune the graphic console #par (mar=mar, mgp=mgp, oma=oma, tcl=tcl) par(mar = mar) if (is.null(longcovnames)) { longcovnames <- covnames maxchar <- max(sapply(longcovnames, nchar)) } else { maxchar <- max(sapply(longcovnames, nchar)) } min.mar <- par("mar") mar[2] <- max(min.mar[2], trunc(mar[2] + maxchar/10)) + mar[2] + 0.5 par(mar = mar) ## now reverse the order of everything so the plot proceeds from ## to top to bottom with respect to original ordering of variables pts = rev(pts) pts2 = rev(pts2) longcovnames = rev(longcovnames) if(plot){ # plot the estimates if(is.null(x.max)){ plot(c(pts,pts2), c(idx,idx), #xlim=c(0, max(c(pts,pts2))), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", type="n", main=main, cex.main=cex.main) } if(!is.null(x.max)){ plot(c(pts,pts2), c(idx,idx), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", type="n", xlim=x.range, main=main, cex.main=cex.main) } abline(v=0, lty=2) points(pts, idx, cex=cex.pts) # before matched points(pts2, idx, pch=19, cex=cex.pts) # after matched if (v.axis){ axis(3) } if (is.null(longcovnames)){ axis(2, at=1:K, labels=covnames[1:K], las=2, hadj=1, lty=0, cex.axis=cex.vars) } else{ axis(2, at=1:K, labels=longcovnames[1:K], las=2, hadj=1, lty=0, cex.axis=cex.vars) } } else{ plot(c(pts,pts2), c(idx,idx), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", #xaxs="i", #yaxs="i", type="n", axes=FALSE, #ylim=c(max(idx)+.25, min(idx)-.25), #xlim=x.range, main="", cex.main=cex.main,...) } return(list("raw"=pts, "matched"=pts2)) } arm/R/rescale.R0000644000176200001440000000141713014470370012775 0ustar liggesusers# Function for standardizing regression predictors by dividing by 2 sd' rescale <- function (x, binary.inputs="center"){ # function to rescale by subtracting the mean and dividing by 2 sd's if (!is.numeric(x)){ x <- as.numeric(factor(x)) x.obs <- x[!is.na(x)] } x.obs <- x[!is.na(x)] # for binary cases if (length(unique(x.obs))==2){ if (binary.inputs=="0/1"){ x <- (x-min(x.obs))/(max(x.obs)-min(x.obs)) return (x) } else if (binary.inputs=="-0.5,0.5"){ return (x-0.5) } else if (binary.inputs=="center"){ return (x-mean(x.obs)) } else if (binary.inputs=="full"){ return ((x-mean(x.obs))/(2*sd(x.obs))) } } else { return ((x-mean(x.obs))/(2*sd(x.obs))) } } arm/R/triangleplot.R0000644000176200001440000001214013014470370014056 0ustar liggesusers triangleplot <- function (x, y = NULL, cutpts = NULL, details = TRUE, n.col.legend = 5, cex.col = 0.7, cex.var = 0.9, digits = 1, color = FALSE) { if (!is.matrix(x)) stop("x must be a matrix!") if (dim(x)[1] != dim(x)[2]) stop("x must be a square matrix!") x.na <- x x.na[is.na(x.na)] <- -999 z.plot <- x if (is.null(y)) { z.names <- dimnames(x)[[2]] } else { z.names <- y } for (i in 1:dim(z.plot)[1]) for (j in i:dim(z.plot)[2]) z.plot[i, j] <- NA layout(matrix(c(2, 1), 1, 2, byrow = FALSE), c(10.5, 1.5)) layout(matrix(c(2, 1), 1, 2, byrow = FALSE), c(10.5, 1.5)) if (is.null(cutpts)) { if (details) { neg.check <- abs(sum(z.plot[z.plot < 0], na.rm = T)) if (neg.check > 0) { z.breaks <- sort(c(0, seq(min(z.plot, na.rm = T), max(z.plot, na.rm = T), length = n.col.legend))) } else { z.breaks <- seq(min(z.plot, na.rm = T), max(z.plot, na.rm = T), length = n.col.legend + 1) } for (i in 1:4) { n1 <- length(unique(round(z.breaks, digits = digits))) n2 <- length(z.breaks) ifelse((n1 != n2), digits <- digits + 1, digits <- digits) } if (digits > 3) { stop("Too many digits! Try to adjust n.col.legend to get better presentation!") } } else { postive.z <- na.exclude(unique(round(z.plot[z.plot > 0], digits = digits))) neg.check <- abs(sum(z.plot[z.plot < 0], na.rm = T)) ifelse(neg.check > 0, negative.z <- na.exclude(unique(round(z.plot[z.plot < 0], digits = digits))), negative.z <- 0) max.z <- max(z.plot, na.rm = T) min.z <- min(z.plot, na.rm = T) z.breaks <- sort(unique(c(postive.z, negative.z))) n.breaks <- length(z.breaks) l.legend <- ceiling(n.col.legend/2) if (n.breaks > 8) { if (neg.check > 0) { postive.z <- seq(0, max(postive.z), length = l.legend + 1) negative.z <- seq(min(negative.z), 0, length = l.legend) z.breaks <- sort(unique(c(postive.z, negative.z))) n.breaks <- length(z.breaks) z.breaks[1] <- min.z z.breaks[n.breaks] <- max.z n.col.legend <- length(z.breaks) - 1 } else { postive.z <- seq(0, max(postive.z), length = n.col.legend + 1) z.breaks <- sort(unique(c(postive.z, negative.z))) n.breaks <- length(z.breaks) z.breaks[1] <- min.z z.breaks[n.breaks] <- max.z n.col.legend <- length(z.breaks) - 1 } } else { if (neg.check > 0) { z.breaks <- sort(c(0, seq(min(z.plot, na.rm = T), max(z.plot, na.rm = T), length = n.col.legend))) } else { z.breaks <- seq(min(z.plot, na.rm = T), max(z.plot, na.rm = T), length = n.col.legend + 1) } } } } if (!is.null(cutpts)) { z.breaks = cutpts n.breaks <- length(z.breaks) n.col.legend <- length(z.breaks) - 1 } if (color) { z.colors <- heat.colors(n.col.legend)[n.col.legend:1] } else { z.colors <- gray(n.col.legend:1/n.col.legend) } par(mar = c(0.5, 0.1, 2, 0.1), pty = "m") plot(c(0, 1), c(min(z.breaks), max(z.breaks)), type = "n", bty = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n") for (i in 2:(length(z.breaks))) { rect(xleft = 0.5, ybottom = z.breaks[i - 1], xright = 1, ytop = z.breaks[i], col = z.colors[i - 1]) text(x = 0.45, y = z.breaks[i - 1], labels = format(round(z.breaks[i - 1], digits)), cex = cex.col, adj = 1, xpd = TRUE) } rect(xleft = 0.5, ybottom = z.breaks[length(z.breaks)], xright = 1, ytop = z.breaks[length(z.breaks)], col = z.colors[length(z.colors)]) text(x = 0.45, y = z.breaks[length(z.breaks)], labels = format(round(z.breaks[length(z.breaks)], digits)), cex = cex.col, adj = 1, xpd = TRUE) par(mar = c(0.1, 0.1, 2, 0.1), pty = "m") image(x = 1:dim(z.plot)[1], y = 1:dim(z.plot)[2], z = z.plot, xaxt = "n", yaxt = "n", bty = "n", col = z.colors, breaks = z.breaks, xlim = c(-2, dim(z.plot)[1] + 0.5), ylim = c(-1, dim(z.plot)[2] + 0.5), xlab = "", ylab = "") text(x = 1:dim(z.plot)[1], y = 1:dim(z.plot)[2], labels = z.names, cex = cex.var, adj = 1, xpd = TRUE) for (i in 1:dim(z.plot)[1]) { for (j in i:dim(z.plot)[2]) { if (x.na[i, j] == -999 & i != j) points(x = j, y = i, pch = "x", cex = 0.9) } } } arm/R/load.first.R0000644000176200001440000000056213014470370013424 0ustar liggesusers.onAttach <- function(...) { mylib <- dirname(system.file(package = "arm")) ver <- packageDescription("arm", lib.loc = mylib)$Version builddate <- packageDescription("arm", lib.loc = mylib)$Date packageStartupMessage(paste("\narm (Version ", ver, ", built: ", builddate, ")\n", sep = "")) packageStartupMessage("Working directory is ", getwd(), "\n") } arm/R/display.R0000644000176200001440000003242214602510623013024 0ustar liggesuserssetMethod("display", signature(object = "lm"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call summ <- summary (object) out$sigma.hat <- summ$sigma out$r.squared <- summ$r.squared if(detail){ coef <- summ$coef[,,drop=FALSE] } else{ coef <- summ$coef[,1:2,drop=FALSE] } dimnames(coef)[[2]][1:2] <- c("coef.est","coef.se") out$coef <- coef[,"coef.est"]#,drop=FALSE] out$se <- coef[,"coef.se"]#,drop=FALSE] out$t.value <- summ$coef[,3] out$p.value <- summ$coef[,4] out$n <- summ$df[1] + summ$df[2] out$k <- summ$df[1] print (out$call) pfround (coef, digits) cat("---\n") cat (paste ("n = ", out$n, ", k = ", out$k, "\nresidual sd = ", fround (out$sigma.hat, digits), ", R-Squared = ", fround (out$r.squared, 2), "\n", sep="")) return(invisible(out)) } ) setMethod("display", signature(object = "bayesglm"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call summ <- summary(object, dispersion = object$dispersion) if(detail){ coef <- summ$coefficients coef[ rownames( coef ) %in% rownames( summ$coef[, , drop = FALSE]) , ] <- summ$coef[ , , drop = FALSE ] out$z.value <- coef[,3]#,drop=FALSE] out$p.value <- coef[,4]#,drop=FALSE] } else{ coef <- matrix( NA, length( object$coefficients ),2 ) rownames(coef) <- names( object$coefficients ) ## M coef[ rownames( coef ) %in% rownames( summ$coef[, 1:2, drop = FALSE]) , ] <- summ$coef[ , 1:2, drop = FALSE ] ## M } dimnames(coef)[[2]][1:2] <- c( "coef.est", "coef.se") out$coef <- coef[,"coef.est"]#,drop=FALSE] out$se <- coef[,"coef.se"]#,drop=FALSE] out$n <- summ$df[1] + summ$df[2] out$k <- summ$df[1] out$deviance <- summ$deviance out$null.deviance <- summ$null.deviance print(out$call) pfround(coef, digits) cat("---\n") cat(paste("n = ", out$n, ", k = ", out$k, "\nresidual deviance = ", fround(out$deviance, 1), ", null deviance = ", fround(out$null.deviance, 1), " (difference = ", fround(out$null.deviance - out$deviance, 1), ")", "\n", sep = "")) out$dispersion <- if (is.null(object$dispersion)){ summ$dispersion } else { object$dispersion } if (out$dispersion != 1) { out$overdispersion.parameter <- out$dispersion cat(paste("overdispersion parameter = ", fround(out$dispersion, 1), "\n", sep = "")) if (family(object)$family == "gaussian") { out$sigma.hat <- sqrt(out$dispersion) cat(paste("residual sd is sqrt(overdispersion) = ", fround(out$sigma.hat, digits), "\n", sep = "")) } } return(invisible(out)) } ) #setMethod("display", signature(object = "bayesglm.h"), # function (object, digits = 2, detail = FALSE) # { # call <- object$call # summ <- summary(object, dispersion = object$dispersion) # if(detail){ # coef <- summ$coefficients # coef[ rownames( coef ) %in% rownames( summ$coef[, , drop = FALSE]) , ] <- summ$coef[ , , drop = FALSE ] # } # else{ # coef <- matrix( NA, length( object$coefficients ),2 ) # rownames(coef) <- names( object$coefficients ) ## M # coef[ rownames( coef ) %in% rownames( summ$coef[, 1:2, drop = FALSE]) , ] <- summ$coef[ , 1:2, drop = FALSE ] ## M # } # dimnames(coef)[[2]][1:2] <- c( "coef.est", "coef.se") # #n <- summ$df[1] + summ$df[2] # n <- summ$df.residual # k <- summ$df[1] # print(call) # if(max(object$batch)>0){ # nn<- strsplit( rownames( coef )[seq( from= length( object$batch ) + 1 ,to = nrow( coef ))], "." , fixed=TRUE) # bb<- c( object$batch,unlist( lapply (nn , function( lst ) { lst[[3]] } ) ) ) # } # else {bb<- c( object$batch)} # cc<- cbind( fround( coef, digits ), bb ) # dimnames(cc)[[2]][3]<-"batch" # print( cc , quote = FALSE ) # cat("---\n") # cat(paste("n = ", n, ", k = ", k, "\nresidual deviance = ", # fround(summ$deviance, 1), ", null deviance = ", fround(summ$null.deviance, # 1), " (difference = ", fround(summ$null.deviance - # summ$deviance, 1), ")", "\n", sep = "")) # dispersion <- if (is.null(object$dispersion)) # summ$dispersion # else object$dispersion # if (dispersion != 1) { # cat(paste("overdispersion parameter = ", fround(dispersion, # 1), "\n", sep = "")) # if (family(object)$family == "gaussian") { # cat(paste("residual sd is sqrt(overdispersion) = ", # fround(sqrt(dispersion), digits), "\n", sep = "")) # cat(paste("group sd is sigma.batch = ", # fround(object$sigma.batch, digits), "\n", sep = "")) # } # } # } #) setMethod("display", signature(object = "glm"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call summ <- summary(object, dispersion = object$dispersion) if(detail){ coef <- summ$coef[, , drop = FALSE] out$z.value <- coef[,3]#,drop=FALSE] out$p.value <- coef[,4]#,drop=FALSE] } else{ coef <- summ$coef[, 1:2, drop = FALSE] } dimnames(coef)[[2]][1:2] <- c("coef.est", "coef.se") out$n <- summ$df[1] + summ$df[2] out$k <- summ$df[1] out$coef <- coef[,"coef.est"] out$se <- coef[,"coef.se"] print(out$call) pfround(coef, digits) out$deviance <- summ$deviance out$null.deviance <- summ$null.deviance cat("---\n") cat(paste(" n = ", out$n, ", k = ", out$k, "\n residual deviance = ", fround(out$deviance, 1), ", null deviance = ", fround(out$null.deviance, 1), " (difference = ", fround(summ$null.deviance - summ$deviance, 1), ")", "\n", sep = "")) out$dispersion <- if (is.null(object$dispersion)){ summ$dispersion } else { object$dispersion } if (out$dispersion != 1) { cat(paste(" overdispersion parameter = ", fround(out$dispersion, 1), "\n", sep = "")) if (family(object)$family=="gaussian") { out$sigma.hat <- sqrt(out$dispersion) cat(paste(" residual sd is sqrt(overdispersion) = ", fround(out$sigma.hat, digits), "\n", sep = "")) } } return(invisible(out)) } ) #setMethod("display", signature(object = "mer"), # function(object, digits=2) # { # call <- object@call # print (call) # #object <- summary(object) # fcoef <- fixef(object) # useScale <- attr( VarCorr(object), "sc") # corF <- vcov(object)@factors$correlation # coefs <- cbind(fcoef, corF@sd) # if (length (fcoef) > 0){ # dimnames(coefs) <- list(names(fcoef), c("coef.est", "coef.se")) # pfround (coefs, digits) # } # cat("\nError terms:\n") # vc <- as.matrix.VarCorr (VarCorr (object), useScale=useScale, digits) # print (vc[,c(1:2,4:ncol(vc))], quote=FALSE) # ngrps <- lapply(object@flist, function(x) length(levels(x))) # REML <- object@status["REML"] # llik <- logLik(object, REML) # AIC <- AIC(llik) # dev <- object@deviance["ML"] # Dbar # n <- object@devComp["n"] # Dhat <- -2*(llik) # Dhat # pD <- dev - Dhat # pD # DIC <- dev + pD # DIC=Dbar+pD=Dhat+2pD # cat("---\n") # cat(sprintf("number of obs: %d, groups: ", n)) # cat(paste(paste(names(ngrps), ngrps, sep = ", "), collapse = "; ")) # cat(sprintf("\nAIC = %g, DIC = ", fround(AIC, 1))) # cat(fround(DIC, 1)) # cat("\ndeviance =", fround (dev, 1), "\n") # if (useScale < 0){ # cat("overdispersion parameter =", fround (.Call("mer_sigma", # object, FALSE, PACKAGE = "lme4"), 1), "\n") # } # } #) setMethod("display", signature(object = "merMod"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object@call print (out$call) #object <- summary(object) #summ <- summary(object) fcoef <- fixef(object) #coefs <- attr(summ, "coefs") #useScale <- attr (VarCorr (object), "sc") useScale <- getME(object, "devcomp")$dims["useSc"] corF <- vcov(object)@factors$correlation coefs <- cbind(fcoef, corF@sd) if (length (fcoef) > 0){ if (!useScale) { coefs <- coefs[, 1:2, drop = FALSE] out$z.value <- coefs[, 1]/coefs[, 2] out$p.value <- 2 * pnorm(abs(out$z.value), lower.tail = FALSE) coefs <- cbind(coefs, `z value` = out$z.value, `Pr(>|z|)` = out$p.value) } else { out$t.value <- coefs[, 1]/coefs[, 2] coefs <- cbind(coefs, `t value` = out$t.value) } dimnames(coefs)[[2]][1:2] <- c("coef.est", "coef.se") if(detail){ pfround (coefs, digits) } else{ pfround(coefs[,1:2], digits) } } out$coef <- coefs[,"coef.est"] out$se <- coefs[,"coef.se"] cat("\nError terms:\n") vc <- as.matrix.VarCorr (VarCorr (object), useScale=useScale, digits=digits) print (vc[,c(1:2,4:ncol(vc))], quote=FALSE) out$ngrps <- lapply(object@flist, function(x) length(levels(x))) is_REML <- isREML(object) llik <- logLik(object, REML=is_REML) out$AIC <- AIC(llik) out$deviance <- deviance(refitML(object)) # Dbar out$n <- getME(object, "devcomp")$dims["n"] Dhat <- -2*(llik) # Dhat pD <- out$deviance - Dhat # pD out$DIC <- out$deviance + pD # DIC=Dbar+pD=Dhat+2pD cat("---\n") cat(sprintf("number of obs: %d, groups: ", out$n)) cat(paste(paste(names(out$ngrps), out$ngrps, sep = ", "), collapse = "; ")) cat(sprintf("\nAIC = %g, DIC = ", round(out$AIC,1))) cat(round(out$DIC, 1)) cat("\ndeviance =", fround (out$deviance, 1), "\n") if (useScale < 0){ out$sigma.hat <- .Call("mer_sigma", object, FALSE, PACKAGE = "lme4") cat("overdispersion parameter =", fround (out$sigma.hat, 1), "\n") } return(invisible(out)) } ) setMethod("display", signature(object = "polr"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call summ <- summary(object) if(detail){ coef <- summ$coef[, , drop = FALSE] out$t.value <- coef[,"t value"] } else{ coef <- summ$coef[, 1:2, drop = FALSE] } dimnames(coef)[[2]][1:2] <- c("coef.est", "coef.se") out$coef <- coef[,"coef.est"] out$se <- coef[,"coef.se"] out$n <- summ$n out$k <- nrow (coef) out$k.intercepts <- length (summ$zeta) print(out$call) pfround(coef, digits) cat("---\n") cat(paste("n = ", out$n, ", k = ", out$k, " (including ", out$k.intercepts, " intercepts)\nresidual deviance = ", fround(deviance(object), 1), ", null deviance is not computed by polr", "\n", sep = "")) #cat("AIC:", fround(AIC(object), 1), "\n") return(invisible(out)) } ) setMethod("display", signature(object = "svyglm"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call out$survey.design <- object$survey.design summ <- summary(object) if(detail){ coef <- summ$coef[, , drop = FALSE] out$z.value <- coef[,3]#,drop=FALSE] out$p.value <- coef[,4]#,drop=FALSE] } else{ coef <- summ$coef[, 1:2, drop = FALSE] } dimnames(coef)[[2]][1:2] <- c("coef.est", "coef.se") out$n <- summ$df[1] + summ$df[2] out$k <- summ$df[1] out$coef <- coef[,"coef.est"] out$se <- coef[,"coef.se"] print(out$call) cat("\n") print(out$survey.design) cat("\n") pfround(coef, digits) out$deviance <- summ$deviance out$null.deviance <- summ$null.deviance cat("---\n") cat(paste(" n = ", out$n, ", k = ", out$k, "\n residual deviance = ", fround(out$deviance, 1), ", null deviance = ", fround(out$null.deviance, 1), " (difference = ", fround(summ$null.deviance - summ$deviance, 1), ")", "\n", sep = "")) out$dispersion <- summ$dispersion[1] if (out$dispersion != 1) { cat(paste(" overdispersion parameter = ", fround(out$dispersion, 1), "\n", sep = "")) if (family(object)$family=="gaussian") { out$sigma.hat <- sqrt(out$dispersion) cat(paste(" residual sd is sqrt(overdispersion) = ", fround(out$sigma.hat, digits), "\n", sep = "")) } } return(invisible(out)) } ) #setMethod("display", signature(object = "bayespolr"), # function(object, digits=2) # { # call <- object$call # summ <- summary(object) # coef <- summ$coef[, 1:2, drop = FALSE] # dimnames(coef)[[2]] <- c("coef.est", "coef.se") # n <- summ$n # or maybe should be "nobs", I don't know for sure # k <- nrow (coef) # k.intercepts <- length (summ$zeta) # print(call) # pfround(coef, digits) # cat("---\n") # cat(paste("n = ", n, ", k = ", k, " (including ", k.intercepts, # " intercepts)\nresidual deviance = ", # fround(summ$deviance, 1), # ", null deviance is not computed by bayespolr", # "\n", sep = "")) # } #) arm/R/fitted.R0000644000176200001440000000271213014470370012635 0ustar liggesusers # the plan here is to shuffle the ranefs back into the way a merMod object # stores them so that a simple X * beta + Z * theta op does the trick fitted.sim.merMod <- function(object, regression,...){ if (missing(regression) || is.null(regression)) stop("fitted for sim.mer requires original merPred object as well."); if (!inherits(regression, "merMod")) stop("regression argument for fitted on sim.mer does not inherit from class 'merMod'"); sims <- object; numSimulations <- dim(sims@fixef)[1]; devcomp <- getME(regression, "devcomp"); dims <- devcomp$dims; numRanef <- dims[["q"]]; numLevels <- dims[["reTrms"]]; simulatedRanef <- matrix(0, numRanef, numSimulations); index <- 0; for (i in 1:length(sims@ranef)) { levelSims <- sims@ranef[[i]]; numCoefficientsPerLevel <- dim(levelSims)[2]; numGroupsPerLevel <- dim(levelSims)[3]; for (j in 1:numCoefficientsPerLevel) { ranefRange <- index + 1:numGroupsPerLevel; index <- index + numGroupsPerLevel; simulatedRanef[ranefRange,] <- t(levelSims[,j,]); } } X <- getME(regression, "X"); Zt <- getME(regression, "Zt"); linearPredictor <- as.matrix(tcrossprod(X, sims@fixef) + crossprod(Zt, simulatedRanef)) + matrix(getME(regression, "offset"), dims[["n"]], numSimulations); if (dims[["GLMM"]] == 0L){ return(linearPredictor) }else{ return(regression@resp$family$linkinv(linearPredictor)) } }; arm/R/AllGeneric.R0000644000176200001440000000262213014470370013363 0ustar liggesusers #setGeneric("coef") #setGeneric("print") #setGeneric("fitted") #setGeneric("extractAIC") if (!isGeneric("coefplot")) { setGeneric("coefplot", function(object, ...) standardGeneric("coefplot")) } if (!isGeneric("display")) { setGeneric("display", function(object, ...) standardGeneric("display")) } if (!isGeneric("sim")) { setGeneric("sim", function(object, ...) standardGeneric("sim")) } sigma.hat <- function(object,...){ UseMethod("sigma.hat") } if (!isGeneric("se.coef")) { setGeneric("se.coef", function(object, ...) standardGeneric("se.coef")) } if (!isGeneric("mcsamp")) { setGeneric("mcsamp", function(object, ...) standardGeneric("mcsamp")) } if (!isGeneric("standardize")) { setGeneric("standardize", function(object, ...) standardGeneric("standardize")) } #if (!isGeneric("terms.bayes")) { # setGeneric("terms.bayes", # function(x, ...) # standardGeneric("terms.bayes")) #} if (!isGeneric("traceplot")) { setGeneric("traceplot", function(x, ...) standardGeneric("traceplot"), useAsDefault = function(x, ...) coda::traceplot(x, ...)) } arm/R/coef.R0000644000176200001440000000125613014470370012274 0ustar liggesusers coef.sim <- function(object,...){ ans <- object@coef return(ans) } coef.sim.polr <- function(object, slot=c("ALL", "coef", "zeta"),...){ slot <- match.arg(slot) if(slot=="coef"){ ans <- object@coef } else if(slot=="zeta"){ ans <- object@zeta } else { ans <- cbind(object@zeta, object@coef) } return(ans) } coef.sim.merMod <- function(object,...){ fef <- object@fixef ref <- object@ranef ans <- list("fixef" = fef, "ranef" = ref) return(ans) } fixef.sim.merMod <- function(object,...){ ans <- object@fixef return(ans) } ranef.sim.merMod <- function(object,...){ ans <- object@ranef return(ans) } arm/R/sigma.hat.R0000644000176200001440000000350313014470370013230 0ustar liggesusers sigma.hat.lm <- function(object,...){ sigma <- summary(object)$sigma return (sigma) } sigma.hat.glm <- function(object,...){ dispersion <- if (is.null(object$dispersion)){ summary(object)$dispersion } else{ object$dispersion } if (object$family$family == "gaussian") { sigma <- sqrt(dispersion) } else { sigma <- summary(object, correlation = TRUE)$sigma #sigma <- sqrt(deviance(object)/df.residual(object)) } return(sigma) } sigma.hat.sim <- function(object,...){ sigma <- object@sigma return (sigma) } sigma.hat.merMod <- function(object,...){ #object <- summary (object) fcoef <- fixef(object) #useScale <- attr (VarCorr (object), "sc") # =sc? #useScale <- object@dims["useSc"] useScale <- getME(object, "devcomp")$dims["useSc"] #ngrps <- lapply(object@flist, function(x) length(levels(x))) #n.groupings <- length (ngrps) varc <- VarCorr (object) sc <- attr(varc, "sc") # =useScale recorr <- lapply(varc, function(el) attr(el, "correlation")) reStdDev <- c(lapply(varc, function(el) attr(el, "stddev")), list(Residual = sc)) n.groupings <- length(recorr) sigmas <- as.list (rep (NA, n.groupings+1)) sigmas[1] <- ifelse (useScale, sc, 1) #####if NA, sd=1 cors <- as.list (rep (NA, n.groupings+1)) names (sigmas) <- names (cors) <- c ("data", names (varc)) for (k in 1:n.groupings){ sigmas[[k+1]] <- reStdDev[[k]] cors[[k+1]] <- as.matrix (recorr[[k]]) if (length (cors[[k+1]]) == 1) cors[[k+1]] <- NA } return (list (sigma=sigmas, cors=cors)) } sigma.hat.sim.merMod <- function(object,...) { sigma <- object@sigma return (sigma) } arm/MD50000644000176200001440000000626314602517552011357 0ustar liggesusers8fa0dc4b060ce8c5eb9eb20168f3f971 *CHANGELOG fde0a2d7145c6781d2ba9a9d89b59f2d *DESCRIPTION 0807a09587453aa0a6c70a1ccebbdc8a *NAMESPACE df99a0be1f7702e22980626c8c9c6336 *R/AllClass.R de23b5716ddafb25fbb2abee086af892 *R/AllGeneric.R 798f4770f806716769c85d5fd827e032 *R/AllInternal.R 73aaffc4bc4ef7334888371ef67c4dca *R/balance.R 5093d7811dbfd7c03981170adcd18ea9 *R/bayesglm.R 054bbff33242f6e4bd26a9f7990207b1 *R/bayesglm.h.R 2f1dbf590eda1111607feb000f318aab *R/bayespolr.R 828d634c780a39b66596cc9fe885cf20 *R/binnedplot.R 7b72b8fab8bd8a78cd849318fcfe5325 *R/coef.R a012a9e1014899bac761bd1b6103205e *R/coefplot.R 87ff45a243d955c0d0d3bd8af50a3f2f *R/contrasts.bayes.R 041d95b04bf7fdb3dbee0fde2bfbe400 *R/corrplot.R 004bf778675992949bc419bcdcf21382 *R/discrete.histogram.R 6db1c8b21abb043dd1de905b2f102d4b *R/display.R 74c65898e73cd54baa81e8aed4bbf781 *R/extractDIC.R 01ed741d359e1ed07bf61a543b3889ac *R/fitted.R 069a7f96fbba5b80380d6bc90aa766be *R/fround.R 9e1dc642876804773d8d9e56c6fde116 *R/go.R 78c23bf2f0dd152a68a264805111053b *R/invlogit.R 26f9a0e44dededc7181e3eec6ecd3e84 *R/load.first.R 0abc9dcad202c44cb985ad97b77af16e *R/matching.R df9287e969f74e2947f9e0e5b19d26fc *R/mcsamp.R 7be84861e689714dc27857682d749a74 *R/model.matrixBayes.R 6d6bc7861c1f13930bfa36044b8c0ca4 *R/multicomp.plot.R 7d0f269ea12f242f4d43e3661f68396e *R/readColumns.R bcf237b4f9940d6b8da304a403cc3a99 *R/rescale.R 0eb80aef5e725716ee52fafa50654820 *R/residual.plot.R b2c045448ef2d771b1213b48d09f01b4 *R/se.coef.R 182cfee5b48b437cdc22b005cfc4c62b *R/sigma.hat.R 1ded9c8538a369ab08d54b9b9500f2e8 *R/sim.R b2aebcf507ea399f88098d90c9002a57 *R/simmer.R ccd813b440101e320bbdeabc36c61a0e *R/standardize.R af03f0653476d7242cb96915aa3ba7eb *R/traceplot.R 4dae5be8be23a21a990dd56234748f31 *R/triangleplot.R 91f29004f60c810f6f3cc60a5a9520f3 *README.md 12e52a54f9a2b2aa85f8162365ecce7c *data/lalonde.rda 8d528001b15d7ee29ae38011dd6d7864 *man/balance.Rd c48081163741773a5e94773d9fc18fee *man/bayesglm.Rd 8a91e3e8eda21c3177556485de2e43e4 *man/bayespolr.Rd ebcb240293af88f21122a5edde46d44b *man/binnedplot.Rd ce4a636e3cabb7e8ab9c0967077ca36d *man/coefplot.Rd a1b8750a84af242a5317ab317b2c9fbd *man/contrasts.bayes.Rd 31accba9d79c6a08c0a871aab1d36ecc *man/corrplot.Rd 9449fa9d48406131a6bb36c55abc02fa *man/discrete.histogram.Rd 71fb3d77fdaacc5b46ace05c2b41f778 *man/display.Rd fca667b4198132390e73c91160541eb1 *man/extractDIC.mer.Rd f369ae9b94cbafa6783974a219d98cde *man/fround.Rd 2f96eecdbd14cd8ce4caa733f383b828 *man/go.Rd 252d366231e5912427f51c46d69da410 *man/invlogit.Rd e7f14f9263a4f3966f0fb9c7ca194a21 *man/lalonde.Rd 93dd0b99834ed4ed9cb1b4fd9a8bc1fa *man/matching.Rd 380f76417beff9b45a14e039204505a0 *man/mcsamp.Rd 33853edcafe777b46ed95125f5704311 *man/model.matrixBayes.Rd 6ce8710af8c054cd4262b7a87169154d *man/multicomp.plot.Rd 36a4b93b16160c3659bf8379d32d2abb *man/readColumns.Rd c1d2330f842bb2e92ee2a2a855fdb9c2 *man/rescale.Rd ac82073046f893e37c9500741a39014d *man/residual.plot.Rd 4daff88c386691fa72eec0cb9d02541d *man/se.coef.Rd 0a1dd5a48de8698930dc00605630e892 *man/sigma.hat.Rd 74864d3e83f962bbbbd4c71765f0fd30 *man/sim.Rd d217db42375db16268fb13597dee7a20 *man/standardize.Rd f2120afe3b932435f11180d9ac5b3a57 *man/traceplot.Rd 66635f3bc271935f08bdb626869ebbf5 *man/triangleplot.Rd