arm/0000755000175000017500000000000014302744502011164 5ustar nileshnilesharm/CHANGELOG0000644000175000017500000003474614301551626012416 0ustar nileshnilesh2022-8-25 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.13.1 * NAMESPACE: import solve from Matrix * R/simmer: comment out solveFun(), and use solve from Matrix direclty 2021-10-15 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.12-2 * man/lalonde.Rd: fixed the link to lalonde data (from http to https) 2021-10-08 Marius Barth * DESCRIPTION: (Version, Date): removed the Hmisc package from Imports field * NAMESPACE: Do not import wtd.var from Hmisc, anymore (this is to increase crossplatform compatibility) * R/balance.R: Replace call to Hmisc::wtd.var() with call to stats::cov.wt() 2020-7-27 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.11-2 * NAMESPACE: import weighted.mean from stats and wtd.var from Hmisc * R/balance: new balance, print.balance, plot.balance function * R/matching: new matching function * man/balance: new description to new functions 2020-4-27 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.11-0 * NAMESPACE: import setClass from methods (BUGS reported by Henrik) 2018-4-12 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.10-1 * R/bayesglm: fix a bug where scale=TRUE the prior.scale miscount the nvars. * R/sim.glm: improve the speed. * man/standardized: fix a typo in the example 2016-11-24 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.9-3 * DESCRIPTION: new description, and change http to https in URL 2016-9-4 Yu-Sung Su * DESCRIPTION: add BugReports and change LICENSE to GPL >=3, fix Vincent's name (spelling error, sorry Vincent!) ======= 2016-9-2 Yu-Sung Su * DESCRIPTION: add BugReports and change LICENSE to GPL >=3 * Doc fix Vincent's name 2016-8-21 Yu-Sung Su * DESCRIPTION (Version, Date): 1.9-1 * NAMESPACE: import show from methods 2015-7-7 Yu-Sung Su * DESCRIPTION (Version, Date): 1.8-6 * NAMESPACE: import more from base packages (new R rules) 2015-5-3 Yu-Sung Su * DESCRIPTION (Version, Date): 1.8-5 * R/bayesglm: fix a missing line in the re-factorization of bayesglm.fit, when scaled=TRUE, and a column of X takes on more than two values, than prior.scale = prior.scale /(sd(x)*2). 2015-4-7 Yu-Sung Su * DESCRIPTION (Version, Date): 1.8-4 * R/sigma.hat: sigma.hat changed to S3 function. * R/fitted: changed to S3 function * R/coef: coef, fixef, ranef, changed to S3 function 2015-3-31 Yu-Sung Su * DESCRIPTION (Version, Date): 1.8-03 * R/bayesglm: revert back to a more straightforward coding, easier for debugging. * R/bayespolr: check n.iter to maxit, and pass it through control. 2014-8-27 Yu-Sung Su * DESCRIPTION (Version, Date): 1.7-07 * R/readColumns: add read.columns() * R/sim: fix a bug in the name calling of beta.hat * man/readColumns: add description for read.columns() * NAMESPACE: export read.columns * DESCRIPTION: remove foreign and R2WinBUGS from suggests 2014-8-1 Yu-Sung Su * DESCRIPTION (Version, Date): 1.7-05 (thanks to Dr. Martyn Plummer's contribution) * R/bayesglm: fix several bugs in bayesglm * R/display: change the display for bayesglm to fit the changes stated above. * man/bayesglm: 1. change M2 and M7 example codes to make them equivalent to M1 and M3. 2. change the description for prior.scale for the gaussian family. * DESCRIPTION: remove foreign and R2WinBUGS from suggests 2014-4-27 Yu-Sung Su * DESCRIPTION (Version, Date): 1.7-03 * R/bayesglm: revert back to the use of lm.fit to lm.wfit; put a stop when dispersion goes Inf 2014-4-24 Yu-Sung Su * DESCRIPTION (Version, Date): 1.7-02 * R/simmer.R: simmer attaches names to fixed effects * R/fitted: fitted uses correct observational weights for glmms * R/bayesglm: use change the use of lm.fit to lm.wfit. 2013-11-25 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-10 * make changes that fit to oldrelease R. * R/se.ranef, se.coef: change postVar to condVar 2013-9-23 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-09 * start supporting new lme4 2013-9-23 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-09 * start supporting new lme4 2013-8-22 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-07 * revert back to 1.6-07, stop supporting the new lme4. * R/bayesglm: fix various bugs 2013-8-21 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-08 * clean up DESCRIPTION and NAMESPACE 2013-7-12 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-07 * made various change to adjust the new lme4 * currently, sim.mer is not working, waiting for revision. 2013-5-9 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-06 * NAMESPACE: export new method fitted() for sim.mer * R/fitted: add fitted() for sim.mer object * man/sim: add description for fitted() for sim.mer object * R/bayesglm fix a bug in bayesglm() in "subset" 2013-3-8 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-05 * NAMESPACE: export logit() 2013-2-27 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-04 * R/coefplot: fix a bug when the formula does not have an intercept * man/bayesglm: fix a coding error for weights in the bayesglm.fit 2013-2-20 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-03, add import from survey package * R/AllClass: set old class svyglm. * R/display: add svyglm method * R/coefplot: fix a bug when the formula does not have an intercept * man/display: add svyglm method 2013-1-5 Yu-Sung Su * DESCRIPTION (Version, Date): 1.6-01 * R/bayesglm: fix an issue in updating start in the loop 2012-10-13 Yu-Sung Su * R/coefplot: fix an issue in coefplot. No longer reset par when exit. * R/bayesglm: fix an issue in dev and family$state$valideta, family$state$mu 2012-10-03 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-08 * R/bayesglm: fix various bugs in bayesglm 2012-09-26 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-07 * R/balance: handle the situation when the formula in pscore.fit is not directly express. 2012-09-20 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-06 * R/bayesglm: stop using .Fortran() here. 2012-06-6 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-05 * man/bayesglm: add predictLM * R/bayesglm: add predict.bayesglm, predictLM to fit with model.matrixBayes 2012-04-27 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-04 * man/bayesglm: rewrite the description for the option scaled. 2012-03-3 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-03 * DESCRIPTION: add foreign as the required package * R/simmer: new sim() for mer class 2012-01-19 Yu-Sung Su * DESCRIPTION (Version, Date): 1.5-01 * R/mcsamp: add mcsamp() back, though it is not working. * R/AllGeneric: set coef, print, as generic to pass the check 2011-11-21 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-14 * R/.onAttach: fix the NOTE issue 2011-06-19 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-13 * R/coefplot: fix margin control. 2011-06-11 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-12 * R/bayespolr: add min.prior.scale * R/binnedplot: add nclass > 1 check * man/bayespolr: add min.prior.scale 2011-05-25 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-11 * R/bayesglm: fix a bug when there are some observation-weights that are zero. 2011-05-9 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-10 * R/display: fix a bug in display.lm that fails to print out se. 2011-05-8 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-09 * R/binnedplot: fix a bug of no sd when binnedplot only get one point. 2011-04-24 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-08 * display: now return objects after displaying the fitted model. * sigma.hat: fix a bug in sigma.hat for mer 2011-03-1 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-07 * AllClass: add sim.polr class * coef: add coef() for sim.polr * sim: add sim() for polr 2011-03-1 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-06 * NAMESPACE: export distcrete.histogram 2011-02-23 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-04 * R/binnedplot: pass addition graphical parameters to the function. 2011-02-15 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-03 * R/sim: fix a bug in sim.glm() when there is only an intercept as a predictor. (discovered by Barnes Benjamin) 2011-02-14 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-02 * R/bayesglm: fix some dimension issues when NCOL(x.nobs)==1 2011-02-05 Yu-Sung Su * DESCRIPTION (Version, Date): 1.4-01 * R/load.first: lib --> lib.loc in packageDescription 2010-11-20 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-08 * R/simmer: samples directly from the posterior of the fixed and random effects, given sigma and Sigma 2010-10-24 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-07 add new methods for sim object, coef, fixef, ranef and sigm.hat 2010-9-24 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-06 * R/bayesglm: fix a bug when a model of one predictor with no intercept is fitted * man/several: CRAN no longer alows genericFunction docType 2010-6-28 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-05 * R/extractDIC: add s3 methods for extractDIC and extractAIC for the mer class * Rd/extractDIC 2010-1-21 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-04 * R/standardize: add polr method * Rd/standardize: change the example code to make M1 and M2 equivalent. 2010-1-15 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-03 * R/balanceplot: fix a bug in balance(), take out the intercept 2010-1-11 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-02 * R/bayesglm: new bayesglm.fit (written by Daniel Lee) 2010-1-8 Yu-Sung Su * DESCRIPTION (Version, Date): 1.3-01. * R/bayesglm: a bug in x.matrix augmentation 2009-12-30 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-13. * R/bayesglm: smarter use of x matrix to save memory usage 2009-12-12 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-12. * R/simmer: use of sparse matrix in sim.mer 2009-12-08 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-11; add abind pacakge dependencyR * R/simmer: new sim functions for "mer" class 2009-11-22 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-10. * NAMESPACE: export logit 2009-4-29 Yu-Sung Su * R/display: fix format inconsistency in sprintf (fround) 2009-4-13 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-9. * R/macthing: fix a bug in matching replace=TRUE 2009-3-31 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-8. * R/display: add option detail 2009-3-1 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-7. * R/display: fix a bug in display.mer 2009-2-26 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-6. * R/display: print out t-value, z-value, p-value 2009-2-20 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-5. * R/load.first: no longer set default digit=2 2009-2-17 Yu-Sung Su * NAMESPACE: export binned.resids 2009-2-4 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-4, no longer need car * R/load.first: car is no longer required 2009-2-1 Yu-Sung Su * man/coefplot: fixed doc error * man/sim: fixed doc error 2009-1-30 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-3. * R/coefplot: fixed margin bugs in coefplot.default 2009-1-29 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-2. * R/sim: for mer method, add option ranef. Users choose to return sim.ranef or not. 2009-1-28 Yu-Sung Su * man: first attempt to clean up help files to comply the new rule. in particular, use \dQuote and \sQuote for "" and ''. * man/bayesglm: update reference * man/bayespolr: update reference 2009-1-22 Yu-Sung Su * man/rescale: update reference. * man/standardize: update reference. 2009-1-16 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-1. * NAMESPACE: export S4 method for standardize * man/standardize: add description for S4 methods. * R/AllGeneric: add a generic function for standardize * R/standardize: add standardize.default, S4 methods for lm, glm and mer. 2009-1-03 Yu-Sung Su * DESCRIPTION (Version, Date): 1.2-0. arm/DESCRIPTION0000644000175000017500000000312614302744502012674 0ustar nileshnileshPackage: arm Version: 1.13-1 Date: 2022-8-25 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@bu.edu"), person("Jennifer", "Hill", role = "ctb", email = "jennifer.hill@nyu.edu"), person("Maria Grazia", "Pittau", role = "ctb", email = "grazia@stat.columbia.edu"), person("Jouni", "Kerman", role = "ctb", email = "jouni@kerman.com"), person("Tian", "Zheng", role = "ctb", email = "tzheng@stat.columbia.edu"), person("Vincent", "Dorie", role = "ctb", email = "vjd4@nyu.edu") ) Author: Andrew Gelman [aut], Yu-Sung Su [aut, cre], Masanao Yajima [ctb], Jennifer Hill [ctb], Maria Grazia Pittau [ctb], Jouni Kerman [ctb], Tian Zheng [ctb], Vincent Dorie [ctb] Maintainer: Yu-Sung Su BugReports: https://github.com/suyusung/arm/issues/ Depends: R (>= 3.1.0), MASS, Matrix (>= 1.0), stats, lme4 (>= 1.0) Imports: abind, coda, graphics, grDevices, methods, nlme, utils Description: Functions to accompany A. Gelman and J. Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2007. License: GPL (> 2) URL: https://CRAN.R-project.org/package=arm NeedsCompilation: no Packaged: 2022-08-28 19:33:28 UTC; suyus Repository: CRAN Date/Publication: 2022-08-28 20:00:02 UTC arm/data/0000755000175000017500000000000013651440121012071 5ustar nileshnilesharm/data/lalonde.rda0000644000175000017500000001371013651440121014201 0ustar nileshnilesh ] xUEPieYFZWuUqi(PQ@d&F}iYbH $$F AgZyΫ:\{{a[<:U{Zh۲ILlScX?~W~K̄cbb^˶1$\1 dޭcɈ>G*Wzd/Z?0qAI^qѧƩƣ+^TGv}I5vH;vI¥1$N+?PCi)W5T.>^GWbK[Qˢf{~_ *OU;G}E}$K#[Oa/Kj(=He/WvyH{eGe+#׏Wݜ!)Ƒr5Tt_(=jjg@CyAðODs?zvʟJWSvxJUDZů8RN>2iܣyuCYw/iunSqN?=gи@q?z^P|G4@u(Rw RߓvIw'nD*[_WrZI9UxmH9wG"]I{+Wzxn%='e_wNzXM[]I~xhZNIGFu&yuF|Y'+P:VIu QhѾ#[g:V +:t}.4 WbI޿)Z꣍~OGih M}N "/}P{屆P}_jjui\b?Z4э#߭EzϞ.{EϹ)hS_;~}/ -}V)~}'*]CO`hiH :^}Gcޥ?P)Rvk쉴kW_=lISQ>\gVz8µK߁zWR!Wg;KC~˗&;~::ۋ7 `~sE-{ӹa{'vI}[S> 6tn>%x\_֡kA|ҳtQ<12 ny'gpnrfZ4H %$qF$ s̈́IͩpY|-⥐_Z2\XxՂ,Y}?x~돂'CrؗR SC ! D-۩y OL+:.ki_ |-0->63Se\:i'ϲFڷG΃/'CRNr]/M> ^#X{\cH}ρv%w/U=/]4yuvd;?y"~x^EjlX1̯c}'1#'^LնK$|IĬig|c쮠wL2׈׋h1'-+wb? -}O,:#ATgŒ"_:YKײo݊xj#_u q^os@|_' ;p}6ԗ2) |:4K;q?I 6.?lNsBfGwn{Ƴm9"p zr?9'1t];!^ 'Aɸ>ҞDZ|>B_rFD?|)Hy6?0 ߐ*<_3ՒC٘dyF۽p/Q^ I[3OޯKp( zk}Z? BT}%[E{-?mn!Qʝ-`\,}ˆz}q`3_x˥WR=/{^ͻgG[ߧj.x}` o uO]8eah {9{ZWwolLFvCy\'ݚY`Ǻ֞/mO sr]8F¾(-,{̓p{ɴ>x.=cΰ_59˞-p/>,hתLߗtyًLJrl>7v_qͼx,r]vHXoͼ:]s|ހM˓_~ArH50sOC88PllwpyGs$:`tعL=pˤ _/m|\3_EEy>4ۅv+OLywJzrNvk P EKȺ^v+et%+{(|'U\MPq4kxY@^ϻlJΗ~{eOrce ^BK!e7ߏ^-mXcg0]x3v(,8Q(fh{A>K_9Veߎx[`n.2JM=i'֜կ`y'0x=+O-zXzo:wA_T9=;뀗W 6^힫*vd|"ē-pn87.<xeE"qcO7x^x%8La_lO+:;4> ƛy|s9;?1ɲoXʴK8ߙ:K[s_mkzȸҼ+R2u})|y9<#6~+-Sׂ'1}ou\ 9u9N)jIs&G`nYo?Ӻ9/n+LcwLrϿ@\X4:>{*f>/MGрqmOq8 ]sG`n5Wt\]ꎗճT9wy߳-mo ᆳ[C >X fW}׎hi,miK[RM Vn*nyᎯ:/h_"߾ҖINL{=Җ-cd 1=[Җd';Nv٩_i]50~dCk߯Uicƌ:J}l\¨Uœc'O <_>>aҤcFMxf'&ƸZZ8U7=ͧL0|ŤgQh_W4qzPʛ(M\-MXGOOL?qd'~r'~'4Lc04Lc04\cp5\cp5\cpah Cc041 ah Cc85Sc85Sc85Sc85Sc85Sc4Kc4Kc4Kc4Kc4Kc5[c5[c=D[c5Fn^^^^^ѳ'>:#GG7>z@49́hDs @4h 1Dc!C4h 8qD#G4h8qD3@4 D3@4 D3@4'9͉hNDs"ќD4'9ͅh.Ds! \B4ͅh.Ds#܈F4 7͍h}nD 2){ binary[i] = 0 } } #ifelse(estimand="ATT",sqrt(var.c[i]/var.t[i]),sqrt(var.t[i]/var.c[i])) # dimnames(diff.means) <- list(covnames[-(K + 1)], c("treat", "control", "unstd.diff", # "abs.std.diff", "ratio")) # diff.means[is.na(diff.means)] = "--" #maybe only worry about in print function dimnames(diff.means) <- list(covnames, c("treat", "control", "unstd.diff", "abs.std.diff", "ratio")) # Now we calculate balance on the restructured data diff.means.matched = matrix(NA, K, 5) # for (i in 1:K) { wts0 <- matched[treat==0] # separate means by group diff.means.matched[i, 1] <- mean(rawdata[treat == 1, i]) diff.means.matched[i, 2] <- weighted.mean(rawdata[treat==0, i],w=wts0) # separate variances by group == only used as input to calculations below # these overwrite the variance above var.t[i] <- var(rawdata[treat == 1, i]) var.c[i] <- as.numeric(stats::cov.wt(rawdata[treat == 0, i, drop = FALSE], wt = wts0)$cov) # difference in means diff.means.matched[i, 3] <- diff.means.matched[i, 1] - diff.means.matched[i, 2] # absolute standardized difference in means (denominator is stolen from # calculations on raw data above) diff.means.matched[i, 4] <- abs(diff.means.matched[i, 3])/std.denom[i] if(length(unique(rawdata[,covnames[i]]))>2){ # just for binary # ratio of sds (treat over control: should we change to comparison over inferential) diff.means.matched[i, 5] <- sqrt(var.c[i]/var.t[i]) } } #dimnames(diff.means.matched) <- list(covnames[-(K + 1)], c("treat", "control", "unstd.diff", # "abs.std.diff", "ratio")) dimnames(diff.means.matched) <- list(covnames, c("treat", "control", "unstd.diff", "abs.std.diff", "ratio")) # out <- list(diff.means.raw = diff.means, diff.means.matched = diff.means.matched, covnames = covnames, binary = binary) class(out) <- "balance" return(out) } print.balance <- function(x, ..., combined=FALSE, digits= 2) { if(combined==FALSE){ cat("Balance Statistics for Unmatched Data\n") cat("--\n") print(round(x$diff.means.raw, digits=digits)) cat("--\n") cat("\n") cat("Balance Statistics for Matched Data\n") cat("--\n") print(round(x$diff.means.matched, digits=digits), na.print="--") cat("--\n") cat("\n") } else{ cat("Balance Statistics\n") cat("--\n") print(round(cbind(x$diff.means.raw,x$diff.matched.raw)[,c(4,9,5,10)], digits=digits), na.print="--") } } ### NEXT NEED TO FIGURE OUT HOW TO REVERSE THE ORDER OF THE COVARIATES plot.balance <- function(x, longcovnames=NULL, which.covs="mixed", v.axis=TRUE, cex.main=1, cex.vars=1, cex.pts=1, mar=c(4, 3, 5.1, 2), plot=TRUE, x.max = NULL,...) { # if which.covs = mixed then it plots all as std diffs # if which.covs = binary it only plots binary and as abs unstd diffs # if which.covs = cont it only plots non-binary and as abs std diffs # covnames <- x$covnames if(!is.null(x.max)){ x.range = c(0,x.max) } # if(which.covs=="binary") { # cat("condition satisfied \n") # } # if plotting all, then use the standardized diff for all if(which.covs == "mixed"){ pts <- x$diff.means.raw[,4] # before matched.dat pts2 <- x$diff.means.matched[,4] # after matched K <- length(pts) idx <- 1:K main="Absolute Standardized Difference in Means" } #if plotting just binary use the unstandardized difference # for the plot make it the absolute value of if(which.covs == "binary"){ pts <- abs(x$diff.means.raw[x$binary==TRUE,3]) # before matched.dat pts2 <- abs(x$diff.means.matched[x$binary==TRUE,3]) # after matched K <- length(pts) idx <- 1:K main="Absolute Difference in Means" covnames = covnames[x$binary==TRUE] } #if plotting just continuous use the standardized difference if(which.covs == "cont"){ pts <- x$diff.means.raw[x$binary==FALSE,4] # before matched pts2 <- x$diff.means.matched[x$binary==FALSE,4] # after matched K <- length(pts) idx <- 1:K main="Absolute Standardized Difference in Means" covnames = covnames[x$binary==FALSE] } cat(pts,"\n") # tune the graphic console #par (mar=mar, mgp=mgp, oma=oma, tcl=tcl) par(mar = mar) if (is.null(longcovnames)) { longcovnames <- covnames maxchar <- max(sapply(longcovnames, nchar)) } else { maxchar <- max(sapply(longcovnames, nchar)) } min.mar <- par("mar") mar[2] <- max(min.mar[2], trunc(mar[2] + maxchar/10)) + mar[2] + 0.5 par(mar = mar) ## now reverse the order of everything so the plot proceeds from ## to top to bottom with respect to original ordering of variables pts = rev(pts) pts2 = rev(pts2) longcovnames = rev(longcovnames) if(plot){ # plot the estimates if(is.null(x.max)){ plot(c(pts,pts2), c(idx,idx), #xlim=c(0, max(c(pts,pts2))), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", type="n", main=main, cex.main=cex.main) } if(!is.null(x.max)){ plot(c(pts,pts2), c(idx,idx), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", type="n", xlim=x.range, main=main, cex.main=cex.main) } abline(v=0, lty=2) points(pts, idx, cex=cex.pts) # before matched points(pts2, idx, pch=19, cex=cex.pts) # after matched if (v.axis){ axis(3) } if (is.null(longcovnames)){ axis(2, at=1:K, labels=covnames[1:K], las=2, hadj=1, lty=0, cex.axis=cex.vars) } else{ axis(2, at=1:K, labels=longcovnames[1:K], las=2, hadj=1, lty=0, cex.axis=cex.vars) } } else{ plot(c(pts,pts2), c(idx,idx), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", #xaxs="i", #yaxs="i", type="n", axes=FALSE, #ylim=c(max(idx)+.25, min(idx)-.25), #xlim=x.range, main="", cex.main=cex.main,...) } return(list("raw"=pts, "matched"=pts2)) } arm/R/bayesglm.h.R0000644000175000017500000006312113014470370013542 0ustar nileshnilesh## 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/bayespolr.R0000644000175000017500000002533213014470370013513 0ustar nileshnilesh# 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.R0000644000175000017500000000056213014470370013556 0ustar nileshnilesh.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/fround.R0000644000175000017500000000025613014470370013006 0ustar nileshnileshfround <- function (x, digits) { format (round (x, digits), nsmall=digits) } pfround <- function (x, digits) { print (fround (x, digits), quote=FALSE) } arm/R/mcsamp.R0000644000175000017500000001253113014470370012770 0ustar nileshnilesh# 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/sim.R0000644000175000017500000001275313263577474012331 0ustar nileshnileshsetMethod("sim", signature(object = "lm"), function(object, n.sims=100) { object.class <- class(object)[[1]] summ <- summary (object) coef <- summ$coef[,1:2,drop=FALSE] dimnames(coef)[[2]] <- c("coef.est","coef.sd") sigma.hat <- summ$sigma beta.hat <- coef[,1,drop = FALSE] V.beta <- summ$cov.unscaled n <- summ$df[1] + summ$df[2] k <- summ$df[1] sigma <- rep (NA, n.sims) beta <- array (NA, c(n.sims,k)) dimnames(beta) <- list (NULL, rownames(beta.hat)) for (s in 1:n.sims){ sigma[s] <- sigma.hat*sqrt((n-k)/rchisq(1,n-k)) beta[s,] <- MASS::mvrnorm (1, beta.hat, V.beta*sigma[s]^2) } ans <- new("sim", coef = beta, sigma = sigma) return (ans) } ) setMethod("sim", signature(object = "glm"), function(object, n.sims=100) { object.class <- class(object)[[1]] summ <- summary (object, correlation=TRUE, dispersion = object$dispersion) coef <- summ$coef[,1:2,drop=FALSE] dimnames(coef)[[2]] <- c("coef.est","coef.sd") beta.hat <- coef[,1,drop=FALSE] sd.beta <- coef[,2,drop=FALSE] corr.beta <- summ$corr n <- summ$df[1] + summ$df[2] k <- summ$df[1] V.beta <- corr.beta * array(sd.beta,c(k,k)) * t(array(sd.beta,c(k,k))) #beta <- array (NA, c(n.sims,k)) # dimnames(beta) <- list (NULL, dimnames(beta.hat)[[1]]) # for (s in 1:n.sims){ # beta[s,] <- MASS::mvrnorm (1, beta.hat, V.beta) # } beta <- MASS::mvrnorm (n.sims, beta.hat, V.beta) # Added by Masanao beta2 <- array (0, c(n.sims,length(coefficients(object)))) dimnames(beta2) <- list (NULL, names(coefficients(object))) beta2[,dimnames(beta2)[[2]]%in%dimnames(beta)[[2]]] <- beta # Added by Masanao sigma <- rep (sqrt(summ$dispersion), n.sims) ans <- new("sim", coef = beta2, sigma = sigma) return(ans) } ) setMethod("sim", signature(object = "polr"), function(object, n.sims=100){ x <- as.matrix(model.matrix(object)) coefs <- coef(object) k <- length(coefs) zeta <- object$zeta Sigma <- vcov(object) if(n.sims==1){ parameters <- t(MASS::mvrnorm(n.sims, c(coefs, zeta), Sigma)) }else{ parameters <- MASS::mvrnorm(n.sims, c(coefs, zeta), Sigma) } ans <- new("sim.polr", coef = parameters[,1:k,drop=FALSE], zeta = parameters[,-(1:k),drop=FALSE]) return(ans) }) #setMethod("sim", signature(object = "mer"), # function(object, n.sims=100) # { # #object <- summary(object) ## if (lapply(object@bVar,sum)<=0|sum(unlist(lapply(object@bVar, is.na)))>0){ ## object@call$control <- list(usePQL=TRUE) ## object <- lmer(object@call$formula) # #} # #sc <- attr (VarCorr (object), "sc") # # simulate unmodeled coefficients # # fcoef <- fixef(object) # corF <- vcov(object)@factors$correlation # se.unmodeled <- corF@sd # V.beta <- (se.unmodeled %o% se.unmodeled) * as.matrix(corF) # beta.unmodeled <- NULL # if (length (fcoef) > 0){ # beta.unmodeled[[1]] <- mvrnorm (n.sims, fcoef, V.beta) # names (beta.unmodeled) <- "unmodeled" # } # # simulate coefficients within groups # #coef <- ranef (object) # #estimate <- ranef(object, postVar=TRUE) # #vars <- object@bVar # #beta.bygroup <- vars # # sc <- attr (VarCorr (object), "sc") # coef <- ranef(object, postVar=TRUE) # beta.bygroup <- c(coef) # n.groupings <- length (coef) # for (m in 1:n.groupings){ # #vars.m <- vars[[m]] # vars.m <- attr (coef[[m]], "postVar") # K <- dim(vars.m)[1] # J <- dim(vars.m)[3] # beta.bygroup[[m]] <- array (NA, c(n.sims, J, K)) # bhat <- coef[[m]] # for (j in 1:J){ # V.beta <- untriangle(vars.m[,,j])#*sc^2 # beta.bygroup[[m]][,j,] <- mvrnorm (n.sims, bhat[j,], V.beta) # } # dimnames (beta.bygroup[[m]]) <- c (list(NULL), dimnames(bhat)) # } # betas <- c (beta.unmodeled, beta.bygroup) # return (betas) # } #) #setMethod("sim", signature(object = "mer"), # function(object, n.sims=100, ranef=TRUE) # { # # simulate unmodeled coefficients # fcoef <- fixef(object) # corF <- vcov(object)@factors$correlation # se.unmodeled <- corF@sd # V.beta <- (se.unmodeled %o% se.unmodeled) * as.matrix(corF) # beta.unmodeled <- NULL # if (length (fcoef) > 0){ # beta.unmodeled[[1]] <- mvrnorm (n.sims, fcoef, V.beta) # names (beta.unmodeled) <- "fixef"#"unmodeled" # coef <- beta.unmodeled # } # if(ranef){ # # simulate coefficients within groups # sc <- attr (VarCorr (object), "sc") # scale # #coef <- ranef (object) # #estimate <- ranef(object, postVar=TRUE) # coef <- ranef(object, postVar=TRUE) # beta.bygroup <- coef # n.groupings <- length (coef) # for (m in 1:n.groupings){ # bhat <- as.matrix(coef[[m]]) # to suit the use of mvrnorm # vars.m <- attr (coef[[m]], "postVar") # K <- dim(vars.m)[1] # J <- dim(vars.m)[3] # beta.bygroup[[m]] <- array (NA, c(n.sims, J, K)) # for (j in 1:J){ # V.beta <- .untriangle(vars.m[,,j])#*sc^2 # beta.bygroup[[m]][,j,] <- mvrnorm (n.sims, bhat[j,], V.beta) # } # dimnames (beta.bygroup[[m]]) <- c (list(NULL), dimnames(bhat)) # } # coef <- c (beta.unmodeled, beta.bygroup) # } # return (coef) # } #) arm/R/corrplot.R0000644000175000017500000000212613014470370013353 0ustar nileshnilesh corrplot <- function(data, varnames=NULL, cutpts=NULL, abs=TRUE, details=TRUE, n.col.legend=5, cex.col=0.7, cex.var=0.9, digits=1, color=FALSE) { # some check! if (is.matrix(data)|is.data.frame(data)){ } else { stop ("Data must be a matrix or a data frame!") } if (sum(sapply(data, FUN=is.character))>0) stop ("Data contains non-numeric variables!") if (n.col.legend > 8) stop ("Suggestion: More than 8 levels of colors is difficult to read!") # prepare correlation matrix if (abs){ z.plot <- abs(cor(data, data, use="pairwise.complete.obs")) } else{ z.plot <- cor(data, data, use="pairwise.complete.obs") } if (is.null(varnames)){ z.names <- dimnames(data)[[2]] } else{ z.names <- varnames } triangleplot(x=z.plot, y=z.names, cutpts=cutpts, details=details, n.col.legend=n.col.legend, cex.col=cex.col, cex.var=cex.var, digits=digits, color=color) } arm/R/standardize.R0000644000175000017500000000673513014470370014031 0ustar nileshnileshstandardize.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/AllInternal.R0000644000175000017500000001713513014470370013722 0ustar nileshnilesh# 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/simmer.R0000644000175000017500000001142414301540413013000 0ustar nileshnilesh# simulations of sigma, fixef, and ranef drawn from a posterior # under a flat prior and conditioned on estimate of ranef covar setMethod("sim", signature(object = "merMod"), function(object, n.sims=100) { applyLeftFactor <- function(decomp, rhs) { c(as.vector(decomp$ul %*% rhs[ranefRange] + decomp$ur %*% rhs[fixefRange]), as.vector(decomp$lr %*% rhs[fixefRange])); } # information is conditional on hyperparameters # information is of [ranef, fixef] getInverseInformationLeftFactor <- function(regression) { Lz <- getME(regression, "L"); Rzx <- getME(regression, "RZX"); Rx <- getME(regression, "RX"); # upper left, lower right, and lower left blocks of left-factor of inverse #solveFunc <- getMethod("solve", signature(a = "CHMfactor", b = "diagonalMatrix")); #Rz.inv <- t(solveFunc(Lz, Diagonal(Lz@Dim[1]), "L")); Rz.inv <- t(solve(Lz, Diagonal(Lz@Dim[1]), system = "L")); Rx.inv <- solve(Rx); Rzx.inv <- -Rz.inv %*% Rzx %*% Rx.inv; # this is me figuring some stuff out. new lmer doesn't permute Zt apparently # #Lz.tmp <- as(Lz, "sparseMatrix"); #P.chol <- as(Lz@perm + 1, "pMatrix"); #Zt <- getME(regression, "Zt"); #W <- Diagonal(numObs, regression@resp$sqrtXwt); ## P.ranef <- getRanefPerm(regression); #Lambdat <- getME(regression, "Lambdat") # t(P.ranef) %*% getME(regression, "Lambdat") %*% P.ranef; #A <- Lambdat %*% Zt; #C <- A %*% W; #L.hyp <- Cholesky(tcrossprod(P.chol %*% C), Imult = 1, LDL = FALSE, perm = FALSE); #L.hyp@perm <- Lz@perm; #L.hyp@type[1] <- 2L; #browser(); #P.ranef <- getRanefPerm(model); #Lambda <- P.ranef %*% getRanefChol(model) %*% t(P.ranef); Lambda <- t(getME(regression, "Lambda")); return(list(ul = Lambda %*% Rz.inv, ur = Lambda %*% Rzx.inv, lr = Rx.inv)); } # assumes p(sigma^2) propto sigma^-2 sampleCommonScale <- function(ignored) { return(sqrt(1 / rgamma(1, 0.5 * numDoF, 0.5 * devcomp$cmp[["pwrss"]]))); } regression <- object; devcomp <- getME(regression, "devcomp"); dims <- devcomp$dims; if (dims[["NLMM"]] != 0L) stop("sim not yet implemented for nlmms"); numObs <- dims[["n"]]; numRanef <- dims[["q"]]; numFixef <- dims[["p"]]; numLevels <- dims[["reTrms"]]; isLinearMixedModel <- dims[["GLMM"]] == 0L && dims[["NLMM"]] == 0L; numEffects <- numRanef + numFixef; numDoF <- numObs - numFixef; # pertain to simulations that we do all as a single vector ranefRange <- 1:numRanef; fixefRange <- numRanef + 1:numFixef; # stuff used to rearrange ranef into usable form groupsPerUniqueFactor <- lapply(regression@flist, levels); factorPerLevel <- attr(regression@flist, "assign"); coefficientNamesPerLevel <- regression@cnms; numCoefficientsPerLevel <- as.numeric(sapply(coefficientNamesPerLevel, length)); numGroupsPerLevel <- as.numeric(sapply(groupsPerUniqueFactor[factorPerLevel], length)); numRanefsPerLevel <- numCoefficientsPerLevel * numGroupsPerLevel; ranefLevelMap <- rep.int(seq_along(numRanefsPerLevel), numRanefsPerLevel); # storage for sims simulatedSD <- if (isLinearMixedModel) { rep(NA, n.sims); } else { NA }; simulatedRanef <- vector("list", numLevels); names(simulatedRanef) <- names(regression@cnms); for (i in 1:numLevels) { simulatedRanef[[i]] <- array(NA, c(n.sims, numGroupsPerLevel[i], numCoefficientsPerLevel[i]), list(NULL, groupsPerUniqueFactor[[factorPerLevel[i]]], coefficientNamesPerLevel[[i]])); } simulatedFixef <- matrix(NA, n.sims, numFixef, dimnames = list(NULL, names(fixef(regression)))); # "b" are the rotated random effects, i.e. what ranef() returns in # a rearranged format. effectsMean <- c(getME(regression, "b")@x, getME(regression, "beta")); effectsCovLeftFactor <- getInverseInformationLeftFactor(regression); for (i in 1:n.sims) { if (isLinearMixedModel) { simulatedSD[i] <- sampleCommonScale(regression); sphericalEffects <- rnorm(numEffects, 0, simulatedSD[i]); } else { sphericalEffects <- rnorm(numEffects); } simulatedEffects <- applyLeftFactor(effectsCovLeftFactor, sphericalEffects) + effectsMean; simulatedFixef[i,] <- simulatedEffects[fixefRange]; rawRanef <- simulatedEffects[ranefRange]; simulatedRanefPerLevel <- split(rawRanef, ranefLevelMap); for (k in 1:numLevels) { simulatedRanef[[k]][i,,] <- matrix(simulatedRanefPerLevel[[k]], ncol = numCoefficientsPerLevel[k], byrow = TRUE); } } ans <- new("sim.merMod", "fixef" = simulatedFixef, "ranef" = simulatedRanef, "sigma" = simulatedSD); return(ans); }); arm/R/invlogit.R0000644000175000017500000000020713014470370013340 0ustar nileshnilesh#R function for the logistic function logit <- function (x) { log(x/(1-x)) } invlogit <- function (x) { 1/(1+exp(-x)) } arm/R/triangleplot.R0000644000175000017500000001214013014470370014210 0ustar nileshnilesh 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/se.coef.R0000644000175000017500000000724313014470370013036 0ustar nileshnileshsetMethod("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/AllClass.R0000644000175000017500000000411113014470370013201 0ustar nileshnileshsetOldClass("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/residual.plot.R0000644000175000017500000000225213014470370014274 0ustar nileshnilesh# ============================================================================== # 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/bayesglm.R0000644000175000017500000007120013263604567013326 0ustar nileshnileshbayesglm <- function (formula, family = gaussian, data, weights, subset, na.action, start = NULL, etastart, mustart, offset, control = list(...), model = TRUE, method = "glm.fit", x = FALSE, y = TRUE, contrasts = NULL, drop.unused.levels = TRUE, prior.mean = 0, prior.scale = NULL, prior.df = 1, prior.mean.for.intercept = 0, prior.scale.for.intercept = NULL, prior.df.for.intercept = 1, min.prior.scale = 1e-12, scaled = TRUE, keep.order = TRUE, drop.baseline = TRUE, maxit = 100, print.unnormalized.log.posterior = FALSE, Warning = TRUE, ...) { call <- match.call() if (is.character(family)) { family <- get(family, mode = "function", envir = parent.frame()) } if (is.function(family)) { family <- family() } if (is.null(family$family)) { print(family) stop("'family' not recognized") } if (missing(data)) { data <- environment(formula) } mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "subset", "weights", "na.action", "etastart", "mustart", "offset"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- drop.unused.levels mf$na.action <- NULL mf[[1L]] <- quote(stats::model.frame) mf <- eval(mf, parent.frame()) if (identical(method, "model.frame")){ return(mf) } if (!is.character(method) && !is.function(method)){ stop("invalid 'method' argument") } if (identical(method, "glm.fit")){ control <- do.call("glm.control", control) } control$maxit <- maxit mt <- attr(mf, "terms") Y <- model.response(mf, "any") if (length(dim(Y)) == 1L) { nm <- rownames(Y) dim(Y) <- NULL if (!is.null(nm)) { names(Y) <- nm } } X <- if (!is.empty.model(mt)) { model.matrixBayes(object = mt, data = data, contrasts.arg = contrasts, keep.order = keep.order, drop.baseline = drop.baseline) }else { matrix(, NROW(Y), 0L) } weights <- as.vector(model.weights(mf)) if (!is.null(weights) && !is.numeric(weights)) { stop("'weights' must be a numeric vector") } if (!is.null(weights) && any(weights < 0)) { stop("negative weights not allowed") } offset <- as.vector(model.offset(mf)) if (!is.null(offset)) { if (length(offset) != NROW(Y)) stop(gettextf("number of offsets is %d should equal %d (number of observations)", length(offset), NROW(Y)), domain = NA) } mustart <- model.extract(mf, "mustart") etastart <- model.extract(mf, "etastart") fit <- bayesglm.fit(x = X, y = Y, weights = weights, start = start, etastart = etastart, mustart = mustart, offset = offset, family = family, control = control, intercept = attr(mt, "intercept") > 0L, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = prior.mean.for.intercept, prior.scale.for.intercept = prior.scale.for.intercept, prior.df.for.intercept = prior.df.for.intercept, min.prior.scale = min.prior.scale, print.unnormalized.log.posterior = print.unnormalized.log.posterior, scaled = scaled, Warning = Warning) if (length(offset) && attr(mt, "intercept") > 0L) { fit2 <- bayesglm.fit(x = X[, "(Intercept)", drop = FALSE], y = Y, weights = weights, offset = offset, family = family, control = control, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = prior.mean.for.intercept, prior.scale.for.intercept = prior.scale.for.intercept, prior.df.for.intercept = prior.df.for.intercept, min.prior.scale = min.prior.scale, print.unnormalized.log.posterior = print.unnormalized.log.posterior, scaled = scaled, Warning = Warning) if (!fit2$converged){ warning("fitting to calculate the null deviance did not converge -- increase 'maxit'?") } fit$null.deviance <- fit2$deviance } if (model) { fit$model <- mf } fit$na.action <- attr(mf, "na.action") if (x) { fit$x <- X } if (!y) { fit$y <- NULL } fit <- c(fit, list(call = call, formula = formula, terms = mt, data = data, offset = offset, control = control, method = method, contrasts = attr(X, "contrasts"), xlevels = .getXlevels(mt, mf)), keep.order = keep.order, drop.baseline = drop.baseline) class(fit) <- c("bayesglm", "glm", "lm") return(fit) } bayesglm.fit <- function (x, y, weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(), control = list(), intercept = TRUE, prior.mean = 0, prior.scale = NULL, prior.df = 1, prior.mean.for.intercept = 0, prior.scale.for.intercept = NULL, prior.df.for.intercept = 1, min.prior.scale = 1e-12, scaled = TRUE, print.unnormalized.log.posterior = FALSE, Warning = TRUE) { control <- do.call("glm.control", control) x <- as.matrix(x) xnames <- dimnames(x)[[2L]] ynames <- if (is.matrix(y)){ rownames(y) }else{ names(y) } conv <- FALSE nobs <- NROW(y) nvars <- NCOL(x) #=============================== # initialize priors #=============================== if(is.null(prior.scale)){ prior.scale <- 2.5 if(family$link == "probit"){ prior.scale <- prior.scale*1.6 } } if(is.null(prior.scale.for.intercept)){ prior.scale.for.intercept <- 10 if(family$link == "probit"){ prior.scale.for.intercept <- prior.scale.for.intercept*1.6 } } if(intercept){ nvars <- nvars - 1 } if(length(prior.mean)==1L){ prior.mean <- rep(prior.mean, nvars) }else if(length(prior.mean)!=nvars){ stop("invalid length for prior.mean") } if(length(prior.scale)==1L){ prior.scale <- rep(prior.scale, nvars) }else if(length(prior.scale)!=nvars){ stop("invalid length for prior.scale") } if(length(prior.df)==1L){ prior.df <- rep(prior.df, nvars) }else if(length(prior.df)!=nvars){ stop("invalid length for prior.df") } if(intercept){ prior.mean <- c(prior.mean.for.intercept, prior.mean) prior.scale <- c(prior.scale.for.intercept, prior.scale) prior.df <- c(prior.df.for.intercept, prior.df) } if(scaled){ if(family$family=="gaussian"){ prior.scale <- prior.scale*2*sd(y) } prior.scale.0 <- prior.scale if(nvars==0&intercept){ # this is need to reajust nvars when intercept is TRUE nvars <- 1 }else if(intercept){ nvars <- nvars + 1 } for(j in 1:nvars){ x.obs <- x[,j] x.obs <- x.obs[!is.na(x.obs)] num.categories <- length(unique(x.obs)) x.scale <- 1 if(num.categories==2L){ x.scale <- max(x.obs) - min(x.obs) }else if(num.categories>2){ x.scale <- 2*sd(x.obs) } prior.scale[j] <- prior.scale[j]/x.scale if(prior.scale[j] < min.prior.scale){ prior.scale[j] <- min.prior.scale warning("prior scale for varible ", j, " set to min.prior.scale = ", min.prior.scale, "\n") } } } #=================== nvars <- NCOL(x) EMPTY <- nvars == 0 if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) variance <- family$variance linkinv <- family$linkinv if (!is.function(variance) || !is.function(linkinv)) stop("'family' argument seems not to be a valid family object", call. = FALSE) dev.resids <- family$dev.resids aic <- family$aic mu.eta <- family$mu.eta unless.null <- function(x, if.null){ if (is.null(x)) if.null else x } valideta <- unless.null(family$valideta, function(eta) TRUE) validmu <- unless.null(family$validmu, function(mu) TRUE) if (is.null(mustart)) { eval(family$initialize) }else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } if (EMPTY) { eta <- rep.int(0, nobs) + offset if (!valideta(eta)) stop("invalid linear predictor values in empty model", call. = FALSE) mu <- linkinv(eta) if (!validmu(mu)) stop("invalid fitted means in empty model", call. = FALSE) dev <- sum(dev.resids(y, mu, weights)) w <- ((weights * mu.eta(eta)^2)/variance(mu))^0.5 residuals <- (y - mu)/mu.eta(eta) good <- rep_len(TRUE, length(residuals)) boundary <- conv <- TRUE coef <- numeric() iter <- 0L } else { coefold <- NULL eta <- if (!is.null(etastart)){ etastart }else if (!is.null(start)){ if (length(start) != nvars){ if(start==0&length(start)==1){ start <- rep(0, nvars) offset + as.vector(ifelse((NCOL(x) == 1L), x*start, x %*% start)) }else{ stop(gettextf("length of 'start' should equal %d and correspond to initial coefs for %s", nvars, paste(deparse(xnames), collapse = ", ")), domain = NA) } } else { coefold <- start offset + as.vector(if (NCOL(x) == 1L) x * start else x %*% start) } }else{ family$linkfun(mustart) } mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("cannot find valid starting values: please specify some", call. = FALSE) devold <- sum(dev.resids(y, mu, weights)) boundary <- conv <- FALSE #====================================== # initialize prior.sd #====================================== prior.sd <- prior.scale #===================================== dispersion <- ifelse((family$family %in% c("poisson", "binomial")), 1, var(y)/10000) dispersionold <- dispersion for (iter in 1L:control$maxit) { good <- weights > 0 varmu <- variance(mu)[good] if (anyNA(varmu)) stop("NAs in V(mu)") if (any(varmu == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) if (all(!good)) { conv <- FALSE warning(gettextf("no observations informative at iteration %d", iter), domain = NA) break } z <- (eta - offset)[good] + (y - mu)[good]/mu.eta.val[good] w <- sqrt((weights[good] * mu.eta.val[good]^2)/variance(mu)[good]) ngoodobs <- as.integer(nobs - sum(!good)) #====================== # data augmentation #========================= # coefs.hat <- rep(0, NCOL(x)) # why do we need coefs.hat here? SU 2015.3.30 x.star <- rbind(x, diag(NCOL(x))) if(intercept&scaled){ x.star[nobs+1,] <- colMeans(x) } z.star <- c (z, prior.mean) w.star <- c (w, sqrt(dispersion)/prior.sd) #================================================= good.star <- c (good, rep(TRUE,NCOL(x))) ngoodobs.star <- ngoodobs + NCOL(x) #fit <- .Call(C_Cdqrls, x.star[good, , drop = FALSE] * # w.star, z.star * w.star, min(1e-07, control$epsilon/1000), # check = FALSE) fit <- lm.fit(x = x.star[good.star,,drop=FALSE]*w.star, y = z.star*w.star) if (any(!is.finite(fit$coefficients))) { conv <- FALSE warning(gettextf("non-finite coefficients at iteration %d", iter), domain = NA) break } start[fit$qr$pivot] <- coefs.hat <- fit$coefficients fit$qr$qr <- as.matrix (fit$qr$qr) V.coefs <- chol2inv(fit$qr$qr[1:NCOL(x.star), 1:NCOL(x.star), drop = FALSE]) if (family$family == "gaussian" & scaled){ prior.scale <- prior.scale.0 } prior.sd <- ifelse(prior.df == Inf, prior.scale, sqrt(((coefs.hat - prior.mean)^2 + diag(V.coefs)*dispersion + prior.df * prior.scale^2)/(1 + prior.df))) start[fit$qr$pivot] <- fit$coefficients eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) dev <- sum(dev.resids(y, mu, weights)) if (!(family$family %in% c("poisson", "binomial"))) { mse.resid <- mean((w * (z - x %*% coefs.hat))^2) mse.uncertainty <- mean(rowSums(( x %*% V.coefs ) * x)) * dispersion # faster dispersion <- mse.resid + mse.uncertainty } if (control$trace) cat("Deviance = ", dev, " Iterations - ", iter, "\n", sep = "") boundary <- FALSE if (!is.finite(dev)) { if (is.null(coefold)) stop("no valid set of coefficients has been found: please supply starting values", call. = FALSE) warning("step size truncated due to divergence", call. = FALSE) ii <- 1 while (!is.finite(dev)) { if (ii > control$maxit) stop("inner loop 1; cannot correct step size", call. = FALSE) ii <- ii + 1 start <- (start + coefold)/2 eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) dev <- sum(dev.resids(y, mu, weights)) } boundary <- TRUE if (control$trace) cat("Step halved: new deviance = ", dev, "\n", sep = "") } if (!(valideta(eta) && validmu(mu))) { if (is.null(coefold)) stop("no valid set of coefficients has been found: please supply starting values", call. = FALSE) warning("step size truncated: out of bounds", call. = FALSE) ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; cannot correct step size", call. = FALSE) ii <- ii + 1 start <- (start + coefold)/2 eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) } boundary <- TRUE dev <- sum(dev.resids(y, mu, weights)) if (control$trace) cat("Step halved: new deviance = ", dev, "\n", sep = "") } #=============================== # print unnormalized log posterior #================================ if (family$family == "binomial" && print.unnormalized.log.posterior) { logprior <- sum(dt(coefs.hat, prior.df, prior.mean, log = TRUE)) xb <- invlogit( x %*% coefs.hat ) loglikelihood <- sum( log( c( xb[ y == 1 ], 1 - xb[ y == 0 ] ) ) ) cat( "log prior: ", logprior, ", log likelihood: ", loglikelihood, ", unnormalized log posterior: ", loglikelihood +logprior, "\n" ,sep="") } #================================ if (iter > 1 & abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon & abs(dispersion - dispersionold)/(0.1 + abs(dispersion)) < control$epsilon) { conv <- TRUE coef <- start break }else { devold <- dev dispersionold <- dispersion coef <- coefold <- start } } if (!conv){ warning("algorithm did not converge", call. = FALSE) } if (boundary){ warning("algorithm stopped at boundary value", call. = FALSE) } eps <- 10 * .Machine$double.eps if (family$family == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)){ warning("fitted probabilities numerically 0 or 1 occurred", call. = FALSE) } } if (family$family == "poisson") { if (any(mu < eps)){ warning("fitted rates numerically 0 occurred", call. = FALSE) } } if (fit$rank < nvars){ coef[fit$qr$pivot][seq.int(fit$rank + 1, nvars)] <- NA } xxnames <- xnames[fit$qr$pivot] residuals <- rep.int(NA, nobs) residuals[good] <- z - (eta - offset)[good] fit$qr$qr <- as.matrix(fit$qr$qr) nr <- min(sum(good), nvars) if (nr < nvars) { Rmat <- diag(nvars) Rmat[1L:nr, 1L:nvars] <- fit$qr$qr[1L:nr, 1L:nvars] } else Rmat <- fit$qr$qr[1L:nvars, 1L:nvars] Rmat <- as.matrix(Rmat) Rmat[row(Rmat) > col(Rmat)] <- 0 names(coef) <- xnames colnames(fit$qr$qr) <- xxnames dimnames(Rmat) <- list(xxnames, xxnames) } names(residuals) <- ynames names(mu) <- ynames names(eta) <- ynames wt <- rep.int(0, nobs) wt[good] <- w^2 names(wt) <- ynames names(weights) <- ynames names(y) <- ynames wtdmu <- if (intercept){ sum(weights * y)/sum(weights) } else{ linkinv(offset) } nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) rank <- if (EMPTY) { 0 } else{ fit$rank } resdf <- n.ok - rank aic.model <- aic(y, n.ok, mu, weights, dev) + 2 * rank list(coefficients = coef, residuals = residuals, fitted.values = mu, effects = if (!EMPTY) fit$effects, R = if (!EMPTY) Rmat, rank = rank, qr = if (!EMPTY) structure(getQr(fit)[c("qr", "rank", "qraux", "pivot", "tol")], class = "qr"), family = family, linear.predictors = eta, deviance = dev, aic = aic.model, null.deviance = nulldev, iter = iter, weights = wt, prior.weights = weights, df.residual = resdf, df.null = nulldf, y = y, converged = conv, boundary = boundary, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.sd = prior.sd, dispersion = dispersion) } setMethod("print", signature(x = "bayesglm"), function(x, digits=2) display(object=x, digits=digits)) setMethod("show", signature(object = "bayesglm"), function(object) display(object, digits=2)) predict.bayesglm <- function (object, newdata = NULL, type = c("link", "response", "terms"), se.fit = FALSE, dispersion = NULL, terms = NULL, na.action = na.pass, ...) { type <- match.arg(type) na.act <- object$na.action object$na.action <- NULL if (!se.fit) { if (missing(newdata)) { pred <- switch(type, link = object$linear.predictors, response = object$fitted.values, terms = predictLM(object, se.fit = se.fit, scale = 1, type = "terms", terms = terms)) if (!is.null(na.act)) pred <- napredict(na.act, pred) } else { pred <- predictLM(object, newdata, se.fit, scale = 1, type = ifelse(type == "link", "response", type), terms = terms, na.action = na.action) switch(type, response = { pred <- family(object)$linkinv(pred) }, link = , terms = ) } } else { if (inherits(object, "survreg")) dispersion <- 1 if (is.null(dispersion) || dispersion == 0) dispersion <- summary(object, dispersion = dispersion)$dispersion residual.scale <- as.vector(sqrt(dispersion)) pred <- predictLM(object, newdata, se.fit, scale = residual.scale, type = ifelse(type == "link", "response", type), terms = terms, na.action = na.action) fit <- pred$fit se.fit <- pred$se.fit switch(type, response = { se.fit <- se.fit * abs(family(object)$mu.eta(fit)) fit <- family(object)$linkinv(fit) }, link = , terms = ) if (missing(newdata) && !is.null(na.act)) { fit <- napredict(na.act, fit) se.fit <- napredict(na.act, se.fit) } pred <- list(fit = fit, se.fit = se.fit, residual.scale = residual.scale) } pred } predictLM <- function (object, newdata, se.fit = FALSE, scale = NULL, df = Inf, interval = c("none", "confidence", "prediction"), level = 0.95, type = c("response", "terms"), terms = NULL, na.action = na.pass, pred.var = res.var/weights, weights = 1, ...) { tt <- terms(object) keep.order <- object$keep.order drop.baseline <- object$drop.baseline if (!inherits(object, "lm")) warning("calling predict.lm() ...") if (missing(newdata) || is.null(newdata)) { mm <- X <- model.matrix(object) mmDone <- TRUE offset <- object$offset } else { Terms <- delete.response(tt) m <- model.frame(Terms, newdata, na.action = na.action, xlev = object$xlevels) if (!is.null(cl <- attr(Terms, "dataClasses"))) .checkMFClasses(cl, m) X <- model.matrixBayes(Terms, m, contrasts.arg = object$contrasts, keep.order = keep.order, drop.baseline = drop.baseline) offset <- rep(0, nrow(X)) if (!is.null(off.num <- attr(tt, "offset"))) for (i in off.num) offset <- offset + eval(attr(tt, "variables")[[i + 1]], newdata) if (!is.null(object$call$offset)) offset <- offset + eval(object$call$offset, newdata) mmDone <- FALSE } n <- length(object$residuals) p <- object$rank p1 <- seq_len(p) piv <- if (p) getQr(object)$pivot[p1] if (p < ncol(X) && !(missing(newdata) || is.null(newdata))) warning("prediction from a rank-deficient fit may be misleading") beta <- object$coefficients predictor <- drop(X[, piv, drop = FALSE] %*% beta[piv]) if (!is.null(offset)) predictor <- predictor + offset interval <- match.arg(interval) if (interval == "prediction") { if (missing(newdata)) warning("Predictions on current data refer to _future_ responses\n") if (missing(newdata) && missing(weights)) { w <- .weights.default(object) if (!is.null(w)) { weights <- w warning("Assuming prediction variance inversely proportional to weights used for fitting\n") } } if (!missing(newdata) && missing(weights) && !is.null(object$weights) && missing(pred.var)) warning("Assuming constant prediction variance even though model fit is weighted\n") if (inherits(weights, "formula")) { if (length(weights) != 2L) stop("'weights' as formula should be one-sided") d <- if (missing(newdata) || is.null(newdata)) model.frame(object) else newdata weights <- eval(weights[[2L]], d, environment(weights)) } } type <- match.arg(type) if (se.fit || interval != "none") { res.var <- if (is.null(scale)) { r <- object$residuals w <- object$weights rss <- sum(if (is.null(w)) r^2 else r^2 * w) df <- object$df.residual rss/df } else scale^2 if (type != "terms") { if (p > 0) { XRinv <- if (missing(newdata) && is.null(w)) qr.Q(getQr(object))[, p1, drop = FALSE] else X[, piv] %*% qr.solve(qr.R(getQr(object))[p1, p1]) ip <- drop(XRinv^2 %*% rep(res.var, p)) } else ip <- rep(0, n) } } if (type == "terms") { if (!mmDone) { mm <- model.matrixBayes(object, keep.order = keep.order, drop.baseline = drop.baseline) mmDone <- TRUE } aa <- attr(mm, "assign") ll <- attr(tt, "term.labels") hasintercept <- attr(tt, "intercept") > 0L if (hasintercept) ll <- c("(Intercept)", ll) aaa <- factor(aa, labels = ll) asgn <- split(order(aa), aaa) if (hasintercept) { asgn$"(Intercept)" <- NULL if (!mmDone) { mm <- model.matrixBayes(object, keep.order = keep.order, drop.baseline = drop.baseline) mmDone <- TRUE } avx <- colMeans(mm) termsconst <- sum(avx[piv] * beta[piv]) } nterms <- length(asgn) if (nterms > 0) { predictor <- matrix(ncol = nterms, nrow = NROW(X)) dimnames(predictor) <- list(rownames(X), names(asgn)) if (se.fit || interval != "none") { ip <- matrix(ncol = nterms, nrow = NROW(X)) dimnames(ip) <- list(rownames(X), names(asgn)) Rinv <- qr.solve(qr.R(getQr(object))[p1, p1]) } if (hasintercept) X <- sweep(X, 2L, avx, check.margin = FALSE) unpiv <- rep.int(0L, NCOL(X)) unpiv[piv] <- p1 for (i in seq.int(1L, nterms, length.out = nterms)) { iipiv <- asgn[[i]] ii <- unpiv[iipiv] iipiv[ii == 0L] <- 0L predictor[, i] <- if (any(iipiv > 0L)) X[, iipiv, drop = FALSE] %*% beta[iipiv] else 0 if (se.fit || interval != "none") ip[, i] <- if (any(iipiv > 0L)) as.matrix(X[, iipiv, drop = FALSE] %*% Rinv[ii, , drop = FALSE])^2 %*% rep.int(res.var, p) else 0 } if (!is.null(terms)) { predictor <- predictor[, terms, drop = FALSE] if (se.fit) ip <- ip[, terms, drop = FALSE] } } else { predictor <- ip <- matrix(0, n, 0L) } attr(predictor, "constant") <- if (hasintercept) termsconst else 0 } if (interval != "none") { tfrac <- qt((1 - level)/2, df) hwid <- tfrac * switch(interval, confidence = sqrt(ip), prediction = sqrt(ip + pred.var)) if (type != "terms") { predictor <- cbind(predictor, predictor + hwid %o% c(1, -1)) colnames(predictor) <- c("fit", "lwr", "upr") } else { if (!is.null(terms)) hwid <- hwid[, terms, drop = FALSE] lwr <- predictor + hwid upr <- predictor - hwid } } if (se.fit || interval != "none") { se <- sqrt(ip) if (type == "terms" && !is.null(terms) && !se.fit) se <- se[, terms, drop = FALSE] } if (missing(newdata) && !is.null(na.act <- object$na.action)) { predictor <- napredict(na.act, predictor) if (se.fit) se <- napredict(na.act, se) } if (type == "terms" && interval != "none") { if (missing(newdata) && !is.null(na.act)) { lwr <- napredict(na.act, lwr) upr <- napredict(na.act, upr) } list(fit = predictor, se.fit = se, lwr = lwr, upr = upr, df = df, residual.scale = sqrt(res.var)) } else if (se.fit) list(fit = predictor, se.fit = se, df = df, residual.scale = sqrt(res.var)) else predictor } getQr <- function(x, ...){ if (is.null(r <- x$qr)) stop("lm object does not have a proper 'qr' component.\n Rank zero or should not have used lm(.., qr=FALSE).") r } arm/R/display.R0000644000175000017500000003241313014470370013156 0ustar nileshnileshsetMethod("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/matching.R0000644000175000017500000001104413707226233013306 0ustar nileshnilesh## 2019 version of matching function matching <- function(z, score, replace=FALSE){ # argument z is the vector of indicators for treatment or control # # argument score is the vector of the propensity scores in the # # same order as z # # THIS FUNCTION REQUIRES THE INFERENTIAL GROUP TO SATISFY Z=1 # # Group satisfying Z=1 will remain intact and matches for them will # # be found from among those satisfying Z=0 # # # # the function (potentially) returns several things # # 1) match.ind: a vector of indices that the corresponding unit is # # matched to. The length is equal to the number of unique IDs # # 2) cnts: shows the number of times each unit will be used in any # # subsequent analyses (1 for each treated unit and number of # # times used as a match for each control unit (equivalently the # # number of treated units it is matched to) # # # # 3a) pairs: indicator for each pair [only available for # # replace=TRUE] # OR # 3b) matches: a matrix capturing which treated observations # were matched to which controls [only for replace=FALSE] # # # Ties are broken through random sampling so set seed if you want # # to replicate results # ##################################################################### n <- length(score) nt <- sum(z) nc <- sum(1-z) ind.t <- c(1:n)[z==1] ind.c <- c(1:n)[z==0] cnts <- rep(0, n) cnts[z==1] = rep(1,nt) scorec <- score[z == 0] scoret <- score[z == 1] # matching with replacement if (replace){ # calculate distances between all pairs of units dist = abs(outer(scoret,scorec,FUN="-")) # find the identify the controls with the minimum distance from # each treated -- if there are ties, randomly pick one mins = apply(dist,1,min) # create a matrix with 1's for control columns matching the minimum # distance for the corresponding treatment rows matches = dist - mins matches[matches!=0] = 1 matches = 1 - matches # if more than one control observation is chosen as a match for a given # treated we randomly chose which column to retain if(sum(matches)>nt){ # figure out which rows and then replace the multiple 1's with one # randomly chosen one for(i in c(1:nt)[apply(matches,1,sum)>1]){ matches_i <- c(1:nc)[matches[i,]==1] nmi <- length(matches_i) matches[i,matches_i] <- sample(c(1,rep(0,nmi-1)),nmi,replace=FALSE) } } # now fill in matched and ind.mt and pairs and counts ind.cm <- matches %*% ind.c # now record counts cnts[z==0] <- apply(matches,2,sum) # match indicators -- shouldn't be used for analysis match.ind <- c(ind.t, ind.cm) out <- list(match.ind = match.ind, cnts = cnts, matches = matches) } # matching *without* replacement if (!replace){ pairs = rep(NA,n) match.ind <- rep(0, n) tally <- 0 for (i in ind.t) { ## DEAL WITH TIES IN A MORE PRINCIPLED WAY? -- can do by adding a second # argument to break ties that is random available <- (1:n)[(z == 0) & (match.ind == 0)] j <- available[order(abs(score[available] - score[i]))[1]] cnts[j] <- 1 match.ind[i] <- j match.ind[j] <- i tally <- tally + 1 pairs[c(i, j)] <- tally } #match.ind <- match.ind[match.ind!=0] out <- list(match.ind = match.ind, cnts = cnts, pairs = pairs) } return(out) } #pscores.fun <- function(treat=Z, outs=Y, covs=X){ # # # N <- nrow(covs) # nouts <- 1 # ncovs <- ncol(covs) # # # # first set up places to store results # res <- matrix(0,nouts,2) # bal <- matrix(0,ncovs,2) # # # # estimate p-scores # dat <- cbind.data.frame(treat=treat,covs) # mod <- glm(dat,family=binomial(link="logit")) # qx <- predict(mod, type="response")#mod$linear # # # ### Now Matching With Replacement # matchout <- matching(z=treat, score=qx, replace=TRUE) # # # ### and treatment effect estimation with robust s.e.'s # wts <- rep(1, N) # wts[treat == 0] <- matchout$cnts # res <- .wls.all2(cbind(rep(1, sum(wts > 0)), treat[wts > 0],covs[wts > 0, ]), wts[wts > 0], outs[wts > 0], treat[wts > 0]) # c(res[3],sqrt(res[2])) #} arm/R/fitted.R0000644000175000017500000000271213014470370012767 0ustar nileshnilesh # the plan here is to shuffle the ranefs back into the way a merMod object # stores them so that a simple X * beta + Z * theta op does the trick fitted.sim.merMod <- function(object, regression,...){ if (missing(regression) || is.null(regression)) stop("fitted for sim.mer requires original merPred object as well."); if (!inherits(regression, "merMod")) stop("regression argument for fitted on sim.mer does not inherit from class 'merMod'"); sims <- object; numSimulations <- dim(sims@fixef)[1]; devcomp <- getME(regression, "devcomp"); dims <- devcomp$dims; numRanef <- dims[["q"]]; numLevels <- dims[["reTrms"]]; simulatedRanef <- matrix(0, numRanef, numSimulations); index <- 0; for (i in 1:length(sims@ranef)) { levelSims <- sims@ranef[[i]]; numCoefficientsPerLevel <- dim(levelSims)[2]; numGroupsPerLevel <- dim(levelSims)[3]; for (j in 1:numCoefficientsPerLevel) { ranefRange <- index + 1:numGroupsPerLevel; index <- index + numGroupsPerLevel; simulatedRanef[ranefRange,] <- t(levelSims[,j,]); } } X <- getME(regression, "X"); Zt <- getME(regression, "Zt"); linearPredictor <- as.matrix(tcrossprod(X, sims@fixef) + crossprod(Zt, simulatedRanef)) + matrix(getME(regression, "offset"), dims[["n"]], numSimulations); if (dims[["GLMM"]] == 0L){ return(linearPredictor) }else{ return(regression@resp$family$linkinv(linearPredictor)) } }; arm/R/AllGeneric.R0000644000175000017500000000262213014470370013515 0ustar nileshnilesh #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/readColumns.R0000644000175000017500000000044313014470370013763 0ustar nileshnileshread.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/extractDIC.R0000644000175000017500000000174213014470370013504 0ustar nileshnilesh 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/coefplot.R0000644000175000017500000003304613014470370013327 0ustar nileshnileshcoefplot.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/contrasts.bayes.R0000644000175000017500000000407413014470370014635 0ustar nileshnileshcontr.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/multicomp.plot.R0000644000175000017500000000676413014470370014511 0ustar nileshnilesh#============================================================================== # 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/sigma.hat.R0000644000175000017500000000350313014470370013362 0ustar nileshnilesh 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/traceplot.R0000644000175000017500000000407013014470370013504 0ustar nileshnilesh#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/discrete.histogram.R0000644000175000017500000000616713014470370015316 0ustar nileshnileshdiscrete.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/model.matrixBayes.R0000644000175000017500000001470713014470370015106 0ustar nileshnilesh#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/binnedplot.R0000644000175000017500000000467413014470370013657 0ustar nileshnilesh# ==================================================================== # 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/rescale.R0000644000175000017500000000141713014470370013127 0ustar nileshnilesh# 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/coef.R0000644000175000017500000000125613014470370012426 0ustar nileshnilesh 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/MD50000644000175000017500000000626314302744502011503 0ustar nileshnilesh8fa0dc4b060ce8c5eb9eb20168f3f971 *CHANGELOG e3fee347917e801e1cbf3a282c3a6074 *DESCRIPTION 0807a09587453aa0a6c70a1ccebbdc8a *NAMESPACE df99a0be1f7702e22980626c8c9c6336 *R/AllClass.R de23b5716ddafb25fbb2abee086af892 *R/AllGeneric.R a2c62bf06a9a76dc6965d8f435f471ec *R/AllInternal.R 73aaffc4bc4ef7334888371ef67c4dca *R/balance.R 5093d7811dbfd7c03981170adcd18ea9 *R/bayesglm.R 054bbff33242f6e4bd26a9f7990207b1 *R/bayesglm.h.R 2f1dbf590eda1111607feb000f318aab *R/bayespolr.R 828d634c780a39b66596cc9fe885cf20 *R/binnedplot.R 7b72b8fab8bd8a78cd849318fcfe5325 *R/coef.R a012a9e1014899bac761bd1b6103205e *R/coefplot.R 87ff45a243d955c0d0d3bd8af50a3f2f *R/contrasts.bayes.R 041d95b04bf7fdb3dbee0fde2bfbe400 *R/corrplot.R 004bf778675992949bc419bcdcf21382 *R/discrete.histogram.R 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 0abc9dcad202c44cb985ad97b77af16e *R/matching.R df9287e969f74e2947f9e0e5b19d26fc *R/mcsamp.R 7be84861e689714dc27857682d749a74 *R/model.matrixBayes.R 6d6bc7861c1f13930bfa36044b8c0ca4 *R/multicomp.plot.R 7d0f269ea12f242f4d43e3661f68396e *R/readColumns.R bcf237b4f9940d6b8da304a403cc3a99 *R/rescale.R 0eb80aef5e725716ee52fafa50654820 *R/residual.plot.R b2c045448ef2d771b1213b48d09f01b4 *R/se.coef.R 182cfee5b48b437cdc22b005cfc4c62b *R/sigma.hat.R 1ded9c8538a369ab08d54b9b9500f2e8 *R/sim.R b2aebcf507ea399f88098d90c9002a57 *R/simmer.R ccd813b440101e320bbdeabc36c61a0e *R/standardize.R af03f0653476d7242cb96915aa3ba7eb *R/traceplot.R 4dae5be8be23a21a990dd56234748f31 *R/triangleplot.R 91f29004f60c810f6f3cc60a5a9520f3 *README.md 12e52a54f9a2b2aa85f8162365ecce7c *data/lalonde.rda 8d528001b15d7ee29ae38011dd6d7864 *man/balance.Rd c48081163741773a5e94773d9fc18fee *man/bayesglm.Rd 8a91e3e8eda21c3177556485de2e43e4 *man/bayespolr.Rd ebcb240293af88f21122a5edde46d44b *man/binnedplot.Rd ce4a636e3cabb7e8ab9c0967077ca36d *man/coefplot.Rd a1b8750a84af242a5317ab317b2c9fbd *man/contrasts.bayes.Rd 31accba9d79c6a08c0a871aab1d36ecc *man/corrplot.Rd 9449fa9d48406131a6bb36c55abc02fa *man/discrete.histogram.Rd 71fb3d77fdaacc5b46ace05c2b41f778 *man/display.Rd fca667b4198132390e73c91160541eb1 *man/extractDIC.mer.Rd f369ae9b94cbafa6783974a219d98cde *man/fround.Rd 2f96eecdbd14cd8ce4caa733f383b828 *man/go.Rd 252d366231e5912427f51c46d69da410 *man/invlogit.Rd e7f14f9263a4f3966f0fb9c7ca194a21 *man/lalonde.Rd 93dd0b99834ed4ed9cb1b4fd9a8bc1fa *man/matching.Rd 380f76417beff9b45a14e039204505a0 *man/mcsamp.Rd 33853edcafe777b46ed95125f5704311 *man/model.matrixBayes.Rd 6ce8710af8c054cd4262b7a87169154d *man/multicomp.plot.Rd 36a4b93b16160c3659bf8379d32d2abb *man/readColumns.Rd c1d2330f842bb2e92ee2a2a855fdb9c2 *man/rescale.Rd ac82073046f893e37c9500741a39014d *man/residual.plot.Rd 4daff88c386691fa72eec0cb9d02541d *man/se.coef.Rd 0a1dd5a48de8698930dc00605630e892 *man/sigma.hat.Rd 74864d3e83f962bbbbd4c71765f0fd30 *man/sim.Rd d217db42375db16268fb13597dee7a20 *man/standardize.Rd f2120afe3b932435f11180d9ac5b3a57 *man/traceplot.Rd 66635f3bc271935f08bdb626869ebbf5 *man/triangleplot.Rd arm/NAMESPACE0000644000175000017500000000630614301551502012403 0ustar nileshnileshimportFrom(graphics, "abline", "axis", "box", "image", "layout", "lines", "par", "plot", "points", "polygon", "rect", "segments", "text", "title") importFrom(grDevices, "gray", "heat.colors", "rainbow") importFrom(methods, "as", "getMethod", "new", "setClass", "setOldClass", "show", "signature") importFrom(utils, "packageDescription", "read.fwf") importFrom(Matrix, "t", "crossprod", "tcrossprod", "colMeans", "Diagonal", "solve" ) importFrom(stats, ".getXlevels", ".checkMFClasses", "AIC", "as.formula", "binomial", "coefficients", "coef", "contrasts<-", "cor", "dcauchy", "delete.response", "deviance", "dlogis", "dnorm", "dt", "family", "fitted", "formula", "gaussian", "glm.control", "is.empty.model", "lm.fit", "logLik", "model.extract", "model.frame", "model.matrix", "model.matrix.default", "model.offset", "model.response", "model.weights", "na.exclude", "na.omit", "na.pass", "napredict", "optim", "predict", "pcauchy", "plogis", "pnorm", "qt", "rchisq", "rgamma", "rnorm", "sd", "terms", "terms.formula", "var", "vcov", "weighted.mean") importFrom(coda, "nvar", "varnames", "nchain" ) importFrom(MASS, "polr", "mvrnorm" ) importFrom(nlme, "fixef", "ranef", "VarCorr" ) importFrom(lme4, "getME", "isREML", "refitML" ) importFrom(abind, "abind") exportClasses( "balance", "bayesglm", "bayespolr", "sim", "sim.merMod" ) exportMethods( "coefplot", "display", "mcsamp", "se.coef", "sim", "print", "show", "standardize", "traceplot" ) export( "extractDIC", "balance", "bayesglm", "bayesglm.fit", "bayespolr", "binnedplot", "binned.resids", "coefplot", "coefplot.default", "contr.bayes.ordered", "contr.bayes.unordered", "corrplot", "display", "discrete.histogram", "discrete.hist", "fround", "G", "go", "invlogit", "logit", "matching", "mcsamp", "model.matrixBayes", "multicomp.plot", "mcplot", "pfround", "read.columns", "rescale", "residual.plot", "se.coef", "se.fixef", "se.ranef", "sigma.hat", "sim", "traceplot", "triangleplot" ) S3method(extractDIC, merMod) S3method(print, GO) S3method(plot, balance) S3method(print, balance) S3method(predict, bayesglm) S3method(coef, sim) S3method(coef, sim.polr) S3method(coef, sim.merMod) S3method(fitted, sim.merMod) S3method(fixef, sim.merMod) S3method(ranef, sim.merMod) S3method(sigma.hat, lm) S3method(sigma.hat, glm) S3method(sigma.hat, merMod) S3method(sigma.hat, sim) S3method(sigma.hat, sim.merMod) arm/README.md0000644000175000017500000000011713651440121012436 0ustar nileshnilesh# arm ARM: Data Analysis Using Regression and Multilevel/Hierarchical Models arm/man/0000755000175000017500000000000014301551502011732 5ustar nileshnilesharm/man/sim.Rd0000644000175000017500000001106513014470370013017 0ustar nileshnilesh\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/balance.Rd0000644000175000017500000000751113707331516013624 0ustar nileshnilesh\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, treat, matched, estimand="ATT") \method{print}{balance}(x, \dots, combined = FALSE, digits = 2) \method{plot}{balance}(x, longcovnames=NULL, which.covs="mixed", v.axis=TRUE, cex.main=1, cex.vars=1, cex.pts=1, mar=c(4, 3, 5.1, 2), plot=TRUE, x.max = NULL, \ldots) } \arguments{ \item{rawdata}{The full covariate dataset} \item{treat}{the vector of treatment assignments for the full dataset} \item{matched}{vector of weights to apply to the full dataset to create the restructured data: for matching without replacement these will all be 0's and 1's; for one-to-one matching with replacement these will all be non-negative integers; for IPTW or more complicated matching methods these could be any non-negative numbers} \item{estimand}{can either be \code{ATT}, \code{ATC}, or \code{ATE}, default is \code{ATT}} \item{x}{an object return by the balance function.} \item{combined}{default is \code{FALSE}} \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{which.covs}{\code{mixed} then it plots all as std diffs; \code{binary} it only plots binary and as abs unstd diffs; \code{cont} it only plots non-binary and as abs std diffs} \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{x.max}{set the max of the \code{xlim}, default is \code{NULL}} \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{jennifer.hill@nyu.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 <- matches$cnts # balance check b.stats <- balance(lalonde, treat, matched, estimand = "ATT") print(b.stats) plot(b.stats) par(old.par) } \keyword{methods} \keyword{manip} \keyword{hplot} \keyword{dplot} arm/man/binnedplot.Rd0000644000175000017500000000612013014470370014361 0ustar nileshnilesh\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/sigma.hat.Rd0000644000175000017500000000351013014470370014076 0ustar nileshnilesh\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/extractDIC.mer.Rd0000644000175000017500000000155713014470370015010 0ustar nileshnilesh\name{extractDIC} %\docType{genericFunction} \alias{extractDIC} \alias{extractDIC.merMod} \alias{extractAIC.merMod} \title{ Extract AIC and DIC from a \sQuote{mer} model } \description{ Computes the (generalized) Akaike *A*n *I*nformation *C*riterion and *D*eviance *I*nformation *C*riterion for a mer model. } \usage{ extractDIC(fit,\dots) \method{extractDIC}{merMod}(fit,\dots) %\method{extractAIC}{merMod}(fit,\dots) } \arguments{ \item{fit}{fitted \code{merMod} mode, usually the result of a fiiter like \code{merMod}.} \item{\dots}{further arguments (currently unused).} } \author{ Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \examples{ fm1 <- lmer(Reaction ~ Days + (Days|Subject), sleepstudy) extractAIC(fm1) extractDIC(fm1) } \keyword{manip} \keyword{methods} arm/man/discrete.histogram.Rd0000644000175000017500000000265613014470370016033 0ustar nileshnilesh\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/contrasts.bayes.Rd0000644000175000017500000000325613014470370015354 0ustar nileshnilesh\name{contrast.bayes} \alias{contr.bayes.ordered} \alias{contr.bayes.unordered} \title{Contrast Matrices} \description{ Return a matrix of contrasts used in \code{\link{bayesglm}}. } \usage{ contr.bayes.unordered(n, base = 1, contrasts = TRUE) contr.bayes.ordered (n, scores = 1:n, contrasts = TRUE) } \arguments{ \item{n}{a vector of levels for a factor, or the number of levels.} \item{base}{an integer specifying which group is considered the baseline group. Ignored if \code{contrasts} is \code{FALSE}.} \item{contrasts}{a logical indicating whether contrasts should be computed.} \item{scores}{the set of values over which orthogonal polynomials are to be computed.} } \details{ These functions are adapted from \code{contr.treatment} and \code{contr.poly} in \code{\link{stats}} package. The purpose for these functions are to keep the baseline levels of categorical variables and thus to suit the use of \code{\link{bayesglm}}. \code{contr.bayes.unordered} is equivalent to \code{contr.treatment} whereas \code{contr.bayes.ordered} is equivalent to \code{contr.poly}. } \author{Yu-Sung Su \email{suyusung@tsinghua.edu.cn}} \seealso{ \code{\link{C}}, \code{\link{contr.helmert}}, \code{\link{contr.poly}}, \code{\link{contr.sum}}, \code{\link{contr.treatment}}; \code{\link{glm}}, \code{\link{aov}}, \code{\link{lm}}, \code{\link{bayesglm}}. } \examples{ cat.var <- rep(1:3, 5) dim(contr.bayes.unordered(cat.var)) # 15*15 baseline level kept! dim(contr.treatment(cat.var)) # 15*14 } \keyword{design} \keyword{regression} \keyword{array} \keyword{manip} arm/man/traceplot.Rd0000644000175000017500000000250713014470370014225 0ustar nileshnilesh\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/se.coef.Rd0000644000175000017500000000530213014470370013546 0ustar nileshnilesh\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/readColumns.Rd0000644000175000017500000000066313014470370014505 0ustar nileshnilesh\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/model.matrixBayes.Rd0000644000175000017500000000603713014470370015621 0ustar nileshnilesh\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/invlogit.Rd0000644000175000017500000000222113014470370014054 0ustar nileshnilesh\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/mcsamp.Rd0000644000175000017500000001101213707327672013516 0ustar nileshnilesh\name{mcsamp} %\docType{genericFunction} \alias{mcsamp} \alias{mcsamp.default} \alias{mcsamp,merMod-method} %\alias{mcsamp,glmer-method} \title{Generic Function to Run \sQuote{mcmcsamp()} in lme4} \description{ The quick function for MCMC sampling for lmer and glmer objects and convert to Bugs objects for easy display. } \usage{ \method{mcsamp}{default}(object, n.chains=3, n.iter=1000, n.burnin=floor(n.iter/2), n.thin=max(1, floor(n.chains * (n.iter - n.burnin)/1000)), saveb=TRUE, deviance=TRUE, make.bugs.object=TRUE) \S4method{mcsamp}{merMod} (object, ...) %\S4method{mcsamp}{glmer} (object, ...) } \arguments{ \item{object}{\code{mer} objects from \code{lme4}} \item{n.chains}{number of MCMC chains} \item{n.iter}{number of iteration for each MCMC chain} \item{n.burnin}{number of burnin for each MCMC chain, Default is \code{n.iter/2}, that is, discarding the first half of the simulations.} \item{n.thin}{keep every kth draw from each MCMC chain. Must be a positive integer. Default is \code{max(1, floor(n.chains * (n.iter-n.burnin) / 1000))} which will only thin if there are at least 2000 simulations.} \item{saveb}{if 'TRUE', causes the values of the random effects in each sample to be saved.} \item{deviance}{compute deviance for \code{mer} objects. Only works for \code{\link[lme4]{lmer}} object} \item{make.bugs.object}{tranform the output into bugs object, default is TRUE} \item{\ldots}{further arguments passed to or from other methods.} } \details{ This function generates a sample from the posterior distribution of the parameters of a fitted model using Markov Chain Monte Carlo methods. It automatically simulates multiple sequences and allows convergence to be monitored. The function relies on \code{mcmcsamp} in \code{lme4}. } \value{ An object of (S3) class '"bugs"' suitable for use with the functions in the "R2WinBUGS" package. } \references{Andrew Gelman and Jennifer Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2006. Douglas Bates and Deepayan Sarkar, lme4: Linear mixed-effects models using S4 classes. } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{ys463@columbia.edu} } \seealso{\code{\link{display}}, \code{\link[lme4]{lmer}}, \code{\link{sim}} } \examples{ ## Here's a simple example of a model of the form, y = a + bx + error, ## with 10 observations in each of 10 groups, and with both the intercept ## and the slope varying by group. First we set up the model and data. ## # group <- rep(1:10, rep(10,10)) # group2 <- rep(1:10, 10) # mu.a <- 0 # sigma.a <- 2 # mu.b <- 3 # sigma.b <- 4 # rho <- 0.56 # Sigma.ab <- array (c(sigma.a^2, rho*sigma.a*sigma.b, # rho*sigma.a*sigma.b, sigma.b^2), c(2,2)) # sigma.y <- 1 # ab <- mvrnorm (10, c(mu.a,mu.b), Sigma.ab) # a <- ab[,1] # b <- ab[,2] # d <- rnorm(10) # # x <- rnorm (100) # y1 <- rnorm (100, a[group] + b*x, sigma.y) # y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) # y3 <- rnorm (100, a[group] + b[group]*x + d[group2], sigma.y) # y4 <- rbinom(100, 1, prob=invlogit(a[group] + b*x + d[group2])) # ## ## Then fit and display a simple varying-intercept model: # # M1 <- lmer (y1 ~ x + (1|group)) # display (M1) # M1.sim <- mcsamp (M1) # print (M1.sim) # plot (M1.sim) ## ## Then the full varying-intercept, varying-slope model: ## # M2 <- lmer (y1 ~ x + (1 + x |group)) # display (M2) # M2.sim <- mcsamp (M2) # print (M2.sim) # plot (M2.sim) ## ## Then the full varying-intercept, logit model: ## # M3 <- lmer (y2 ~ x + (1|group), family=binomial(link="logit")) # display (M3) # M3.sim <- mcsamp (M3) # print (M3.sim) # plot (M3.sim) ## ## Then the full varying-intercept, varying-slope logit model: ## # M4 <- lmer (y2 ~ x + (1|group) + (0+x |group), # family=binomial(link="logit")) # display (M4) # M4.sim <- mcsamp (M4) # print (M4.sim) # plot (M4.sim) # ## ## Then non-nested varying-intercept, varying-slop model: ## # M5 <- lmer (y3 ~ x + (1 + x |group) + (1|group2)) # display(M5) # M5.sim <- mcsamp (M5) # print (M5.sim) # plot (M5.sim) } \keyword{models} \keyword{methods} arm/man/standardize.Rd0000644000175000017500000000571513263576224014557 0ustar nileshnilesh\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) 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} arm/man/display.Rd0000644000175000017500000001162413014470370013675 0ustar nileshnilesh\name{display} %\docType{genericFunction} \alias{display} \alias{display,lm-method} \alias{display,bayesglm-method} %\alias{display,bayesglm.h-method} \alias{display,glm-method} \alias{display,merMod-method} \alias{display,polr-method} \alias{display,svyglm-method} \title{Functions for Processing lm, glm, mer, polr and svyglm Output} \description{This generic function gives a clean printout of lm, glm, mer, polr and svyglm objects.} \usage{ display (object, ...) \S4method{display}{lm}(object, digits=2, detail=FALSE) \S4method{display}{bayesglm}(object, digits=2, detail=FALSE) %\S4method{display}{bayesglm.h}(object, digits=2, detail=FALSE) \S4method{display}{glm}(object, digits=2, detail=FALSE) \S4method{display}{merMod}(object, digits=2, detail=FALSE) \S4method{display}{polr}(object, digits=2, detail=FALSE) \S4method{display}{svyglm}(object, digits=2, detail=FALSE) } \arguments{ \item{object}{The output of a call to lm, glm, mer, polr, svyglm or related regressions function with n data points and k predictors.} \item{...}{further arguments passed to or from other methods.} \item{digits}{number of significant digits to display.} \item{detail}{defaul is \code{FALSE}, if \code{TRUE}, display p-values or z-values} } \details{This generic function gives a clean printout of lm, glm, mer and polr objects, focusing on the most pertinent pieces of information: the coefficients and their standard errors, the sample size, number of predictors, residual standard deviation, and R-squared. Note: R-squared is automatically displayed to 2 digits, and deviances are automatically displayed to 1 digit, no matter what. } \value{Coefficients and their standard errors, the sample size, number of predictors, residual standard deviation, and R-squared} \references{Andrew Gelman and Jennifer Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2006.} \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn}; Maria Grazia Pittau \email{grazia@stat.columbia.edu} } \note{Output are the model, the regression coefficients and standard errors, and the residual sd and R-squared (for a linear model), or the null deviance and residual deviance (for a generalized linear model). } \seealso{\code{\link[base]{summary}}, \code{\link[stats]{lm}}, \code{\link[stats]{glm}}, \code{\link[lme4]{lmer}}, \code{\link[MASS]{polr}}, \code{\link[survey]{svyglm}} } \examples{ # Here's a simple example of a model of the form, y = a + bx + error, # with 10 observations in each of 10 groups, and with both the # intercept and the slope varying by group. First we set up the model and data. group <- rep(1:10, rep(10,10)) group2 <- rep(1:10, 10) mu.a <- 0 sigma.a <- 2 mu.b <- 3 sigma.b <- 4 rho <- 0.56 Sigma.ab <- array (c(sigma.a^2, rho*sigma.a*sigma.b, rho*sigma.a*sigma.b, sigma.b^2), c(2,2)) sigma.y <- 1 ab <- mvrnorm (10, c(mu.a,mu.b), Sigma.ab) a <- ab[,1] b <- ab[,2] d <- rnorm(10) x <- rnorm (100) y1 <- rnorm (100, a[group] + b*x, sigma.y) y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) y3 <- rnorm (100, a[group] + b[group]*x + d[group2], sigma.y) y4 <- rbinom(100, 1, prob=invlogit(a[group] + b*x + d[group2])) # display a simple linear model M1 <- lm (y1 ~ x) display (M1) M1.sim <- sim(M1, n.sims=2) # display a simple logit model M2 <- glm (y2 ~ x, family=binomial(link="logit")) display (M2) M2.sim <- sim(M2, n.sims=2) # Then fit and display a simple varying-intercept model: M3 <- lmer (y1 ~ x + (1|group)) display (M3) M3.sim <- sim(M3, n.sims=2) # Then the full varying-intercept, varying-slope model: M4 <- lmer (y1 ~ x + (1 + x |group)) display (M4) M4.sim <- sim(M4, n.sims=2) # Then the full varying-intercept, logit model: M5 <- glmer (y2 ~ x + (1|group), family=binomial(link="logit")) display (M5) M5.sim <- sim(M5, n.sims=2) # Then the full varying-intercept, varying-slope logit model: M6 <- glmer (y2 ~ x + (1|group) + (0 + x |group), family=binomial(link="logit")) display (M6) M6.sim <- sim(M6, n.sims=2) # Then non-nested varying-intercept, varying-slop model: M7 <- lmer (y3 ~ x + (1 + x |group) + (1|group2)) display(M7) M7.sim <- sim(M7, n.sims=2) # Then the ordered logit model from polr M8 <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display(M8) M9 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display(M9) } \keyword{manip} \keyword{methods} arm/man/coefplot.Rd0000644000175000017500000001631113014470370014041 0ustar nileshnilesh\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/matching.Rd0000644000175000017500000000305113707332141014017 0ustar nileshnilesh\name{matching} \alias{matching} \title{Single Nearest Neighborhood Matching} \description{ Function for processing matching with propensity score } \usage{ matching(z, score, replace=FALSE) } \arguments{ \item{z}{vector of indicators for treatment or control.} \item{score}{vector of the propensity scores in the same order as z.} \item{replace}{whether the control units could be reused for matching, default is \code{FALSE}.} } \details{Function for matching each treatment unit in turn the control unit (not previously chosen) with the closest propensity score } \value{ The function returns a vector of indices that the corresponding unit is matched to. 0 means matched to nothing.} \references{Andrew Gelman and Jennifer Hill. (2006). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models}. Cambridge University Press.} \author{Jeniffer Hill \email{jh1030@columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link{balance}} } \examples{ # matching first 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="response") matches <- matching(z=lalonde$treat, score=pscores) matched <- matches$cnts # balance check! b.stats <- balance(lalonde, treat, matched) print(b.stats) plot(b.stats) } \keyword{models} \keyword{methods} arm/man/residual.plot.Rd0000644000175000017500000000312513014470370015012 0ustar nileshnilesh\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/corrplot.Rd0000644000175000017500000000576713014470370014107 0ustar nileshnilesh\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/multicomp.plot.Rd0000644000175000017500000000601113014470370015210 0ustar nileshnilesh\name{multicomp.plot} \alias{multicomp.plot} \alias{mcplot} \title{Multiple Comparison Plot} \description{ Plots significant difference of simulated array. } \usage{ multicomp.plot(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)) } \arguments{ \item{object}{Simulated array of coefficients, columns being different variables and rows being simulated result.} \item{alpha}{Level of significance to compare.} \item{main}{Main label.} \item{label}{Labels for simulated parameters.} \item{shortlabel}{Short labels to put into the plot.} \item{show.pvalue}{Default is FALSE, if set to TRUE replaces short label with Bayesian p value. } \item{label.as.shortlabel}{Default is FALSE, if set to TRUE takes first 2 character of label and use it as short label.} \item{label.on.which.axis}{default is the 3rd (top) axis.} \item{col.low}{Color of significantly low coefficients.} \item{col.same}{Color of not significant difference.} \item{col.high}{Color of significantly high coefficients.} \item{vertical.line}{Default is TRUE, if set to FALSE does not draw vertical line.} \item{horizontal.line}{Default is FALSE, if set to TRUE draws horizontal line.} \item{vertical.line.lty}{Line type of vertical line.} \item{horizontal.line.lty}{Line type of horizontal line.} \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(3.5,3.5,3.5,3.5)}.} } \value{ \item{pvalue}{Array of Bayesian p value.} \item{significant}{Array of significance.} } \references{Andrew Gelman and Jennifer Hill. (2006). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models}. Cambridge University Press. } \author{ Masanao Yajima \email{yajima@stat.columbia.edu}, Andrew Gelman \email{gelman@stat.columbia.edu} } \seealso{ \code{\link{coefplot}} } \examples{ old.par <- par(no.readonly = TRUE) # example 1 simulation.array <- data.frame(coef1=rnorm(100,10,2), coef2=rnorm(100,5,2), coef3=rnorm(100,0,1), coef4=rnorm(100,-5,3), coef5=rnorm(100,-2,1)) short.lab <- c("c01", "c02", "c03", "c04", "c05") multicomp.plot(simulation.array[,1:4], label.as.shortlabel=TRUE) # wraper for multicomp.plot mcplot(simulation.array, shortlabel = short.lab) # example 2 data(lalonde) M1 <- lm(re78 ~ treat + re74 + re75 + age + educ + u74 + u75, data=lalonde) M1.sim <- sim(M1) lm.sim <- coef(M1.sim)[,-1] multicomp.plot(lm.sim, label.as.shortlabel=TRUE, label.on.which.axis=2) par(old.par) } \keyword{hplot}