arm/0000755000176200001440000000000013016563475011043 5ustar liggesusersarm/NAMESPACE0000644000176200001440000000622112756204117012256 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", "setOldClass", "show", "signature") importFrom(utils, "packageDescription", "read.fwf") importFrom(Matrix, "t", "crossprod", "tcrossprod", "colMeans", "Diagonal" ) 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") 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/CHANGELOG0000644000176200001440000003200013015547556012251 0ustar liggesusers<<<<<<< HEAD 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 >>>>>>> parent of 10648fa... 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/data/0000755000176200001440000000000013015551231011736 5ustar liggesusersarm/data/lalonde.rda0000644000176200001440000001124413015551403014047 0ustar liggesusersBZh91AY&SY=.n`:A)EUUW)*P@I`2Pf1M0M5? 4j=SzL52i#)2ipW }@,%ng޻ʩߍv[;%UWgv%~ܰN!/"nJ2.`O- BЌW^1w:/>sPb~TB*h(I66jv6ȧ0Q!Jz$ouDQԪ]*!Do+*P UD? ǒzn$&ڦiI-~"a՛>we<I ~2ڟj[)(]u=YXVU(t.W^"9qswV"*eA KO&FsNؾ0 DXvRW VIrMcW$vq@>֣-._b*R_ƚOW@u[D?@31` D3t0Oe&fo/ez-&]Y#1c1@;nou$VZii0rD%)JRVMڲm0{jɶVMڲmՓmmeGKZiciix)K8h)JPЛmdm&mY6jɶVMڲmՓm5򝬵$zׯ !UUJMme6mNk(dOr2eJLsB9~wWZV{{VMڲmՓmmdm.Cq! VF֬mdm&mY6j۔c1c1'V8ݎ81c1c.F1c19 thg97c c1c;chꪫ c.P4e9,,OuU@|ߌ^Dj5jՎZ{k}8,EX9LPȝa A"W_}ѱ^ )!*H -('؄ʀ(JbhZ N_%#1II&D@U#FB9NJQ+R&VFK= 2R"i.CC*Z43b2L"ٲf&L( CCTSI[H:m5V&К*ʂĹIM(e Nhlq5]]((x,gPne[9|2Suܳm{ʏ?Nȍ%t덍z7G1HAT7?a8ֵ6$1\[gOU ߷j d g;׺Gvwauj_:=[ןS]w-לcϲcvS|+*6=gF8ٺdtˁMdLKx|0~K#"d3R.Cd+ ƸϕU2'F\]FaNڰΙΜ8nݯies oc}ώ<+5oٻ*慗RDRa+#nWl9=5,eMhc7:jcuO|2ˉ-1e߾qdjTm T[UӅ X8O+l(=([(_VPPB#u6U8 w }W5V:38M7Cj]{;tupSqfpA4{;mc 3q, TҢ" )9ټۂo3[_g!cYp9V Ci܈z Xw)f%v0OtjϹ[0*_΃a:]9iNg[ؠY);")0"yX$ab|bø LTTO@@Q4ruF*W/s챳NaA>jJ+$ADm)-6sἫOϨPe"گ'};fp9dW{I8F @dEM)29" {[TٗG,ႶnZ%֛Ũoҙ3Mc ܩqb_nf0"Cv=ӚonƴP MOn57ޣp:Il`Z>x\^tu:Mȣ#.tMVIuTx*rG $%@zPęCR)&QװQ󈉰Qh(++yO5ǷVD[ vec4i>b>`:?/!z2Vh*"ʢs ib*"mHW2 | 48=hjHp^7܄D RN"t^> !(:@//Q-pJz\s ,6P&l j H1ڀ *R|Pd\ cƞ}/NOa41wwJu'8J|NN\VA>E9 "P_HIs"!L  1nޝДd+$ >2Z}9kTqڅ؄lvNG0ד{u lE5HxD֐Diwf^PW3=2M`u}]姂[v`&|ϋNpC ^ iA6o:m&OMD_*14Ju+4&+Ɉiz{]2@TJE;^|hޜ+UKkO[q[ߛ@ZItN"9M1&&Ћsp+gM7ö{/z_/\>F 2'DUPkuSXNA]+{H̽:By7{/8[ /u @H'SS.Q.ؕQQ m4s!PG h14"0d:os\dIb@Eg\&أVK ZP- MU4HWl}9hawL^"+Uey8{rE8P=arm/R/0000755000176200001440000000000013015551231011226 5ustar liggesusersarm/R/balance.R0000644000176200001440000001456212510746300012750 0ustar liggesusersbalance <- function (rawdata, matched, pscore.fit, factor=TRUE) { #int <- attr(terms(pscore.fit), "intercept") call.raw <- call.matched <- pscore.fit$call call.raw$data <- substitute(rawdata) call.matched$data <- substitute(matched) if(!is.call(pscore.fit$call$formula)){ call.raw$formula <- formula(terms(pscore.fit)) } if (!factor){ form <- gsub("factor(", "", call.raw$formula, fixed = TRUE) form <- gsub(")", "", form, fixed = TRUE) form <- as.formula(paste(form[2], form[1], form[3], -1)) call.raw$formula <- call.matched$formula <- form } else{ form <- call.raw$formula form <- as.formula(paste(form[2], form[1], form[3], -1)) call.raw$formula <- call.matched$formula <- form } fit.raw <- eval(call.raw) fit.matched <- eval(call.matched) class(fit.raw$formula) <- class(fit.matched$formula) <- c("bayesglm", "formula") treat.raw <- fit.raw$y treat.matched <- fit.matched$y pred.raw <- model.matrixBayes(fit.raw$formula, data=rawdata, keep.order=TRUE) pred.matched <- model.matrixBayes(fit.matched$formula, data=matched, keep.order=TRUE) #if (int){ # pred.raw <- model.matrix(fit.raw)[,-1] # pred.matched <- model.matrix(fit.matched)[,-1] #} #if (!int){ # pred.raw <- model.matrix(fit.raw) # pred.matched <- model.matrix(fit.matched) #} if(dim(pred.raw)[2]!=dim(pred.matched)[2]) warnings("number of covariates of the raw data does not equal to that of the matched data! This might be due to the drop of factor levels. Use factor=FALSE to proceed!") raw.dat <- data.frame(pred.raw,treat=treat.raw) matched.dat <- data.frame(pred.matched,treat=treat.matched) covnames <- c(colnames(pred.matched),"treat") K <- length(covnames)-1 # diff.mean.rawdata diff.means=matrix(NA,K,6) for(i in 1:K){ diff.means[i,1:2] <- c(mean(raw.dat[(raw.dat[,"treat"]==1),i]), mean(raw.dat[(raw.dat[,"treat"]==0),i])) diff.means[i,3] <- diff.means[i,1]-diff.means[i,2] diff.means[i,5] <- sqrt(var(raw.dat[(raw.dat[,"treat"]==1),i])/ sum((raw.dat[,"treat"]==1)) + var(raw.dat[(raw.dat[,"treat"]==0),i])/sum((raw.dat[,"treat"]==0))) diff.means[i,6] <- sqrt((var(raw.dat[(raw.dat[,"treat"]==1),i])+ var(raw.dat[(raw.dat[,"treat"]==0),i]))/2) diff.means[i,4] <- diff.means[i,3]/diff.means[i,6] } dimnames(diff.means) <- list(covnames[-(K+1)], c("Treat","control","diff","diff.std","se","sd")) # diff.means.matched.dat diff.means.matched=matrix(NA,K,6) for(i in 1:K){ diff.means.matched[i,1:2] <- c(mean(matched.dat[(matched.dat[,"treat"]==1),i]), mean(matched.dat[(matched.dat[,"treat"]==0),i])) diff.means.matched[i,3] <- diff.means.matched[i,1]-diff.means.matched[i,2] diff.means.matched[i,5] <- sqrt(var(matched.dat[(matched.dat[,"treat"]==1),i])/ sum((raw.dat[,"treat"]==1)) + var(raw.dat[(raw.dat[,"treat"]==0),i])/sum((raw.dat[,"treat"]==0))) diff.means.matched[i,6] <- sqrt((var(raw.dat[(raw.dat[,"treat"]==1),i])+ var(raw.dat[(raw.dat[,"treat"]==0),i]))/2) diff.means.matched[i,4] <- diff.means.matched[i,3]/diff.means.matched[i,6] } dimnames(diff.means.matched) <- list(covnames[-(K+1)], c("Treat","control","diff","diff.std","se","sd")) out <- list(diff.means.raw=diff.means, diff.means.matched=diff.means.matched, covnames=covnames) class(out) <- "balance" return(out) } print.balance <- function(x, ..., digits= 2) { cat("Differences in Means of Unmatched Data\n") cat("--\n") print(round(x$diff.means.raw, digits=digits)) cat("--\n") cat("\n") cat("Differences in Means of Matched Data\n") cat("--\n") print(round(x$diff.means.matched, digits=digits)) cat("--\n") cat("\n") } plot.balance <- function(x, longcovnames=NULL, main="Standardized Difference in Means", v.axis=TRUE, cex.main=1, cex.vars=0.8, cex.pts=0.8, mar=c(0, 3, 5.1, 2), plot=TRUE, ...) { K <- dim(x$diff.means.raw)[1] idx <- 1:K covnames <- x$covnames # prepare for plot use est <- x$diff.means.raw[,3] sd <- x$diff.means.raw[,6] est2 <- x$diff.means.matched[,3] sd2 <- x$diff.means.matched[,6] # x.range <- range (c(est,est2)/c(sd,sd2)) # x.range[2] <- x.range[2] +.3 # A <- -x.range[1]/(x.range[2]-x.range[1]) # B <- 1/(x.range[2]-x.range[1]) # pts <- A + B*(est/sd) # before matched.dat # pts2 <- A + B*(est2/sd2) # after macthed pts <- est/sd # before matched.dat pts2 <- est2/sd2 # after macthed #x.range <- c(jitter(min(c(pts, pts2)),15), max(c(pts,pts2)+.105)) # tune the graphic console #par (mar=mar, mgp=mgp, oma=oma, tcl=tcl) par(mar = c(0, 3, 5.1, 2)) if (is.null(longcovnames)) { longcovnames <- covnames maxchar <- max(sapply(longcovnames, nchar)) } else { maxchar <- max(sapply(longcovnames, nchar)) } min.mar <- par("mar") mar[2] <- min(min.mar[2], trunc(mar[2] + maxchar/10)) + mar[2] + 0.1 par(mar = mar) if(plot){ # plot the estimates plot(c(pts,pts2), c(idx,idx), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", #xaxs="i", #yaxs="i", type="n", #ylim=c(max(idx)+.25, min(idx)-.25), #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/residual.plot.R0000644000176200001440000000225211041432446014142 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/extractDIC.R0000644000176200001440000000174212217744601013357 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/AllInternal.R0000644000176200001440000001713512205145544013573 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 (varc, 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(varc, "sc")[[1]] if(is.na(sc)) sc <- 1 # recorr <- lapply(varc, function(el) el@factors$correlation) recorr <- lapply(varc, function(el) attr(el, "correlation")) #reStdDev <- c(lapply(recorr, slot, "sd"), list(Residual = sc)) reStdDev <- c(lapply(varc, 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/fround.R0000644000176200001440000000025611006475113012653 0ustar liggesusersfround <- function (x, digits) { format (round (x, digits), nsmall=digits) } pfround <- function (x, digits) { print (fround (x, digits), quote=FALSE) } arm/R/AllClass.R0000644000176200001440000000411112217744601013054 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/display.R0000644000176200001440000003241312550042226013023 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) 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/bayesglm.R0000644000176200001440000007074712524513531013200 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) 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/triangleplot.R0000644000176200001440000001214012510746300014055 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/rescale.R0000644000176200001440000000141711035300261012765 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/fitted.R0000644000176200001440000000271212510746300012634 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/multicomp.plot.R0000644000176200001440000000676411526512623014363 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/se.coef.R0000644000176200001440000000724312242072514012704 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/bayesglm.h.R0000644000176200001440000006312111562432751013417 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/readColumns.R0000644000176200001440000000044312436075565013647 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/contrasts.bayes.R0000644000176200001440000000407411006475113014502 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/coef.R0000644000176200001440000000125612510746300012273 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/go.R0000644000176200001440000000375411006475113011771 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/model.matrixBayes.R0000644000176200001440000001470712510746300014753 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/bayespolr.R0000644000176200001440000002533212506504301013356 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/load.first.R0000644000176200001440000000056211662441023013424 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/standardize.R0000644000176200001440000000673512217752560013707 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/invlogit.R0000644000176200001440000000020711041167666013217 0ustar liggesusers#R function for the logistic function logit <- function (x) { log(x/(1-x)) } invlogit <- function (x) { 1/(1+exp(-x)) } arm/R/simmer.R0000644000176200001440000001133112550042226012646 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")); 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/discrete.histogram.R0000644000176200001440000000616712413107536015167 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/traceplot.R0000644000176200001440000000407012510746300013351 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/coefplot.R0000644000176200001440000003304612111075142013170 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/sim.R0000644000176200001440000001266012436075565012167 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) } # 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/AllGeneric.R0000644000176200001440000000262212510746300013362 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/mcsamp.R0000644000176200001440000001253112221326454012640 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/binnedplot.R0000644000176200001440000000467412506504301013522 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/sigma.hat.R0000644000176200001440000000350312510746300013227 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/R/matching.R0000644000176200001440000000573111171421361013152 0ustar liggesusersmatching <- 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 # # the function returns a vector of indices that the corresponding # # unit is matched to. 0 means matched to nothing. # # # # now also returns a number for each pair making it easier to # # later recover those pairs if (replace){ nt <- sum(z) nc <- length(z) - nt cnts <- rep(0, nc) scorec <- score[z == 0] scoret <- score[z == 1] indc <- NULL nearest <- rep(NA, nt) ind.mt <- matrix(0, nc, nt) ind.t <- (1:(nt + nc))[z == 1] for(j in 1:nt) { near <- (1:nc)[abs(scoret[j] - scorec) == min(abs(scoret[j] - scorec))] if(length(near) == 1) { nearest[j] <- near indc <- c(indc, near) } else { nearest[j] <- near[sample(1:length(near), 1, replace = F)] indc <- c(indc, nearest[j]) } cnts[nearest[j]] <- cnts[nearest[j]] + 1 ind.mt[nearest[j], cnts[nearest[j]]] <- ind.t[j] } # ind.mt <- ind.mt[ind.mt[, 1] != 0, 1:max(cnts)] # now create list of indicators to pull off appropriate dataset ind <- numeric(nt + sum(cnts)) # first get treat indicators ind[1:nt] <- (1:(nt + nc))[z == 1] #now the control indicators tmp <- (1:(nt + nc))[z == 0] ind[(nt + 1):length(ind)] <- tmp[indc] # out <- list(matched = unique(ind), pairs = matrix(ind, length(ind)/2, 2), ind.mt = ind.mt, cnts = cnts) } if (!replace){ n <- length(score) matched <- rep(0, n) pairs <- rep(0, n) b <- (sum(z) < n/2) * 1 tally <- 0 for (i in (1:n)[z == b]) { available <- (1:n)[(z != b) & (matched == 0)] j <- available[order(abs(score[available] - score[i]))[1]] matched[i] <- j matched[j] <- i tally <- tally + 1 pairs[c(i, j)] <- tally } out <- cbind.data.frame(matched = matched, 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/corrplot.R0000644000176200001440000000212612510746300013220 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/MD50000644000176200001440000000620713016563475011360 0ustar liggesusers49cc52b71f537d004256ac9ec324a39a *CHANGELOG 03e5969b6573f347bf14931cb88a1f5f *DESCRIPTION 7b0b4c7cf6fd9651e37d1fd481be7b43 *NAMESPACE df99a0be1f7702e22980626c8c9c6336 *R/AllClass.R de23b5716ddafb25fbb2abee086af892 *R/AllGeneric.R a2c62bf06a9a76dc6965d8f435f471ec *R/AllInternal.R 918521df294f108996d4ecae5446121e *R/balance.R 91354d7e65bd1d9068553d85a5e164d5 *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 7a7faa9a2bdbe892275d4ed1e5dc2755 *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 8db68f019ae5bdd6ae103328db51a832 *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 472916eae727da75730bac3269679541 *R/sim.R 3d9248a996d479cd604322283ae62a0d *R/simmer.R ccd813b440101e320bbdeabc36c61a0e *R/standardize.R af03f0653476d7242cb96915aa3ba7eb *R/traceplot.R 4dae5be8be23a21a990dd56234748f31 *R/triangleplot.R d830f95a11aea3dc8d6ae1769013dc14 *data/lalonde.rda 54284ad057b236cb94043035813afd3a *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 b23c39c0461c761ba57a11c17c13433e *man/lalonde.Rd 18d4a0e1d7b67eb17e573c4e84ae7b17 *man/matching.Rd 42e37e92f0fe85daae4c4af82f5f8176 *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 cf4f3997a5abff3ab48630e9f4c40113 *man/standardize.Rd f2120afe3b932435f11180d9ac5b3a57 *man/traceplot.Rd 66635f3bc271935f08bdb626869ebbf5 *man/triangleplot.Rd arm/DESCRIPTION0000644000176200001440000000332213016563475012551 0ustar liggesusersPackage: arm Version: 1.9-3 Date: 2016-11-21 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"), person("Masanao", "Yajima", role = "ctb", email = "yajima@stat.ucla.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. URL: https://CRAN.R-project.org/package=arm License: GPL (>= 3) NeedsCompilation: no Repository: CRAN Repository/R-Forge/Project: arm Repository/R-Forge/Revision: 274 Repository/R-Forge/DateTimeStamp: 2016-11-24 11:30:54 Date/Publication: 2016-11-27 15:01:33 Packaged: 2016-11-24 11:46:10 UTC; rforge arm/man/0000755000176200001440000000000013015551231011600 5ustar liggesusersarm/man/mcsamp.Rd0000644000176200001440000001107612507526771013374 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{\link[lme4]{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[lme4]{mcmcsamp}}, \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/fround.Rd0000644000176200001440000000152211523140642013366 0ustar liggesusers\name{fround} \alias{fround} \alias{pfround} \title{Formating the Rounding of Numbers} \description{ \code{fround} rounds the values in its first argument to the specified number of decimal places with surrounding quotes. \code{pfround} rounds the values in its first argument to the specified number of decimal places without surrounding quotes. } \usage{ fround(x, digits) pfround(x, digits) } \arguments{ \item{x}{a numeric vector.} \item{digits}{integer indicating the precision to be used.} } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{ \code{\link{round}} } \examples{ x <- rnorm(1) fround(x, digits=2) pfround(x, digits=2) } \keyword{manip} \keyword{print} arm/man/residual.plot.Rd0000644000176200001440000000312512142730465014665 0ustar liggesusers\name{residual.plot} \alias{residual.plot} \title{residual plot for the observed values} \description{ Plots the residual of observed variable. } \usage{ residual.plot(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", ...) } \arguments{ \item{Expected}{ Expected value. } \item{Residuals}{ Residual value. } \item{sigma}{ Standard error. } \item{main}{ main for the plot. See \code{plot} for detail.} \item{col.pts}{ Color of the points. } \item{col.ctr}{ Color of the line at zero. } \item{col.sgm}{ Color of standard error line. } \item{cex}{ A numerical value giving the amount by which plotting text and symbols should be magnified relative to the default. See par for detail. } \item{gray.scale}{ If \code{TRUE}, makes the plot into black and white. This option overwrites the color specification. Default is FALSE. } \item{xlab}{ Label for x axis. } \item{ylab}{ Label for y axis. } \item{\dots}{ Additional parameters passed to \code{plot} function. } } \value{ Plot to visualize pattern of residulal value for the expected value. } \author{ Masanao Yajima \email{yajima@stat.columbia.edu}, M.Grazia Pittau \email{grazia@stat.columbia.edu} } \examples{ old.par <- par(no.readonly = TRUE) x <- rnorm(100) y <- rnorm(100) fit <- lm(y~x) y.hat <- fitted(fit) u <- resid(fit) sigma <- sigma.hat(fit) residual.plot(y.hat, u, sigma) par(old.par) } \keyword{hplot} arm/man/se.coef.Rd0000644000176200001440000000530212510746300013413 0ustar liggesusers\name{se.coef} %\docType{genericFunction} \alias{se.coef} \alias{se.coef,lm-method} \alias{se.coef,glm-method} \alias{se.coef,merMod-method} \alias{se.fixef} \alias{se.ranef} \title{Extract Standard Errors of Model Coefficients} \description{ These functions extract standard errors of model coefficients from objects returned by modeling functions. } \usage{ se.coef (object, \dots) se.fixef (object) se.ranef (object) \S4method{se.coef}{lm}(object) \S4method{se.coef}{glm}(object) \S4method{se.coef}{merMod}(object) } \arguments{ \item{object}{object of \code{lm}, \code{glm} and \code{merMod} fit} \item{\dots}{other arguments} } \value{ \code{se.coef} gives lists of standard errors for \code{coef}, \code{se.fixef} gives a vector of standard errors for \code{fixef} and \code{se.ranef} gives a list of standard errors for \code{ranef}. } \details{ \code{se.coef} extracts standard errors from objects returned by modeling functions. \code{se.fixef} extracts standard errors of the fixed effects from objects returned by lmer and glmer functions. \code{se.ranef} extracts standard errors of the random effects from objects returned by lmer and glmer functions. } \seealso{ \code{\link{display}}, \code{\link{coef}}, \code{\link{sigma.hat}}, } \references{Andrew Gelman and Jennifer Hill. (2006). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models}. Cambridge University Press.} \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \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)) mu.a <- 0 sigma.a <- 2 mu.b <- 3 sigma.b <- 4 rho <- 0 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] # x <- rnorm (100) y1 <- rnorm (100, a[group] + b[group]*x, sigma.y) y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) # lm fit M1 <- lm (y1 ~ x) se.coef (M1) # glm fit M2 <- glm (y2 ~ x) se.coef (M2) # lmer fit M3 <- lmer (y1 ~ x + (1 + x |group)) se.coef (M3) se.fixef (M3) se.ranef (M3) # glmer fit M4 <- glmer (y2 ~ 1 + (0 + x |group), family=binomial(link="logit")) se.coef (M4) se.fixef (M4) se.ranef (M4) } \keyword{manip} \keyword{methods} \keyword{models} arm/man/model.matrixBayes.Rd0000644000176200001440000000603712510746300015466 0ustar liggesusers\name{model.matrixBayes} %\docType{genericFunction} \alias{model.matrixBayes} \title{Construct Design Matrices} \description{ \code{model.matrixBayes} creates a design matrix. } \usage{ model.matrixBayes(object, data = environment(object), contrasts.arg = NULL, xlev = NULL, keep.order = FALSE, drop.baseline=FALSE,...) %model.matrix.bayes.h(object, data = environment(object), % contrasts.arg = NULL, xlev = NULL, keep.order = FALSE, batch = NULL, ...) } \arguments{ \item{object}{an object of an appropriate class. For the default method, a model formula or terms object.} \item{data}{a data frame created with \code{\link{model.frame}}. If another sort of object, \code{model.frame} is called first.} \item{contrasts.arg}{A list, whose entries are contrasts suitable for input to the \code{\link{contrasts}} replacement function and whose names are the names of columns of \code{data} containing \code{\link{factor}}s.} \item{xlev}{to be used as argument of \code{\link{model.frame}} if \code{data} has no \code{"terms"} attribute.} \item{keep.order}{a logical value indicating whether the terms should keep their positions. If \code{FALSE} the terms are reordered so that main effects come first, followed by the interactions, all second-order, all third-order and so on. Effects of a given order are kept in the order specified.} \item{drop.baseline}{Drop the base level of categorical Xs, default is TRUE.} % \item{batch}{Not implement yet!} \item{\dots}{further arguments passed to or from other methods.} } \details{ \code{model.matrixBayes} is adapted from \code{model.matrix} in the \code{stats} pacakge and is designed for the use of \code{\link{bayesglm}}.% and \code{bayesglm.hierachical} (not yet implemented!). It is designed to keep baseline levels of all categorical varaibles and keep the variable names unodered in the output. The design matrices created by \code{model.matrixBayes} are unidentifiable using classical regression methods, though; they can be identified using \code{\link{bayesglm}}.% and %\code{bayesglm.hierachical}. } \references{Andrew Gelman, Aleks Jakulin, Maria Grazia Pittau and Yu-Sung Su. (2009). \dQuote{A Weakly Informative Default Prior Distribution For Logistic And Other Regression Models.} \emph{The Annals of Applied Statistics} 2 (4): 1360--1383. \url{http://www.stat.columbia.edu/~gelman/research/published/priors11.pdf} } \seealso{ \code{\link[stats]{model.frame}}, \code{\link[stats]{model.extract}}, \code{\link[stats]{terms}}, \code{\link[stats]{terms.formula}}, \code{\link{bayesglm}}. } \author{Yu-Sung Su \email{suyusung@tsinghua.edu.cn}} \examples{ ff <- log(Volume) ~ log(Height) + log(Girth) str(m <- model.frame(ff, trees)) (model.matrix(ff, m)) class(ff) <- c("bayesglm", "terms", "formula") (model.matrixBayes(ff, m)) %class(ff) <- c("bayesglm.h", "terms", "formula") %(model.matrixBayes(ff, m)) } \keyword{models} \keyword{manip} arm/man/traceplot.Rd0000644000176200001440000000250712510746300014072 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/invlogit.Rd0000644000176200001440000000222111556226532013732 0ustar liggesusers\name{invlogit} \alias{invlogit} \alias{logit} \title{Logistic and Inverse logistic functions} \description{ Inverse-logit function, transforms continuous values to the range (0, 1) } \usage{ logit(x) invlogit(x) } \arguments{ \item{x}{A vector of continuous values} } \details{ The Inverse-logit function defined as: \eqn{logit^-1(x) = e^x/(1+e^x)} transforms continuous values to the range (0, 1), which is necessary, since probabilities must be between 0 and 1 and maps from the linear predictor to the probabilities } \value{ A vector of estimated probabilities } \references{Andrew Gelman and Jennifer Hill. (2006). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models}. Cambridge University Press.} \author{Andrew Gelman \email{gelman@stat.columbia.edu}, M.Grazia Pittau \email{grazia@stat.columbia.edu} } \examples{ data(frisk) n <- 100 x1 <- rnorm (n) x2 <- rbinom (n, 1, .5) b0 <- 1 b1 <- 1.5 b2 <- 2 Inv.logit <- invlogit(b0+b1*x1+b2*x2) plot(b0+b1*x1+b2*x2, Inv.logit) } \keyword{models} arm/man/binnedplot.Rd0000644000176200001440000000612011531720150014223 0ustar liggesusers\name{binnedplot} \alias{binnedplot} \alias{binned.resids} \title{Binned Residual Plot} \description{ A function that plots averages of y versus averages of x and can be useful to plot residuals for logistic regression. } \usage{ binnedplot(x ,y, nclass=NULL, xlab="Expected Values", ylab="Average residual", main="Binned residual plot", cex.pts=0.8, col.pts=1, col.int="gray", ...) } \arguments{ \item{x}{The expected values from the logistic regression.} \item{y}{The residuals values from logistic regression (observed values minus expected values).} \item{nclass}{Number of categories (bins) based on their fitted values in which the data are divided. Default=NULL and will take the value of nclass according to the $n$ such that if $n >=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/corrplot.Rd0000644000176200001440000000576711523140642013754 0ustar liggesusers\name{corrplot} \alias{corrplot} \title{Correlation Plot} \description{ Function for making a correlation plot starting from a data matrix } \usage{ corrplot (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) } \arguments{ \item{data}{a data matrix} \item{varnames}{variable names of the data matrix, if not provided use default variable names} \item{abs}{if TRUE, transform all correlation values into positive values, default=TRUE.} \item{cutpts}{a vector of cutting points for color legend, default is NULL. The function will decide the cutting points if cutpts is not assigned.} \item{details}{show more than one digits correlaton values. Default is TRUE. FALSE is suggested to get readable output.} \item{n.col.legend}{number of legend for the color thermometer.} \item{cex.col}{font size of the color thermometer.} \item{cex.var}{font size of the variable names.} \item{digits}{number of digits shown in the text of the color theromoeter.} \item{color}{color of the plot, default is FALSE, which uses gray scale.} } \details{ The function adapts the R function for Figure 8 in Tian Zheng, Matthew Salganik, and Andrew Gelman, 2006, "How many people do you know in prison?: using overdispersion in count data to estimate social structure in networks", Journal of the American Statistical Association, Vol.101, N0. 474: p.409-23. } \value{ A correlation plot. } \references{ Tian Zheng, Matthew Salganik, and Andrew Gelman, 2006, "How many people do you know in prison?: using overdispersion in count data to estimate social structure in networks", Journal of the American Statistical Association, Vol.101, N0. 474: p.409-23} \author{Tian Zheng \email{tzheng@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link[stats]{cor}}, \code{\link[graphics]{par}} } \examples{ old.par <- par(no.readonly = TRUE) x1 <- rnorm(1000,50,2) x2 <- rbinom(1000,1,prob=0.63) x3 <- rpois(1000, 2) x4 <- runif(1000,40,100) x5 <- rnorm(1000,100,30) x6 <- rbeta(1000,2,2) x7 <- rpois(1000,10) x8 <- rbinom(1000,1,prob=0.4) x9 <- rbeta(1000,5,4) x10 <- runif(1000,-10,-1) test.data <- data.matrix(cbind(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10)) test.names <- c("a short name01","a short name02","a short name03", "a short name04","a short name05","a short name06", "a short name07","a short name08","a short name09", "a short name10") # example 1 corrplot(test.data) # example 2 corrplot(test.data,test.names, abs=FALSE, n.col.legend=7) corrplot(test.data,test.names, abs=TRUE, n.col.legend=7) # example 3 data(lalonde) corrplot(lalonde, details=FALSE, color=TRUE) corrplot(lalonde, cutpts=c(0,0.25,0.5,0.75), color=TRUE, digits=2) par(old.par) } \keyword{dplot} arm/man/readColumns.Rd0000644000176200001440000000066312436075565014371 0ustar liggesusers\name{readColumns} % functions \alias{read.columns} \title{Function to read data by columns} \description{ A function read data by columns } \usage{ read.columns(filename, columns) } \arguments{ \item{filename}{user specified file name including path of the file} \item{columns}{which columns of the data to be read} } \author{Andrew Gelman \email{gelman@stat.columbia.edu} } \keyword{methods} arm/man/sigma.hat.Rd0000644000176200001440000000351012510746300013743 0ustar liggesusers\name{sigma.hat} %\docType{genericFunction} \alias{sigma.hat} \alias{sigma.hat.lm} \alias{sigma.hat.glm} \alias{sigma.hat.merMod} \alias{sigma.hat.sim} \alias{sigma.hat.sim.merMod} \title{Extract Residual Errors} \description{This generic function extracts residual errors from a fitted model. } \usage{ sigma.hat(object,\dots) \method{sigma.hat}{lm}(object,\dots) \method{sigma.hat}{glm}(object,\dots) \method{sigma.hat}{merMod}(object,\dots) \method{sigma.hat}{sim}(object,\dots) \method{sigma.hat}{sim.merMod}(object,\dots) } \arguments{ \item{object}{any fitted model object of \code{lm}, \code{glm} and \code{merMod} class} \item{\dots}{other arguments} } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link{display}}, \code{\link{summary}}, \code{\link{lm}}, \code{\link{glm}}, \code{\link[lme4]{lmer}} } \examples{ group <- rep(1:10, rep(10,10)) mu.a <- 0 sigma.a <- 2 mu.b <- 3 sigma.b <- 4 rho <- 0 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] x <- rnorm (100) y1 <- rnorm (100, a[group] + b[group]*x, sigma.y) y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) M1 <- lm (y1 ~ x) sigma.hat(M1) M2 <- bayesglm (y1 ~ x, prior.scale=Inf, prior.df=Inf) sigma.hat(M2) # should be same to sigma.hat(M1) M3 <- glm (y2 ~ x, family=binomial(link="logit")) sigma.hat(M3) M4 <- lmer (y1 ~ (1+x|group)) sigma.hat(M4) M5 <- glmer (y2 ~ (1+x|group), family=binomial(link="logit")) sigma.hat(M5) } \keyword{manip} \keyword{methods} arm/man/balance.Rd0000644000176200001440000000723011523140642013460 0ustar liggesusers\name{balance} \docType{class} % Classes \alias{balance-class} % Function \alias{balance} % display methods \alias{print.balance} \alias{plot.balance} \title{Functions to compute the balance statistics} \description{ This function computes the balance statistics before and after matching. } \usage{ balance(rawdata, matched, pscore.fit, factor=TRUE) \method{print}{balance}(x, \dots, digits = 2) \method{plot}{balance}(x, longcovnames = NULL, main = "Standardized Difference in Means", v.axis=TRUE, cex.main = 1, cex.vars = 0.8, cex.pts = 0.8, mar=c(0,3,5.1,2), plot=TRUE, \dots) } \arguments{ \item{rawdata}{data before using \code{matching} function, see the example below.} \item{matched}{matched data using \code{matching} function, see the example below.} \item{pscore.fit}{glm.fit object to get propensity scores.} \item{factor}{default is \code{TRUE} which will display the factorized categorical variables. In a situation where no equal levels of factorized categorical variables is observed, use factor=FALSE to proceed.} \item{x}{an object return by the balance function.} \item{digits}{minimal number of \emph{significant} digits, default is 2.} \item{longcovnames}{long covariate names. If not provided, plot will use covariate variable name by default} \item{main}{The main title (on top) using font and size (character expansion) \code{par("font.main")} and color \code{par("col.main")}; default title is \code{Standardized Difference in Means}.} \item{v.axis}{default is \code{TRUE}, which shows the top axis--axis(3).} \item{cex.main}{font size of main title} \item{cex.vars}{font size of variabel names} \item{cex.pts}{point size of the estimates} \item{mar}{A numerical vector of the form \code{c(bottom, left, top, right)} which gives the number of lines of margin to be specified on the four sides of the plot. The default is \code{c(0,3,5.1,2)}.} \item{plot}{default is \code{TRUE}, which will plot the plot.} \item{\dots}{other plot options may be passed to this function} } \details{ This function plots the balance statistics before and after matching. The open circle dots represent the unmatched balance statistics. The solid dots represent the matched balance statistics. The closer the value of the estimates to the zero, the better the treated and control groups are balanced after matching. } \note{ The function does not work with predictors that contain factor(x), log(x) or all other data transformation. Create new objects for these variables. Attach them into the original dataset before doing the matching procedure. } \references{Andrew Gelman and Jennifer Hill. (2006). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models}. Cambridge University Press. (Chapter 10)} \author{Jennifer Hill \email{jh1030@columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link{matching}}, \code{\link{par}} } \examples{ # matching first old.par <- par(no.readonly = TRUE) data(lalonde) attach(lalonde) fit <- glm(treat ~ re74 + re75 + age + factor(educ) + black + hisp + married + nodegr + u74 + u75, family=binomial(link="logit")) pscores <- predict(fit, type="link") matches <- matching(z=lalonde$treat, score=pscores) matched <- lalonde[matches$matched,] # balance check b.stats <- balance(lalonde, matched, fit) print(b.stats) plot(b.stats) par(old.par) } \keyword{methods} \keyword{manip} \keyword{hplot} \keyword{dplot} arm/man/discrete.histogram.Rd0000644000176200001440000000265612413107536015704 0ustar liggesusers\name{discrete.histogram} \alias{discrete.histogram} \alias{discrete.hist} \title{Histogram for Discrete Distributions} \description{Creates a prettier histogram for discrete distributions} \usage{ discrete.histogram (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", ...) } \arguments{ \item{x}{The vector of x's} \item{prob}{The probabilities for the x's} \item{prob2}{A second vector of probabilities of the x's} \item{prob3}{A third vector of probabilities of the x's} \item{xlab}{Label for the x axis} \item{xaxs.label}{Label for the x's} \item{yaxs.label}{Label for the y axis} \item{bar.width}{Width of the bars} \item{freq}{If TRUE, shows a frequency histogram as opposed to probability.} \item{prob.col}{The color of the first set of histogram bars.} \item{prob2.col}{The color of the second set of histogram bars.} \item{prob3.col}{The color of the third set of histogram bars.} \item{...}{Additional arguments passed to function \code{plot}} } \details{This function displays a histogram for discrete probability distributions. } \examples{ a <- c(3,4,0,0,5,1,1,1,1,0) discrete.histogram (a) x <- c(0,1,3,4,5) p <- c(.3,.4,.1,.1,.1) discrete.histogram (x,p) x <- c(0,1,3,4,5) y <- c(3,4,1,1,1) discrete.histogram (x,y) } \keyword{dplot} arm/man/coefplot.Rd0000644000176200001440000001631111532014340013701 0ustar liggesusers\name{coefplot} %\docType{genericFunction} \alias{coefplot} \alias{coefplot.default} \alias{coefplot,numeric-method} \alias{coefplot,lm-method} \alias{coefplot,glm-method} \alias{coefplot,bugs-method} \alias{coefplot,polr-method} \title{Generic Function for Making Coefficient Plot} \description{ Functions that plot the coefficients plus and minus 1 and 2 sd from a lm, glm, bugs, and polr fits. } \usage{ coefplot(object,\dots) \method{coefplot}{default}(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=.1, \dots) \S4method{coefplot}{bugs}(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), \dots) \S4method{coefplot}{numeric}(object, \dots) \S4method{coefplot}{lm}(object, varnames=NULL, intercept=FALSE, \dots) \S4method{coefplot}{glm}(object, varnames=NULL, intercept=FALSE, \dots) \S4method{coefplot}{polr}(object, varnames=NULL, \dots) } \arguments{ \item{object}{fitted objects-lm, glm, bugs and polr, or a vector of coefficients.} \item{...}{further arguments passed to or from other methods.} \item{coefs}{a vector of coefficients.} \item{sds}{a vector of sds of coefficients.} \item{CI}{confidence interval, default is 2, which will plot plus and minus 2 sds or 95\% CI. If CI=1, plot plus and minus 1 sds or 50\% CI instead.} \item{lower.conf.bounds}{lower bounds of confidence intervals.} \item{upper.conf.bounds}{upper bounds of confidence intervals.} \item{varnames}{a vector of variable names, default is NULL, which will use the names of variables; if specified, the length of varnames must be equal to the length of predictors, including the intercept.} \item{vertical}{orientation of the plot, default is TRUE which will plot variable names in the 2nd axis. If FALSE, plot variable names in the first axis instead.} \item{v.axis}{default is TRUE, which shows the bottom axis--axis(1).} \item{h.axis}{default is TRUE, which shows the left axis--axis(2).} \item{cex.var}{The fontsize of the varible names, default=0.8.} \item{cex.pts}{The size of data points, default=0.9.} \item{col.pts}{color of points and segments, default is black.} \item{pch.pts}{symbol of points, default is solid dot.} \item{var.las}{the orientation of variable names against the axis, default is 2. see the usage of \code{las} in \code{\link{par}}.} \item{main}{The main title (on top) using font and size (character expansion) \code{par("font.main")} and color \code{par("col.main")}.} \item{xlab}{X axis label using font and character expansion \code{par("font.lab")} and color \code{par("col.lab")}.} \item{ylab}{Y axis label, same font attributes as \code{xlab}.} \item{mar}{A numerical vector of the form \code{c(bottom, left, top, right)} which gives the number of lines of margin to be specified on the four sides of the plot. The default is \code{c(1,3,5.1,2)}.} \item{plot}{default is TRUE, plot the estimates.} \item{add}{if add=TRUE, plot over the existing plot. default is FALSE.} \item{offset}{add extra spaces to separate from the existing dots. default is 0.1.} % \item{lower.bound}{default is -Inf.} \item{var.idx}{the index of the variables of a bugs object, default is NULL which will plot all the variables.} \item{intercept}{If TRUE will plot intercept, default=FALSE to get better presentation.} } \details{ This function plots coefficients from bugs, lm, glm and polr with 1 sd and 2 sd interval bars. } \value{ Plot of the coefficients from a bugs, lm or glm fit. You can add the intercept, the variable names and the display the result of the fitted model. } \references{Andrew Gelman and Jennifer Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2006.} \author{Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link{display}}, \code{\link[graphics]{par}}, \code{\link[stats]{lm}}, \code{\link[stats]{glm}}, \code{\link{bayesglm}}, \code{\link[graphics]{plot}} } \examples{ old.par <- par(no.readonly = TRUE) y1 <- rnorm(1000,50,23) y2 <- rbinom(1000,1,prob=0.72) x1 <- rnorm(1000,50,2) x2 <- rbinom(1000,1,prob=0.63) x3 <- rpois(1000, 2) x4 <- runif(1000,40,100) x5 <- rbeta(1000,2,2) longnames <- c("a long name01","a long name02","a long name03", "a long name04","a long name05") fit1 <- lm(y1 ~ x1 + x2 + x3 + x4 + x5) fit2 <- glm(y2 ~ x1 + x2 + x3 + x4 + x5, family=binomial(link="logit")) op <- par() # plot 1 par (mfrow=c(2,2)) coefplot(fit1) coefplot(fit2, col.pts="blue") # plot 2 longnames <- c("(Intercept)", longnames) coefplot(fit1, longnames, intercept=TRUE, CI=1) # plot 3 coefplot(fit2, vertical=FALSE, var.las=1, frame.plot=TRUE) # plot 4: comparison to show bayesglm works better than glm n <- 100 x1 <- rnorm (n) x2 <- rbinom (n, 1, .5) b0 <- 1 b1 <- 1.5 b2 <- 2 y <- rbinom (n, 1, invlogit(b0+b1*x1+b2*x2)) y <- ifelse (x2==1, 1, y) x1 <- rescale(x1) x2 <- rescale(x2, "center") M1 <- glm (y ~ x1 + x2, family=binomial(link="logit")) display (M1) M2 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit")) display (M2) #=================== # stacked plot #=================== coefplot(M2, xlim=c(-1,5), intercept=TRUE) coefplot(M1, add=TRUE, col.pts="red") #==================== # arrayed plot #==================== par(mfrow=c(1,2)) x.scale <- c(0, 7.5) # fix x.scale for comparison coefplot(M1, xlim=x.scale, main="glm", intercept=TRUE) coefplot(M2, xlim=x.scale, main="bayesglm", intercept=TRUE) # plot 5: the ordered logit model from polr M3 <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) coefplot(M3, main="polr") M4 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) coefplot(M4, main="bayespolr", add=TRUE, col.pts="red") ## plot 6: plot bugs & lmer # par <- op # M5 <- lmer(Reaction ~ Days + (1|Subject), sleepstudy) # M5.sim <- mcsamp(M5) # coefplot(M5.sim, var.idx=5:22, CI=1, ylim=c(18,1), main="lmer model") # plot 7: plot coefficients & sds vectors coef.vect <- c(0.2, 1.4, 2.3, 0.5) sd.vect <- c(0.12, 0.24, 0.23, 0.15) longnames <- c("var1", "var2", "var3", "var4") coefplot (coef.vect, sd.vect, varnames=longnames, main="Regression Estimates") coefplot (coef.vect, sd.vect, varnames=longnames, vertical=FALSE, var.las=1, main="Regression Estimates") par(old.par) } \keyword{hplot} \keyword{dplot} \keyword{methods} \keyword{manip} arm/man/sim.Rd0000644000176200001440000001106512510746300012664 0ustar liggesusers\name{sim} %\docType{genericFunction} \alias{sim} \alias{sim-class} \alias{sim.merMod-class} \alias{sim,lm-method} \alias{sim,glm-method} \alias{sim,polr-method} \alias{sim,merMod-method} \alias{coef.sim} \alias{coef.sim.polr} \alias{coef.sim.merMod} \alias{fixef.sim.merMod} \alias{ranef.sim.merMod} \alias{fitted.sim.merMod} \title{Functions to Get Posterior Distributions} \description{ This generic function gets posterior simulations of sigma and beta from a \code{lm} object, or simulations of beta from a \code{glm} object, or simulations of beta from a \code{merMod} object } \usage{ sim(object, ...) \S4method{sim}{lm}(object, n.sims = 100) \S4method{sim}{glm}(object, n.sims = 100) \S4method{sim}{polr}(object, n.sims = 100) \S4method{sim}{merMod}(object, n.sims = 100) \method{coef}{sim}(object,\dots) \method{coef}{sim.polr}(object, slot=c("ALL", "coef", "zeta"),\dots) \method{coef}{sim.merMod}(object,\dots) \method{fixef}{sim.merMod}(object,\dots) \method{ranef}{sim.merMod}(object,\dots) \method{fitted}{sim.merMod}(object, regression,\dots) } \arguments{ \item{object}{the output of a call to \code{lm} with n data points and k predictors.} \item{slot}{return which slot of \code{sim.polr}, available options are \code{coef, zeta, ALL}.} \item{...}{further arguments passed to or from other methods.} \item{n.sims}{number of independent simulation draws to create.} \item{regression}{the orginial mer model} } \value{ \item{coef}{matrix (dimensions n.sims x k) of n.sims random draws of coefficients.} \item{zeta}{matrix (dimensions n.sims x k) of n.sims random draws of zetas (cut points in polr).} \item{fixef}{matrix (dimensions n.sims x k) of n.sims random draws of coefficients of the fixed effects for the \code{merMod} objects. Previously, it is called \code{unmodeled}.} \item{sigma}{vector of n.sims random draws of sigma (for \code{glm}'s, this just returns a vector of 1's or else of the square root of the overdispersion parameter if that is in the model)} } \references{Andrew Gelman and Jennifer Hill. (2006). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models}. Cambridge University Press.} \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn}; Vincent Dorie \email{vjd4@nyu.edu} } \seealso{\code{\link{display}}, \code{\link{lm}}, \code{\link{glm}}, \code{\link[lme4]{lmer}} } \examples{ #Examples of "sim" set.seed (1) J <- 15 n <- J*(J+1)/2 group <- rep (1:J, 1:J) mu.a <- 5 sigma.a <- 2 a <- rnorm (J, mu.a, sigma.a) b <- -3 x <- rnorm (n, 2, 1) sigma.y <- 6 y <- rnorm (n, a[group] + b*x, sigma.y) u <- runif (J, 0, 3) y123.dat <- cbind (y, x, group) # Linear regression x1 <- y123.dat[,2] y1 <- y123.dat[,1] M1 <- lm (y1 ~ x1) display(M1) M1.sim <- sim(M1) coef.M1.sim <- coef(M1.sim) sigma.M1.sim <- sigma.hat(M1.sim) ## to get the uncertainty for the simulated estimates apply(coef(M1.sim), 2, quantile) quantile(sigma.hat(M1.sim)) # Logistic regression u.data <- cbind (1:J, u) dimnames(u.data)[[2]] <- c("group", "u") u.dat <- as.data.frame (u.data) y <- rbinom (n, 1, invlogit (a[group] + b*x)) M2 <- glm (y ~ x, family=binomial(link="logit")) display(M2) M2.sim <- sim (M2) coef.M2.sim <- coef(M2.sim) sigma.M2.sim <- sigma.hat(M2.sim) # Ordered Logistic regression house.plr <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display(house.plr) M.plr <- sim(house.plr) coef.sim <- coef(M.plr, slot="coef") zeta.sim <- coef(M.plr, slot="zeta") coefall.sim <- coef(M.plr) # Using lmer: # Example 1 E1 <- lmer (y ~ x + (1 | group)) display(E1) E1.sim <- sim (E1) coef.E1.sim <- coef(E1.sim) fixef.E1.sim <- fixef(E1.sim) ranef.E1.sim <- ranef(E1.sim) sigma.E1.sim <- sigma.hat(E1.sim) yhat <- fitted(E1.sim, E1) # Example 2 u.full <- u[group] E2 <- lmer (y ~ x + u.full + (1 | group)) display(E2) E2.sim <- sim (E2) coef.E2.sim <- coef(E2.sim) fixef.E2.sim <- fixef(E2.sim) ranef.E2.sim <- ranef(E2.sim) sigma.E2.sim <- sigma.hat(E2.sim) yhat <- fitted(E2.sim, E2) # Example 3 y <- rbinom (n, 1, invlogit (a[group] + b*x)) E3 <- glmer (y ~ x + (1 | group), family=binomial(link="logit")) display(E3) E3.sim <- sim (E3) coef.E3.sim <- coef(E3.sim) fixef.E3.sim <- fixef(E3.sim) ranef.E3.sim <- ranef(E3.sim) sigma.E3.sim <- sigma.hat(E3.sim) yhat <- fitted(E3.sim, E3) } \keyword{models} \keyword{methods} arm/man/standardize.Rd0000644000176200001440000000571712217752560014424 0ustar liggesusers\name{standardize} %\docType{genericFunction} \alias{standardize} \alias{standardize,lm-method} \alias{standardize,glm-method} \alias{standardize,merMod-method} \alias{standardize,polr-method} \title{Function for Standardizing Regression Predictors by Centering and Dividing by 2 sd's} \description{Numeric variables that take on more than two values are each rescaled to have a mean of 0 and a sd of 0.5; Binary variables are rescaled to have a mean of 0 and a difference of 1 between their two categories; Non-numeric variables that take on more than two values are unchanged; Variables that take on only one value are unchanged } \usage{ \S4method{standardize}{lm}(object, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") \S4method{standardize}{glm}(object, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") \S4method{standardize}{merMod}(object, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") \S4method{standardize}{polr}(object, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") } \arguments{ \item{object}{an object of class \code{lm} or \code{glm}} \item{unchanged}{vector of names of parameters to leave unstandardized} \item{standardize.y}{ if TRUE, the outcome variable is standardized also} \item{binary.inputs}{options for standardizing binary variables} } \details{ "0/1" (rescale so that the lower value is 0 and the upper is 1) "-0.5/0.5" (rescale so that the lower value is -0.5 and upper is 0.5) "center" (rescale so that the mean of the data is 0 and the difference between the two categories is 1) "full" (rescale by subtracting the mean and dividing by 2 sd's) "leave.alone" (do nothing) } \references{Andrew Gelman. (2008). \dQuote{Scaling regression inputs by dividing by two standard deviations.} \emph{Statistics in Medicine} 27: 2865--2873. \url{http://www.stat.columbia.edu/~gelman/research/published/standardizing7.pdf} } \author{Andrew Gelman \email{gelman@stat.columbia.edu} Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link{rescale}} } \examples{ # Set up the fake data n <- 100 x <- rnorm (n, 2, 1) x1 <- rnorm (n) x1 <- (x1-mean(x1))/(2*sd(x1)) # standardization x2 <- rbinom (n, 1, .5) b0 <- 1 b1 <- 1.5 b2 <- 2 y <- rbinom (n, 1, invlogit(b0+b1*x1+b2*x2)) y2 <- sample(1:5, n, replace=TRUE) M1 <- glm (y ~ x, family=binomial(link="logit")) display(M1) M1.1 <- glm (y ~ rescale(x), family=binomial(link="logit")) display(M1.1) M1.2 <- standardize(M1.1) display(M1.2) # M1.1 & M1.2 should be the same M2 <- polr(ordered(y2) ~ x) display(M2) M2.1 <- polr(ordered(y2) ~ rescale(x)) display(M2.1) M2.2 <- standardize(M2.1) display(M2.2) # M2.1 & M2.2 should be the same } \keyword{manip} \keyword{models} \keyword{methods}