arm/0000755000176200001440000000000015167714742011047 5ustar liggesusersarm/MD50000644000176200001440000000626315167714742011366 0ustar liggesusers29a3d3ee337c2454fb18ae08cf49fd7c *CHANGELOG 1ae5bd4610453790f3f05857fb709918 *DESCRIPTION 7d40d53b400ac7baf286c753f8ba696e *NAMESPACE df99a0be1f7702e22980626c8c9c6336 *R/AllClass.R de23b5716ddafb25fbb2abee086af892 *R/AllGeneric.R 798f4770f806716769c85d5fd827e032 *R/AllInternal.R 73aaffc4bc4ef7334888371ef67c4dca *R/balance.R 5093d7811dbfd7c03981170adcd18ea9 *R/bayesglm.R 054bbff33242f6e4bd26a9f7990207b1 *R/bayesglm.h.R 2f1dbf590eda1111607feb000f318aab *R/bayespolr.R 828d634c780a39b66596cc9fe885cf20 *R/binnedplot.R 40d3c3f97dd47af36fedac3280bdefe4 *R/coef.R a012a9e1014899bac761bd1b6103205e *R/coefplot.R 87ff45a243d955c0d0d3bd8af50a3f2f *R/contrasts.bayes.R 041d95b04bf7fdb3dbee0fde2bfbe400 *R/corrplot.R 004bf778675992949bc419bcdcf21382 *R/discrete.histogram.R 6db1c8b21abb043dd1de905b2f102d4b *R/display.R 74c65898e73cd54baa81e8aed4bbf781 *R/extractDIC.R 01ed741d359e1ed07bf61a543b3889ac *R/fitted.R 069a7f96fbba5b80380d6bc90aa766be *R/fround.R 9e1dc642876804773d8d9e56c6fde116 *R/go.R 78c23bf2f0dd152a68a264805111053b *R/invlogit.R 26f9a0e44dededc7181e3eec6ecd3e84 *R/load.first.R 0abc9dcad202c44cb985ad97b77af16e *R/matching.R df9287e969f74e2947f9e0e5b19d26fc *R/mcsamp.R 7be84861e689714dc27857682d749a74 *R/model.matrixBayes.R 6d6bc7861c1f13930bfa36044b8c0ca4 *R/multicomp.plot.R 7d0f269ea12f242f4d43e3661f68396e *R/readColumns.R 0dc3ffdd4c262488b7994dbc8dd08a70 *R/rescale.R 0eb80aef5e725716ee52fafa50654820 *R/residual.plot.R b2c045448ef2d771b1213b48d09f01b4 *R/se.coef.R 182cfee5b48b437cdc22b005cfc4c62b *R/sigma.hat.R b6e0ca1f4923f57f1081e2da15cb7fe9 *R/sim.R b2aebcf507ea399f88098d90c9002a57 *R/simmer.R fed3e27da541ce5ea74d1f54f009e74f *R/standardize.R af03f0653476d7242cb96915aa3ba7eb *R/traceplot.R 4dae5be8be23a21a990dd56234748f31 *R/triangleplot.R 91f29004f60c810f6f3cc60a5a9520f3 *README.md 12e52a54f9a2b2aa85f8162365ecce7c *data/lalonde.rda 8d528001b15d7ee29ae38011dd6d7864 *man/balance.Rd 52f432a989617794a3cc0154d1f28632 *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 7fc858bb0db16a7184e3506ce44c59e4 *man/lalonde.Rd 93dd0b99834ed4ed9cb1b4fd9a8bc1fa *man/matching.Rd 380f76417beff9b45a14e039204505a0 *man/mcsamp.Rd 5dc6a40b84eed2b201757701b25178f3 *man/model.matrixBayes.Rd 6ce8710af8c054cd4262b7a87169154d *man/multicomp.plot.Rd 36a4b93b16160c3659bf8379d32d2abb *man/readColumns.Rd d581b99748c6a0e1d23f41d635102d07 *man/rescale.Rd ac82073046f893e37c9500741a39014d *man/residual.plot.Rd 4daff88c386691fa72eec0cb9d02541d *man/se.coef.Rd 0a1dd5a48de8698930dc00605630e892 *man/sigma.hat.Rd 74864d3e83f962bbbbd4c71765f0fd30 *man/sim.Rd e9acebcda00645298e106d1bac754e63 *man/standardize.Rd f2120afe3b932435f11180d9ac5b3a57 *man/traceplot.Rd 66635f3bc271935f08bdb626869ebbf5 *man/triangleplot.Rd arm/R/0000755000176200001440000000000015167675217011253 5ustar liggesusersarm/R/sigma.hat.R0000644000176200001440000000350315155406662013243 0ustar liggesusers sigma.hat.lm <- function(object,...){ sigma <- summary(object)$sigma return (sigma) } sigma.hat.glm <- function(object,...){ dispersion <- if (is.null(object$dispersion)){ summary(object)$dispersion } else{ object$dispersion } if (object$family$family == "gaussian") { sigma <- sqrt(dispersion) } else { sigma <- summary(object, correlation = TRUE)$sigma #sigma <- sqrt(deviance(object)/df.residual(object)) } return(sigma) } sigma.hat.sim <- function(object,...){ sigma <- object@sigma return (sigma) } sigma.hat.merMod <- function(object,...){ #object <- summary (object) fcoef <- fixef(object) #useScale <- attr (VarCorr (object), "sc") # =sc? #useScale <- object@dims["useSc"] useScale <- getME(object, "devcomp")$dims["useSc"] #ngrps <- lapply(object@flist, function(x) length(levels(x))) #n.groupings <- length (ngrps) varc <- VarCorr (object) sc <- attr(varc, "sc") # =useScale recorr <- lapply(varc, function(el) attr(el, "correlation")) reStdDev <- c(lapply(varc, function(el) attr(el, "stddev")), list(Residual = sc)) n.groupings <- length(recorr) sigmas <- as.list (rep (NA, n.groupings+1)) sigmas[1] <- ifelse (useScale, sc, 1) #####if NA, sd=1 cors <- as.list (rep (NA, n.groupings+1)) names (sigmas) <- names (cors) <- c ("data", names (varc)) for (k in 1:n.groupings){ sigmas[[k+1]] <- reStdDev[[k]] cors[[k+1]] <- as.matrix (recorr[[k]]) if (length (cors[[k+1]]) == 1) cors[[k+1]] <- NA } return (list (sigma=sigmas, cors=cors)) } sigma.hat.sim.merMod <- function(object,...) { sigma <- object@sigma return (sigma) } arm/R/invlogit.R0000644000176200001440000000020715155406662013221 0ustar liggesusers#R function for the logistic function logit <- function (x) { log(x/(1-x)) } invlogit <- function (x) { 1/(1+exp(-x)) } arm/R/matching.R0000644000176200001440000001104415155406662013161 0ustar liggesusers## 2019 version of matching function matching <- function(z, score, replace=FALSE){ # argument z is the vector of indicators for treatment or control # # argument score is the vector of the propensity scores in the # # same order as z # # THIS FUNCTION REQUIRES THE INFERENTIAL GROUP TO SATISFY Z=1 # # Group satisfying Z=1 will remain intact and matches for them will # # be found from among those satisfying Z=0 # # # # the function (potentially) returns several things # # 1) match.ind: a vector of indices that the corresponding unit is # # matched to. The length is equal to the number of unique IDs # # 2) cnts: shows the number of times each unit will be used in any # # subsequent analyses (1 for each treated unit and number of # # times used as a match for each control unit (equivalently the # # number of treated units it is matched to) # # # # 3a) pairs: indicator for each pair [only available for # # replace=TRUE] # OR # 3b) matches: a matrix capturing which treated observations # were matched to which controls [only for replace=FALSE] # # # Ties are broken through random sampling so set seed if you want # # to replicate results # ##################################################################### n <- length(score) nt <- sum(z) nc <- sum(1-z) ind.t <- c(1:n)[z==1] ind.c <- c(1:n)[z==0] cnts <- rep(0, n) cnts[z==1] = rep(1,nt) scorec <- score[z == 0] scoret <- score[z == 1] # matching with replacement if (replace){ # calculate distances between all pairs of units dist = abs(outer(scoret,scorec,FUN="-")) # find the identify the controls with the minimum distance from # each treated -- if there are ties, randomly pick one mins = apply(dist,1,min) # create a matrix with 1's for control columns matching the minimum # distance for the corresponding treatment rows matches = dist - mins matches[matches!=0] = 1 matches = 1 - matches # if more than one control observation is chosen as a match for a given # treated we randomly chose which column to retain if(sum(matches)>nt){ # figure out which rows and then replace the multiple 1's with one # randomly chosen one for(i in c(1:nt)[apply(matches,1,sum)>1]){ matches_i <- c(1:nc)[matches[i,]==1] nmi <- length(matches_i) matches[i,matches_i] <- sample(c(1,rep(0,nmi-1)),nmi,replace=FALSE) } } # now fill in matched and ind.mt and pairs and counts ind.cm <- matches %*% ind.c # now record counts cnts[z==0] <- apply(matches,2,sum) # match indicators -- shouldn't be used for analysis match.ind <- c(ind.t, ind.cm) out <- list(match.ind = match.ind, cnts = cnts, matches = matches) } # matching *without* replacement if (!replace){ pairs = rep(NA,n) match.ind <- rep(0, n) tally <- 0 for (i in ind.t) { ## DEAL WITH TIES IN A MORE PRINCIPLED WAY? -- can do by adding a second # argument to break ties that is random available <- (1:n)[(z == 0) & (match.ind == 0)] j <- available[order(abs(score[available] - score[i]))[1]] cnts[j] <- 1 match.ind[i] <- j match.ind[j] <- i tally <- tally + 1 pairs[c(i, j)] <- tally } #match.ind <- match.ind[match.ind!=0] out <- list(match.ind = match.ind, cnts = cnts, pairs = pairs) } return(out) } #pscores.fun <- function(treat=Z, outs=Y, covs=X){ # # # N <- nrow(covs) # nouts <- 1 # ncovs <- ncol(covs) # # # # first set up places to store results # res <- matrix(0,nouts,2) # bal <- matrix(0,ncovs,2) # # # # estimate p-scores # dat <- cbind.data.frame(treat=treat,covs) # mod <- glm(dat,family=binomial(link="logit")) # qx <- predict(mod, type="response")#mod$linear # # # ### Now Matching With Replacement # matchout <- matching(z=treat, score=qx, replace=TRUE) # # # ### and treatment effect estimation with robust s.e.'s # wts <- rep(1, N) # wts[treat == 0] <- matchout$cnts # res <- .wls.all2(cbind(rep(1, sum(wts > 0)), treat[wts > 0],covs[wts > 0, ]), wts[wts > 0], outs[wts > 0], treat[wts > 0]) # c(res[3],sqrt(res[2])) #} arm/R/residual.plot.R0000644000176200001440000000225215155406662014155 0ustar liggesusers# ============================================================================== # residual plot for the observed values # ============================================================================== residual.plot <- function ( Expected, Residuals, sigma, main = deparse(substitute( Expected )), col.pts = "blue", col.ctr = "red", col.sgm = "black", cex = 0.5, gray.scale = FALSE, xlab="Predicted", ylab="Residuals", ... ) { if( gray.scale == TRUE ) { col.pts <- "black"; col.ctr <- "black"; col.sgm <- "gray60"; } plot( Expected[!is.na( Residuals )], Residuals[ !is.na( Residuals ) ], xlab = xlab, ylab = ylab, main = main, col = col.pts, pch = 19, cex = cex, ... ); #mtext( "Residuals vs Predicted", 3, cex= 0.6 ) #, adj=1 ); # add the zero line for clarity abline ( h = 0, lty = "dashed", col = col.ctr ); # residual s.e. resid.se <- sigma; # Add two-standard-error lines abline ( h = 2*resid.se, lty = "dashed", col = col.sgm ); abline ( h = -2*resid.se, lty = "dashed", col = col.sgm ); } arm/R/AllInternal.R0000644000176200001440000001712615155406662013603 0ustar liggesusers# some useful little functions #.round <- base:::round sd.scalar <- function (x, ...) {sqrt(var(as.vector(x), ...))} wmean <- function (x, w, ...) {mean(x*w, ...)/mean(w, ...)} logit <- function (x) {log(x/(1-x))} .untriangle <- function (x) {x + t(x) - x*diag(nrow(as.matrix(x)))} # new functions! as.matrix.VarCorr <- function (x, ..., useScale, digits){ # VarCorr function for lmer objects, altered as follows: # 1. specify rounding # 2. print statement at end is removed # 3. reMat is returned # 4. last line kept in reMat even when there's no error term sc <- attr(x, "sc")[[1]] if(is.na(sc)) sc <- 1 # recorr <- lapply(varc, function(el) el@factors$correlation) recorr <- lapply(x, function(el) attr(el, "correlation")) #reStdDev <- c(lapply(recorr, slot, "sd"), list(Residual = sc)) reStdDev <- c(lapply(x, function(el) attr(el, "stddev")), list(Residual = sc)) reLens <- unlist(c(lapply(reStdDev, length))) reMat <- array('', c(sum(reLens), 4), list(rep('', sum(reLens)), c("Groups", "Name", "Variance", "Std.Dev."))) reMat[1+cumsum(reLens)-reLens, 1] <- names(reLens) reMat[,2] <- c(unlist(lapply(reStdDev, names)), "") # reMat[,3] <- format(unlist(reStdDev)^2, digits = digits) # reMat[,4] <- format(unlist(reStdDev), digits = digits) reMat[,3] <- fround(unlist(reStdDev)^2, digits) reMat[,4] <- fround(unlist(reStdDev), digits) if (any(reLens > 1)) { maxlen <- max(reLens) corr <- do.call("rbind", lapply(recorr, function(x, maxlen) { x <- as(x, "matrix") # cc <- format(round(x, 3), nsmall = 3) cc <- fround (x, digits) cc[!lower.tri(cc)] <- "" nr <- dim(cc)[1] if (nr >= maxlen) return(cc) cbind(cc, matrix("", nr, maxlen-nr)) }, maxlen)) colnames(corr) <- c("Corr", rep("", maxlen - 1)) reMat <- cbind(reMat, rbind(corr, rep("", ncol(corr)))) } # if (!useScale) reMat <- reMat[-nrow(reMat),] if (useScale<0) reMat[nrow(reMat),] <- c ("No residual sd", rep("",ncol(reMat)-1)) return (reMat) } # rwish and dwish functions stolen from Martin and Quinn's MCMCpack rwish <- function (v, S){ if (!is.matrix(S)) S <- matrix(S) if (nrow(S) != ncol(S)) { stop(message = "S not square in rwish().\n") } if (v < nrow(S)) { stop(message = "v is less than the dimension of S in rwish().\n") } p <- nrow(S) CC <- chol(S) Z <- matrix(0, p, p) diag(Z) <- sqrt(rchisq(p, v:(v - p + 1))) if (p > 1) { pseq <- 1:(p - 1) Z[rep(p * pseq, pseq) + unlist(lapply(pseq, seq))] <- rnorm(p * (p - 1)/2) } return(crossprod(Z %*% CC)) } dwish <- function (W, v, S) { if (!is.matrix(S)) S <- matrix(S) if (nrow(S) != ncol(S)) { stop(message = "W not square in dwish()\n\n") } if (!is.matrix(W)) S <- matrix(W) if (nrow(W) != ncol(W)) { stop(message = "W not square in dwish()\n\n") } if (nrow(S) != ncol(W)) { stop(message = "W and X of different dimensionality in dwish()\n\n") } if (v < nrow(S)) { stop(message = "v is less than the dimension of S in dwish()\n\n") } k <- nrow(S) gammapart <- 1 for (i in 1:k) { gammapart <- gammapart * gamma((v + 1 - i)/2) } denom <- gammapart * 2^(v * k/2) * pi^(k * (k - 1)/4) detS <- det(S) detW <- det(W) hold <- solve(S) %*% W tracehold <- sum(hold[row(hold) == col(hold)]) num <- detS^(-v/2) * detW^((v - k - 1)/2) * exp(-1/2 * tracehold) return(num/denom) } # no visible binding~~~~~~~~~~~~~~~ # functions used to pass the check for bayespolr pgumbel <- function(q, loc = 0, scale = 1, lower.tail = TRUE) { q <- (q - loc)/scale p <- exp(-exp(-q)) if (!lower.tail) 1 - p else p } dgumbel <- function (x, loc = 0, scale = 1, log = FALSE) { d <- log(1/scale) - x - exp(-x) if (!log) exp(d) else d } # defin n to pass the bayesglm.fit and bayesglm.h.fit check n <- NULL # for mcplot .pvalue <- function ( v1, v2 ){ mean( ( sign( v1 - v2 ) + 1 ) / 2 ) } .is.significant <- function ( p, alpha = 0.05 ){ significant <- 0 + ( p > ( 1 - alpha ) ) - ( p < alpha ) return( significant ) } .weights.default <- function (object, ...) { wts <- object$weights if (is.null(wts)) wts else napredict(object$na.action, wts) } #.sweep.inv <- function(G){ # # sweeps a symmetric matrix on all positions # # (so inverts the matrix) # for(i in 1:nrow(G)) { # G <- .sweep.oper(G, i) # } # G #} # #.sweep.oper <- function(G = theta, k = 1.){ # # k is the sweep position # p <- dim(G)[1.] # H <- G # #first do generic elements (those that don't involve k) # H[] <- 0. # tmp <- matrix(G[, k], p, 1.) %*% matrix(G[, k], 1., p) # #now replace the row and col with index=k # H <- G - tmp/G[k, k] # H[, k] <- G[, k]/G[k, k] # #now replace the (k,k) diagonal element # H[k, ] <- G[, k]/G[k, k] # # and we're done # H[k, k] <- -1./G[k, k] # H #} # # #.wls.all2 <- function(X, w = wts, Y = y, treat = Trt) #{ # # # # This produces coefficient estimates and both standard and robust variances # # estimates for regression with weights # # the standard variance corresponds to a situation where an observation represents # # the mean of w observations # # the robust variance corresponds to a situation where weights represent # # probability or sampling weights # # # # first put together the necessary data inputs # # # nunits <- sum(w > 0) # k <- ncol(X) # ## now the weights, properly normed # wn <- w * (nunits/sum(w)) # W <- diag(wn * (nunits/sum(wn))) # # # # x prime x inverse (including weights) # vhat <- - .sweep.inv((t(X) %*% W %*% X)) # # # # estimated regression coefficients and variance for just the treatment coefficient # b <- vhat %*% t(X) %*% W %*% Y # MSE <- c(t(Y) %*% W %*% Y - t(b) %*% t(X) %*% W %*% Y)/(nunits - k) # var.std <- (vhat * MSE)[2, 2] # # # ###### now for the robust variance calculations # # now a matrix where each row represents the contribution to the score # # for each observation # U <- c((Y - X %*% b) * wn) * X # # finite sample adjustment # qc <- nunits/(nunits - 2) # # the sum of outer products of each of the above score contributions for # # each person is calculated here # prodU <- array(0, c(k, k, nunits)) # for(i in 1:nunits) { # prodU[, , i] <- outer(U[i, ], U[i, ]) # } # # putting it all together... # Vrob <- qc * vhat %*% apply(prodU, c(1, 2), sum) %*% vhat # # and we pull off the variance just for the treatment effect # var.rob <- Vrob[2, 2] # ############### # results <- c(var.std, var.rob, b[2]) # results #} arm/R/AllClass.R0000644000176200001440000000411115155406662013062 0ustar liggesuserssetOldClass("family") setOldClass("mcmc.list") setOldClass("polr") setOldClass("bugs") setOldClass("svyglm") setClass("balance", representation( rawdata = "data.frame", matched = "data.frame", factor = "logical") ) setClass("bayesglm", representation( formula = "formula", family = "family", prior.mean = "numeric", prior.scale = "numeric", prior.df = "numeric"), contains = "glm" ) #setClass("bayesglm.h", # representation( # formula = "formula", # family = "family", # prior.mean = "numeric", # prior.scale = "numeric", # prior.df = "numeric", # batch = "numeric"), # contains = "bayesglm" #) #setClass("polr", # representation( # formula = "formula", # Hess = "logical", # method = "character" ## prior.mean = "numeric", ## prior.scale = "numeric", ## prior.df = "numeric", ## prior.mean.for.cutpoints = "numeric", ## prior.scale.for.cutpoints = "numeric", ## prior.df.for.cutpoints = "numeric" # ), # contains="oldClass" #) setClass("bayespolr", representation( formula = "formula", Hess = "logical", method = "character", prior.mean = "numeric", prior.scale = "numeric", prior.df = "numeric", prior.mean.for.cutpoints = "numeric", prior.scale.for.cutpoints = "numeric", prior.df.for.cutpoints = "numeric"), contains = "polr" ) setClass("sim", representation( coef = "matrix", sigma = "numeric") ) setClass("sim.polr", representation( coef = "matrix", zeta = "matrix") ) setClass("sim.merMod", representation( fixef = "matrix", ranef = "list", sigma = "ANY") ) setClass("GO") arm/R/triangleplot.R0000644000176200001440000001214015155406662014071 0ustar liggesusers triangleplot <- function (x, y = NULL, cutpts = NULL, details = TRUE, n.col.legend = 5, cex.col = 0.7, cex.var = 0.9, digits = 1, color = FALSE) { if (!is.matrix(x)) stop("x must be a matrix!") if (dim(x)[1] != dim(x)[2]) stop("x must be a square matrix!") x.na <- x x.na[is.na(x.na)] <- -999 z.plot <- x if (is.null(y)) { z.names <- dimnames(x)[[2]] } else { z.names <- y } for (i in 1:dim(z.plot)[1]) for (j in i:dim(z.plot)[2]) z.plot[i, j] <- NA layout(matrix(c(2, 1), 1, 2, byrow = FALSE), c(10.5, 1.5)) layout(matrix(c(2, 1), 1, 2, byrow = FALSE), c(10.5, 1.5)) if (is.null(cutpts)) { if (details) { neg.check <- abs(sum(z.plot[z.plot < 0], na.rm = T)) if (neg.check > 0) { z.breaks <- sort(c(0, seq(min(z.plot, na.rm = T), max(z.plot, na.rm = T), length = n.col.legend))) } else { z.breaks <- seq(min(z.plot, na.rm = T), max(z.plot, na.rm = T), length = n.col.legend + 1) } for (i in 1:4) { n1 <- length(unique(round(z.breaks, digits = digits))) n2 <- length(z.breaks) ifelse((n1 != n2), digits <- digits + 1, digits <- digits) } if (digits > 3) { stop("Too many digits! Try to adjust n.col.legend to get better presentation!") } } else { postive.z <- na.exclude(unique(round(z.plot[z.plot > 0], digits = digits))) neg.check <- abs(sum(z.plot[z.plot < 0], na.rm = T)) ifelse(neg.check > 0, negative.z <- na.exclude(unique(round(z.plot[z.plot < 0], digits = digits))), negative.z <- 0) max.z <- max(z.plot, na.rm = T) min.z <- min(z.plot, na.rm = T) z.breaks <- sort(unique(c(postive.z, negative.z))) n.breaks <- length(z.breaks) l.legend <- ceiling(n.col.legend/2) if (n.breaks > 8) { if (neg.check > 0) { postive.z <- seq(0, max(postive.z), length = l.legend + 1) negative.z <- seq(min(negative.z), 0, length = l.legend) z.breaks <- sort(unique(c(postive.z, negative.z))) n.breaks <- length(z.breaks) z.breaks[1] <- min.z z.breaks[n.breaks] <- max.z n.col.legend <- length(z.breaks) - 1 } else { postive.z <- seq(0, max(postive.z), length = n.col.legend + 1) z.breaks <- sort(unique(c(postive.z, negative.z))) n.breaks <- length(z.breaks) z.breaks[1] <- min.z z.breaks[n.breaks] <- max.z n.col.legend <- length(z.breaks) - 1 } } else { if (neg.check > 0) { z.breaks <- sort(c(0, seq(min(z.plot, na.rm = T), max(z.plot, na.rm = T), length = n.col.legend))) } else { z.breaks <- seq(min(z.plot, na.rm = T), max(z.plot, na.rm = T), length = n.col.legend + 1) } } } } if (!is.null(cutpts)) { z.breaks = cutpts n.breaks <- length(z.breaks) n.col.legend <- length(z.breaks) - 1 } if (color) { z.colors <- heat.colors(n.col.legend)[n.col.legend:1] } else { z.colors <- gray(n.col.legend:1/n.col.legend) } par(mar = c(0.5, 0.1, 2, 0.1), pty = "m") plot(c(0, 1), c(min(z.breaks), max(z.breaks)), type = "n", bty = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n") for (i in 2:(length(z.breaks))) { rect(xleft = 0.5, ybottom = z.breaks[i - 1], xright = 1, ytop = z.breaks[i], col = z.colors[i - 1]) text(x = 0.45, y = z.breaks[i - 1], labels = format(round(z.breaks[i - 1], digits)), cex = cex.col, adj = 1, xpd = TRUE) } rect(xleft = 0.5, ybottom = z.breaks[length(z.breaks)], xright = 1, ytop = z.breaks[length(z.breaks)], col = z.colors[length(z.colors)]) text(x = 0.45, y = z.breaks[length(z.breaks)], labels = format(round(z.breaks[length(z.breaks)], digits)), cex = cex.col, adj = 1, xpd = TRUE) par(mar = c(0.1, 0.1, 2, 0.1), pty = "m") image(x = 1:dim(z.plot)[1], y = 1:dim(z.plot)[2], z = z.plot, xaxt = "n", yaxt = "n", bty = "n", col = z.colors, breaks = z.breaks, xlim = c(-2, dim(z.plot)[1] + 0.5), ylim = c(-1, dim(z.plot)[2] + 0.5), xlab = "", ylab = "") text(x = 1:dim(z.plot)[1], y = 1:dim(z.plot)[2], labels = z.names, cex = cex.var, adj = 1, xpd = TRUE) for (i in 1:dim(z.plot)[1]) { for (j in i:dim(z.plot)[2]) { if (x.na[i, j] == -999 & i != j) points(x = j, y = i, pch = "x", cex = 0.9) } } } arm/R/bayesglm.R0000644000176200001440000007120015155406662013172 0ustar liggesusersbayesglm <- function (formula, family = gaussian, data, weights, subset, na.action, start = NULL, etastart, mustart, offset, control = list(...), model = TRUE, method = "glm.fit", x = FALSE, y = TRUE, contrasts = NULL, drop.unused.levels = TRUE, prior.mean = 0, prior.scale = NULL, prior.df = 1, prior.mean.for.intercept = 0, prior.scale.for.intercept = NULL, prior.df.for.intercept = 1, min.prior.scale = 1e-12, scaled = TRUE, keep.order = TRUE, drop.baseline = TRUE, maxit = 100, print.unnormalized.log.posterior = FALSE, Warning = TRUE, ...) { call <- match.call() if (is.character(family)) { family <- get(family, mode = "function", envir = parent.frame()) } if (is.function(family)) { family <- family() } if (is.null(family$family)) { print(family) stop("'family' not recognized") } if (missing(data)) { data <- environment(formula) } mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "subset", "weights", "na.action", "etastart", "mustart", "offset"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- drop.unused.levels mf$na.action <- NULL mf[[1L]] <- quote(stats::model.frame) mf <- eval(mf, parent.frame()) if (identical(method, "model.frame")){ return(mf) } if (!is.character(method) && !is.function(method)){ stop("invalid 'method' argument") } if (identical(method, "glm.fit")){ control <- do.call("glm.control", control) } control$maxit <- maxit mt <- attr(mf, "terms") Y <- model.response(mf, "any") if (length(dim(Y)) == 1L) { nm <- rownames(Y) dim(Y) <- NULL if (!is.null(nm)) { names(Y) <- nm } } X <- if (!is.empty.model(mt)) { model.matrixBayes(object = mt, data = data, contrasts.arg = contrasts, keep.order = keep.order, drop.baseline = drop.baseline) }else { matrix(, NROW(Y), 0L) } weights <- as.vector(model.weights(mf)) if (!is.null(weights) && !is.numeric(weights)) { stop("'weights' must be a numeric vector") } if (!is.null(weights) && any(weights < 0)) { stop("negative weights not allowed") } offset <- as.vector(model.offset(mf)) if (!is.null(offset)) { if (length(offset) != NROW(Y)) stop(gettextf("number of offsets is %d should equal %d (number of observations)", length(offset), NROW(Y)), domain = NA) } mustart <- model.extract(mf, "mustart") etastart <- model.extract(mf, "etastart") fit <- bayesglm.fit(x = X, y = Y, weights = weights, start = start, etastart = etastart, mustart = mustart, offset = offset, family = family, control = control, intercept = attr(mt, "intercept") > 0L, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = prior.mean.for.intercept, prior.scale.for.intercept = prior.scale.for.intercept, prior.df.for.intercept = prior.df.for.intercept, min.prior.scale = min.prior.scale, print.unnormalized.log.posterior = print.unnormalized.log.posterior, scaled = scaled, Warning = Warning) if (length(offset) && attr(mt, "intercept") > 0L) { fit2 <- bayesglm.fit(x = X[, "(Intercept)", drop = FALSE], y = Y, weights = weights, offset = offset, family = family, control = control, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = prior.mean.for.intercept, prior.scale.for.intercept = prior.scale.for.intercept, prior.df.for.intercept = prior.df.for.intercept, min.prior.scale = min.prior.scale, print.unnormalized.log.posterior = print.unnormalized.log.posterior, scaled = scaled, Warning = Warning) if (!fit2$converged){ warning("fitting to calculate the null deviance did not converge -- increase 'maxit'?") } fit$null.deviance <- fit2$deviance } if (model) { fit$model <- mf } fit$na.action <- attr(mf, "na.action") if (x) { fit$x <- X } if (!y) { fit$y <- NULL } fit <- c(fit, list(call = call, formula = formula, terms = mt, data = data, offset = offset, control = control, method = method, contrasts = attr(X, "contrasts"), xlevels = .getXlevels(mt, mf)), keep.order = keep.order, drop.baseline = drop.baseline) class(fit) <- c("bayesglm", "glm", "lm") return(fit) } bayesglm.fit <- function (x, y, weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(), control = list(), intercept = TRUE, prior.mean = 0, prior.scale = NULL, prior.df = 1, prior.mean.for.intercept = 0, prior.scale.for.intercept = NULL, prior.df.for.intercept = 1, min.prior.scale = 1e-12, scaled = TRUE, print.unnormalized.log.posterior = FALSE, Warning = TRUE) { control <- do.call("glm.control", control) x <- as.matrix(x) xnames <- dimnames(x)[[2L]] ynames <- if (is.matrix(y)){ rownames(y) }else{ names(y) } conv <- FALSE nobs <- NROW(y) nvars <- NCOL(x) #=============================== # initialize priors #=============================== if(is.null(prior.scale)){ prior.scale <- 2.5 if(family$link == "probit"){ prior.scale <- prior.scale*1.6 } } if(is.null(prior.scale.for.intercept)){ prior.scale.for.intercept <- 10 if(family$link == "probit"){ prior.scale.for.intercept <- prior.scale.for.intercept*1.6 } } if(intercept){ nvars <- nvars - 1 } if(length(prior.mean)==1L){ prior.mean <- rep(prior.mean, nvars) }else if(length(prior.mean)!=nvars){ stop("invalid length for prior.mean") } if(length(prior.scale)==1L){ prior.scale <- rep(prior.scale, nvars) }else if(length(prior.scale)!=nvars){ stop("invalid length for prior.scale") } if(length(prior.df)==1L){ prior.df <- rep(prior.df, nvars) }else if(length(prior.df)!=nvars){ stop("invalid length for prior.df") } if(intercept){ prior.mean <- c(prior.mean.for.intercept, prior.mean) prior.scale <- c(prior.scale.for.intercept, prior.scale) prior.df <- c(prior.df.for.intercept, prior.df) } if(scaled){ if(family$family=="gaussian"){ prior.scale <- prior.scale*2*sd(y) } prior.scale.0 <- prior.scale if(nvars==0&intercept){ # this is need to reajust nvars when intercept is TRUE nvars <- 1 }else if(intercept){ nvars <- nvars + 1 } for(j in 1:nvars){ x.obs <- x[,j] x.obs <- x.obs[!is.na(x.obs)] num.categories <- length(unique(x.obs)) x.scale <- 1 if(num.categories==2L){ x.scale <- max(x.obs) - min(x.obs) }else if(num.categories>2){ x.scale <- 2*sd(x.obs) } prior.scale[j] <- prior.scale[j]/x.scale if(prior.scale[j] < min.prior.scale){ prior.scale[j] <- min.prior.scale warning("prior scale for varible ", j, " set to min.prior.scale = ", min.prior.scale, "\n") } } } #=================== nvars <- NCOL(x) EMPTY <- nvars == 0 if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) variance <- family$variance linkinv <- family$linkinv if (!is.function(variance) || !is.function(linkinv)) stop("'family' argument seems not to be a valid family object", call. = FALSE) dev.resids <- family$dev.resids aic <- family$aic mu.eta <- family$mu.eta unless.null <- function(x, if.null){ if (is.null(x)) if.null else x } valideta <- unless.null(family$valideta, function(eta) TRUE) validmu <- unless.null(family$validmu, function(mu) TRUE) if (is.null(mustart)) { eval(family$initialize) }else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } if (EMPTY) { eta <- rep.int(0, nobs) + offset if (!valideta(eta)) stop("invalid linear predictor values in empty model", call. = FALSE) mu <- linkinv(eta) if (!validmu(mu)) stop("invalid fitted means in empty model", call. = FALSE) dev <- sum(dev.resids(y, mu, weights)) w <- ((weights * mu.eta(eta)^2)/variance(mu))^0.5 residuals <- (y - mu)/mu.eta(eta) good <- rep_len(TRUE, length(residuals)) boundary <- conv <- TRUE coef <- numeric() iter <- 0L } else { coefold <- NULL eta <- if (!is.null(etastart)){ etastart }else if (!is.null(start)){ if (length(start) != nvars){ if(start==0&length(start)==1){ start <- rep(0, nvars) offset + as.vector(ifelse((NCOL(x) == 1L), x*start, x %*% start)) }else{ stop(gettextf("length of 'start' should equal %d and correspond to initial coefs for %s", nvars, paste(deparse(xnames), collapse = ", ")), domain = NA) } } else { coefold <- start offset + as.vector(if (NCOL(x) == 1L) x * start else x %*% start) } }else{ family$linkfun(mustart) } mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("cannot find valid starting values: please specify some", call. = FALSE) devold <- sum(dev.resids(y, mu, weights)) boundary <- conv <- FALSE #====================================== # initialize prior.sd #====================================== prior.sd <- prior.scale #===================================== dispersion <- ifelse((family$family %in% c("poisson", "binomial")), 1, var(y)/10000) dispersionold <- dispersion for (iter in 1L:control$maxit) { good <- weights > 0 varmu <- variance(mu)[good] if (anyNA(varmu)) stop("NAs in V(mu)") if (any(varmu == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) if (all(!good)) { conv <- FALSE warning(gettextf("no observations informative at iteration %d", iter), domain = NA) break } z <- (eta - offset)[good] + (y - mu)[good]/mu.eta.val[good] w <- sqrt((weights[good] * mu.eta.val[good]^2)/variance(mu)[good]) ngoodobs <- as.integer(nobs - sum(!good)) #====================== # data augmentation #========================= # coefs.hat <- rep(0, NCOL(x)) # why do we need coefs.hat here? SU 2015.3.30 x.star <- rbind(x, diag(NCOL(x))) if(intercept&scaled){ x.star[nobs+1,] <- colMeans(x) } z.star <- c (z, prior.mean) w.star <- c (w, sqrt(dispersion)/prior.sd) #================================================= good.star <- c (good, rep(TRUE,NCOL(x))) ngoodobs.star <- ngoodobs + NCOL(x) #fit <- .Call(C_Cdqrls, x.star[good, , drop = FALSE] * # w.star, z.star * w.star, min(1e-07, control$epsilon/1000), # check = FALSE) fit <- lm.fit(x = x.star[good.star,,drop=FALSE]*w.star, y = z.star*w.star) if (any(!is.finite(fit$coefficients))) { conv <- FALSE warning(gettextf("non-finite coefficients at iteration %d", iter), domain = NA) break } start[fit$qr$pivot] <- coefs.hat <- fit$coefficients fit$qr$qr <- as.matrix (fit$qr$qr) V.coefs <- chol2inv(fit$qr$qr[1:NCOL(x.star), 1:NCOL(x.star), drop = FALSE]) if (family$family == "gaussian" & scaled){ prior.scale <- prior.scale.0 } prior.sd <- ifelse(prior.df == Inf, prior.scale, sqrt(((coefs.hat - prior.mean)^2 + diag(V.coefs)*dispersion + prior.df * prior.scale^2)/(1 + prior.df))) start[fit$qr$pivot] <- fit$coefficients eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) dev <- sum(dev.resids(y, mu, weights)) if (!(family$family %in% c("poisson", "binomial"))) { mse.resid <- mean((w * (z - x %*% coefs.hat))^2) mse.uncertainty <- mean(rowSums(( x %*% V.coefs ) * x)) * dispersion # faster dispersion <- mse.resid + mse.uncertainty } if (control$trace) cat("Deviance = ", dev, " Iterations - ", iter, "\n", sep = "") boundary <- FALSE if (!is.finite(dev)) { if (is.null(coefold)) stop("no valid set of coefficients has been found: please supply starting values", call. = FALSE) warning("step size truncated due to divergence", call. = FALSE) ii <- 1 while (!is.finite(dev)) { if (ii > control$maxit) stop("inner loop 1; cannot correct step size", call. = FALSE) ii <- ii + 1 start <- (start + coefold)/2 eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) dev <- sum(dev.resids(y, mu, weights)) } boundary <- TRUE if (control$trace) cat("Step halved: new deviance = ", dev, "\n", sep = "") } if (!(valideta(eta) && validmu(mu))) { if (is.null(coefold)) stop("no valid set of coefficients has been found: please supply starting values", call. = FALSE) warning("step size truncated: out of bounds", call. = FALSE) ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; cannot correct step size", call. = FALSE) ii <- ii + 1 start <- (start + coefold)/2 eta <- drop(x %*% start) mu <- linkinv(eta <- eta + offset) } boundary <- TRUE dev <- sum(dev.resids(y, mu, weights)) if (control$trace) cat("Step halved: new deviance = ", dev, "\n", sep = "") } #=============================== # print unnormalized log posterior #================================ if (family$family == "binomial" && print.unnormalized.log.posterior) { logprior <- sum(dt(coefs.hat, prior.df, prior.mean, log = TRUE)) xb <- invlogit( x %*% coefs.hat ) loglikelihood <- sum( log( c( xb[ y == 1 ], 1 - xb[ y == 0 ] ) ) ) cat( "log prior: ", logprior, ", log likelihood: ", loglikelihood, ", unnormalized log posterior: ", loglikelihood +logprior, "\n" ,sep="") } #================================ if (iter > 1 & abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon & abs(dispersion - dispersionold)/(0.1 + abs(dispersion)) < control$epsilon) { conv <- TRUE coef <- start break }else { devold <- dev dispersionold <- dispersion coef <- coefold <- start } } if (!conv){ warning("algorithm did not converge", call. = FALSE) } if (boundary){ warning("algorithm stopped at boundary value", call. = FALSE) } eps <- 10 * .Machine$double.eps if (family$family == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)){ warning("fitted probabilities numerically 0 or 1 occurred", call. = FALSE) } } if (family$family == "poisson") { if (any(mu < eps)){ warning("fitted rates numerically 0 occurred", call. = FALSE) } } if (fit$rank < nvars){ coef[fit$qr$pivot][seq.int(fit$rank + 1, nvars)] <- NA } xxnames <- xnames[fit$qr$pivot] residuals <- rep.int(NA, nobs) residuals[good] <- z - (eta - offset)[good] fit$qr$qr <- as.matrix(fit$qr$qr) nr <- min(sum(good), nvars) if (nr < nvars) { Rmat <- diag(nvars) Rmat[1L:nr, 1L:nvars] <- fit$qr$qr[1L:nr, 1L:nvars] } else Rmat <- fit$qr$qr[1L:nvars, 1L:nvars] Rmat <- as.matrix(Rmat) Rmat[row(Rmat) > col(Rmat)] <- 0 names(coef) <- xnames colnames(fit$qr$qr) <- xxnames dimnames(Rmat) <- list(xxnames, xxnames) } names(residuals) <- ynames names(mu) <- ynames names(eta) <- ynames wt <- rep.int(0, nobs) wt[good] <- w^2 names(wt) <- ynames names(weights) <- ynames names(y) <- ynames wtdmu <- if (intercept){ sum(weights * y)/sum(weights) } else{ linkinv(offset) } nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) rank <- if (EMPTY) { 0 } else{ fit$rank } resdf <- n.ok - rank aic.model <- aic(y, n.ok, mu, weights, dev) + 2 * rank list(coefficients = coef, residuals = residuals, fitted.values = mu, effects = if (!EMPTY) fit$effects, R = if (!EMPTY) Rmat, rank = rank, qr = if (!EMPTY) structure(getQr(fit)[c("qr", "rank", "qraux", "pivot", "tol")], class = "qr"), family = family, linear.predictors = eta, deviance = dev, aic = aic.model, null.deviance = nulldev, iter = iter, weights = wt, prior.weights = weights, df.residual = resdf, df.null = nulldf, y = y, converged = conv, boundary = boundary, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.sd = prior.sd, dispersion = dispersion) } setMethod("print", signature(x = "bayesglm"), function(x, digits=2) display(object=x, digits=digits)) setMethod("show", signature(object = "bayesglm"), function(object) display(object, digits=2)) predict.bayesglm <- function (object, newdata = NULL, type = c("link", "response", "terms"), se.fit = FALSE, dispersion = NULL, terms = NULL, na.action = na.pass, ...) { type <- match.arg(type) na.act <- object$na.action object$na.action <- NULL if (!se.fit) { if (missing(newdata)) { pred <- switch(type, link = object$linear.predictors, response = object$fitted.values, terms = predictLM(object, se.fit = se.fit, scale = 1, type = "terms", terms = terms)) if (!is.null(na.act)) pred <- napredict(na.act, pred) } else { pred <- predictLM(object, newdata, se.fit, scale = 1, type = ifelse(type == "link", "response", type), terms = terms, na.action = na.action) switch(type, response = { pred <- family(object)$linkinv(pred) }, link = , terms = ) } } else { if (inherits(object, "survreg")) dispersion <- 1 if (is.null(dispersion) || dispersion == 0) dispersion <- summary(object, dispersion = dispersion)$dispersion residual.scale <- as.vector(sqrt(dispersion)) pred <- predictLM(object, newdata, se.fit, scale = residual.scale, type = ifelse(type == "link", "response", type), terms = terms, na.action = na.action) fit <- pred$fit se.fit <- pred$se.fit switch(type, response = { se.fit <- se.fit * abs(family(object)$mu.eta(fit)) fit <- family(object)$linkinv(fit) }, link = , terms = ) if (missing(newdata) && !is.null(na.act)) { fit <- napredict(na.act, fit) se.fit <- napredict(na.act, se.fit) } pred <- list(fit = fit, se.fit = se.fit, residual.scale = residual.scale) } pred } predictLM <- function (object, newdata, se.fit = FALSE, scale = NULL, df = Inf, interval = c("none", "confidence", "prediction"), level = 0.95, type = c("response", "terms"), terms = NULL, na.action = na.pass, pred.var = res.var/weights, weights = 1, ...) { tt <- terms(object) keep.order <- object$keep.order drop.baseline <- object$drop.baseline if (!inherits(object, "lm")) warning("calling predict.lm() ...") if (missing(newdata) || is.null(newdata)) { mm <- X <- model.matrix(object) mmDone <- TRUE offset <- object$offset } else { Terms <- delete.response(tt) m <- model.frame(Terms, newdata, na.action = na.action, xlev = object$xlevels) if (!is.null(cl <- attr(Terms, "dataClasses"))) .checkMFClasses(cl, m) X <- model.matrixBayes(Terms, m, contrasts.arg = object$contrasts, keep.order = keep.order, drop.baseline = drop.baseline) offset <- rep(0, nrow(X)) if (!is.null(off.num <- attr(tt, "offset"))) for (i in off.num) offset <- offset + eval(attr(tt, "variables")[[i + 1]], newdata) if (!is.null(object$call$offset)) offset <- offset + eval(object$call$offset, newdata) mmDone <- FALSE } n <- length(object$residuals) p <- object$rank p1 <- seq_len(p) piv <- if (p) getQr(object)$pivot[p1] if (p < ncol(X) && !(missing(newdata) || is.null(newdata))) warning("prediction from a rank-deficient fit may be misleading") beta <- object$coefficients predictor <- drop(X[, piv, drop = FALSE] %*% beta[piv]) if (!is.null(offset)) predictor <- predictor + offset interval <- match.arg(interval) if (interval == "prediction") { if (missing(newdata)) warning("Predictions on current data refer to _future_ responses\n") if (missing(newdata) && missing(weights)) { w <- .weights.default(object) if (!is.null(w)) { weights <- w warning("Assuming prediction variance inversely proportional to weights used for fitting\n") } } if (!missing(newdata) && missing(weights) && !is.null(object$weights) && missing(pred.var)) warning("Assuming constant prediction variance even though model fit is weighted\n") if (inherits(weights, "formula")) { if (length(weights) != 2L) stop("'weights' as formula should be one-sided") d <- if (missing(newdata) || is.null(newdata)) model.frame(object) else newdata weights <- eval(weights[[2L]], d, environment(weights)) } } type <- match.arg(type) if (se.fit || interval != "none") { res.var <- if (is.null(scale)) { r <- object$residuals w <- object$weights rss <- sum(if (is.null(w)) r^2 else r^2 * w) df <- object$df.residual rss/df } else scale^2 if (type != "terms") { if (p > 0) { XRinv <- if (missing(newdata) && is.null(w)) qr.Q(getQr(object))[, p1, drop = FALSE] else X[, piv] %*% qr.solve(qr.R(getQr(object))[p1, p1]) ip <- drop(XRinv^2 %*% rep(res.var, p)) } else ip <- rep(0, n) } } if (type == "terms") { if (!mmDone) { mm <- model.matrixBayes(object, keep.order = keep.order, drop.baseline = drop.baseline) mmDone <- TRUE } aa <- attr(mm, "assign") ll <- attr(tt, "term.labels") hasintercept <- attr(tt, "intercept") > 0L if (hasintercept) ll <- c("(Intercept)", ll) aaa <- factor(aa, labels = ll) asgn <- split(order(aa), aaa) if (hasintercept) { asgn$"(Intercept)" <- NULL if (!mmDone) { mm <- model.matrixBayes(object, keep.order = keep.order, drop.baseline = drop.baseline) mmDone <- TRUE } avx <- colMeans(mm) termsconst <- sum(avx[piv] * beta[piv]) } nterms <- length(asgn) if (nterms > 0) { predictor <- matrix(ncol = nterms, nrow = NROW(X)) dimnames(predictor) <- list(rownames(X), names(asgn)) if (se.fit || interval != "none") { ip <- matrix(ncol = nterms, nrow = NROW(X)) dimnames(ip) <- list(rownames(X), names(asgn)) Rinv <- qr.solve(qr.R(getQr(object))[p1, p1]) } if (hasintercept) X <- sweep(X, 2L, avx, check.margin = FALSE) unpiv <- rep.int(0L, NCOL(X)) unpiv[piv] <- p1 for (i in seq.int(1L, nterms, length.out = nterms)) { iipiv <- asgn[[i]] ii <- unpiv[iipiv] iipiv[ii == 0L] <- 0L predictor[, i] <- if (any(iipiv > 0L)) X[, iipiv, drop = FALSE] %*% beta[iipiv] else 0 if (se.fit || interval != "none") ip[, i] <- if (any(iipiv > 0L)) as.matrix(X[, iipiv, drop = FALSE] %*% Rinv[ii, , drop = FALSE])^2 %*% rep.int(res.var, p) else 0 } if (!is.null(terms)) { predictor <- predictor[, terms, drop = FALSE] if (se.fit) ip <- ip[, terms, drop = FALSE] } } else { predictor <- ip <- matrix(0, n, 0L) } attr(predictor, "constant") <- if (hasintercept) termsconst else 0 } if (interval != "none") { tfrac <- qt((1 - level)/2, df) hwid <- tfrac * switch(interval, confidence = sqrt(ip), prediction = sqrt(ip + pred.var)) if (type != "terms") { predictor <- cbind(predictor, predictor + hwid %o% c(1, -1)) colnames(predictor) <- c("fit", "lwr", "upr") } else { if (!is.null(terms)) hwid <- hwid[, terms, drop = FALSE] lwr <- predictor + hwid upr <- predictor - hwid } } if (se.fit || interval != "none") { se <- sqrt(ip) if (type == "terms" && !is.null(terms) && !se.fit) se <- se[, terms, drop = FALSE] } if (missing(newdata) && !is.null(na.act <- object$na.action)) { predictor <- napredict(na.act, predictor) if (se.fit) se <- napredict(na.act, se) } if (type == "terms" && interval != "none") { if (missing(newdata) && !is.null(na.act)) { lwr <- napredict(na.act, lwr) upr <- napredict(na.act, upr) } list(fit = predictor, se.fit = se, lwr = lwr, upr = upr, df = df, residual.scale = sqrt(res.var)) } else if (se.fit) list(fit = predictor, se.fit = se, df = df, residual.scale = sqrt(res.var)) else predictor } getQr <- function(x, ...){ if (is.null(r <- x$qr)) stop("lm object does not have a proper 'qr' component.\n Rank zero or should not have used lm(.., qr=FALSE).") r } arm/R/load.first.R0000644000176200001440000000056215155406662013437 0ustar liggesusers.onAttach <- function(...) { mylib <- dirname(system.file(package = "arm")) ver <- packageDescription("arm", lib.loc = mylib)$Version builddate <- packageDescription("arm", lib.loc = mylib)$Date packageStartupMessage(paste("\narm (Version ", ver, ", built: ", builddate, ")\n", sep = "")) packageStartupMessage("Working directory is ", getwd(), "\n") } arm/R/go.R0000644000176200001440000000375415155406662012005 0ustar liggesusers # Name: go(..., add=FALSE,timer=FALSE) # Description: Like source() but recalls the last source file names by default. Multiple source files can be specified. # Parameters: ... = list of filenames as character strings; # add = add these names to the current list? if replace, then FALSE # Note: does not pass parameters to source() # Example: go('myprog') # will run source('myprog.r') # go() # will run source('myprog.r') again # go('somelib',add=TRUE) # will run source('myprog.r') and source('somelib.r') # go('myprog','somelib') # same as above # go('mytest') # will run source('mytest') only # go() # runs source('mytest') again # Reference: jouni@kerman.com, kerman@stat.columbia.edu # Modified: 2004-06-22 # go <- function(..., add=FALSE, timer=FALSE) { last.sources <- getOption(".Last.Source") sources <- unlist(list(...)) if (length(sources)<1) { sources <- last.sources } else if (add) { sources <- c(last.sources,sources) } if (length(sources)<1) { return(cat("Usage: go('sourcefile', 'sourcefile2', ..., add=?, timer=?)\n")) } options(".Last.Source"=sources) cat("Source file(s): ",sources,"\n") yy <- NULL for (src in sources) { if (is.na(src)) { next } if (!file.exists(src)) { src2 <- paste(src, ".R", sep="") if (file.exists(src2)) src <- src2 else { cat("source('",src,"') : file does not exist.\n",sep='') next } } cat("source('",src,"')\n",sep="") if (timer) cat("source('",src,"') : ",max(na.omit(system.time(source(src)))), " seconds elapsed.\n", sep='') else yy[[src]] <- source(src) } invisible(yy) } # By entering "G" on the console, go() is run. This is faster than typing "go()"... print.GO <- function(x,...) {go()} G <- structure(NA, class="GO") #class(G) <- "GO" # end of go.R arm/R/fitted.R0000644000176200001440000000271215155406662012650 0ustar liggesusers # the plan here is to shuffle the ranefs back into the way a merMod object # stores them so that a simple X * beta + Z * theta op does the trick fitted.sim.merMod <- function(object, regression,...){ if (missing(regression) || is.null(regression)) stop("fitted for sim.mer requires original merPred object as well."); if (!inherits(regression, "merMod")) stop("regression argument for fitted on sim.mer does not inherit from class 'merMod'"); sims <- object; numSimulations <- dim(sims@fixef)[1]; devcomp <- getME(regression, "devcomp"); dims <- devcomp$dims; numRanef <- dims[["q"]]; numLevels <- dims[["reTrms"]]; simulatedRanef <- matrix(0, numRanef, numSimulations); index <- 0; for (i in 1:length(sims@ranef)) { levelSims <- sims@ranef[[i]]; numCoefficientsPerLevel <- dim(levelSims)[2]; numGroupsPerLevel <- dim(levelSims)[3]; for (j in 1:numCoefficientsPerLevel) { ranefRange <- index + 1:numGroupsPerLevel; index <- index + numGroupsPerLevel; simulatedRanef[ranefRange,] <- t(levelSims[,j,]); } } X <- getME(regression, "X"); Zt <- getME(regression, "Zt"); linearPredictor <- as.matrix(tcrossprod(X, sims@fixef) + crossprod(Zt, simulatedRanef)) + matrix(getME(regression, "offset"), dims[["n"]], numSimulations); if (dims[["GLMM"]] == 0L){ return(linearPredictor) }else{ return(regression@resp$family$linkinv(linearPredictor)) } }; arm/R/coefplot.R0000644000176200001440000003304615155406662013210 0ustar liggesuserscoefplot.default <- function(coefs, sds, CI=2, lower.conf.bounds, upper.conf.bounds, varnames=NULL, vertical=TRUE, v.axis=TRUE, h.axis=TRUE, cex.var=0.8, cex.pts=0.9, col.pts=1, pch.pts=20, var.las=2, main=NULL, xlab=NULL, ylab=NULL, mar=c(1,3,5.1,2), plot=TRUE, add=FALSE, offset=0.1, ...) { # collect informations if (is.list(coefs)){ coefs <- unlist(coefs) } n.x <- length(coefs) idx <- seq(1, n.x) #bound <- lower.bound if(!missing(lower.conf.bounds)){ if(length(coefs)!=length(lower.conf.bounds)){ stop("Number of conf.bounds does not equal to number of estimates") } } if(!missing(upper.conf.bounds)){ if(length(coefs)!=length(upper.conf.bounds)){ stop("Number of conf.bounds does not equal to number of estimates") } } if(!missing(sds)){ coefs.h <- coefs + CI*sds coefs.l <- coefs - CI*sds est1 <- cbind(coefs - sds, coefs + sds) est2 <- cbind(coefs - 2*sds, coefs + 2*sds) if(!missing(lower.conf.bounds)){ est1[,1] <- lower.conf.bounds CI <- 1 } if(!missing(upper.conf.bounds)){ est1[,2] <- upper.conf.bounds CI <- 1 } }else{ #coefs.h <- upper.conf.bounds #coefs.l <- lower.conf.bounds est1 <- cbind(coefs, coefs) if(!missing(lower.conf.bounds)){ est1[,1] <- lower.conf.bounds CI <- 1 } if(!missing(upper.conf.bounds)){ est1[,2] <- upper.conf.bounds CI <- 1 } } old.par <- par(no.readonly=TRUE) #on.exit(par(old.par)) min.mar <- par('mar') if (is.null(main)){main <- "Regression Estimates"} if (is.null(xlab)){xlab <- ""} if (is.null(ylab)){ylab <- ""} par(mar = mar) if (is.null(varnames)) { maxchar <- 0 } else{ maxchar <- max(sapply(varnames, nchar)) } # add margin to the axis k <- 1/n.x if(plot){ if (vertical){ mar[2] <- max(min.mar[2], trunc(mar[2] + maxchar/10)) + 0.1 par(mar=mar) if(!add){ plot(c(coefs.l, coefs.h), c(idx+k,idx-k), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if (h.axis){ #axis(1) axis(3) } if (v.axis){ axis(2, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(v=0, lty=2) points(coefs, idx, pch=pch.pts, cex=cex.pts, col=col.pts) if (CI==2){ segments (est1[,1], idx, est1[,2], idx, lwd=2, col=col.pts) segments (est2[,1], idx, est2[,2], idx, lwd=1, col=col.pts) } else{ segments (est1[,1], idx, est1[,2], idx, lwd=1, col=col.pts) } } else{ idx <- idx + offset points(coefs, idx, pch=pch.pts, cex=cex.pts, col=col.pts) if (CI==2){ segments (est1[,1], idx, est1[,2], idx, lwd=2, col=col.pts) segments (est2[,1], idx, est2[,2], idx, lwd=1, col=col.pts) } else{ segments (est1[,1], idx, est1[,2], idx, lwd=1, col=col.pts) } } } # end of if vertical else{ # horizontal mar[1] <- max(min.mar[1], trunc(mar[1] + maxchar/10)) + 0.1 par(mar=mar) if(!add){ plot(c(idx+k,idx-k), c(coefs.l, coefs.h), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if (v.axis){ axis(2, las=var.las) #axis(4, las=var.las) } if (h.axis){ axis(1, 1:n.x, varnames[1:n.x], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(h=0, lty=2) points(idx, coefs, pch=pch.pts, cex=cex.pts, col=col.pts) if (CI==2){ segments (idx, est1[,1], idx, est1[,2], lwd=2, col=col.pts) segments (idx, est2[,1], idx, est2[,2], lwd=1, col=col.pts) } else if (CI==1) { segments (idx, est1[,1], idx, est1[,2], lwd=1, col=col.pts) } } else{ idx <- idx + offset points(idx, coefs, pch=pch.pts, cex=cex.pts, col=col.pts) if (CI==2){ segments (idx, est1[,1], idx, est1[,2], lwd=2, col=col.pts) segments (idx, est2[,1], idx, est2[,2], lwd=1, col=col.pts) } else if (CI==1) { segments (idx, est1[,1], idx, est1[,2], lwd=1, col=col.pts) } } } } else{ if (vertical){ mar[2] <- max(min.mar[2], trunc(mar[2] + maxchar/10)) + 0.1 par(mar=mar) plot(c(coefs.l, coefs.h), c(idx+k,idx-k), type="n", axes=F, main="", xlab=xlab, ylab=ylab,...) # if (v.axis){ # axis(2, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, # lty=0, cex.axis=cex.var) # } } else{ # horizontal mar[1] <- max(min.mar[1], trunc(mar[1] + maxchar/10)) + 0.1 par(mar=mar) plot(c(idx+k,idx-k), c(coefs.l, coefs.h), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) #if (h.axis){ # axis(1, 1:n.x, varnames[1:n.x], las=var.las, tck=FALSE, # lty=0, cex.axis=cex.var) # } } } #on.exit(par(old.par)) } setMethod("coefplot", signature(object = "numeric"), function(object, ...) { coefplot.default(object, ...) } ) setMethod("coefplot", signature(object = "lm"), function(object, varnames=NULL, intercept=FALSE, ...) { # collect informations coefs <- summary(object)$coef[,1] sds <- summary(object)$coef[,2] ifelse (is.null(varnames), varnames <- names(coefs), varnames <- varnames) if (length(varnames)!= length(names(coefs))){ stop(message="the length of varnames does not equal the length of predictors. Note: varnames must include a name for constant/intercept") } chk.int <- attr(terms(object), "intercep") if(chk.int & intercept | !chk.int & intercept | !chk.int & !intercept){ intercept <- TRUE coefs <- coefs sds <- sds varnames <- varnames } else if(chk.int & !intercept){ coefs <- coefs[-1] sds <- sds[-1] varnames <- varnames[-1] } # plotting coefplot(coefs, sds, varnames=varnames, ...) } ) setMethod("coefplot", signature(object = "glm"), function(object, varnames=NULL, intercept=FALSE,...) { # collect informations coefs <- summary(object)$coef[,1] sds <- summary(object)$coef[,2] ifelse (is.null(varnames), varnames <- names(coefs), varnames <- varnames) if (length(varnames)!= length(names(coefs))){ stop(message="the length of varnames does not equal the length of predictors. Note: varnames must include a name for constant/intercept") } chk.int <- attr(terms(object), "intercep") if(chk.int & intercept | !chk.int & intercept | !chk.int & !intercept){ intercept <- TRUE coefs <- coefs sds <- sds varnames <- varnames } else if(chk.int & !intercept){ coefs <- coefs[-1] sds <- sds[-1] varnames <- varnames[-1] } # plotting coefplot(coefs, sds, varnames=varnames, ...) } ) setMethod("coefplot", signature(object = "bugs"), function(object, var.idx=NULL, varnames=NULL, CI=1, vertical=TRUE, v.axis=TRUE, h.axis=TRUE, cex.var=0.8, cex.pts=0.9, col.pts=1, pch.pts=20, var.las=2, main=NULL, xlab=NULL, ylab=NULL, plot=TRUE, add=FALSE, offset=.1, mar=c(1,3,5.1,2), ...) { if (is.null(var.idx)){ var.idx <- 1:length(object$summary[,"50%"]) } n.x <- length(var.idx) idx <- 1:n.x coefs <- object$summary[,"50%"][var.idx] if (is.null(varnames)){ varnames <- names(coefs) } if (is.null(main)){main <- "Regression Estimates"} if (is.null(xlab)){xlab <- ""} if (is.null(ylab)){ylab <- ""} min.mar <- par('mar') par(mar=mar) maxchar <- max(sapply(varnames, nchar)) k <- 1/n.x if (CI==1){ CI50.h <- object$summary[,"75%"][var.idx] CI50.l <- object$summary[,"25%"][var.idx] CI50 <- cbind(CI50.l, CI50.h) if (vertical){ mar[2] <- min(min.mar[2], trunc(mar[2] + maxchar/10)) + 0.1 par(mar=mar) if(add){ segments (CI50[,1], idx+offset, CI50[,2], idx+offset, lwd=1, col=col.pts) points(coefs, idx+offset, pch=20, cex=cex.pts, col=col.pts) } else{ plot(c(CI50[,1],CI50[,2]), c(idx+k,idx-k), type="n", axes=F, main=main, xlab=xlab, ylab=ylab, ...) if(plot){ if (h.axis){ axis(3) } if (v.axis){ axis(2, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(v=0, lty=2) segments (CI50[,1], idx, CI50[,2], idx, lwd=1, col=col.pts) points(coefs, idx, pch=20, cex=cex.pts, col=col.pts) } } } else { mar[1] <- min(min.mar[1], trunc(mar[1] + maxchar/10)) + 0.1 par(mar=mar) if(add){ segments (idx+offset, CI50[,1], idx+offset, CI50[,2], lwd=1, col=col.pts) points(idx+offset, coefs, pch=20, cex=cex.pts, col=col.pts) } else{ plot(c(idx+k,idx-k), c(CI50[,1],CI50[,2]), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if(plot){ if (v.axis){ axis(2) } if (h.axis){ axis(1, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(h=0, lty=2) segments (idx, CI50[,1], idx, CI50[,2], lwd=1, col=col.pts) points(idx, coefs, pch=20, cex=cex.pts, col=col.pts) } } } } if (CI==2){ CI50.h <- object$summary[,"75%"][var.idx] CI50.l <- object$summary[,"25%"][var.idx] CI95.h <- object$summary[,"97.5%"][var.idx] CI95.l <- object$summary[,"2.5%"][var.idx] CI50 <- cbind(CI50.l, CI50.h) CI95 <- cbind(CI95.l, CI95.h) if (vertical){ mar[2] <- min(min.mar[2], trunc(mar[2] + maxchar/10)) + 0.1 par(mar=mar) if(add){ segments (CI50[,1], idx+offset, CI50[,2], idx+offset, lwd=2, col=col.pts) segments (CI95[,1], idx+offset, CI95[,2], idx+offset, lwd=1, col=col.pts) points(coefs, idx+offset, pch=20, cex=cex.pts, col=col.pts) } else{ plot(c(CI95[,1],CI95[,2]), c(idx+k,idx-k), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if(plot){ if (h.axis){ axis(3) } if (v.axis){ axis(2, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(v=0, lty=2) segments (CI50[,1], idx, CI50[,2], idx, lwd=2, col=col.pts) segments (CI95[,1], idx, CI95[,2], idx, lwd=1, col=col.pts) points(coefs, idx, pch=20, cex=cex.pts, col=col.pts) } } } else { mar[1] <- min(min.mar[1], trunc(mar[1] + maxchar/10)) + 0.1 par(mar=mar) if(add){ segments (idx+offset, CI50[,1], idx+offset, CI50[,2], lwd=2, col=col.pts) segments (idx+offset, CI95[,1], idx+offset, CI95[,2], lwd=1, col=col.pts) points(idx+offset, coefs, pch=20, cex=cex.pts, col=col.pts) } else{ plot(c(idx+k,idx-k), c(CI95[,1],CI95[,2]), type="n", axes=F, main=main, xlab=xlab, ylab=ylab,...) if(plot){ if (v.axis){ axis(2) } if (h.axis){ axis(1, n.x:1, varnames[n.x:1], las=var.las, tck=FALSE, lty=0, cex.axis=cex.var) } abline(h=0, lty=2) segments (idx, CI50[,1], idx, CI50[,2], lwd=2, col=col.pts) segments (idx, CI95[,1], idx, CI95[,2], lwd=1, col=col.pts) points(idx, coefs, pch=20, cex=cex.pts, col=col.pts) } } } } } ) setMethod("coefplot", signature(object = "polr"), function(object, varnames=NULL,...) { # collect informations coefs <- summary(object)$coef[,1] sds <- summary(object)$coef[,2] ifelse(is.null(varnames), varnames <- names(coefs), varnames <- varnames) # plotting coefplot(coefs, sds, varnames=varnames, ...) } ) arm/R/traceplot.R0000644000176200001440000000407015155406662013365 0ustar liggesusers#traceplot.default <- function(x, ...) coda::traceplot # ======================================================================== # function for trace plot # ======================================================================== #setMethod("traceplot", signature(x = "mcmc.list"), # function (x, smooth = TRUE, col = 1:6, type = "l", ylab = "", ...) #{ # args <- list(...) # for (j in 1:nvar(x)) { # xp <- as.vector(time(x)) # yp <- if (nvar(x) > 1) # x[, j, drop = TRUE] # else x # yp <- do.call("cbind", yp) # matplot(xp, yp, xlab = "Iterations", ylab = ylab, type = type, # col = col, ...) # if (!is.null(varnames(x)) && is.null(list(...)$main)) # title(paste("Trace of", varnames(x)[j])) # if (smooth) { # scol <- rep(col, length = nchain(x)) # for (k in 1:nchain(x)) lines(lowess(xp, yp[, k]), # col = scol[k]) # } # } #} #) # setMethod("traceplot", signature(x = "bugs"), function( x, mfrow = c( 1, 1 ), varname = NULL, match.head = TRUE, ask = TRUE, col = rainbow( x$n.chains ), lty = 1, lwd = 1, ... ) { par( mfrow = mfrow ) par( ask = ask ) n.chain <- x$n.chains n.keep <- x$n.keep bugs.array <- x$sims.array varnamelist <- gsub( "\\[.*\\]","", dimnames( bugs.array )[[3]], fixed = FALSE ) if( is.null( varname ) ){ varname <- ".*" } if( match.head ) { varname <- paste( "^", varname, sep="" ) } index <- unlist( sapply( varname, function( x ){ grep( x, varnamelist ) } ) ) n.var <- length( index ) for( j in index ) { range.x <- c( 1, n.keep ) range.y <- range( bugs.array[,,j] ) v.name <- dimnames( bugs.array )[[3]][j] plot( range.x, range.y, type = "n", main = v.name, xlab = "iteration", ylab = v.name, xaxt = "n", xaxs = "i", ... ) for( i in 1:n.chain ) { x.cord <- 1:n.keep y.cord <- bugs.array[,i,j] lines( x.cord , y.cord , col = col[i], lty = lty, lwd = lwd ) } axis( 1, at = seq(0, n.keep, n.keep*0.1), tick = TRUE ) } } ) arm/R/fround.R0000644000176200001440000000025615155406662012667 0ustar liggesusersfround <- function (x, digits) { format (round (x, digits), nsmall=digits) } pfround <- function (x, digits) { print (fround (x, digits), quote=FALSE) } arm/R/se.coef.R0000644000176200001440000000724315155406662012717 0ustar liggesuserssetMethod("se.coef", signature(object = "lm"), function(object) { object.class <- class(object)[[1]] sqrt (diag(vcov(object))) } ) setMethod("se.coef", signature(object = "glm"), function(object) { object.class <- class(object)[[1]] sqrt (diag(vcov(object))) } ) #setMethod("se.coef", signature(object = "mer"), # function(object) # { # # if (sum(unlist(lapply(object@bVar, is.na)))>0){ ## object@call$control <- list(usePQL=TRUE) ## object <- lmer(object@call$formula) ## } # #ngrps <- lapply(object@flist, function(x) length(levels(x))) # fcoef <- fixef(object) # #sc <- attr (VarCorr (object), "sc") # corF <- vcov(object)@factors$correlation # se.unmodeled <- NULL # se.unmodeled[[1]] <- corF@sd # names (se.unmodeled) <- "unmodeled" # # #coef <- ranef (object) # #estimate <- ranef(object, postVar=TRUE) # coef <- ranef(object, postVar=TRUE) # se.bygroup <- coef #ranef( object, postVar = TRUE ) # n.groupings <- length (coef) # # for (m in 1:n.groupings){ # vars.m <- attr (coef[[m]], "postVar") # K <- dim(vars.m)[1] # J <- dim(vars.m)[3] # se.bygroup[[m]] <- array (NA, c(J,K)) # for (j in 1:J){ # se.bygroup[[m]][j,] <- sqrt(diag(as.matrix(vars.m[,,j]))) # } ## se.bygroup[[m]] <- se.bygroup[[m]]*sc # names.full <- dimnames (ranef(object)[[m]]) # dimnames (se.bygroup[[m]]) <- list (names.full[[1]], # names.full[[2]]) # } # #names(se.bygroup) <- names(ngrps) # ses <- c (se.unmodeled, se.bygroup) # return (ses) # } #) setMethod("se.coef", signature(object = "merMod"), function(object) { #ngrps <- lapply(object@flist, function(x) length(levels(x))) fcoef <- fixef(object) #sc <- attr (VarCorr (object), "sc") corF <- vcov(object)@factors$correlation se.unmodeled <- NULL se.unmodeled[[1]] <- corF@sd names (se.unmodeled) <- "fixef"#"unmodeled" #coef <- ranef (object) #estimate <- ranef(object, postVar=TRUE) coef <- ranef(object, condVar=TRUE) se.bygroup <- coef #ranef( object, postVar = TRUE ) n.groupings <- length (coef) for (m in 1:n.groupings){ vars.m <- attr (coef[[m]], "postVar") K <- dim(vars.m)[1] J <- dim(vars.m)[3] se.bygroup[[m]] <- array (NA, c(J,K)) for (j in 1:J){ se.bygroup[[m]][j,] <- sqrt(diag(as.matrix(vars.m[,,j]))) } # se.bygroup[[m]] <- se.bygroup[[m]]*sc names.full <- dimnames (coef[[m]]) dimnames (se.bygroup[[m]]) <- list (names.full[[1]], names.full[[2]]) } #names(se.bygroup) <- names(ngrps) ses <- c (se.unmodeled, se.bygroup) return (ses) } ) se.fixef <- function (object){ #object <- summary (object) fcoef.name <- names(fixef(object)) corF <- vcov(object)@factors$correlation ses <- corF@sd names(ses) <- fcoef.name return (ses) } se.ranef <- function (object){ #ngrps <- lapply(object@flist, function(x) length(levels(x))) se.bygroup <- ranef( object, condVar = TRUE ) n.groupings<- length( se.bygroup ) for( m in 1:n.groupings ) { vars.m <- attr( se.bygroup[[m]], "postVar" ) K <- dim(vars.m)[1] J <- dim(vars.m)[3] names.full <- dimnames(se.bygroup[[m]]) se.bygroup[[m]] <- array(NA, c(J, K)) for (j in 1:J) { se.bygroup[[m]][j, ] <- sqrt(diag(as.matrix(vars.m[, , j]))) } dimnames(se.bygroup[[m]]) <- list(names.full[[1]], names.full[[2]]) } return(se.bygroup) } arm/R/coef.R0000644000176200001440000000126415155424361012302 0ustar liggesusers coef.sim <- function(object,...){ ans <- object@coef return(ans) } coef.sim.polr <- function(object, slot=c("ALL", "coef", "zeta"),...){ slot <- match.arg(slot) if(slot=="coef"){ ans <- object@coef } else if(slot=="zeta"){ ans <- object@zeta } else { ans <- cbind(object@zeta, object@coef) } return(ans) } coef.sim.merMod <- function(object,...){ fef <- object@fixef ref <- object@ranef ans <- list("fixef" = fef, "ranef" = ref) return(ans) } fixef.sim.merMod <- function(object,...){ ans <- object@fixef return(ans) } ranef.sim.merMod <- function(object,...){ ans <- object@ranef return(ans) } arm/R/discrete.histogram.R0000644000176200001440000000616715155406662015177 0ustar liggesusersdiscrete.histogram <- function (x, prob, prob2 = NULL, prob3 = NULL, xlab = "x", xaxs.label = NULL, yaxs.label = NULL, bar.width = NULL, freq = FALSE, prob.col = "blue", prob2.col = "red", prob3.col = "gray", ...) { if (!missing(x) && missing(prob)) { prob <- table(x) x <- sort(unique(x)) } if (length(x) != length(prob)) { stop("Length of 'x' must be the same as the length of 'prob'") } if (!freq) { prob <- prob/sum(prob) prob2 <- prob2/sum(prob2) prob3 <- prob3/sum(prob3) ylab <- "Probability" } else { ylab <- "Count" } if (is.numeric(x)) { x.values <- sort(unique(x)) n.x.values <- length(x.values) if (is.null(bar.width)) { gaps <- x.values[2:n.x.values] - x.values[1:(n.x.values - 1)] bar.width <- min(gaps) * 0.2 } par(mar = c(3, 3, 4, 1), mgp = c(1.7, 0.5, 0), tck = -0.01) plot(range(x) + c(-2, 2) * bar.width, c(0, max(prob, prob2, prob3)), xlab = xlab, ylab = ylab, xaxs = "i", xaxt = "n", yaxs = "i", yaxt = ifelse(is.null(yaxs.label), "s", "n"), bty = "l", type = "n", ...) if (is.null(xaxs.label)) { axis(1, x.values) } else { axis(1, xaxs.label[[1]], xaxs.label[[2]]) } } else { x.values <- unique(x) n.x.values <- length(x.values) if (is.null(bar.width)) { bar.width <- 0.2 } par(mar = c(3, 3, 4, 1), mgp = c(1.7, 0.5, 0), tck = -0.01) plot(c(1, n.x.values) + c(-2, 2) * bar.width, c(0, max(prob, prob2, prob3)), xlab = xlab, ylab = ylab, xaxs = "i", xaxt = "n", yaxs = "i", yaxt = ifelse(is.null(yaxs.label), "s", "n"), bty = "l", type = "n", ...) if (is.null(xaxs.label)) { axis(1, 1:n.x.values, x.values) } else { axis(1, xaxs.label[[1]], xaxs.label[[2]]) } x <- 1:length(x) } if (!is.null(yaxs.label)) { axis(2, yaxs.label[[1]], yaxs.label[[2]]) } offset <- rep(0, 3) if (length(prob2) != 0 & length(prob3) != 0) { offset[1] <- -bar.width offset[2] <- 0 offset[3] <- bar.width } if (length(prob2) > 0 & length(prob3) == 0) { offset[1] <- -bar.width/2 offset[2] <- bar.width/2 offset[3] <- 0 } for (i in 1:length(x)) { polygon(x[i] + c(-1, -1, 1, 1) * bar.width/2 + offset[1], c(0, prob[i], prob[i], 0), border = prob.col, col = prob.col) if (!is.null(prob2)) { polygon(x[i] + c(-1, -1, 1, 1) * bar.width/2 + offset[2], c(0, prob2[i], prob2[i], 0), border = prob2.col, col = prob2.col) } if (!is.null(prob3)) { polygon(x[i] + c(-1, -1, 1, 1) * bar.width/2 + offset[3], c(0, prob3[i], prob3[i], 0), border = prob3.col, col = prob3.col) } } } discrete.hist <- discrete.histogram arm/R/mcsamp.R0000644000176200001440000001253115155406662012651 0ustar liggesusers# mcsamp function (wrapper for mcmcsamp in lmer()) # Quick function to run mcmcsamp() [the function for MCMC sampling for # lmer objects) and convert to Bugs objects for easy display mcsamp.default <- function (object, n.chains=3, n.iter=1000, n.burnin=floor(n.iter/2), n.thin=max(1, floor(n.chains * (n.iter - n.burnin)/1000)), saveb=TRUE, deviance=TRUE, make.bugs.object=TRUE) { cat("mcsamp() used to be a wrapper for mcmcsamp() in lme4.\nCurrently, mcmcsamp() is no longer available in lme4.\nSo in the meantime, we suggest that users use sim() to get\nsimulated estimates.\n") } #mcsamp.default <- function (object, n.chains=3, n.iter=1000, n.burnin=floor(n.iter/2), # n.thin=max(1, floor(n.chains * (n.iter - n.burnin)/1000)), # saveb=TRUE, deviance=TRUE, make.bugs.object=TRUE) #{ # # if (n.chains<2) stop ("n.chains must be at least 2") # n.keep <- n.iter - n.burnin # first.chain <- mcmcsamp (object, n.iter, saveb=saveb, trans=TRUE, deviance=deviance)[(n.burnin+1):n.iter,] # n.parameters <- ncol(first.chain) # # if (deviance) { # sims <- array (NA, c(n.keep, n.chains, n.parameters+1)) # } # if (!deviance){ # sims <- array (NA, c(n.keep, n.chains, n.parameters)) # } # # pred.names <- attr(terms(object), "term.labels") # par.names <- dimnames(first.chain)[[2]] # par.names <- gsub("b.", "b@", par.names, ignore.case = FALSE, # Su: rename "b.*" to "" # extended = TRUE, perl = FALSE, # fixed = TRUE, useBytes = FALSE) # par.names <- gsub("b@.*", "", par.names, ignore.case = FALSE, # extended = TRUE, perl = FALSE, # fixed = FALSE) # par.names <- par.names[is.na(match(par.names,""))] # name.chk.idx <- as.logical(match(par.names, pred.names, nomatch=0)) # par.names[name.chk.idx] <- paste("beta", par.names[name.chk.idx], sep=".") # # if (saveb){ # b.hat <- se.coef (object) # Su: use se.coef() # n.groupings <- length(b.hat) - 1 # J <- NA # K <- NA # for (m in 1:n.groupings){ # J[m] <- dim(b.hat[[m+1]])[1] # K[m] <- dim(b.hat[[m+1]])[2] # var.names <- paste (abbreviate(names(b.hat)[m+1],4), ".", # unlist (dimnames(b.hat[[m+1]])[2]), sep="") ##sep="." # par.names <- c (par.names, # paste (rep(var.names,J[m]), "[", rep(1:J[m],each=K[m]), "]", sep="")) # } # } # sims[,1,1:n.parameters] <- first.chain # # for (k in 2:n.chains){ # sims[,k,1:n.parameters] <- mcmcsamp (object, n.iter, saveb=saveb, trans=TRUE, deviance=deviance)[(n.burnin+1):n.iter,] # } # # select <- c(rep(FALSE, n.thin-1),TRUE) # sims <- sims[select,,] # # for (j in 1:n.parameters){ # if (pmatch("log(sigma^2)", par.names[j], nomatch=0)){#=="log(sigma^2)"){ # par.names[j] <- "sigma.y" # sims[,,j] <- exp (sims[,,j]/2) # } # else if (pmatch("log(", par.names[j], nomatch=0)){#(substr(par.names[j],1,4)=="log("){ # par.names[j] <- paste ("sigma.", substr(par.names[j], 5, nchar(par.names[j])-1), sep="") # sims[,,j] <- exp (sims[,,j]/2) # } # else if (pmatch("atanh(", par.names[j], nomatch=0)){#(substr(par.names[j],1,6)=="atanh("){ # par.names[j] <- paste ("rho.", substr(par.names[j], 7, nchar(par.names[j])-1), sep="") # sims[,,j] <- tanh (sims[,,j]) # } # #else if (substr(par.names[j],1,4)=="eta."){#(pmatch("eta.", par.names[j], nomatch=0)){#(substr(par.names[j],1,4)=="eta."){ # # par.names[j] <- paste ("", substr(par.names[j], 5, nchar(par.names[j])), sep="") # # par.names[j] <- par.names[j] # #} # else if (pmatch("deviance", par.names[j], nomatch=0)){#(par.names[j]=="deviance"){ # Su: keep par.names for "deviance" # sims[,,n.parameters+1] <- sims[,,j] # sims <- sims[,,-j] # Su: delete deviance value from sims # } ## else { ## } # } # par.names <- gsub("(", "", par.names, ignore.case = FALSE, # extended = TRUE, perl = FALSE, # fixed = TRUE, useBytes = FALSE) # par.names <- gsub(")", "", par.names, ignore.case = FALSE, # extended = TRUE, perl = FALSE, # fixed = TRUE, useBytes = FALSE) # # par.names <- gsub(".Intercept", ".Int", par.names, ignore.case = FALSE, ## extended = TRUE, perl = FALSE, ## fixed = TRUE, useBytes = FALSE) # par.names <- gsub("rescale", "z.", par.names, ignore.case = FALSE, # extended = TRUE, perl = FALSE, # fixed = TRUE, useBytes = FALSE) # # par.names <- par.names[is.na(match(par.names,"deviance"))] # Su: delete par.names for "deviance" # # if (deviance){ # dimnames(sims) <- list (NULL, NULL, c(par.names,"deviance")) # } # if (!deviance){ # dimnames(sims) <- list (NULL, NULL, par.names) # } # if (make.bugs.object){ # return (as.bugs.array (sims, program="lmer", n.iter=n.iter, n.burnin=n.burnin, n.thin=n.thin, DIC=deviance)) # } # else { # return (sims) # } #} # # # setMethod("mcsamp", signature(object = "merMod"), function (object, ...) { mcsamp.default(object, deviance=TRUE, ...) } ) # #setMethod("mcsamp", signature(object = "glmer"), # function (object, ...) #{ # mcsamp.default(object, deviance=FALSE, ...) #} #) arm/R/simmer.R0000644000176200001440000001142415155406662012665 0ustar liggesusers# simulations of sigma, fixef, and ranef drawn from a posterior # under a flat prior and conditioned on estimate of ranef covar setMethod("sim", signature(object = "merMod"), function(object, n.sims=100) { applyLeftFactor <- function(decomp, rhs) { c(as.vector(decomp$ul %*% rhs[ranefRange] + decomp$ur %*% rhs[fixefRange]), as.vector(decomp$lr %*% rhs[fixefRange])); } # information is conditional on hyperparameters # information is of [ranef, fixef] getInverseInformationLeftFactor <- function(regression) { Lz <- getME(regression, "L"); Rzx <- getME(regression, "RZX"); Rx <- getME(regression, "RX"); # upper left, lower right, and lower left blocks of left-factor of inverse #solveFunc <- getMethod("solve", signature(a = "CHMfactor", b = "diagonalMatrix")); #Rz.inv <- t(solveFunc(Lz, Diagonal(Lz@Dim[1]), "L")); Rz.inv <- t(solve(Lz, Diagonal(Lz@Dim[1]), system = "L")); Rx.inv <- solve(Rx); Rzx.inv <- -Rz.inv %*% Rzx %*% Rx.inv; # this is me figuring some stuff out. new lmer doesn't permute Zt apparently # #Lz.tmp <- as(Lz, "sparseMatrix"); #P.chol <- as(Lz@perm + 1, "pMatrix"); #Zt <- getME(regression, "Zt"); #W <- Diagonal(numObs, regression@resp$sqrtXwt); ## P.ranef <- getRanefPerm(regression); #Lambdat <- getME(regression, "Lambdat") # t(P.ranef) %*% getME(regression, "Lambdat") %*% P.ranef; #A <- Lambdat %*% Zt; #C <- A %*% W; #L.hyp <- Cholesky(tcrossprod(P.chol %*% C), Imult = 1, LDL = FALSE, perm = FALSE); #L.hyp@perm <- Lz@perm; #L.hyp@type[1] <- 2L; #browser(); #P.ranef <- getRanefPerm(model); #Lambda <- P.ranef %*% getRanefChol(model) %*% t(P.ranef); Lambda <- t(getME(regression, "Lambda")); return(list(ul = Lambda %*% Rz.inv, ur = Lambda %*% Rzx.inv, lr = Rx.inv)); } # assumes p(sigma^2) propto sigma^-2 sampleCommonScale <- function(ignored) { return(sqrt(1 / rgamma(1, 0.5 * numDoF, 0.5 * devcomp$cmp[["pwrss"]]))); } regression <- object; devcomp <- getME(regression, "devcomp"); dims <- devcomp$dims; if (dims[["NLMM"]] != 0L) stop("sim not yet implemented for nlmms"); numObs <- dims[["n"]]; numRanef <- dims[["q"]]; numFixef <- dims[["p"]]; numLevels <- dims[["reTrms"]]; isLinearMixedModel <- dims[["GLMM"]] == 0L && dims[["NLMM"]] == 0L; numEffects <- numRanef + numFixef; numDoF <- numObs - numFixef; # pertain to simulations that we do all as a single vector ranefRange <- 1:numRanef; fixefRange <- numRanef + 1:numFixef; # stuff used to rearrange ranef into usable form groupsPerUniqueFactor <- lapply(regression@flist, levels); factorPerLevel <- attr(regression@flist, "assign"); coefficientNamesPerLevel <- regression@cnms; numCoefficientsPerLevel <- as.numeric(sapply(coefficientNamesPerLevel, length)); numGroupsPerLevel <- as.numeric(sapply(groupsPerUniqueFactor[factorPerLevel], length)); numRanefsPerLevel <- numCoefficientsPerLevel * numGroupsPerLevel; ranefLevelMap <- rep.int(seq_along(numRanefsPerLevel), numRanefsPerLevel); # storage for sims simulatedSD <- if (isLinearMixedModel) { rep(NA, n.sims); } else { NA }; simulatedRanef <- vector("list", numLevels); names(simulatedRanef) <- names(regression@cnms); for (i in 1:numLevels) { simulatedRanef[[i]] <- array(NA, c(n.sims, numGroupsPerLevel[i], numCoefficientsPerLevel[i]), list(NULL, groupsPerUniqueFactor[[factorPerLevel[i]]], coefficientNamesPerLevel[[i]])); } simulatedFixef <- matrix(NA, n.sims, numFixef, dimnames = list(NULL, names(fixef(regression)))); # "b" are the rotated random effects, i.e. what ranef() returns in # a rearranged format. effectsMean <- c(getME(regression, "b")@x, getME(regression, "beta")); effectsCovLeftFactor <- getInverseInformationLeftFactor(regression); for (i in 1:n.sims) { if (isLinearMixedModel) { simulatedSD[i] <- sampleCommonScale(regression); sphericalEffects <- rnorm(numEffects, 0, simulatedSD[i]); } else { sphericalEffects <- rnorm(numEffects); } simulatedEffects <- applyLeftFactor(effectsCovLeftFactor, sphericalEffects) + effectsMean; simulatedFixef[i,] <- simulatedEffects[fixefRange]; rawRanef <- simulatedEffects[ranefRange]; simulatedRanefPerLevel <- split(rawRanef, ranefLevelMap); for (k in 1:numLevels) { simulatedRanef[[k]][i,,] <- matrix(simulatedRanefPerLevel[[k]], ncol = numCoefficientsPerLevel[k], byrow = TRUE); } } ans <- new("sim.merMod", "fixef" = simulatedFixef, "ranef" = simulatedRanef, "sigma" = simulatedSD); return(ans); }); arm/R/readColumns.R0000644000176200001440000000044315155406662013644 0ustar liggesusersread.columns <- function (filename, columns){ start <- min(columns) length <- max(columns) - start + 1 if (start == 1) { return(read.fwf(filename, widths = length)) } else { return(read.fwf(filename, widths = c(start - 1, length))[, 2]) } } arm/R/display.R0000644000176200001440000003242215155406662013037 0ustar liggesuserssetMethod("display", signature(object = "lm"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call summ <- summary (object) out$sigma.hat <- summ$sigma out$r.squared <- summ$r.squared if(detail){ coef <- summ$coef[,,drop=FALSE] } else{ coef <- summ$coef[,1:2,drop=FALSE] } dimnames(coef)[[2]][1:2] <- c("coef.est","coef.se") out$coef <- coef[,"coef.est"]#,drop=FALSE] out$se <- coef[,"coef.se"]#,drop=FALSE] out$t.value <- summ$coef[,3] out$p.value <- summ$coef[,4] out$n <- summ$df[1] + summ$df[2] out$k <- summ$df[1] print (out$call) pfround (coef, digits) cat("---\n") cat (paste ("n = ", out$n, ", k = ", out$k, "\nresidual sd = ", fround (out$sigma.hat, digits), ", R-Squared = ", fround (out$r.squared, 2), "\n", sep="")) return(invisible(out)) } ) setMethod("display", signature(object = "bayesglm"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call summ <- summary(object, dispersion = object$dispersion) if(detail){ coef <- summ$coefficients coef[ rownames( coef ) %in% rownames( summ$coef[, , drop = FALSE]) , ] <- summ$coef[ , , drop = FALSE ] out$z.value <- coef[,3]#,drop=FALSE] out$p.value <- coef[,4]#,drop=FALSE] } else{ coef <- matrix( NA, length( object$coefficients ),2 ) rownames(coef) <- names( object$coefficients ) ## M coef[ rownames( coef ) %in% rownames( summ$coef[, 1:2, drop = FALSE]) , ] <- summ$coef[ , 1:2, drop = FALSE ] ## M } dimnames(coef)[[2]][1:2] <- c( "coef.est", "coef.se") out$coef <- coef[,"coef.est"]#,drop=FALSE] out$se <- coef[,"coef.se"]#,drop=FALSE] out$n <- summ$df[1] + summ$df[2] out$k <- summ$df[1] out$deviance <- summ$deviance out$null.deviance <- summ$null.deviance print(out$call) pfround(coef, digits) cat("---\n") cat(paste("n = ", out$n, ", k = ", out$k, "\nresidual deviance = ", fround(out$deviance, 1), ", null deviance = ", fround(out$null.deviance, 1), " (difference = ", fround(out$null.deviance - out$deviance, 1), ")", "\n", sep = "")) out$dispersion <- if (is.null(object$dispersion)){ summ$dispersion } else { object$dispersion } if (out$dispersion != 1) { out$overdispersion.parameter <- out$dispersion cat(paste("overdispersion parameter = ", fround(out$dispersion, 1), "\n", sep = "")) if (family(object)$family == "gaussian") { out$sigma.hat <- sqrt(out$dispersion) cat(paste("residual sd is sqrt(overdispersion) = ", fround(out$sigma.hat, digits), "\n", sep = "")) } } return(invisible(out)) } ) #setMethod("display", signature(object = "bayesglm.h"), # function (object, digits = 2, detail = FALSE) # { # call <- object$call # summ <- summary(object, dispersion = object$dispersion) # if(detail){ # coef <- summ$coefficients # coef[ rownames( coef ) %in% rownames( summ$coef[, , drop = FALSE]) , ] <- summ$coef[ , , drop = FALSE ] # } # else{ # coef <- matrix( NA, length( object$coefficients ),2 ) # rownames(coef) <- names( object$coefficients ) ## M # coef[ rownames( coef ) %in% rownames( summ$coef[, 1:2, drop = FALSE]) , ] <- summ$coef[ , 1:2, drop = FALSE ] ## M # } # dimnames(coef)[[2]][1:2] <- c( "coef.est", "coef.se") # #n <- summ$df[1] + summ$df[2] # n <- summ$df.residual # k <- summ$df[1] # print(call) # if(max(object$batch)>0){ # nn<- strsplit( rownames( coef )[seq( from= length( object$batch ) + 1 ,to = nrow( coef ))], "." , fixed=TRUE) # bb<- c( object$batch,unlist( lapply (nn , function( lst ) { lst[[3]] } ) ) ) # } # else {bb<- c( object$batch)} # cc<- cbind( fround( coef, digits ), bb ) # dimnames(cc)[[2]][3]<-"batch" # print( cc , quote = FALSE ) # cat("---\n") # cat(paste("n = ", n, ", k = ", k, "\nresidual deviance = ", # fround(summ$deviance, 1), ", null deviance = ", fround(summ$null.deviance, # 1), " (difference = ", fround(summ$null.deviance - # summ$deviance, 1), ")", "\n", sep = "")) # dispersion <- if (is.null(object$dispersion)) # summ$dispersion # else object$dispersion # if (dispersion != 1) { # cat(paste("overdispersion parameter = ", fround(dispersion, # 1), "\n", sep = "")) # if (family(object)$family == "gaussian") { # cat(paste("residual sd is sqrt(overdispersion) = ", # fround(sqrt(dispersion), digits), "\n", sep = "")) # cat(paste("group sd is sigma.batch = ", # fround(object$sigma.batch, digits), "\n", sep = "")) # } # } # } #) setMethod("display", signature(object = "glm"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call summ <- summary(object, dispersion = object$dispersion) if(detail){ coef <- summ$coef[, , drop = FALSE] out$z.value <- coef[,3]#,drop=FALSE] out$p.value <- coef[,4]#,drop=FALSE] } else{ coef <- summ$coef[, 1:2, drop = FALSE] } dimnames(coef)[[2]][1:2] <- c("coef.est", "coef.se") out$n <- summ$df[1] + summ$df[2] out$k <- summ$df[1] out$coef <- coef[,"coef.est"] out$se <- coef[,"coef.se"] print(out$call) pfround(coef, digits) out$deviance <- summ$deviance out$null.deviance <- summ$null.deviance cat("---\n") cat(paste(" n = ", out$n, ", k = ", out$k, "\n residual deviance = ", fround(out$deviance, 1), ", null deviance = ", fround(out$null.deviance, 1), " (difference = ", fround(summ$null.deviance - summ$deviance, 1), ")", "\n", sep = "")) out$dispersion <- if (is.null(object$dispersion)){ summ$dispersion } else { object$dispersion } if (out$dispersion != 1) { cat(paste(" overdispersion parameter = ", fround(out$dispersion, 1), "\n", sep = "")) if (family(object)$family=="gaussian") { out$sigma.hat <- sqrt(out$dispersion) cat(paste(" residual sd is sqrt(overdispersion) = ", fround(out$sigma.hat, digits), "\n", sep = "")) } } return(invisible(out)) } ) #setMethod("display", signature(object = "mer"), # function(object, digits=2) # { # call <- object@call # print (call) # #object <- summary(object) # fcoef <- fixef(object) # useScale <- attr( VarCorr(object), "sc") # corF <- vcov(object)@factors$correlation # coefs <- cbind(fcoef, corF@sd) # if (length (fcoef) > 0){ # dimnames(coefs) <- list(names(fcoef), c("coef.est", "coef.se")) # pfround (coefs, digits) # } # cat("\nError terms:\n") # vc <- as.matrix.VarCorr (VarCorr (object), useScale=useScale, digits) # print (vc[,c(1:2,4:ncol(vc))], quote=FALSE) # ngrps <- lapply(object@flist, function(x) length(levels(x))) # REML <- object@status["REML"] # llik <- logLik(object, REML) # AIC <- AIC(llik) # dev <- object@deviance["ML"] # Dbar # n <- object@devComp["n"] # Dhat <- -2*(llik) # Dhat # pD <- dev - Dhat # pD # DIC <- dev + pD # DIC=Dbar+pD=Dhat+2pD # cat("---\n") # cat(sprintf("number of obs: %d, groups: ", n)) # cat(paste(paste(names(ngrps), ngrps, sep = ", "), collapse = "; ")) # cat(sprintf("\nAIC = %g, DIC = ", fround(AIC, 1))) # cat(fround(DIC, 1)) # cat("\ndeviance =", fround (dev, 1), "\n") # if (useScale < 0){ # cat("overdispersion parameter =", fround (.Call("mer_sigma", # object, FALSE, PACKAGE = "lme4"), 1), "\n") # } # } #) setMethod("display", signature(object = "merMod"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object@call print (out$call) #object <- summary(object) #summ <- summary(object) fcoef <- fixef(object) #coefs <- attr(summ, "coefs") #useScale <- attr (VarCorr (object), "sc") useScale <- getME(object, "devcomp")$dims["useSc"] corF <- vcov(object)@factors$correlation coefs <- cbind(fcoef, corF@sd) if (length (fcoef) > 0){ if (!useScale) { coefs <- coefs[, 1:2, drop = FALSE] out$z.value <- coefs[, 1]/coefs[, 2] out$p.value <- 2 * pnorm(abs(out$z.value), lower.tail = FALSE) coefs <- cbind(coefs, `z value` = out$z.value, `Pr(>|z|)` = out$p.value) } else { out$t.value <- coefs[, 1]/coefs[, 2] coefs <- cbind(coefs, `t value` = out$t.value) } dimnames(coefs)[[2]][1:2] <- c("coef.est", "coef.se") if(detail){ pfround (coefs, digits) } else{ pfround(coefs[,1:2], digits) } } out$coef <- coefs[,"coef.est"] out$se <- coefs[,"coef.se"] cat("\nError terms:\n") vc <- as.matrix.VarCorr (VarCorr (object), useScale=useScale, digits=digits) print (vc[,c(1:2,4:ncol(vc))], quote=FALSE) out$ngrps <- lapply(object@flist, function(x) length(levels(x))) is_REML <- isREML(object) llik <- logLik(object, REML=is_REML) out$AIC <- AIC(llik) out$deviance <- deviance(refitML(object)) # Dbar out$n <- getME(object, "devcomp")$dims["n"] Dhat <- -2*(llik) # Dhat pD <- out$deviance - Dhat # pD out$DIC <- out$deviance + pD # DIC=Dbar+pD=Dhat+2pD cat("---\n") cat(sprintf("number of obs: %d, groups: ", out$n)) cat(paste(paste(names(out$ngrps), out$ngrps, sep = ", "), collapse = "; ")) cat(sprintf("\nAIC = %g, DIC = ", round(out$AIC,1))) cat(round(out$DIC, 1)) cat("\ndeviance =", fround (out$deviance, 1), "\n") if (useScale < 0){ out$sigma.hat <- .Call("mer_sigma", object, FALSE, PACKAGE = "lme4") cat("overdispersion parameter =", fround (out$sigma.hat, 1), "\n") } return(invisible(out)) } ) setMethod("display", signature(object = "polr"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call summ <- summary(object) if(detail){ coef <- summ$coef[, , drop = FALSE] out$t.value <- coef[,"t value"] } else{ coef <- summ$coef[, 1:2, drop = FALSE] } dimnames(coef)[[2]][1:2] <- c("coef.est", "coef.se") out$coef <- coef[,"coef.est"] out$se <- coef[,"coef.se"] out$n <- summ$n out$k <- nrow (coef) out$k.intercepts <- length (summ$zeta) print(out$call) pfround(coef, digits) cat("---\n") cat(paste("n = ", out$n, ", k = ", out$k, " (including ", out$k.intercepts, " intercepts)\nresidual deviance = ", fround(deviance(object), 1), ", null deviance is not computed by polr", "\n", sep = "")) #cat("AIC:", fround(AIC(object), 1), "\n") return(invisible(out)) } ) setMethod("display", signature(object = "svyglm"), function(object, digits=2, detail=FALSE) { out <- NULL out$call <- object$call out$survey.design <- object$survey.design summ <- summary(object) if(detail){ coef <- summ$coef[, , drop = FALSE] out$z.value <- coef[,3]#,drop=FALSE] out$p.value <- coef[,4]#,drop=FALSE] } else{ coef <- summ$coef[, 1:2, drop = FALSE] } dimnames(coef)[[2]][1:2] <- c("coef.est", "coef.se") out$n <- summ$df[1] + summ$df[2] out$k <- summ$df[1] out$coef <- coef[,"coef.est"] out$se <- coef[,"coef.se"] print(out$call) cat("\n") print(out$survey.design) cat("\n") pfround(coef, digits) out$deviance <- summ$deviance out$null.deviance <- summ$null.deviance cat("---\n") cat(paste(" n = ", out$n, ", k = ", out$k, "\n residual deviance = ", fround(out$deviance, 1), ", null deviance = ", fround(out$null.deviance, 1), " (difference = ", fround(summ$null.deviance - summ$deviance, 1), ")", "\n", sep = "")) out$dispersion <- summ$dispersion[1] if (out$dispersion != 1) { cat(paste(" overdispersion parameter = ", fround(out$dispersion, 1), "\n", sep = "")) if (family(object)$family=="gaussian") { out$sigma.hat <- sqrt(out$dispersion) cat(paste(" residual sd is sqrt(overdispersion) = ", fround(out$sigma.hat, digits), "\n", sep = "")) } } return(invisible(out)) } ) #setMethod("display", signature(object = "bayespolr"), # function(object, digits=2) # { # call <- object$call # summ <- summary(object) # coef <- summ$coef[, 1:2, drop = FALSE] # dimnames(coef)[[2]] <- c("coef.est", "coef.se") # n <- summ$n # or maybe should be "nobs", I don't know for sure # k <- nrow (coef) # k.intercepts <- length (summ$zeta) # print(call) # pfround(coef, digits) # cat("---\n") # cat(paste("n = ", n, ", k = ", k, " (including ", k.intercepts, # " intercepts)\nresidual deviance = ", # fround(summ$deviance, 1), # ", null deviance is not computed by bayespolr", # "\n", sep = "")) # } #) arm/R/corrplot.R0000644000176200001440000000212615155406662013234 0ustar liggesusers corrplot <- function(data, varnames=NULL, cutpts=NULL, abs=TRUE, details=TRUE, n.col.legend=5, cex.col=0.7, cex.var=0.9, digits=1, color=FALSE) { # some check! if (is.matrix(data)|is.data.frame(data)){ } else { stop ("Data must be a matrix or a data frame!") } if (sum(sapply(data, FUN=is.character))>0) stop ("Data contains non-numeric variables!") if (n.col.legend > 8) stop ("Suggestion: More than 8 levels of colors is difficult to read!") # prepare correlation matrix if (abs){ z.plot <- abs(cor(data, data, use="pairwise.complete.obs")) } else{ z.plot <- cor(data, data, use="pairwise.complete.obs") } if (is.null(varnames)){ z.names <- dimnames(data)[[2]] } else{ z.names <- varnames } triangleplot(x=z.plot, y=z.names, cutpts=cutpts, details=details, n.col.legend=n.col.legend, cex.col=cex.col, cex.var=cex.var, digits=digits, color=color) } arm/R/extractDIC.R0000644000176200001440000000174215155406662013365 0ustar liggesusers extractDIC <- function(fit,...){ UseMethod("extractDIC") } extractDIC.merMod <- function(fit,...){ #REML <- fit@dims["REML"] # llik <- logLik(fit, REML) # dev <- fit@deviance["ML"] # n <- fit@dims["n"] # Dhat <- -2 * (llik) # pD <- dev - Dhat # DIC <- dev + pD[[1]] # names(DIC) <- "DIC" # return(DIC) is_REML <- isREML(fit) llik <- logLik(fit, REML=is_REML) dev <- deviance(refitML(fit)) n <- getME(fit, "devcomp")$dims["n"] Dhat <- -2 * (llik) pD <- dev - Dhat DIC <- dev + pD[[1]] names(DIC) <- "DIC" return(DIC) } # #extractAIC.mer <- function(fit,...){ ## REML <- fit@dims["REML"] ## llik <- logLik(fit, REML) ## AIC <- AIC(llik) ## names(AIC) <- "AIC" ## return(AIC) # L <- logLik(refitML(fit)) # edf <- attr(L,"df") # out <- c(edf,-2*L + k*edf) # return(out) #} arm/R/bayespolr.R0000644000176200001440000002533215155406662013374 0ustar liggesusers# New bayespolr() using Kenny's Dirichlet prior distribution bayespolr <- function (formula, data, weights, start, ..., subset, na.action, contrasts = NULL, Hess = TRUE, model = TRUE, method = c("logistic", "probit", "cloglog", "cauchit"), drop.unused.levels = TRUE, prior.mean = 0, prior.scale = 2.5, prior.df = 1, prior.counts.for.bins = NULL, min.prior.scale = 1e-12, scaled = TRUE, maxit = 100, print.unnormalized.log.posterior = FALSE) { logit <- function(p) log(p/(1 - p)) dt.deriv <- function(x, mean, scale, df, log = TRUE, delta = 0.001) { (dt((x + delta - mean)/scale, df, log = log) - dt((x - delta - mean)/scale, df, log = log))/(2 * delta) } fmin <- function(beta) { theta <- beta[pc + 1:q] gamm <- c(-100, cumsum(c(theta[1], exp(theta[-1]))), 100) eta <- offset if (pc > 0) eta <- eta + drop(x %*% beta[1:pc]) pr <- pfun(gamm[y + 1] - eta) - pfun(gamm[y] - eta) if (all(pr > 0)) f <- -sum(wt * log(pr)) else f <- Inf if (pc > 0) f <- f - sum(dt((beta[1:pc] - prior.mean)/prior.scale, prior.df, log = TRUE)) return(f) } gmin <- function(beta) { jacobian <- function(theta) { k <- length(theta) etheta <- exp(theta) mat <- matrix(0, k, k) mat[, 1] <- rep(1, k) for (i in 2:k) mat[i:k, i] <- etheta[i] mat } theta <- beta[pc + 1:q] gamm <- c(-100, cumsum(c(theta[1], exp(theta[-1]))), 100) eta <- offset if (pc > 0) eta <- eta + drop(x %*% beta[1:pc]) pr <- pfun(gamm[y + 1] - eta) - pfun(gamm[y] - eta) p1 <- dfun(gamm[y + 1] - eta) p2 <- dfun(gamm[y] - eta) g1 <- if (pc > 0) t(x) %*% (wt * (p1 - p2)/pr) else numeric(0) xx <- .polrY1 * p1 - .polrY2 * p2 g2 <- -t(xx) %*% (wt/pr) g2 <- t(g2) %*% jacobian(theta) if (pc > 0) g1 <- g1 - dt.deriv(beta[1:pc], prior.mean, prior.scale, prior.df, log = TRUE) if (all(pr > 0)) c(g1, g2) else rep(NA, pc + q) } m <- match.call(expand.dots = FALSE) mf <- match(c("formula", "data", "subset", "weights", "na.action", "etastart", "mustart", "offset"), names(m), 0) m <- m[c(1, mf)] m$drop.unused.levels <- drop.unused.levels method <- match.arg(method) ##### adjust prior.scale for probit #### if (method == "probit"){ prior.scale <- prior.scale*1.6 } ################ for(jj in 1:length(prior.scale)){ if (prior.scale[jj] < min.prior.scale){ prior.scale[jj] <- min.prior.scale warning ("prior scale for variable ", jj, " set to min.prior.scale = ", min.prior.scale,"\n") } } pfun <- switch(method, logistic = plogis, probit = pnorm, cloglog = pgumbel, cauchit = pcauchy) dfun <- switch(method, logistic = dlogis, probit = dnorm, cloglog = dgumbel, cauchit = dcauchy) if (is.matrix(eval.parent(m$data))) m$data <- as.data.frame(data) m$start <- m$Hess <- m$method <- m$... <- NULL m[[1]] <- as.name("model.frame") m <- eval.parent(m) Terms <- attr(m, "terms") x <- model.matrix(Terms, m, contrasts) xint <- match("(Intercept)", colnames(x), nomatch = 0) n <- nrow(x) pc <- ncol(x) cons <- attr(x, "contrasts") if (xint > 0) { x <- x[, -xint, drop = FALSE] pc <- pc - 1 } else warning("an intercept is needed and assumed") wt <- model.weights(m) if (!length(wt)) wt <- rep(1, n) offset <- model.offset(m) if (length(offset) <= 1) offset <- rep(0, n) y <- model.response(m) if (!is.factor(y)) stop("response must be a factor") lev <- levels(y) if (length(lev) <= 2) stop("response must have 3 or more levels") y <- unclass(y) q <- length(lev) - 1 Y <- matrix(0, n, q) .polrY1 <- col(Y) == y .polrY2 <- col(Y) == y - 1 if (missing(start)) { q1 <- length(lev)%/%2 y1 <- (y > q1) X <- cbind(Intercept = rep(1, n), x) fit <- switch(method, logistic = bayesglm.fit(X, y1, wt, family = binomial(), offset = offset, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, min.prior.scale = min.prior.scale, scaled = scaled, control = glm.control(maxit=maxit), print.unnormalized.log.posterior = print.unnormalized.log.posterior), probit = bayesglm.fit(X, y1, wt, family = binomial("probit"), offset = offset, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, min.prior.scale = min.prior.scale, scaled = scaled, control = glm.control(maxit=maxit), print.unnormalized.log.posterior = print.unnormalized.log.posterior), cloglog = bayesglm.fit(X, y1, wt, family = binomial("probit"), offset = offset, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, min.prior.scale = min.prior.scale, scaled = scaled, control = glm.control(maxit=maxit), print.unnormalized.log.posterior = print.unnormalized.log.posterior), cauchit = bayesglm.fit(X, y1, wt, family = binomial("cauchit"), offset = offset, intercept = TRUE, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, min.prior.scale = min.prior.scale, scaled = scaled, control = glm.control(maxit=maxit), print.unnormalized.log.posterior = print.unnormalized.log.posterior)) if (!fit$converged) warning("attempt to find suitable starting values failed") coefs <- fit$coefficients if (any(is.na(coefs))) { warning("design appears to be rank-deficient, so dropping some coefs") keep <- names(coefs)[!is.na(coefs)] coefs <- coefs[keep] x <- x[, keep[-1], drop = FALSE] pc <- ncol(x) } spacing <- logit((1:q)/(q + 1)) if (method != "logistic") spacing <- spacing/1.7 gammas <- -coefs[1] + spacing - spacing[q1] thetas <- c(gammas[1], log(diff(gammas))) start <- c(coefs[-1], thetas) } # rep start to have the same length of coef + zeta else if (length(start)==1){ start <- rep(start, (pc+q)) } else if (length(start) != pc + q) stop("'start' is not of the correct length") J <- NCOL(x) # SU: if no x's, no priors for coefs 2008.2.9 if (xint>1) { if (length(prior.mean) == 1) prior.mean <- rep(prior.mean, J) if (length(prior.scale) == 1) { prior.scale <- rep(prior.scale, J) if (scaled == TRUE) { for (j in 1:J) { x.obs <- x[, j] x.obs <- x.obs[!is.na(x.obs)] num.categories <- length(unique(x.obs)) if (num.categories == 2) { prior.scale[j] <- prior.scale[j]/(max(x.obs) - min(x.obs)) } else if (num.categories > 2) { prior.scale[j] <- prior.scale[j]/(2 * sd(x.obs)) } } } } if (length(prior.df) == 1) { prior.df <- rep(prior.df, J) } } # prior for intercept sum(priors.intercpet)=1 if (is.null(prior.counts.for.bins)) { prior.counts.for.bins <- 1/(q+1) } if (length(prior.counts.for.bins) == 1) { prior.counts.for.bins <- rep(prior.counts.for.bins, q+1) } # Augment the data to add prior information y.0 <- y Y.0 <- Y x.0 <- x wt.0 <- wt offset.0 <- offset .polrY1.0 <- .polrY1 .polrY2.0 <- .polrY2 y <- c (y.0, 1:(q+1)) Y <- matrix(0, n+q+1, q) .polrY1 <- col(Y) == y .polrY2 <- col(Y) == y - 1 x <- rbind (x.0, matrix (colMeans(x.0), nrow=(q+1), ncol=J, byrow=TRUE)) wt <- c (wt.0, prior.counts.for.bins) offset <- c (offset, rep(0,q+1)) # Fit the model as before res <- optim(start, fmin, gmin, method = "BFGS", hessian = Hess, ...) # Restore the old variables y <- y.0 Y <- Y.0 x <- x.0 wt <- wt.0 offset <- offset.0 .polrY1 <- .polrY1.0 .polrY2 <- .polrY2.0 # Continue on as before beta <- res$par[seq_len(pc)] theta <- res$par[pc + 1:q] zeta <- cumsum(c(theta[1], exp(theta[-1]))) deviance <- 2 * res$value niter <- c(f.evals = res$counts[1], g.evals = res$counts[2]) names(zeta) <- paste(lev[-length(lev)], lev[-1], sep = "|") if (pc > 0) { names(beta) <- colnames(x) eta <- drop(x %*% beta) } else { eta <- rep(0, n) } cumpr <- matrix(pfun(matrix(zeta, n, q, byrow = TRUE) - eta), , q) fitted <- t(apply(cumpr, 1, function(x) diff(c(0, x, 1)))) dimnames(fitted) <- list(row.names(m), lev) fit <- list(coefficients = beta, zeta = zeta, deviance = deviance, fitted.values = fitted, lev = lev, terms = Terms, df.residual = sum(wt) - pc - q, edf = pc + q, n = sum(wt), nobs = sum(wt), call = match.call(), method = method, convergence = res$convergence, prior.mean = prior.mean, prior.scale = prior.scale, prior.df = prior.df, prior.counts.for.bins = prior.counts.for.bins, niter = niter) if (Hess) { dn <- c(names(beta), names(zeta)) H <- res$hessian dimnames(H) <- list(dn, dn) fit$Hessian <- H } if (model){ fit$model <- m } fit$na.action <- attr(m, "na.action") fit$contrasts <- cons fit$xlevels <- .getXlevels(Terms, m) class(fit) <- c("bayespolr", "polr") fit } setMethod("print", signature(x = "bayespolr"), function(x, digits= 2) display(object=x, digits=digits)) setMethod("show", signature(object = "bayespolr"), function(object) display(object, digits=2)) arm/R/model.matrixBayes.R0000644000176200001440000001470715155406662014767 0ustar liggesusers#setMethod("model.matrix.bayes", signature(object = "bayesglm"), model.matrixBayes <- function(object, data = environment(object), contrasts.arg = NULL, xlev = NULL, keep.order=FALSE, drop.baseline=FALSE,...) { #class(object) <- c("terms", "formula") t <- if( missing( data ) ) { terms( object ) }else{ terms.formula(object, data = data, keep.order=keep.order) } attr(t, "intercept") <- attr(object, "intercept") if (is.null(attr(data, "terms"))){ data <- model.frame(object, data, xlev=xlev) }else { reorder <- match(sapply(attr(t,"variables"), deparse, width.cutoff=500)[-1], names(data)) if (anyNA(reorder)) { stop( "model frame and formula mismatch in model.matrix()" ) } if(!identical(reorder, seq_len(ncol(data)))) { data <- data[,reorder, drop = FALSE] } } int <- attr(t, "response") if(length(data)) { # otherwise no rhs terms, so skip all this if (drop.baseline){ contr.funs <- as.character(getOption("contrasts")) }else{ contr.funs <- as.character(list("contr.bayes.unordered", "contr.bayes.ordered")) } namD <- names(data) ## turn any character columns into factors for(i in namD) if(is.character( data[[i]] ) ) { data[[i]] <- factor(data[[i]]) warning( gettextf( "variable '%s' converted to a factor", i ), domain = NA) } isF <- vapply(data, function(x) is.factor(x) || is.logical(x), NA) isF[int] <- FALSE isOF <- vapply(data, is.ordered, NA) for( nn in namD[isF] ) # drop response if( is.null( attr( data[[nn]], "contrasts" ) ) ) { contrasts( data[[nn]] ) <- contr.funs[1 + isOF[nn]] } ## it might be safer to have numerical contrasts: ## get(contr.funs[1 + isOF[nn]])(nlevels(data[[nn]])) if ( !is.null( contrasts.arg ) && is.list( contrasts.arg ) ) { if ( is.null( namC <- names( contrasts.arg ) ) ) { stop( "invalid 'contrasts.arg' argument" ) } for (nn in namC) { if ( is.na( ni <- match( nn, namD ) ) ) { warning( gettextf( "variable '%s' is absent, its contrast will be ignored", nn ), domain = NA ) } else { ca <- contrasts.arg[[nn]] if( is.matrix( ca ) ) { contrasts( data[[ni]], ncol( ca ) ) <- ca } else { contrasts( data[[ni]] ) <- contrasts.arg[[nn]] } } } } } else { # internal model.matrix needs some variable isF <- FALSE data <- data.frame(x=rep(0, nrow(data))) } #ans <- .Internal( model.matrix( t, data ) ) ans <- model.matrix.default(object=t, data=data) cons <- if(any(isF)){ lapply( data[isF], function(x) attr( x, "contrasts") ) }else { NULL } attr(ans, "contrasts" ) <- cons ans } #) #setMethod("model.matrix.bayes", signature(object = "bayesglm.h"), #model.matrix.bayes.h <- function (object, data = environment(object), # contrasts.arg = NULL, # xlev = NULL, keep.order = FALSE, batch = NULL, ...) #{ # class(object) <- c("formula") # t <- if (missing(data)) { # terms(object) # } # else { # terms(object, data = data, keep.order = keep.order) # } # attr(t, "intercept") <- attr(object, "intercept") # if (is.null(attr(data, "terms"))) { # data <- model.frame(object, data, xlev = xlev) # } # else { # reorder <- match(sapply(attr(t, "variables"), deparse, # width.cutoff = 500)[-1], names(data)) # if (any(is.na(reorder))) { # stop("model frame and formula mismatch in model.matrix()") # } # if (!identical(reorder, seq_len(ncol(data)))) { # data <- data[, reorder, drop = FALSE] # } # } # int <- attr(t, "response") # if (length(data)) { # contr.funs <- as.character(getOption("contrasts")) # contr.bayes.funs <- as.character(list("contr.bayes.unordered", # "contr.bayes.ordered")) # namD <- names(data) # for (i in namD) if (is.character(data[[i]])) { # data[[i]] <- factor(data[[i]]) # warning(gettextf("variable '%s' converted to a factor", i), domain = NA) # } # isF <- sapply(data, function(x) is.factor(x) || is.logical(x)) # isF[int] <- FALSE # isOF <- sapply(data, is.ordered) # if (length(batch) > 1) { # ba <- batch[isF[-1]] # } # else if (length(batch) == 1) { # ba <- rep(batch, length(isF[-1])) # } # else { # ba <- rep(0, length(isF[-1])) # } # iin <- 1 # for (nn in namD[isF]) if (is.null(attr(data[[nn]], "contrasts"))) { # if (ba[[iin]] > 0) { # contrasts(data[[nn]]) <- contr.bayes.funs # } # else { # contrasts(data[[nn]]) <- contr.funs # } # iin <- iin + 1 # } # if (!is.null(contrasts.arg) && is.list(contrasts.arg)) { # if (is.null(namC <- names(contrasts.arg))) { # stop("invalid 'contrasts.arg' argument") # } # for (nn in namC) { # if (is.na(ni <- match(nn, namD))) { # warning(gettextf("variable '%s' is absent, its contrast will be ignored", # nn), domain = NA) # } # else { # ca <- contrasts.arg[[nn]] # if (is.matrix(ca)) { # contrasts(data[[ni]], ncol(ca)) <- ca # } # else { # contrasts(data[[ni]]) <- contrasts.arg[[nn]] # } # } # } # } # } # else { # isF <- FALSE # data <- list(x = rep(0, nrow(data))) # } # ans <- .Internal(model.matrix(t, data)) # cons <- if (any(isF)) { # lapply(data[isF], function(x) attr(x, "contrasts")) # } # else { # NULL # } # attr(ans, "contrasts") <- cons # ans #} ##) arm/R/AllGeneric.R0000644000176200001440000000262215155406662013376 0ustar liggesusers #setGeneric("coef") #setGeneric("print") #setGeneric("fitted") #setGeneric("extractAIC") if (!isGeneric("coefplot")) { setGeneric("coefplot", function(object, ...) standardGeneric("coefplot")) } if (!isGeneric("display")) { setGeneric("display", function(object, ...) standardGeneric("display")) } if (!isGeneric("sim")) { setGeneric("sim", function(object, ...) standardGeneric("sim")) } sigma.hat <- function(object,...){ UseMethod("sigma.hat") } if (!isGeneric("se.coef")) { setGeneric("se.coef", function(object, ...) standardGeneric("se.coef")) } if (!isGeneric("mcsamp")) { setGeneric("mcsamp", function(object, ...) standardGeneric("mcsamp")) } if (!isGeneric("standardize")) { setGeneric("standardize", function(object, ...) standardGeneric("standardize")) } #if (!isGeneric("terms.bayes")) { # setGeneric("terms.bayes", # function(x, ...) # standardGeneric("terms.bayes")) #} if (!isGeneric("traceplot")) { setGeneric("traceplot", function(x, ...) standardGeneric("traceplot"), useAsDefault = function(x, ...) coda::traceplot(x, ...)) } arm/R/multicomp.plot.R0000644000176200001440000000676415155406662014372 0ustar liggesusers#============================================================================== # Multiple Comparison Plot #============================================================================== multicomp.plot <- function(object, alpha=0.05, main = "Multiple Comparison Plot", label = NULL, shortlabel = NULL, show.pvalue = FALSE, label.as.shortlabel = FALSE, label.on.which.axis = 3, col.low = "lightsteelblue", col.same = "white", col.high = "lightslateblue", vertical.line = TRUE, horizontal.line = FALSE, vertical.line.lty = 1, horizontal.line.lty = 1, mar=c(3.5,3.5,3.5,3.5)) { # object check: S4 methods instead?! if (!is.data.frame(object)){ if(is.matrix(object)){ object <- as.data.frame(object) } else stop ( message = "object must be a matrix or a data.frame" ) } ind <- dim( object ) [2] name <- dimnames( object ) [[2]] # label if( is.null( label ) ) { label <- name } else if( length( label ) != ind ) { stop( message = "you must specify all the label" ) } # short label if( !is.null( shortlabel ) && length( shortlabel ) != ind ){ stop( message = "you must specify all the short label" ) } else if( is.null( shortlabel ) && label.as.shortlabel ){ shortlabel <- abbreviate( label, minlength = 2) } ################################ # Calculate bayesian p-value ################################ bayes.pvalue <- matrix( 0, ind, ind ) bayes.signif <- matrix( 0, ind, ind ) for( i in 1:ind ) { for( j in 1:ind ) { bayes.pvalue[i, j] <- .pvalue( object[ , j], object[ , i] ) } } for( i in 1:ind ) { for( j in 1:ind ) { bayes.signif[i, j] <- .is.significant( bayes.pvalue[i, j], alpha = alpha ) } } dimnames( bayes.pvalue ) <- list( label, label ) diag( bayes.signif ) <- 0 dimnames( bayes.signif ) <- list( label, label ) bayes.signif <- bayes.signif [ , ind:1] bayes.pvalue <- bayes.pvalue [ , ind:1] ################################ # Plot ################################ maxchar <- max(sapply(label, nchar)) mar.idx <- label.on.which.axis par(mar=mar) min.mar <- par('mar') if(mar.idx==3){ mar[mar.idx] <- min(min.mar[mar.idx], trunc(mar[mar.idx] + maxchar/3)) + mar[mar.idx] + 0.1 } else { mar[mar.idx] <- min(min.mar[mar.idx], trunc(mar[mar.idx] + maxchar/2)) + 0.1 } par(mar=mar) image( 1:nrow( bayes.signif ), 1:ncol( bayes.signif ), bayes.signif, ylab = "", xlab = "", yaxt = "n", xaxt = "n", col = c( col.low, col.same, col.high ) ) box( "plot" ) axis(2, at = 0, labels = "", las = 1, line = 0, tick = FALSE, xaxs = "i", yaxs = "i" ) axis(mar.idx, at = 1:nrow( bayes.signif ),line = -0.8, las = 2 , cex = 0.3, labels = label, tick = FALSE, xaxs = "i") title( main = main, line = mar[3] - 3 ) for( a in 1:ind ) { if( vertical.line ) { lines( c( a + 0.5, a + 0.5 ), c( 0, ind + 1 ), lty = vertical.line.lty ) } if( horizontal.line ) { lines( c( 0, ind + 1 ), c( a + 0.5, a + 0.5 ), lty = horizontal.line.lty ) } if( !is.null( shortlabel ) ) { for( b in 1:ind ) { if( show.pvalue ){ text( a, b, ( round( bayes.pvalue, 2 ) )[a,b], cex = 0.5 ) } else { text( a, b, shortlabel[ind+1-b], cex = 0.7 ) } } } } invisible( list( pvalue = bayes.pvalue, significant = bayes.signif ) ) } mcplot <- multicomp.plot arm/R/balance.R0000644000176200001440000002152415155406662012760 0ustar liggesusers# balance function after 2019 balance <- function (rawdata, treat, matched, estimand="ATT") #factor = TRUE) { # rawdata: the full covariate dataset # treat: the vector of treatment assignments for the full dataset # matched: vector of weights to apply to the full dataset to create the # restructured data: # --for matching without replacement these will all be 0's and 1's # --for one-to-one matching with replacement these will all be non-negative # integers # --for IPTW or more complicated matching methods these could be any # non-negative numbers # estimand: can either be ATT, ATC, or ATE #require("Hmisc") if(missing(rawdata)) stop("rawdata is required") if(missing(matched)) stop("argument matched is required") if(missing(treat)) stop("treatment vector (treat) is required") cat("Balance diagnostics assume that the estimand is the",estimand,"\n") # #raw.dat <- data.frame(rawdata, treat = treat) covnames <- colnames(rawdata) if (is.null(covnames)){ cat("No covariate names provided. Generic names will be generated.") covnames = paste("v",c(1:ncol(rawdata)),sep="") } K <- length(covnames) diff.means <- matrix(NA, K, 5) var.t <- numeric(K) var.c <- numeric(K) std.denom <- numeric(K) binary <- rep(1,K) # # First we calculate balance on the RAW DATA # Columns are (1) treat mean, (2) control mean, (3) diff in means, (4) abs std diff, # (5) ratio of sds for (i in 1:K) { # separate means by group diff.means[i, 1] <- mean(rawdata[treat==1, i]) diff.means[i, 2] <- mean(rawdata[treat==0, i]) # separate variances by group == only used as input to calculations below var.t[i] <- var(rawdata[(treat == 1), i]) var.c[i] <- var(rawdata[(treat == 0), i]) # denominator in standardized difference calculations if(estimand=="ATE"){std.denom[i] <- sqrt((var.t[i]+var.c[i])/2)} else{ std.denom[i] <- ifelse(estimand=="ATT",sqrt(var.t[i]),sqrt(var.c[i])) } # difference in means diff.means[i, 3] <- diff.means[i, 1] - diff.means[i, 2] # standardized difference in means (sign intact) diff.means[i, 4] <- abs(diff.means[i, 3]/std.denom[i]) if(length(unique(rawdata[,covnames[i]]))>2){ binary[i] = 0 } } #ifelse(estimand="ATT",sqrt(var.c[i]/var.t[i]),sqrt(var.t[i]/var.c[i])) # dimnames(diff.means) <- list(covnames[-(K + 1)], c("treat", "control", "unstd.diff", # "abs.std.diff", "ratio")) # diff.means[is.na(diff.means)] = "--" #maybe only worry about in print function dimnames(diff.means) <- list(covnames, c("treat", "control", "unstd.diff", "abs.std.diff", "ratio")) # Now we calculate balance on the restructured data diff.means.matched = matrix(NA, K, 5) # for (i in 1:K) { wts0 <- matched[treat==0] # separate means by group diff.means.matched[i, 1] <- mean(rawdata[treat == 1, i]) diff.means.matched[i, 2] <- weighted.mean(rawdata[treat==0, i],w=wts0) # separate variances by group == only used as input to calculations below # these overwrite the variance above var.t[i] <- var(rawdata[treat == 1, i]) var.c[i] <- as.numeric(stats::cov.wt(rawdata[treat == 0, i, drop = FALSE], wt = wts0)$cov) # difference in means diff.means.matched[i, 3] <- diff.means.matched[i, 1] - diff.means.matched[i, 2] # absolute standardized difference in means (denominator is stolen from # calculations on raw data above) diff.means.matched[i, 4] <- abs(diff.means.matched[i, 3])/std.denom[i] if(length(unique(rawdata[,covnames[i]]))>2){ # just for binary # ratio of sds (treat over control: should we change to comparison over inferential) diff.means.matched[i, 5] <- sqrt(var.c[i]/var.t[i]) } } #dimnames(diff.means.matched) <- list(covnames[-(K + 1)], c("treat", "control", "unstd.diff", # "abs.std.diff", "ratio")) dimnames(diff.means.matched) <- list(covnames, c("treat", "control", "unstd.diff", "abs.std.diff", "ratio")) # out <- list(diff.means.raw = diff.means, diff.means.matched = diff.means.matched, covnames = covnames, binary = binary) class(out) <- "balance" return(out) } print.balance <- function(x, ..., combined=FALSE, digits= 2) { if(combined==FALSE){ cat("Balance Statistics for Unmatched Data\n") cat("--\n") print(round(x$diff.means.raw, digits=digits)) cat("--\n") cat("\n") cat("Balance Statistics for Matched Data\n") cat("--\n") print(round(x$diff.means.matched, digits=digits), na.print="--") cat("--\n") cat("\n") } else{ cat("Balance Statistics\n") cat("--\n") print(round(cbind(x$diff.means.raw,x$diff.matched.raw)[,c(4,9,5,10)], digits=digits), na.print="--") } } ### NEXT NEED TO FIGURE OUT HOW TO REVERSE THE ORDER OF THE COVARIATES plot.balance <- function(x, longcovnames=NULL, which.covs="mixed", v.axis=TRUE, cex.main=1, cex.vars=1, cex.pts=1, mar=c(4, 3, 5.1, 2), plot=TRUE, x.max = NULL,...) { # if which.covs = mixed then it plots all as std diffs # if which.covs = binary it only plots binary and as abs unstd diffs # if which.covs = cont it only plots non-binary and as abs std diffs # covnames <- x$covnames if(!is.null(x.max)){ x.range = c(0,x.max) } # if(which.covs=="binary") { # cat("condition satisfied \n") # } # if plotting all, then use the standardized diff for all if(which.covs == "mixed"){ pts <- x$diff.means.raw[,4] # before matched.dat pts2 <- x$diff.means.matched[,4] # after matched K <- length(pts) idx <- 1:K main="Absolute Standardized Difference in Means" } #if plotting just binary use the unstandardized difference # for the plot make it the absolute value of if(which.covs == "binary"){ pts <- abs(x$diff.means.raw[x$binary==TRUE,3]) # before matched.dat pts2 <- abs(x$diff.means.matched[x$binary==TRUE,3]) # after matched K <- length(pts) idx <- 1:K main="Absolute Difference in Means" covnames = covnames[x$binary==TRUE] } #if plotting just continuous use the standardized difference if(which.covs == "cont"){ pts <- x$diff.means.raw[x$binary==FALSE,4] # before matched pts2 <- x$diff.means.matched[x$binary==FALSE,4] # after matched K <- length(pts) idx <- 1:K main="Absolute Standardized Difference in Means" covnames = covnames[x$binary==FALSE] } cat(pts,"\n") # tune the graphic console #par (mar=mar, mgp=mgp, oma=oma, tcl=tcl) par(mar = mar) if (is.null(longcovnames)) { longcovnames <- covnames maxchar <- max(sapply(longcovnames, nchar)) } else { maxchar <- max(sapply(longcovnames, nchar)) } min.mar <- par("mar") mar[2] <- max(min.mar[2], trunc(mar[2] + maxchar/10)) + mar[2] + 0.5 par(mar = mar) ## now reverse the order of everything so the plot proceeds from ## to top to bottom with respect to original ordering of variables pts = rev(pts) pts2 = rev(pts2) longcovnames = rev(longcovnames) if(plot){ # plot the estimates if(is.null(x.max)){ plot(c(pts,pts2), c(idx,idx), #xlim=c(0, max(c(pts,pts2))), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", type="n", main=main, cex.main=cex.main) } if(!is.null(x.max)){ plot(c(pts,pts2), c(idx,idx), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", type="n", xlim=x.range, main=main, cex.main=cex.main) } abline(v=0, lty=2) points(pts, idx, cex=cex.pts) # before matched points(pts2, idx, pch=19, cex=cex.pts) # after matched if (v.axis){ axis(3) } if (is.null(longcovnames)){ axis(2, at=1:K, labels=covnames[1:K], las=2, hadj=1, lty=0, cex.axis=cex.vars) } else{ axis(2, at=1:K, labels=longcovnames[1:K], las=2, hadj=1, lty=0, cex.axis=cex.vars) } } else{ plot(c(pts,pts2), c(idx,idx), bty="n", xlab="", ylab="", xaxt="n", yaxt="n", #xaxs="i", #yaxs="i", type="n", axes=FALSE, #ylim=c(max(idx)+.25, min(idx)-.25), #xlim=x.range, main="", cex.main=cex.main,...) } return(list("raw"=pts, "matched"=pts2)) } arm/R/contrasts.bayes.R0000644000176200001440000000407415155406662014516 0ustar liggesuserscontr.bayes.ordered <- function ( n, scores = 1:n, contrasts = TRUE ) { make.poly <- function( n, scores ) { y <- scores - mean( scores ) X <- outer( y, seq_len( n ) - 1, "^" ) QR <- qr( X ) z <- QR$qr z <- z *( row( z ) == col( z ) ) raw <- qr.qy( QR, z ) Z <- sweep( raw, 2, apply( raw, 2, function( x ) sqrt( sum( x^2 ) ) ), "/" ) colnames( Z ) <- paste( "^", 1:n - 1, sep="" ) Z } if ( is.numeric( n ) && length( n ) == 1 ) { levs <- 1:n } else { levs <- n n <- length( levs ) } if ( n < 2 ) { stop( gettextf( "contrasts not defined for %d degrees of freedom", n - 1 ), domain = NA ) } if ( n > 95 ) { stop( gettextf( "orthogonal polynomials cannot be represented accurately enough for %d degrees of freedom", n-1 ), domain = NA ) } if ( length( scores ) != n ) { stop( "'scores' argument is of the wrong length" ) } if ( !is.numeric( scores ) || any( duplicated( scores ) ) ) { stop("'scores' must all be different numbers") } contr <- make.poly( n, scores ) if ( contrasts ) { dn <- colnames( contr ) dn[2:min( 4, n )] <- c( ".L", ".Q", ".C" )[1:min( 3, n-1 )] colnames( contr ) <- dn contr[, , drop = FALSE] } else { contr[, 1] <- 1 contr } } contr.bayes.unordered <- function(n, base = 1, contrasts = TRUE) { if( is.numeric( n ) && length( n ) == 1) { if( n > 1 ) { levs <- 1:n } else stop( "not enough degrees of freedom to define contrasts" ) } else { levs <- n n <- length( n ) } contr <- array( 0, c(n, n), list( levs, levs ) ) diag( contr ) <- 1 if( contrasts ) { if( n < 2 ) { stop( gettextf( "contrasts not defined for %d degrees of freedom", n - 1 ), domain = NA ) } if( base < 1 | base > n ){ stop( "baseline group number out of range" ) } contr <- contr[, , drop = FALSE] } contr } arm/R/standardize.R0000644000176200001440000001066015167674042013704 0ustar liggesusersstandardize.default <- function(call, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") { form <- eval(call$formula, envir = parent.frame()) 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] # Retrieve the data if (is.null(call$data)) { thedata <- get(v) } else { thedata <- get(as.character(call$data))[[v]] } # Check if thedata is valid if (is.function(thedata)) { stop(paste("Error: The object", v, "is a function, not a data vector.")) } if (is.null(thedata) || (!is.numeric(thedata) && !is.factor(thedata))) { stop(paste("Error: The object", v, "must be either numeric or a factor.")) } if (is.na(match(v, unchanged))) { num.categories <- length(unique(thedata[!is.na(thedata)])) if (num.categories == 2) { transform[i] <- binary.inputs # Handle binary inputs } else if (num.categories > 2 & is.numeric(thedata)) { transform[i] <- "full" # Treat numeric with more than 2 categories as standard } } } # New variable names: prefix with "c." if centered or "z." if 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) { new_var <- rescale(get(as.character(call$data))[[varnames[i]]], binary.inputs) assign(varnames.new[i], new_var) # Assign to global environment newvars <- cbind(newvars, new_var) # Combine new variables for output } 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 # For merMod, use @ instead of $ out <- standardize.default(call = call, unchanged = unchanged, standardize.y = standardize.y, binary.inputs = binary.inputs) return(out) } ) arm/R/bayesglm.h.R0000644000176200001440000006312115155406662013423 0ustar liggesusers## Aug 11, 2007 ## 1. model.matrix.bayes, terms.bayes, contr.bayes.unordered ## & contr.bayes.ordered are in "arm" now. ## 2. bayesglm.h now uses model.matrix.bayes2 in "arm". # #bayesglm.h <- function ( formula, family = gaussian, data, weights, subset, # na.action, start = NULL, etastart, mustart, offset, control = glm.control(...), # model = TRUE, method = "glm.fit", x = FALSE, y = TRUE, contrasts = NULL, # prior.mean = 0, prior.scale = 2.5, prior.df = 1, scaled = TRUE, # prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = 1, # batch=0, batch.mean=NA, batch.sd=NA, # batch.mean.mean=0, batch.mean.scale=prior.scale.for.intercept, batch.mean.df=prior.df, # batch.sd.scale=2.5, batch.sd.df=1, # n.iter = 100, drop.baseline = FALSE, separete.intercept = TRUE, # keep.order=TRUE, batch.mean.known=FALSE, ... ) #{ # call <- match.call() # if (is.character(family)) # family <- get(family, mode = "function", envir = parent.frame()) # if (is.function(family)) # family <- family() # if (is.null(family$family)) { # print(family) # stop("'family' not recognized") # } # if (missing(data)) # data <- environment(formula) # mf <- match.call(expand.dots = FALSE) # m <- match(c("formula", "data", "subset", "weights", "na.action", "etastart", "mustart", "offset"), names(mf), 0) # mf <- mf[c(1, m)] # mf$drop.unused.levels <- TRUE # mf[[1]] <- as.name("model.frame") # mf <- eval(mf, parent.frame()) # switch(method, model.frame = return(mf), glm.fit = 1, stop("invalid 'method': ", method)) # mt <- attr(mf, "terms") # Y <- model.response(mf, "any") # if (length(dim(Y)) == 1) { # nm <- rownames(Y) # dim(Y) <- NULL # if (!is.null(nm)) # names(Y) <- nm # } # if (!drop.baseline){ # X <- if (!is.empty.model(mt)){ # #class(mt) <- c("bayesglm.h", "terms", "formula") # model.matrix.bayes.h( mt, mf, contrasts, keep.order=keep.order, batch=batch ) # } # else matrix(, NROW(Y), 0) # } # else { # X <- if (!is.empty.model(mt)) # model.matrix( mt, mf, contrasts ) # else matrix(, NROW(Y), 0) # } ## if ( length( batch ) == 1 ) { batch <- rep ( batch, ncol( X ) ) } # intercept <- (attr(mt, "intercept") > 0) # if( intercept && length(batch)==1 ){ # batch <- c(0,rep (batch, ncol( X )-1)) # } # else if (length(batch)==1 ) { # batch <- rep (batch, ncol( X )) # } # else if ( length( batch ) > 1 ) { # if( length( batch ) != (length(attr(mt,"term.labels") ))) { # stop( "batch is ether all 0 or must be specified for each of the variables." ) # } # else { # assignVec <- attr( X, "assign" ) # tb <- if ( intercept ) { 0 } else { NULL } # for( bi in 1:length( batch ) ){ # tb<-c( tb,rep( batch[bi], sum( assignVec == bi ) ) ) # } # batch <- tb # } # } # # weights <- model.weights(mf) # offset <- model.offset(mf) # if (!is.null(weights) && any(weights < 0)) # stop("negative weights not allowed") # if (!is.null(offset) && length(offset) != NROW(Y)) # stop(gettextf("number of offsets is %d should equal %d (number of observations)", length(offset), NROW(Y)), domain = NA) # mustart <- model.extract(mf, "mustart") # etastart <- model.extract(mf, "etastart") # # fit <- bayesglm.hierarchical.fit(x = X, y = Y, weights = weights, start = start, # etastart = etastart, mustart = mustart, offset = offset, # family = family, control = glm.control( maxit = n.iter ), # intercept = intercept, prior.mean = prior.mean, # prior.scale = prior.scale, # prior.mean.for.intercept = prior.mean.for.intercept, # prior.scale.for.intercept = prior.scale.for.intercept, # prior.df.for.intercept = prior.df.for.intercept, # prior.df = prior.df, batch = batch, batch.mean=batch.mean, batch.sd = batch.sd, # batch.mean.mean = batch.mean.mean, batch.mean.scale = batch.mean.scale, batch.mean.df = batch.mean.df, # batch.sd.scale = batch.sd.scale, batch.sd.df = batch.sd.df, scaled = scaled ,drop.baseline=drop.baseline, # batch.mean.known = batch.mean.known ) # if (any(offset) && attr(mt, "intercept") > 0) { # cat("bayesglm not yet set up to do deviance comparion here\n") # fit$null.deviance <- bayesglm.hierarchical.fit(x = X[, "(Intercept)", drop = FALSE], # y = Y, weights = weights, offset = offset, family = family, # control = control, intercept = intercept, prior.mean = prior.mean, prior.scale = prior.scale, # prior.mean.for.intercept = prior.mean.for.intercept, # prior.scale.for.intercept = prior.scale.for.intercept, # prior.df.for.intercept = prior.df.for.intercept, # prior.df = prior.df, batch = batch, batch.mean = batch.mean, batch.sd = batch.sd, # batch.mean.mean = batch.mean.mean, batch.mean.scale = batch.mean.scale, batch.mean.df = batch.mean.df, # batch.sd.scale = batch.sd.scale, batch.sd.df = batch.sd.df, scaled = scaled,drop.baseline=drop.baseline, # batch.mean.known = batch.mean.known )$deviance # } # if (model) # fit$model <- mf # fit$na.action <- attr(mf, "na.action") # if (x) # fit$x <- X # if (!y) # fit$y <- NULL # fit <- c(fit, list(call = call, formula = formula, terms = mt, # data = data, offset = offset, control = control, method = method, # contrasts = attr(X, "contrasts"), xlevels = .getXlevels(mt, mf))) # class(fit) <- c("bayesglm.h","glm", "lm") # fit #} # # #bayesglm.hierarchical.fit <- #function (x, y, weights = rep(1, nobs), start = NULL, etastart = NULL, # mustart = NULL, offset = rep(0, nobs), family = gaussian(), # control = glm.control(), prior.mean = 0, prior.scale = 2.5, prior.df = 1, # intercept = TRUE, # prior.mean.for.intercept = 0, prior.scale.for.intercept = 10, prior.df.for.intercept = prior.df, # batch=0, batch.mean=NA, batch.sd=NA, # batch.mean.mean=0, batch.mean.scale=2.5, batch.mean.df=1, # batch.sd.scale=2.5, batch.sd.df=1, scaled = TRUE, drop.baseline = FALSE, batch.mean.known = TRUE ) #{ # J <- NCOL(x) # if(intercept && length(batch)==1 ){ # batch <- c(0,rep (batch, J-1)) # } # else if (length(batch)==1 ) { # batch <- rep (batch, J) # } # J.0 <- sum (batch==0) # if (J.0 > 0) { # if (length(prior.mean) == 1) { # prior.mean <- rep(prior.mean, J.0) # if(intercept){ # prior.mean[1] <- prior.mean.for.intercept # } # } # else if (length(prior.mean) > 1) { # if( length( prior.mean ) + intercept != J.0 ){ # stop(message="You must specify the prior.mean for each of the variables") # } # } # if (length(prior.scale) == 1) { # prior.scale <- rep(prior.scale, J.0) # if(intercept){ # prior.scale[1] <- prior.scale.for.intercept # } # } # else if (length(prior.scale) > 1) { # if( length( prior.scale ) + intercept != J.0 ){ # stop(message="You must specify the prior.scale for each of the variables") # } # } # if (scaled == TRUE) { # y.scale <- 1 # if (family$family == "gaussian") { # y.obs <- y[!is.na(y)] # num.categories <- length(unique(y.obs)) # if (num.categories == 2) { # y.scale <- max(y.obs) - min(y.obs) # } # else if (num.categories > 2) { # y.scale <- 2 * sd(y.obs) # } # } # for (j in 1:J.0) { # x.obs <- x[,(1:J)[batch==0][j]] # x.obs <- x.obs[!is.na(x.obs)] # num.categories <- length(unique(x.obs)) # x.scale <- 1 # if (num.categories == 2) { # x.scale <- max(x.obs) - min(x.obs) # } # else if (num.categories > 2) { # x.scale <- 2 * sd(x.obs) # } # prior.scale[j] <- prior.scale[j] * y.scale/x.scale # } # if (is.numeric(prior.scale.for.intercept) & intercept) { # prior.scale[1] <- prior.scale.for.intercept * y.scale # } # } # if (length(prior.df) == 1) { # prior.df <- rep(prior.df, J.0) # } # #### Added by Masanao Yajima 8/30 # if (intercept){ # prior.df[1] <- prior.df.for.intercept # } # } # K <- max (batch) # if (K > 0){ # if ( length( batch.mean ) == 1 ) { batch.means <- rep( batch.mean, K ) } # if ( length( batch.sd ) == 1 ) { batch.sds <- rep( batch.sd, K ) } # if ( length( batch.mean.mean ) == 1 ) { batch.mean.mean <- rep( batch.mean.mean, K ) } # if ( length( batch.mean.scale ) == 1 ) { batch.mean.scale <- rep( batch.mean.scale, K ) } # if ( length( batch.mean.df ) == 1 ) { batch.mean.df <- rep( batch.mean.df, K ) } # if ( length( batch.sd.scale ) == 1 ) { batch.sd.scale <- rep( batch.sd.scale, K ) } # if ( length( batch.sd.df ) == 1 ) { batch.sd.df <- rep( batch.sd.df, K ) } # } # x <- as.matrix( x ) # xnames <- dimnames( x )[[2]] # ynames <- if (is.matrix( y ) ) { rownames( y ) } else { names( y ) } # conv <- FALSE # nobs <- NROW( y ) # nvars <- ncol(x) # EMPTY <- nvars == 0 # if ( is.null( weights ) ){ weights<- rep.int( 1, nobs ) } # if ( is.null( offset ) ) { offset <- rep.int( 0, nobs ) } # variance <- family$variance # dev.resids <- family$dev.resids # aic <- family$aic # linkinv <- family$linkinv # mu.eta <- family$mu.eta # if ( !is.function( variance ) || !is.function( linkinv ) ) { stop( "'family' argument seems not to be a valid family object" ) } # valideta <- family$valideta # if ( is.null(valideta)){ valideta <- function( eta ) TRUE } # validmu <- family$validmu # if ( is.null( validmu ) ) { validmu <- function( mu ) TRUE } # if ( is.null( mustart ) ) { eval( family$initialize ) } # else { # mukeep <- mustart # eval( family$initialize ) # mustart <- mukeep # } # if (EMPTY) { # eta <- rep.int( 0, nobs ) + offset # if ( !valideta( eta ) ) { stop( "invalid linear predictor values in empty model" ) } # mu <- linkinv( eta ) # if ( !validmu( mu ) ) { stop( "invalid fitted means in empty model" ) } # dev <- sum( dev.resids( y, mu, weights ) ) # w <- ( ( weights * mu.eta( eta )^2 )/variance( mu ) )^0.5 # residuals <- ( y - mu )/mu.eta( eta ) # good <- rep( TRUE, length( residuals ) ) # boundary <- conv <- TRUE # coef <- numeric( 0 ) # iter <- 0 # } # else { # coefold <- NULL # eta <- if (!is.null(etastart)) { etastart } # else if ( !is.null( start ) ) { # if ( length( start ) != nvars ) { # stop( gettextf( "length of 'start' should equal %d and correspond to initial coefs for %s", # nvars, paste( deparse( xnames ), collapse = ", " ) ), domain = NA ) # } # else { # coefold <- start # offset + as.vector( if ( NCOL( x ) == 1) { x * start } else { crossprod( x, start ) }) # #offset + as.vector( if (NCOL(x) == 1) { x * start } else { x %*% start }) # } # } # else {family$linkfun(mustart)} # mu <- linkinv( eta ) # if ( !( validmu( mu ) && valideta( eta ) ) ) # stop( "cannot find valid starting values: please specify some" ) # devold <- sum( dev.resids(y, mu, weights ) ) # boundary <- conv <- FALSE ## prior.sd <- prior.scale # dispersion <- 1 # dispersionold <- dispersion # # Define s's and initialize sigma's # mu.0 <- prior.mean # s.0 <- prior.scale # nu.0 <- prior.df # sigma.0 <- s.0 # # Count the number of batches and record where mu.batch_k and sigma.batch_k are unknown # sigma.batch <- NULL # sigma.mu.batch <- NULL # if ( K > 0 ) { # batch.mean.unknown <- is.na( batch.mean ) # batch.sd.unknown <- is.na( batch.sd ) # # Create the W matrix # J.plus <- sum( batch > 0 ) # W <- array( 0, c( J, K ) ) # for ( k in 1:K ){ # W[batch == k, k] <- 1 # } # W.plus <- W[batch>0, ] # J.batch <- colSums( W ) # s.batch <- batch.sd.scale # nu.batch <- batch.sd.df # sigma.batch <- s.batch # mu.mu.batch <- batch.mean.mean # s.mu.batch <- batch.mean.scale # sigma.mu.batch <- s.mu.batch # nu.mu.batch <- ifelse( batch.mean.df == Inf, batch.mean.scale, batch.mean.df ) # # Prepare the subtotals for the batches with unknown means # x.plus <- x[ ,batch > 0] # #x.star <- rbind( cbind( x, x.plus %*% W.plus ), diag( J+K ) ) # x.star <- rbind( cbind( x, tcrossprod( x.plus,t( W.plus ) ) ), diag( J+K ) ) # if ( intercept ) { x.star[NROW( x )+1, 1:J] <- colMeans( x ) } # 17 Dec # dimnames( x.star )[[2]] <- c ( dimnames( x )[[2]], paste( "mu.batch.", 1:K, sep="" ) ) # xnames <- dimnames(x.star)[[2]] # } # else { # if K==0 # x.star <- as.matrix( rbind( x, diag( J ) ) ) # } # nvars.star <- ncol(x.star) ## Loop ####### # for ( iter in 1:control$maxit ) { # good <- weights > 0 # varmu <- variance( mu )[good] # if ( any( is.na( varmu ) ) ) { stop( "NAs in V( mu )") } # if ( any( varmu == 0 ) ) { stop( "0s in V( mu )" ) } # mu.eta.val <- mu.eta( eta ) # if ( any( is.na( mu.eta.val[good] ) ) ) { stop( "NAs in d( mu )/d( eta )" ) } # good <- ( weights > 0 ) & ( mu.eta.val != 0 ) # if ( all( !good ) ) { # conv <- FALSE # warning( "no observations informative at iteration ", iter ) # break # } # z <- ( eta - offset )[good] + ( y - mu )[good] / mu.eta.val[good] # w <- sqrt( ( weights[good] * mu.eta.val[good]^2 ) / variance( mu )[good]) # ngoodobs <- as.integer( nobs - sum( !good ) ) # # This is where we augment the data with the prior information # if ( K > 0 ){ # # Added by Masanao Yajima 2007/07/31 # # when there is batch 0 then # if (min(batch)==0){ # z.star <- c( z, mu.0, rep( 0, J.plus ), mu.mu.batch ) # w.star <- c( w, sqrt( dispersion )*c( 1/sigma.0, 1/sigma.batch[batch[batch>0]], 1/sigma.mu.batch ) ) # ngoodobs.star <- ngoodobs + NCOL( x ) + NCOL( W.plus ) # } # # when there is no batch 0 then # else{ # z.star <- c( z, rep( 0, J.plus ), mu.mu.batch ) # w.star <- c( w, sqrt( dispersion ) * c( 1/sigma.batch[batch[batch>0]], 1/sigma.mu.batch ) ) # ngoodobs.star <- ngoodobs + NCOL( x ) + NCOL( W.plus ) # } # } # else { # z.star <- c( z, mu.0 ) # w.star <- c( w, sqrt( dispersion )/sigma.0 ) # ngoodobs.star <- ngoodobs + NCOL( x ) # } # good.star <- c(good, rep( TRUE, J + K ) ) # nvars <- NCOL( x.star ) # if ( intercept ) { # x.star[NROW( x ) + 1, 1:NCOL( x )] <- colMeans(x) # } # fit <- .Fortran( "dqrls", qr = x.star[good.star, ] * w.star, n = ngoodobs.star, # p = nvars, y = w.star * z.star, ny = as.integer( 1 ), tol = min(1e-07, control$epsilon/1000 ), # coefficients = double( nvars ), residuals = double( ngoodobs.star ), effects = double( ngoodobs.star ), # rank = integer( 1 ), pivot = 1:nvars, qraux = double( nvars ), work = double( 2 * nvars ), PACKAGE = "base" ) # if ( any( !is.finite( fit$coefficients ) ) ) { # conv <- FALSE # warning( "non-finite coefficients at iteration ", iter ) # break # } # # coefs.hat <- fit$coefficients # V.coefs <- chol2inv( as.matrix(fit$qr)[1:ncol( x.star ), 1:ncol( x.star ), drop = FALSE] ) # # Now update the prior scale # # Allocate the coefficients to beta.0, alpha, mu.batch # beta.0.index <- 1:J.0 # beta.0.hat <- coefs.hat[beta.0.index] # V.beta.0 <- diag(V.coefs)[beta.0.index] # # Now update the sigma_j's in batch 0 # sigma.0 <- ifelse ( nu.0 == Inf, s.0, sqrt( ( ( beta.0.hat - mu.0 )^2 + V.beta.0 + nu.0 * s.0^2 )/( 1 + nu.0 ) ) ) # if ( K > 0 ) { # alpha.index <- ( J.0 + 1 ):J # mu.batch.index <- ( J + 1 ):( J + K ) # alpha.hat <- coefs.hat[alpha.index] # mu.batch.hat <- coefs.hat[mu.batch.index] # V.alpha <- diag( V.coefs )[alpha.index] *dispersion #### # V.mu.batch <- diag( V.coefs )[mu.batch.index]*dispersion #### # # Now estimate the sigma.batch_k's where unknown # sigma.batch <- if( batch.sd.unknown ) { # #sqrt( ( t( W.plus ) %*% ( alpha.hat^2 + V.alpha ) + nu.batch * s.batch^2 )/( J.batch + nu.batch ) ) # sqrt( ( crossprod(W.plus,( alpha.hat^2 + V.alpha ) ) + nu.batch * s.batch^2 )/( J.batch + nu.batch ) ) # } # else{ sigma.batch } # # # # Now estimate the sigma.mu.batch_k's where mu.batch_k's are unknown # sigma.mu.batch <- if ( batch.mean.unknown ) { # sqrt( ( ( mu.batch.hat - mu.mu.batch )^2 + V.mu.batch + nu.mu.batch * s.mu.batch^2 )/( 1 + nu.mu.batch ) ) # } # else{ sigma.mu.batch} # # } # start[fit$pivot] <- fit$coefficients # #eta <- drop( as.matrix(x.star[1:nrow( x ), ]) %*% start ) # eta <- drop( tcrossprod( t(start), as.matrix(x.star[1:nrow( x ), ]) ) ) # #eta <- drop(x %*% start) # mu <- linkinv( eta <- eta + offset ) # dev <- sum( dev.resids( y, mu, weights ) ) # if ( !( family$family %in% c( "poisson", "binomial" ) ) ) { # #mse.resid <- mean((w * (z - x %*% coefs.hat))^2) # #mse.resid <- mean((w * (z - as.matrix(x.star[1:nrow(x),]) %*% coefs.hat))^2) # mse.resid <- mean( ( w * ( z - tcrossprod( as.matrix( x.star[1:nrow(x),] ),t( coefs.hat ) ) ) )^2 ) # #mse.uncertainty <- mean(diag(x %*% V.coefs %*% t(x))) * dispersion # #mse.uncertainty <- mean( rowSums( ( x.star[1:nrow(x),] %*% V.coefs ) * x.star[1:nrow(x),] ) ) * dispersion # mse.uncertainty <- mean( rowSums( tcrossprod( x.star[1:nrow(x),], V.coefs ) * x.star[1:nrow(x),] ) ) * dispersion # dispersion <- mse.resid + mse.uncertainty # } # if ( control$trace ) { cat("Deviance =", dev, "Iterations -", iter, "\n") } # boundary <- FALSE # if ( !is.finite( dev ) ) { # if ( is.null( coefold ) ) { # stop( "no valid set of coefficients has been found: please supply starting values", call. = FALSE ) # } # warning( "step size truncated due to divergence", call. = FALSE ) # ii <- 1 # while ( !is.finite( dev ) ) { # if ( ii > control$maxit ) { stop( "inner loop 1; cannot correct step size" ) } # ii <- ii + 1 # start <- ( start + coefold )/2 # #eta <- drop( x %*% start ) # eta <- drop( crossprod( x, start) ) # mu <- linkinv( eta <- eta + offset ) # dev <- sum( dev.resids( y, mu, weights ) ) # } # boundary <- TRUE # if ( control$trace ){ cat( "Step halved: new deviance =", dev, "\n" ) } # } # if ( !( valideta( eta ) && validmu( mu ) ) ) { # if ( is.null( coefold ) ) { # stop("no valid set of coefficients has been found: please supply starting values", call. = FALSE) # } # warning("step size truncated: out of bounds", call. = FALSE) # ii <- 1 # while ( !(valideta( eta ) && validmu( mu ) ) ) { # if ( ii > control$maxit ) { # stop("inner loop 2; cannot correct step size") # } # ii <- ii + 1 # start <- ( start + coefold )/2 # #eta <- drop( x %*% start ) # eta <- drop( crossprod(x, start ) ) # mu <- linkinv( eta <- eta + offset ) # } # boundary <- TRUE # dev <- sum( dev.resids( y, mu, weights ) ) # if ( control$trace ) { cat( "Step halved: new deviance =", dev, "\n" ) } # } # # Convergence Check # if (iter > 1 & abs( dev - devold )/( 0.1 + abs( dev ) ) < control$epsilon # & abs( dispersion - dispersionold)/( 0.1 + abs( dispersion ) ) < control$epsilon ) { # conv <- TRUE # coef <- start # break # } # else { # devold <- dev # dispersionold <- dispersion # coef <- coefold <- start # } # # } ## End of Loop ####### # if ( !conv ) { warning( "algorithm did not converge" ) } # if ( boundary ) { warning( "algorithm stopped at boundary value" ) } # eps <- 10 * .Machine$double.eps # if ( family$family == "binomial" ) { # if ( any( mu > 1 - eps ) || any( mu < eps ) ) { warning( "fitted probabilities numerically 0 or 1 occurred" ) } # } # if ( family$family == "poisson" ) { # if ( any(mu < eps ) ) { warning( "fitted rates numerically 0 occurred" ) } # } # if( drop.baseline==TRUE ){ # if ( fit$rank < nvars ) { # coef[fit$pivot][seq( fit$rank + 1, nvars )] <- NA # } # } # xxnames <- xnames[fit$pivot] # residuals <- rep.int( NA, nobs ) # residuals[good] <- z - ( eta - offset )[good] # fit$qr <- as.matrix( fit$qr ) # nr <- min( sum( good ), nvars ) # if ( nr < nvars ) { # Rmat <- diag( nvars ) # Rmat[1:nr, 1:nvars] <- fit$qr[1:nr, 1:nvars] # } # else { # Rmat <- fit$qr[1:nvars, 1:nvars] # } # Rmat <- as.matrix( Rmat ) # Rmat[ row( Rmat ) > col( Rmat ) ] <- 0 # names( coef ) <- xnames # colnames( fit$qr ) <- xxnames # dimnames( Rmat ) <- list( xxnames, xxnames ) # } # names( residuals ) <- ynames # names( mu ) <- ynames # names( eta ) <- ynames # wt <- rep.int(0, nobs) # wt[good] <- w^2 # names( wt ) <- ynames # names( weights ) <- ynames # names( y ) <- ynames # wtdmu <- if ( intercept ) { sum( weights * y )/sum( weights )} else linkinv( offset ) # nulldev <- sum( dev.resids( y, wtdmu, weights ) ) # n.ok <- nobs - sum( weights == 0 ) # nulldf <- n.ok - as.integer( intercept ) # rank <- if ( EMPTY ) { 0 } else { fit$rank } # resdf <- n.ok - rank # aic.model <- aic(y, n, mu, weights, dev) + 2 * rank # list( coefficients = coef, residuals = residuals, fitted.values = mu, # effects = if ( !EMPTY ) fit$effects, R = if ( !EMPTY ) Rmat, rank = rank, # qr = if ( !EMPTY ) structure(fit[c( "qr", "rank", "qraux", "pivot", "tol" )], class = "qr" ), # family = family, linear.predictors = eta, deviance = dev, aic = aic.model, # null.deviance = nulldev, iter = iter, weights = wt, prior.weights = weights, # df.residual = resdf, df.null = nulldf, y = y, converged = conv, boundary = boundary, # prior.mean = prior.mean, prior.scale = prior.scale, # prior.df = prior.df, prior.sd = sigma.0, dispersion = dispersion, # batch=batch, batch.mean=batch.mean, batch.sd=batch.sd, # batch.mean.mean=batch.mean.mean, batch.mean.scale=batch.mean.scale, batch.mean.df =batch.mean.df, # batch.sd.scale=batch.sd.scale, batch.sd.df=batch.sd.df, # sigma.0=sigma.0, sigma.batch=sigma.batch, sigma.mu.batch=sigma.mu.batch ) #} # #setMethod("print", signature(x = "bayesglm.h"), # function(x, digits=2) display(object=x, digits=2)) #setMethod("show", signature(object = "bayesglm.h"), # function(object) display(object, digits=2)) arm/R/sim.R0000644000176200001440000002422515155425157012164 0ustar liggesuserssetMethod("sim", signature(object = "lm"), function(object, n.sims=100) { object.class <- class(object)[[1]] summ <- summary (object) coef <- summ$coef[,1:2,drop=FALSE] dimnames(coef)[[2]] <- c("coef.est","coef.sd") sigma.hat <- summ$sigma beta.hat <- coef[,1,drop = FALSE] V.beta <- summ$cov.unscaled n <- summ$df[1] + summ$df[2] k <- summ$df[1] sigma <- rep (NA, n.sims) beta <- array (NA, c(n.sims,k)) dimnames(beta) <- list (NULL, rownames(beta.hat)) for (s in 1:n.sims){ sigma[s] <- sigma.hat*sqrt((n-k)/rchisq(1,n-k)) beta[s,] <- MASS::mvrnorm (1, beta.hat, V.beta*sigma[s]^2) } ans <- new("sim", coef = beta, sigma = sigma) return (ans) } ) setMethod("sim", signature(object = "glm"), function(object, n.sims=100) { object.class <- class(object)[[1]] summ <- summary (object, correlation=TRUE, dispersion = object$dispersion) coef <- summ$coef[,1:2,drop=FALSE] dimnames(coef)[[2]] <- c("coef.est","coef.sd") beta.hat <- coef[,1,drop=FALSE] sd.beta <- coef[,2,drop=FALSE] corr.beta <- summ$corr n <- summ$df[1] + summ$df[2] k <- summ$df[1] V.beta <- corr.beta * array(sd.beta,c(k,k)) * t(array(sd.beta,c(k,k))) #beta <- array (NA, c(n.sims,k)) # dimnames(beta) <- list (NULL, dimnames(beta.hat)[[1]]) # for (s in 1:n.sims){ # beta[s,] <- MASS::mvrnorm (1, beta.hat, V.beta) # } beta <- MASS::mvrnorm (n.sims, beta.hat, V.beta) # Added by Masanao beta2 <- array (0, c(n.sims,length(coefficients(object)))) dimnames(beta2) <- list (NULL, names(coefficients(object))) beta2[,dimnames(beta2)[[2]]%in%dimnames(beta)[[2]]] <- beta # Added by Masanao sigma <- rep (sqrt(summ$dispersion), n.sims) ans <- new("sim", coef = beta2, sigma = sigma) return(ans) } ) setMethod("sim", signature(object = "polr"), function(object, n.sims = 100) { if (!requireNamespace("MASS", quietly = TRUE)) { stop("Package 'MASS' is required for this function. Please install it.") } # Extract coefficients and thresholds coefs <- coef(object) zeta <- object$zeta # Number of regression coefficients k <- length(coefs) # Variance-covariance matrix of all parameters (coefficients + thresholds) Sigma <- vcov(object) # Draw parameters from multivariate normal distribution parameters <- MASS::mvrnorm(n = n.sims, mu = c(coefs, zeta), Sigma = Sigma) # If only one simulation, ensure 'parameters' has dimension (1, nparams) if (n.sims == 1) { parameters <- matrix(parameters, nrow = 1) } # Create new "sim.polr" object with coefficients and thresholds separated ans <- new("sim.polr", coef = parameters[, 1:k, drop = FALSE], zeta = parameters[, (k + 1):ncol(parameters), drop = FALSE] ) return(ans) } ) sim.coxph <- function(object, n.sims = 100) { if (!requireNamespace("MASS", quietly = TRUE)) { stop("Package 'MASS' needed for this function to work. Please install it.") } # Check object class if (!inherits(object, "coxph")) { stop("Input object is not a coxph model.") } # Extract coef estimates beta.hat <- coef(object) if (is.null(beta.hat)) stop("Could not extract coefficients from the coxph object.") # Extract variance-covariance matrix of coefficient estimates V.beta <- tryCatch(vcov(object), error = function(e) stop("Could not extract variance-covariance matrix from coxph object.")) k <- length(beta.hat) beta.sim <- matrix(NA, nrow = n.sims, ncol = k) colnames(beta.sim) <- names(beta.hat) for (i in seq_len(n.sims)) { beta.sim[i, ] <- MASS::mvrnorm(1, mu = beta.hat, Sigma = V.beta) } # For consistency with sim.plm, return a list of simulated coefs ans <- list(coef = beta.sim) class(ans) <- "sim.coxph" return(ans) } sim.plm <- function(object, n.sims = 100) { # Load required package if (!requireNamespace("MASS", quietly = TRUE)) { stop("Package 'MASS' needed for this function to work. Please install it.") } # Extract model frame (data used in the fitted model) mf <- tryCatch(model.frame(object), error = function(e) stop("Cannot extract model frame from the object.")) # Extract coefficients and their standard errors summ <- tryCatch(summary(object), error = function(e) stop("Cannot compute summary for the model object.")) # Try to get coefficients table reliably coefmat <- tryCatch( { # Most models have coef matrix under summ$coefficients or summ$coef if (!is.null(summ$coefficients)) { summ$coefficients[, 1:2, drop = FALSE] } else if (!is.null(summ$coef)) { summ$coef[, 1:2, drop = FALSE] } else { stop("Coefficient matrix not found in summary(object).") } }, error = function(e) stop("Error extracting coefficient matrix from summary: ", e$message) ) dimnames(coefmat)[[2]] <- c("coef.est", "coef.sd") # Number of observations (rows) and parameters n <- nrow(mf) k <- nrow(coefmat) # Estimate residual standard deviation # Use deviance or residual variance if available, otherwise fallback sigma.hat <- tryCatch({ dev <- deviance(object) if(is.null(dev)) stop("deviance() returned NULL") sqrt(dev / (n - k)) }, error = function(e) { # fallback: try sigma method if("sigma" %in% methods(class = class(object))) { sigma(object) } else { # fallback: use residuals to estimate sigma res <- residuals(object) if (is.null(res)) stop("Cannot estimate residual standard deviation") sqrt(sum(res^2) / (n - k)) } }) # Unscale covariance matrix of coefficients if necessary # Sometimes vcov(object) already includes sigma^2, so unscale it: Vbeta_raw <- tryCatch(vcov(object), error = function(e) stop("Failed to get vcov of the object")) # Check if Vbeta_raw is scaled by sigma.hat^2 (heuristic) # If max diagonal is more than 100 times sigma.hat^2, probably not scaled diag_vcov <- diag(Vbeta_raw) if(all(diag_vcov > 0) && max(diag_vcov) > 100 * sigma.hat^2) { # Assume vcov returns unscaled covariance of coefficients: multiply by sigma^2 V.beta <- Vbeta_raw * sigma.hat^2 } else { # Assume vcov gives scaled covariance (multiplied by sigma^2), so unscale it V.beta <- Vbeta_raw } # Preallocate outputs sigma <- numeric(n.sims) beta <- matrix(NA, nrow = n.sims, ncol = k) colnames(beta) <- rownames(coefmat) for (s in seq_len(n.sims)) { # Draw sigma from scaled inverse-chi-squared distribution sigma[s] <- sigma.hat * sqrt( (n - k) / rchisq(1, df = n - k) ) # Draw beta conditional on sigma beta[s, ] <- MASS::mvrnorm(1, mu = coefmat[, "coef.est"], Sigma = V.beta * sigma[s]^2) } ans <- list(coef = beta, sigma = sigma) class(ans) <- "sim" 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/binnedplot.R0000644000176200001440000000467415155406662013540 0ustar liggesusers# ==================================================================== # Functions for plotting the binned residuals # ==================================================================== binnedplot <- function(x, y, nclass=NULL, xlab="Expected Values", ylab="Average residual", main="Binned residual plot", cex.pts=0.8, col.pts=1, col.int="gray", ...) { n <- length(x) if (is.null(nclass)){ if (n >= 100){ nclass=floor(sqrt(length(x))) } if (n > 10 & n < 100){ nclass=10 } if (n <=10){ nclass=floor(n/2) } } aa <- data.frame(binned.resids (x, y, nclass)$binned) plot(range(aa$xbar), range(aa$ybar, aa$X2se, -aa$X2se, na.rm=TRUE), xlab=xlab, ylab=ylab, type="n", main=main, ...) abline (0,0, lty=2) lines (aa$xbar, aa$X2se, col=col.int) lines (aa$xbar, -aa$X2se, col=col.int) points (aa$xbar, aa$ybar, pch=19, cex=cex.pts, col=col.pts) } binned.resids <- function (x, y, nclass=floor(sqrt(length(x)))){ breaks.index <- floor(length(x)*(1:(nclass-1))/nclass) if(any(breaks.index==0)) nclass <- 1 x.sort <- sort(x) breaks <- -Inf if(nclass > 1){ for (i in 1:(nclass-1)){ x.lo <- x.sort[breaks.index[i]] x.hi <- x.sort[breaks.index[i]+1] if (x.lo==x.hi){ if (x.lo==min(x)){ x.lo <- -Inf } else { x.lo <- max (x[x 1) sd(y[items]) else 0 output <- rbind (output, c(xbar, ybar, n, x.range, 2*sdev/sqrt(n))) } colnames (output) <- c("xbar", "ybar", "n", "x.lo", "x.hi", "2se") #output <- output[output[,"sdev"] != 0,] return (list (binned=output, xbreaks=xbreaks)) } arm/R/rescale.R0000644000176200001440000000222215157645456013013 0ustar liggesusersrescale <- function(x, binary.inputs = "center") { # Convert x to numeric if its not already if (!is.numeric(x)) { # Store the original levels for categorical variables levels_x <- levels(factor(x)) x <- as.numeric(factor(x)) # Handle binary factors by mapping levels to 0 and 1 if (length(levels_x) == 2) { x <- x - 1 # Maps two levels to 0 and 1 } } x.obs <- x[!is.na(x)] if (length(unique(x.obs)) == 2) { # For binary factors if (binary.inputs == "0/1") { x <- (x-min(x.obs))/(max(x.obs)-min(x.obs)) return(x) # Return original scale } else if (binary.inputs == "-0.5,0.5") { return(x - 0.5) # Rescale to [-0.5, 0.5] } else if (binary.inputs == "center") { return(x - mean(x.obs)) # Center the variable } else if (binary.inputs == "full") { return((x - mean(x.obs)) / (2 * sd(x.obs))) # Standardize } } else { return ((x-mean(x.obs))/(2*sd(x.obs))) } } # Example usage arm/data/0000755000176200001440000000000015155406662011754 5ustar liggesusersarm/data/lalonde.rda0000644000176200001440000001371015155406662014064 0ustar liggesusers‹ í] xUE–ùPie´Y”FZ‘WuߊUqi›È(Îø¡PQ@d³•Ã&ŠF”}iYbHÒ $$„F µµ…Ag±ÅÖZœy¯Î«:¹‡\Þ{É{aé[ß÷<·¶óŸ:UõŸª{£ÆÁZŽhÛ²ILlSßc³Xß?šø~Wø~—K÷Ì„Ñcbbš^ë˶òý®òÕŠ‰1þ$\1 ûdޭÊcÌåªäɈ>GŒ¹*Wzd/ZÐ?0÷ýqéµÀóü¤½AòƒI^ÙqѧƩƣô+»¨^‘TŸ€ìGô¨v}I5ƒÍv»H;åŸþv½I¹Â¥ó1$ÑÜNÕ+?Pûú¼²Cùi)Wí”5¿½‰TåÊ.µ>”^¥GùúWµbKç[éQóÜË¢Ÿš÷Á‰f{~_Òß õ*O÷‰“äU;…§üGúÓ}EõÒ}¬$µKÍ#µ[ù£éO÷a/ÒÞKòjý(=œHe/ÅWvyH{eGeõ§Ê+ÐùŽ#’Ú×ôWú”ÿ¨Ýœ”÷!ý)ÏÆ‘r5µ•Tõt_(=jüj«¼g’@ÆCyAðèO÷õÀDs?µÿz“vÊŸJŸÂWãSv÷¢íÍöx‰´ª§ûJéU<£ìPv ÒÞMÚ{H¹jGù‰î?ºÞ¨•ÿéøé~RåH:^+j7ªÝ݉æñõ'õ" iüJôRÿѸ«Ö ]_J?åÊë4©~ÊNºõ¹&Ѭ?ŽÔSýÊ.Ê—}I;êWÕ^é½›à+ÿª}«üAÏEôœFý«üOÏ],H½U;Úž–Ó~ô¼cuN f—T¯U?_­p¨7èøè¼Ós†š¯¤½Õ¸)ÏÒø¢ò½H?Ê7Vþ§ç©>DZů8RNù‚ú—ž‹Õ> ç2·iÜ£y«uCçYíåw/i§ð”unSã¥qŽú‰ÆêÕNÍ?=gи@Ïqª?åz^P|Gã4å™@ûußë(ïÝR•w Rß“”«vÝIÿ›²Éw'ùnD*œ[‰þ®¤_W‹rZ¯ò­I9ÅUxmH9wG"©]I{+ý´õ‡ÂWzÔxn%í¨=Ôªõ«š'e_wÒNåÛûzXØMõ[ù]Iº~èxhZNÇIýGíêFúu&y«uF÷õ“Õ|Yí'+Pûè:¥ú•Vû›ê¡í¬ÆIÛu QÅíhѾ#É[íg:ïVü Ÿî+:ÿt}Ð<µÇjYÍ¿Õ.4 W´øàbIÑÞ¿—Êù­¡)Zûðúêü¾œê£ßÐ~áÎO´Îá¾GihºÐ÷ Mª½}N ¶þ"µŽ/´}ÝP{Â屆ÆÇPñÂ}_jj¬ui\¬éb±?Zñ4Ô÷ѵ¾#µß­úEz¿†Š÷Ïž.Õ{E´Ï¹ÿ¬)ÔïhõÕS_;Âø~ÌÓ}/ß ÃÒ-}õ•V)Ôù~}ë£í'ª×*¬]C÷O¤ü®‘šÇúîß`íÂå«h­—†ÚéõiœH÷ Õîúê‹ö:Ž^}÷GcóÞ¥¢?ÔòPí£)Rv‡k´ì‰´ßëkíW_=¶lIS´öQ°ö´>\ýÑÞgVz‚éÔ8ºïµû<Øoú{N;ÙÉNÑKbm&Èeg&¾ýaK1½&oØñy¿¯uÓ§··_'Ô´ptýßçEÆæBY¯äºÝÏ»1ï,}9³ï{¸Û÷e–x¥ñ•ß—.|XdLõ‰[°ß­\¹r¶þg¿!"ãiȯªiç>KßÏªzW¼RÖ!£…ãWgÕìâ;îKº¼äèC~î¢Ë—é&ãõö‘çŽë;~é:Ÿ÷×:Û‹7’«üñá¬ò´“ ¦¸šü`~sEö-—²þã{Ó¹aÑ{þ°'vÕÉÔÖøåI÷}Ö[çS>–ç ‘6Âtnï>%ÏËÀ¹§x\µ_Ÿ®ßÖ¡¹økñA¼ù|òÒ³àÿ—ätö›¡ËçQ<1ü2 ânyŒ'g pé¬ËnÖrÁfèÿZÁ4ÿƒHâ %¿$õ—qF$ œsÍ„åIâÍ©pßY|-ðÖâ¥_ÒZÞÇÄÒ2à•å\ò¿XÕxÕ‚€,¾Y}´äÅ?Œx±~ôÉÇë‚ÞäÈ'ÜÓCÿ”ÇrØ—R ýSCû óàž¹! âDê-ÀÛ©Îy O‚L+:.ïki_¦ß |þÇ-0ž-à>º©ø6ã3ÅæS§e\Ø:áiÙë'€·­Üϲ¯úFÚ·½ªƒG΃Ð/'éCÿýRäN—úr§—ãÏ]/ã•ÈM> ùïà^¶#½XÎ{þ\ðcþ‡ŸH}»ßïÞöÏv%w½/ÛUŒ„ú=/ƒ]ï4yðuÐû§¤×êŠëv²“ìd§ó“Äð¯;?yÅá¥"¡Ê†£~‚xªâý„¦ã^õEjñl»®›ÿëX1í̯c}'1#ÞûÎüÊè'^LõÕ¶ºK$|óÉI™Ä¬i÷gý¾|õ†cÃÅì® wöLˆƒ³öýï2ÄÜîþ׈׋¹åþëØh1ÄÕù'ýÕ-Ä+íwûbÁ? Ž-ºâð¢ÏÁ}O,:÷£Å#Aÿ’T³gÅ’"¨_:îYK€ûײo¡ÝŠx¿ºj#´_u âæêöqò^´ºÎo­ƒsÃÚß@|_' ¯;ñp}6Äë·ÿµ‡Ô—2Î) ãú†Ÿà|’:Øçƒ4ÀK;q?½Ià° ð6.?lN‡sBfGwæ¸n{Ƴm9Ôçü"pÜ zròÁ?9ùâþð'¥Ü1úïtÀû€Õ]¤;«!^ïê å…'Aɸ>Òž’DùžZ”|>BÚ_rFÞÏDéí?Ê|)¿”­€óHy6¼?¯0ÀŽÊÎ ÷ß*í<ðä«_ƒü3Õ’„ÿCÙ˜ËdyFÛ½p/¼ÿQ¹^ ã»ÊòIÀ[3O›Þ¯¿ó´îK˜çÊþpþ( ø¡z›ÄÓíkîû}ÚZ˜‡?Âÿ BT½ãØ}%Ì[E{À-?“mºçn¿!QÊ- ýÚ`\ï‚,}ꈿzÊäû}q`3ô_xƒù½ýÎåË¥ŸW¬”ëR—§Ÿ=‡/{^êÍ»ægG[¸ß§ßjþ.±xì·}¥`Ñ ¸çoØ ëuëÒO–¼°÷]8Ïeïa²£hù Ó{þä‡àÜ9{ZÿWÜwïÕåolÿLïFûvCy‚\'ºÝš«ÁïY½`¿Íê÷„ù‚ýåǺ֞/œçm°O Ýé¦÷s½r]à8F¾(-,÷{̓pî­‰{É´>x.ð=Äcžßäΰ_³ï5½ß9Ëž-ñp/¨>ã,šhž×ªLß—tyÙ‹ÇLöæJ”rÛl°óíž÷Ô>7‹ÿìù¸ÉîÒv_Èqͼx,ë½õr]v–÷ÝîHêX©oͼ:ç]”Œ€s|Þ€Mþõ¡Ë“®ö_¿~«ó•óA¾ŸrH®•50î¢ØÿsOCÜ88üPÖl±lwp°y™Gs$Þêó:¯øø`ÖtعL¼ñ=¬œÁp¿üˤßËõ¾ì ðá®_/m|\ý3_–ïEE©y>÷ßû4ëÛ…¦ïv+Oš¾Š·ÇÂûªLû¸ìyówºJ®•zrNô”v¤ŸÍk óPø ì‹âEÀãKȺÌ^v—Þ+ãúeÇäºÞt%ô+ø Î{“¨˜(¤|'âUþ\àýÒMP¾ïà«ùq4k·xªÈY´âÞ@ðçÒ^æñÏ»Ü×lJΗåÂ~È{e‚OåràóìceÿÝ ^ýüàÅB¿ÍK!ÞeþÛ7¦÷¤•·›ß–Ÿ^ÞÛì-müXžó·cøgË0óþÎ]xõ¹Þ3ëvëæÀú(,…8Qö(ðfæhó{äêA°>KÏì_¼³é9¸÷V¿eŠºßŽxç[­`¾ón‡ù.˜2JâMÿôî=i'֜կ`¯y­…¸'Þû0ðž¶x=ï+ØO-zšüXÔz©ÿ®o:ÁwÛA_šüT9Äü=;ûÌû¶ë€—W 6¿^õŠùýíž«Íûµ*ðývŸdî|ÀÝù"Ä“-¹pn8<¹îõZµÍ¬ãvÐSñç:ý«Û-Û v¿õjÀþykä¾Ø¿ âÓÒ|Oî!ØÅïÀ¼¤V›y2ÿ¾auý=‚®ò¨<ÿžUžqðv]ëqsðÁö¡BÖ¯ï篊<Èî„såº“æ¿ X\|¼6¯ZÚ‘û[OœU¿hè/ûÑ<¿YOËï+ê\¤Ë‹~^Ìzö[A¦‰o-q2†óÒî¹f~ÊxöGÖ×u~§Ñíª>7ýƒ.ß<xeE"øq×c°O7ï…x^Ñx%Ëñº8»Lî§Ì÷a_lO…þ•£€Ÿ+úÂ:;4ð>® Æ›y|ÿØsí9ß;‰õí?1Åɲo¥¬XÒÊ´þKÞ8ß™À:Kÿ[s“_¶mkŠÏz¯ò¯È¸Ò¼+†¸¾öðR2œ÷u}ñóü½ù)Ä×ìÓ¤|yìþâ9×<#6Þ~+-ñ˜ÎSÕׂò'¯1}o«˜uîùÊ\ û9u9¬óœ°ž²NÃù)«jIísƒïþ&¿Ÿ‰ªGÌë°`n¢Yo?Óº9Ï/¯í§³ì¨n+LùcwL”rÏ¿@<Ëo ïUK‡Áwªì#p¾LYó]ú*Ä÷ÃO 1ù½¼ø}uϺ¿/æÕ@/h°³øxútÿuw¤¨^$Ç%¶ü wâÊu]êÚ¯bÕ1ó<Ö<÷Œ%YpO|v?Ü—+>­û\X˜4¸öú:«>{Ü*€ü¦ùf>/ÿ¬ƒ¬MGª—ÃþÑ€ïqémï—Oâäq8ç ÷“]©æsÿâG`n5ßWtý®\ˆ•]ꎗճà¼T°îã9wªy¨óßß³¥-m½¿ÿ®o ÷ï¾­ú[åCÅ ·>X fW}í׎héi,¼ó½¾miK[ÚòR“õM¡ê VnÕß*ny°ªÝᎯ¾ý:/Áìh¨_"•¢ ß¾ïÙÒ–çIÚÉN‘Lç{=ÛÒ–¶´¥-cìd§ 1Ù÷=[ÚÒ–¶¼¤ìd';ÙÉNv²ÓÙ©™ÿ_iâû]áû5Ÿ0~ÌdßCk߯U °iÂcÍÆŒž:Jµ}l\¨§UÅ“c'O <_>>aÒ¤±cF²—Mxfô˜'&©†“ƸZÏÎZÏ8U7ñ=ªͧL“0…|ŤgžëQËhù_žñW4q¨¦¸zPÊ›(ÕM\êÁ­”-M¼‡XGOýäÐOL?qýdè'§~ré'·~òè'Á4ÓLc0Á4ÓLc0Á4Ó\cpÁ5×\cpÁ5×\cpah CcÃІÆ04†¡1 ah Cc85†Sc85†Sc85†Sc85†Sc85†Sc¸4†Kc¸4†Kc¸4†Kc¸4†Kc¸4†Kc¸5†[c¸5†[cè=«·D¬[c¸5†ÞF±náÑáÑáÑáÑáÑáÕ^áÕ^áÕ^áÕ^áÕ^…ÑÔѳ'>:ð‘á#ÇGøèÂG7>zðшæ@4¢9ÍhDs šÑˆæ@4†h Ñ¢1DcˆÆ!C4†h Ñ8¢qDãˆÆ#G4ŽhÑ8¢qD3Í@4Ñ D3Í@4Ñ D3Í@4'¢9͉hNDs"šÑœˆæD4'¢9Í…h.Ds!š Ñ\ˆæB4¢¹Í…h.Ds#šÑ܈æF4 £7¢¹Íh}nDó šÑ<ˆæA4¢y̓hDó šѼˆæE4/¢yÍ‹h^Dó"šѼˆ†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ% ¹„!—0ä†\ÂKr C.aÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\‘K8r G.áÈ%¹„#—päŽ\b —È%r‰\b —È%r‰\b —È%r‰\b —È%r‰\b —È%r‰\b —È%r‰\b —È%r‰\b —È%r‰\b —È%r‰\b —È%r‰\b —È%r‰\b —~.1¿„5.a²z § [ŽN˜’ÐãñI ãýïâ~öÿþÛŸUp.»arm/NAMESPACE0000644000176200001440000000634315155425357012272 0ustar liggesusersimportFrom(graphics, "abline", "axis", "box", "image", "layout", "lines", "par", "plot", "points", "polygon", "rect", "segments", "text", "title") importFrom(grDevices, "gray", "heat.colors", "rainbow") importFrom(methods, "as", "getMethod", "new", "setClass", "setOldClass", "show", "signature") importFrom(utils, "packageDescription", "read.fwf", "methods") 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", "residuals", "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/CHANGELOG0000644000176200001440000003627515167675170012277 0ustar liggesusers2026-04-15 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.15.2 * R/standardize: fix a bug when formula is inputed as an object. * man/standardize: and an example to reflect the aformentioned change. 2026-03-15 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.15.2 * R/rescale: fix a bug previous coded in rescale that breaks standardize() 2026-03-15 Yu-Sung Su * DESCRIPTION: (Version, Date): 1.15.1 * R/sim: add hidden function for sim.plm and sim.coxph * R/standardize: rewrite the function * R/rescale: rewrite rescale function to correclty handly binary varaible. 2022-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/README.md0000644000176200001440000000011715155406662012321 0ustar liggesusers# arm ARM: Data Analysis Using Regression and Multilevel/Hierarchical Models arm/man/0000755000176200001440000000000015155406662011616 5ustar liggesusersarm/man/sim.Rd0000644000176200001440000001106515155424461012675 0ustar liggesusers\name{sim} %\docType{genericFunction} \alias{sim} \alias{sim-class} \alias{sim.merMod-class} \alias{sim,lm-method} \alias{sim,glm-method} \alias{sim,polr-method} \alias{sim,merMod-method} \alias{coef.sim} \alias{coef.sim.polr} \alias{coef.sim.merMod} \alias{fixef.sim.merMod} \alias{ranef.sim.merMod} \alias{fitted.sim.merMod} \title{Functions to Get Posterior Distributions} \description{ This generic function gets posterior simulations of sigma and beta from a \code{lm} object, or simulations of beta from a \code{glm} object, or simulations of beta from a \code{merMod} object } \usage{ sim(object, ...) \S4method{sim}{lm}(object, n.sims = 100) \S4method{sim}{glm}(object, n.sims = 100) \S4method{sim}{polr}(object, n.sims = 100) \S4method{sim}{merMod}(object, n.sims = 100) \method{coef}{sim}(object,\dots) \method{coef}{sim.polr}(object, slot=c("ALL", "coef", "zeta"),\dots) \method{coef}{sim.merMod}(object,\dots) \method{fixef}{sim.merMod}(object,\dots) \method{ranef}{sim.merMod}(object,\dots) \method{fitted}{sim.merMod}(object, regression,\dots) } \arguments{ \item{object}{the output of a call to \code{lm} with n data points and k predictors.} \item{slot}{return which slot of \code{sim.polr}, available options are \code{coef, zeta, ALL}.} \item{...}{further arguments passed to or from other methods.} \item{n.sims}{number of independent simulation draws to create.} \item{regression}{the orginial mer model} } \value{ \item{coef}{matrix (dimensions n.sims x k) of n.sims random draws of coefficients.} \item{zeta}{matrix (dimensions n.sims x k) of n.sims random draws of zetas (cut points in polr).} \item{fixef}{matrix (dimensions n.sims x k) of n.sims random draws of coefficients of the fixed effects for the \code{merMod} objects. Previously, it is called \code{unmodeled}.} \item{sigma}{vector of n.sims random draws of sigma (for \code{glm}'s, this just returns a vector of 1's or else of the square root of the overdispersion parameter if that is in the model)} } \references{Andrew Gelman and Jennifer Hill. (2006). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models}. Cambridge University Press.} \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn}; Vincent Dorie \email{vjd4@nyu.edu} } \seealso{\code{\link{display}}, \code{\link{lm}}, \code{\link{glm}}, \code{\link[lme4]{lmer}} } \examples{ #Examples of "sim" set.seed (1) J <- 15 n <- J*(J+1)/2 group <- rep (1:J, 1:J) mu.a <- 5 sigma.a <- 2 a <- rnorm (J, mu.a, sigma.a) b <- -3 x <- rnorm (n, 2, 1) sigma.y <- 6 y <- rnorm (n, a[group] + b*x, sigma.y) u <- runif (J, 0, 3) y123.dat <- cbind (y, x, group) # Linear regression x1 <- y123.dat[,2] y1 <- y123.dat[,1] M1 <- lm (y1 ~ x1) display(M1) M1.sim <- sim(M1) coef.M1.sim <- coef(M1.sim) sigma.M1.sim <- sigma.hat(M1.sim) ## to get the uncertainty for the simulated estimates apply(coef(M1.sim), 2, quantile) quantile(sigma.hat(M1.sim)) # Logistic regression u.data <- cbind (1:J, u) dimnames(u.data)[[2]] <- c("group", "u") u.dat <- as.data.frame (u.data) y <- rbinom (n, 1, invlogit (a[group] + b*x)) M2 <- glm (y ~ x, family=binomial(link="logit")) display(M2) M2.sim <- sim (M2) coef.M2.sim <- coef(M2.sim) sigma.M2.sim <- sigma.hat(M2.sim) # Ordered Logistic regression house.plr <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display(house.plr) M.plr <- sim(house.plr) coef.sim <- coef(M.plr, slot="coef") zeta.sim <- coef(M.plr, slot="zeta") coefall.sim <- coef(M.plr) # Using lmer: # Example 1 E1 <- lmer (y ~ x + (1 | group)) display(E1) E1.sim <- sim (E1) coef.E1.sim <- coef(E1.sim) fixef.E1.sim <- fixef(E1.sim) ranef.E1.sim <- ranef(E1.sim) sigma.E1.sim <- sigma.hat(E1.sim) yhat <- fitted(E1.sim, E1) # Example 2 u.full <- u[group] E2 <- lmer (y ~ x + u.full + (1 | group)) display(E2) E2.sim <- sim (E2) coef.E2.sim <- coef(E2.sim) fixef.E2.sim <- fixef(E2.sim) ranef.E2.sim <- ranef(E2.sim) sigma.E2.sim <- sigma.hat(E2.sim) yhat <- fitted(E2.sim, E2) # Example 3 y <- rbinom (n, 1, invlogit (a[group] + b*x)) E3 <- glmer (y ~ x + (1 | group), family=binomial(link="logit")) display(E3) E3.sim <- sim (E3) coef.E3.sim <- coef(E3.sim) fixef.E3.sim <- fixef(E3.sim) ranef.E3.sim <- ranef(E3.sim) sigma.E3.sim <- sigma.hat(E3.sim) yhat <- fitted(E3.sim, E3) } \keyword{models} \keyword{methods} arm/man/corrplot.Rd0000644000176200001440000000576715155406662013770 0ustar liggesusers\name{corrplot} \alias{corrplot} \title{Correlation Plot} \description{ Function for making a correlation plot starting from a data matrix } \usage{ corrplot (data, varnames=NULL, cutpts=NULL, abs=TRUE, details=TRUE, n.col.legend=5, cex.col=0.7, cex.var=0.9, digits=1, color=FALSE) } \arguments{ \item{data}{a data matrix} \item{varnames}{variable names of the data matrix, if not provided use default variable names} \item{abs}{if TRUE, transform all correlation values into positive values, default=TRUE.} \item{cutpts}{a vector of cutting points for color legend, default is NULL. The function will decide the cutting points if cutpts is not assigned.} \item{details}{show more than one digits correlaton values. Default is TRUE. FALSE is suggested to get readable output.} \item{n.col.legend}{number of legend for the color thermometer.} \item{cex.col}{font size of the color thermometer.} \item{cex.var}{font size of the variable names.} \item{digits}{number of digits shown in the text of the color theromoeter.} \item{color}{color of the plot, default is FALSE, which uses gray scale.} } \details{ The function adapts the R function for Figure 8 in Tian Zheng, Matthew Salganik, and Andrew Gelman, 2006, "How many people do you know in prison?: using overdispersion in count data to estimate social structure in networks", Journal of the American Statistical Association, Vol.101, N0. 474: p.409-23. } \value{ A correlation plot. } \references{ Tian Zheng, Matthew Salganik, and Andrew Gelman, 2006, "How many people do you know in prison?: using overdispersion in count data to estimate social structure in networks", Journal of the American Statistical Association, Vol.101, N0. 474: p.409-23} \author{Tian Zheng \email{tzheng@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link[stats]{cor}}, \code{\link[graphics]{par}} } \examples{ old.par <- par(no.readonly = TRUE) x1 <- rnorm(1000,50,2) x2 <- rbinom(1000,1,prob=0.63) x3 <- rpois(1000, 2) x4 <- runif(1000,40,100) x5 <- rnorm(1000,100,30) x6 <- rbeta(1000,2,2) x7 <- rpois(1000,10) x8 <- rbinom(1000,1,prob=0.4) x9 <- rbeta(1000,5,4) x10 <- runif(1000,-10,-1) test.data <- data.matrix(cbind(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10)) test.names <- c("a short name01","a short name02","a short name03", "a short name04","a short name05","a short name06", "a short name07","a short name08","a short name09", "a short name10") # example 1 corrplot(test.data) # example 2 corrplot(test.data,test.names, abs=FALSE, n.col.legend=7) corrplot(test.data,test.names, abs=TRUE, n.col.legend=7) # example 3 data(lalonde) corrplot(lalonde, details=FALSE, color=TRUE) corrplot(lalonde, cutpts=c(0,0.25,0.5,0.75), color=TRUE, digits=2) par(old.par) } \keyword{dplot} arm/man/balance.Rd0000644000176200001440000000751115155406662013476 0ustar liggesusers\name{balance} \docType{class} % Classes \alias{balance-class} % Function \alias{balance} % display methods \alias{print.balance} \alias{plot.balance} \title{Functions to compute the balance statistics} \description{ This function computes the balance statistics before and after matching. } \usage{ balance(rawdata, 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/se.coef.Rd0000644000176200001440000000530215155406662013427 0ustar liggesusers\name{se.coef} %\docType{genericFunction} \alias{se.coef} \alias{se.coef,lm-method} \alias{se.coef,glm-method} \alias{se.coef,merMod-method} \alias{se.fixef} \alias{se.ranef} \title{Extract Standard Errors of Model Coefficients} \description{ These functions extract standard errors of model coefficients from objects returned by modeling functions. } \usage{ se.coef (object, \dots) se.fixef (object) se.ranef (object) \S4method{se.coef}{lm}(object) \S4method{se.coef}{glm}(object) \S4method{se.coef}{merMod}(object) } \arguments{ \item{object}{object of \code{lm}, \code{glm} and \code{merMod} fit} \item{\dots}{other arguments} } \value{ \code{se.coef} gives lists of standard errors for \code{coef}, \code{se.fixef} gives a vector of standard errors for \code{fixef} and \code{se.ranef} gives a list of standard errors for \code{ranef}. } \details{ \code{se.coef} extracts standard errors from objects returned by modeling functions. \code{se.fixef} extracts standard errors of the fixed effects from objects returned by lmer and glmer functions. \code{se.ranef} extracts standard errors of the random effects from objects returned by lmer and glmer functions. } \seealso{ \code{\link{display}}, \code{\link{coef}}, \code{\link{sigma.hat}}, } \references{Andrew Gelman and Jennifer Hill. (2006). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models}. Cambridge University Press.} \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \examples{ # Here's a simple example of a model of the form, y = a + bx + error, # with 10 observations in each of 10 groups, and with both the # intercept and the slope varying by group. First we set up the model and data. group <- rep(1:10, rep(10,10)) mu.a <- 0 sigma.a <- 2 mu.b <- 3 sigma.b <- 4 rho <- 0 Sigma.ab <- array (c(sigma.a^2, rho*sigma.a*sigma.b, rho*sigma.a*sigma.b, sigma.b^2), c(2,2)) sigma.y <- 1 ab <- mvrnorm (10, c(mu.a,mu.b), Sigma.ab) a <- ab[,1] b <- ab[,2] # x <- rnorm (100) y1 <- rnorm (100, a[group] + b[group]*x, sigma.y) y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) # lm fit M1 <- lm (y1 ~ x) se.coef (M1) # glm fit M2 <- glm (y2 ~ x) se.coef (M2) # lmer fit M3 <- lmer (y1 ~ x + (1 + x |group)) se.coef (M3) se.fixef (M3) se.ranef (M3) # glmer fit M4 <- glmer (y2 ~ 1 + (0 + x |group), family=binomial(link="logit")) se.coef (M4) se.fixef (M4) se.ranef (M4) } \keyword{manip} \keyword{methods} \keyword{models} arm/man/residual.plot.Rd0000644000176200001440000000312515155406662014673 0ustar liggesusers\name{residual.plot} \alias{residual.plot} \title{residual plot for the observed values} \description{ Plots the residual of observed variable. } \usage{ residual.plot(Expected, Residuals, sigma, main = deparse(substitute(Expected)), col.pts = "blue", col.ctr = "red", col.sgm = "black", cex = 0.5, gray.scale = FALSE, xlab = "Predicted", ylab = "Residuals", ...) } \arguments{ \item{Expected}{ Expected value. } \item{Residuals}{ Residual value. } \item{sigma}{ Standard error. } \item{main}{ main for the plot. See \code{plot} for detail.} \item{col.pts}{ Color of the points. } \item{col.ctr}{ Color of the line at zero. } \item{col.sgm}{ Color of standard error line. } \item{cex}{ A numerical value giving the amount by which plotting text and symbols should be magnified relative to the default. See par for detail. } \item{gray.scale}{ If \code{TRUE}, makes the plot into black and white. This option overwrites the color specification. Default is FALSE. } \item{xlab}{ Label for x axis. } \item{ylab}{ Label for y axis. } \item{\dots}{ Additional parameters passed to \code{plot} function. } } \value{ Plot to visualize pattern of residulal value for the expected value. } \author{ Masanao Yajima \email{yajima@stat.columbia.edu}, M.Grazia Pittau \email{grazia@stat.columbia.edu} } \examples{ old.par <- par(no.readonly = TRUE) x <- rnorm(100) y <- rnorm(100) fit <- lm(y~x) y.hat <- fitted(fit) u <- resid(fit) sigma <- sigma.hat(fit) residual.plot(y.hat, u, sigma) par(old.par) } \keyword{hplot} arm/man/readColumns.Rd0000644000176200001440000000066315155406662014366 0ustar liggesusers\name{readColumns} % functions \alias{read.columns} \title{Function to read data by columns} \description{ A function read data by columns } \usage{ read.columns(filename, columns) } \arguments{ \item{filename}{user specified file name including path of the file} \item{columns}{which columns of the data to be read} } \author{Andrew Gelman \email{gelman@stat.columbia.edu} } \keyword{methods} arm/man/sigma.hat.Rd0000644000176200001440000000351015155406662013757 0ustar liggesusers\name{sigma.hat} %\docType{genericFunction} \alias{sigma.hat} \alias{sigma.hat.lm} \alias{sigma.hat.glm} \alias{sigma.hat.merMod} \alias{sigma.hat.sim} \alias{sigma.hat.sim.merMod} \title{Extract Residual Errors} \description{This generic function extracts residual errors from a fitted model. } \usage{ sigma.hat(object,\dots) \method{sigma.hat}{lm}(object,\dots) \method{sigma.hat}{glm}(object,\dots) \method{sigma.hat}{merMod}(object,\dots) \method{sigma.hat}{sim}(object,\dots) \method{sigma.hat}{sim.merMod}(object,\dots) } \arguments{ \item{object}{any fitted model object of \code{lm}, \code{glm} and \code{merMod} class} \item{\dots}{other arguments} } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link{display}}, \code{\link{summary}}, \code{\link{lm}}, \code{\link{glm}}, \code{\link[lme4]{lmer}} } \examples{ group <- rep(1:10, rep(10,10)) mu.a <- 0 sigma.a <- 2 mu.b <- 3 sigma.b <- 4 rho <- 0 Sigma.ab <- array (c(sigma.a^2, rho*sigma.a*sigma.b, rho*sigma.a*sigma.b, sigma.b^2), c(2,2)) sigma.y <- 1 ab <- mvrnorm (10, c(mu.a,mu.b), Sigma.ab) a <- ab[,1] b <- ab[,2] x <- rnorm (100) y1 <- rnorm (100, a[group] + b[group]*x, sigma.y) y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) M1 <- lm (y1 ~ x) sigma.hat(M1) M2 <- bayesglm (y1 ~ x, prior.scale=Inf, prior.df=Inf) sigma.hat(M2) # should be same to sigma.hat(M1) M3 <- glm (y2 ~ x, family=binomial(link="logit")) sigma.hat(M3) M4 <- lmer (y1 ~ (1+x|group)) sigma.hat(M4) M5 <- glmer (y2 ~ (1+x|group), family=binomial(link="logit")) sigma.hat(M5) } \keyword{manip} \keyword{methods} arm/man/binnedplot.Rd0000644000176200001440000000612015155406662014242 0ustar liggesusers\name{binnedplot} \alias{binnedplot} \alias{binned.resids} \title{Binned Residual Plot} \description{ A function that plots averages of y versus averages of x and can be useful to plot residuals for logistic regression. } \usage{ binnedplot(x ,y, nclass=NULL, xlab="Expected Values", ylab="Average residual", main="Binned residual plot", cex.pts=0.8, col.pts=1, col.int="gray", ...) } \arguments{ \item{x}{The expected values from the logistic regression.} \item{y}{The residuals values from logistic regression (observed values minus expected values).} \item{nclass}{Number of categories (bins) based on their fitted values in which the data are divided. Default=NULL and will take the value of nclass according to the $n$ such that if $n >=100$, nclass=floor(sqrt(length(x))); if $10= 2.1.0).} \item{drop.unused.levels}{default \code{TRUE}, if \code{FALSE}, it interpolates the intermediate values if the data have integer levels.} \item{prior.mean}{prior mean for the coefficients: default is 0. Can be a vector of length equal to the number of predictors (not counting the intercepts). If it is a scalar, it is expanded to the length of this vector.} \item{prior.scale}{prior scale for the coefficients: default is 2.5. Can be a vector of length equal to the number of predictors (not counting the intercepts). If it is a scalar, it is expanded to the length of this vector.} \item{prior.df}{for t distribution: default is 1 (Cauchy). Set to \code{Inf} to get normal prior distributions. Can be a vector of length equal to the number of predictors (not counting the intercepts). If it is a scalar, it is expanded to the length of this vector.} \item{prior.counts.for.bins}{default is \code{NULL}, which will augment the data by giving each cut point a \code{1/levels(y)}. To use a noninformative prior, assign prior.counts.for.bins = 0. If it is a scalar, it is expanded to the number of levels of y.} \item{min.prior.scale}{Minimum prior scale for the coefficients: default is 1e-12.} \item{scaled}{if \code{scaled = TRUE}, then the prior distribution is rescaled. Can be a vector of length equal to the number of cutpoints (intercepts). If it is a scalar, it is expanded to the length of this vector.} \item{maxit}{integer giving the maximal number of IWLS iterations, default is 100. This can also be controlled by \code{control}.} \item{print.unnormalized.log.posterior}{display the unnormalized log posterior likelihood for bayesglm fit, default=\code{FALSE}} } \details{ The program is a simple alteration of \code{\link[MASS]{polr}} in \code{VR} version 7.2-31 that augments the loglikelihood with the log of the t prior distributions for the coefficients. We use Student-t prior distributions for the coefficients. The prior distributions for the intercepts (the cutpoints) are set so they apply to the value when all predictors are set to their mean values. If scaled=TRUE, the scales for the prior distributions of the coefficients are determined as follows: For a predictor with only one value, we just use \code{prior.scale}. For a predictor with two values, we use prior.scale/range(x). For a predictor with more than two values, we use prior.scale/(2*sd(x)). } \value{ See \code{polr} for details. \item{prior.mean}{prior means for the cofficients.} \item{prior.scale}{prior scales for the cofficients.} \item{prior.df}{prior dfs for the cofficients.} \item{prior.counts.for.bins}{prior counts for the cutpoints.} } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn}; Maria Grazia Pittau \email{grazia@stat.columbia.edu} } \seealso{\code{\link{bayesglm}}, \code{\link[MASS]{polr}} } \examples{ M1 <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display (M1) M2 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.scale=Inf, prior.df=Inf) # Same as M1 display (M2) M3 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display (M3) M4 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.scale=2.5, prior.df=1) # Same as M3 display (M4) M5 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.scale=2.5, prior.df=7) display (M5) M6 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.scale=2.5, prior.df=Inf) display (M6) # Assign priors M7 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, prior.mean=rep(0,6), prior.scale=rep(2.5,6), prior.df=c(1,1,1,7,7,7)) display (M7) #### Another example y <- factor (rep (1:10,1:10)) x <- rnorm (length(y)) x <- x - mean(x) M8 <- polr (y ~ x) display (M8) M9 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=0) display (M9) # same as M1 M10 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=10000) display (M10) #### Another example y <- factor (rep (1:3,1:3)) x <- rnorm (length(y)) x <- x - mean(x) M11 <- polr (y ~ x) display (M11) M12 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=0) display (M12) # same as M1 M13 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=1) display (M13) M14 <- bayespolr (y ~ x, prior.scale=Inf, prior.df=Inf, prior.counts.for.bins=10) display (M14) } \keyword{models} \keyword{methods} \keyword{regression} arm/man/triangleplot.Rd0000644000176200001440000000375615155406662014624 0ustar liggesusers\name{triangleplot} \alias{triangleplot} \title{Triangle Plot} \description{ Function for making a triangle plot from a square matrix } \usage{ triangleplot (x, y=NULL, cutpts=NULL, details=TRUE, n.col.legend=5, cex.col=0.7, cex.var=0.9, digits=1, color=FALSE) } \arguments{ \item{x}{a square matrix.} \item{y}{a vector of names that corresponds to each element of the square matrix x.} \item{cutpts}{a vector of cutting points for color legend, default is \code{NULL}. The function will decide the cutting points if cutpts is not assigned.} \item{details}{show more than one digits correlaton values. Default is \code{TRUE}. \code{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 makes a triangle plot from a square matrix, e.g., the correlation plot, see \code{\link{corrplot}}. If a square matrix contains missing values, the cells of missing values will be marked \code{x}. } \author{ Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{\code{\link{corrplot}}, \code{\link[graphics]{par}} } \examples{ old.par <- par(no.readonly = TRUE) # create a square matrix x <- matrix(runif(1600, 0, 1), 40, 40) # fig 1 triangleplot(x) # fig 2 assign cutting points triangleplot(x, cutpts=c(0,0.25,0.5,0.75,1), digits=2) # fig 3 if x contains missing value x[12,13] <- x[13,12] <- NA x[25,27] <- x[27,25] <- NA triangleplot(x) par(old.par) # #library(RColorBrewer) #cormat <- cor(iris[,-5]) #triangleplot2(cormat,color = brewer.pal( 5, "RdBu" ), # n.col.legend=5, cex.col=0.7, cex.var=0.5) } \keyword{dplot} arm/man/bayesglm.Rd0000644000176200001440000003110015155501602013671 0ustar liggesusers\name{bayesglm} \docType{class} % Classes \alias{bayesglm-class} %\alias{bayesglm.h-class} % functions \alias{bayesglm} \alias{bayesglm.fit} % display methods \alias{print,bayesglm-method} %\alias{print,bayesglm.h-method} \alias{show,bayesglm-method} %\alias{show,bayesglm.h-method} \alias{predict.bayesglm} \title{Bayesian generalized linear models.} \description{Bayesian functions for generalized linear modeling with independent normal, t, or Cauchy prior distribution for the coefficients.} \usage{ bayesglm (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,...) bayesglm.fit (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) } \arguments{ \item{formula}{a symbolic description of the model to be fit. The details of model specification are given below.} \item{family}{a description of the error distribution and link function to be used in the model. This can be a character string naming a family function, a family function or the result of a call to a family function. (See \code{\link{family}} for details of family functions.)} \item{data}{an optional data frame, list or environment (or object coercible by \code{\link{as.data.frame}} to a data frame) containing the variables in the model. If not found in \code{data}, the variables are taken from \code{environment(formula)}, typically the environment from which \code{glm} is called.} \item{weights}{an optional vector of weights to be used in the fitting process. Should be \code{NULL} or a numeric vector.} \item{subset}{an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. The default is set by the \code{na.action} setting of \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. The \dQuote{factory-fresh} default is \code{\link{na.omit}}. Another possible value is \code{NULL}, no action. Value \code{\link{na.exclude}} can be useful.} \item{start}{starting values for the parameters in the linear predictor.} \item{etastart}{starting values for the linear predictor.} \item{mustart}{starting values for the vector of means.} \item{offset}{this can be used to specify an \emph{a priori} known component to be included in the linear predictor during fitting. This should be \code{NULL} or a numeric vector of length either one or equal to the number of cases. One or more \code{\link{offset}} terms can be included in the formula instead or as well, and if both are specified their sum is used. See \code{\link{model.offset}}.} \item{control}{a list of parameters for controlling the fitting process. See the documentation for \code{\link{glm.control}} for details.} \item{model}{a logical value indicating whether \emph{model frame} should be included as a component of the returned value.} \item{method}{the method to be used in fitting the model. The default method \code{"glm.fit"} uses iteratively reweighted least squares (IWLS). The only current alternative is \code{"model.frame"} which returns the model frame and does no fitting.} \item{x, y}{For \code{glm}: logical values indicating whether the response vector and model matrix used in the fitting process should be returned as components of the returned value. For \code{glm.fit}: \code{x} is a design matrix of dimension \code{n * p}, and \code{y} is a vector of observations of length \code{n}. } \item{contrasts}{an optional list. See the \code{contrasts.arg} of \code{model.matrix.default}.} \item{drop.unused.levels}{default TRUE, if FALSE, it interpolates the intermediate values if the data have integer levels.} \item{intercept}{logical. Should an intercept be included in the \emph{null} model?} \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 intercept, if any). If it is a scalar, it is expanded to the length of this vector.} \item{prior.scale}{prior scale for the coefficients: default is NULL; if is NULL, for a logit model, prior.scale is 2.5; for a probit model, prior scale is 2.5*1.6. Can be a vector of length equal to the number of predictors (not counting the intercept, if any). If it is a scalar, it is expanded to the length of this vector.} \item{prior.df}{prior degrees of freedom for the coefficients. For t distribution: default is 1 (Cauchy). Set to Inf to get normal prior distributions. Can be a vector of length equal to the number of predictors (not counting the intercept, if any). If it is a scalar, it is expanded to the length of this vector.} \item{prior.mean.for.intercept}{prior mean for the intercept: default is 0. See \sQuote{Details}.} \item{prior.scale.for.intercept}{prior scale for the intercept: default is NULL; for a logit model, prior scale for intercept is 10; for probit model, prior scale for intercept is rescaled as 10*1.6.} \item{prior.df.for.intercept}{prior degrees of freedom for the intercept: default is 1.} \item{min.prior.scale}{Minimum prior scale for the coefficients: default is 1e-12.} \item{scaled}{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 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)). If the response is Gaussian, prior.scale is also multiplied by 2 * sd(y). Default is TRUE} \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. Default is TRUE.} \item{drop.baseline}{Drop the base level of categorical x's, default is TRUE.} \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, default=FALSE} \item{Warning}{default is TRUE, which will show the error messages of not convergence and separation.} \item{\dots}{further arguments passed to or from other methods.} } \details{ The program is a simple alteration of \code{glm()} that uses an approximate EM algorithm to update the betas at each step using an augmented regression to represent the prior information. We use Student-t prior distributions for the coefficients. The prior distribution for the constant term is set so it applies 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 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)). We include all the \code{glm()} arguments but we haven't tested that all the options (e.g., \code{offsets}, \code{contrasts}, \code{deviance} for the null model) all work. The new arguments here are: \code{prior.mean}, \code{prior.scale}, \code{prior.scale.for.intercept}, \code{prior.df}, \code{prior.df.for.intercept}and \code{scaled}. } \value{See \code{\link[stats]{glm}} for details. \item{prior.mean}{prior means for the coefficients and the intercept.} \item{prior.scale}{prior scales for the coefficients} \item{prior.df}{prior dfs for the coefficients.} \item{prior.scale.for.intercept}{prior scale for the intercept} \item{prior.df.for.intercept}{prior df for the intercept} } \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{https://sites.stat.columbia.edu/gelman/research/published/priors11.pdf} } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn}; Daniel Lee \email{bearlee@alum.mit.edu}; Aleks Jakulin \email{Jakulin@stat.columbia.edu}} \seealso{ \code{\link[stats]{glm}}, \code{\link{bayespolr}} } \examples{ 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)) M1 <- glm (y ~ x1 + x2, family=binomial(link="logit")) display (M1) M2 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit"), prior.scale=Inf, prior.df=Inf) display (M2) # just a test: this should be identical to classical logit M3 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit")) # default Cauchy prior with scale 2.5 display (M3) M4 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit"), prior.scale=2.5, prior.df=1) # Same as M3, explicitly specifying Cauchy prior with scale 2.5 display (M4) M5 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit"), prior.scale=2.5, prior.df=7) # t_7 prior with scale 2.5 display (M5) M6 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit"), prior.scale=2.5, prior.df=Inf) # normal prior with scale 2.5 display (M6) # Create separation: set y=1 whenever x2=1 # Now it should blow up without the prior! y <- ifelse (x2==1, 1, y) M1 <- glm (y ~ x1 + x2, family=binomial(link="logit")) display (M1) M2 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit"), prior.scale=Inf, prior.scale.for.intercept=Inf) # Same as M1 display (M2) M3 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit")) display (M3) M4 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit"), prior.scale=2.5, prior.scale.for.intercept=10) # Same as M3 display (M4) M5 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit"), prior.scale=2.5, prior.df=7) display (M5) M6 <- bayesglm (y ~ x1 + x2, family=binomial(link="logit"), prior.scale=2.5, prior.df=Inf) display (M6) # bayesglm with gaussian family (bayes lm) sigma <- 5 y2 <- rnorm (n, b0+b1*x1+b2*x2, sigma) M7 <- bayesglm (y2 ~ x1 + x2, prior.scale=Inf, prior.df=Inf) display (M7) # bayesglm with categorical variables z1 <- trunc(runif(n, 4, 9)) levels(factor(z1)) z2 <- trunc(runif(n, 15, 19)) levels(factor(z2)) ## drop the base level (R default) M8 <- bayesglm (y ~ x1 + factor(z1) + factor(z2), family=binomial(link="logit"), prior.scale=2.5, prior.df=Inf) display (M8) ## keep all levels with the intercept, keep the variable order M9 <- bayesglm (y ~ x1 + x1:x2 + factor(z1) + x2 + factor(z2), family=binomial(link="logit"), prior.mean=rep(0,12), prior.scale=rep(2.5,12), prior.df=rep(Inf,12), prior.mean.for.intercept=0, prior.scale.for.intercept=10, prior.df.for.intercept=1, drop.baseline=FALSE, keep.order=TRUE) display (M9) ## keep all levels without the intercept M10 <- bayesglm (y ~ x1 + factor(z1) + x1:x2 + factor(z2)-1, family=binomial(link="logit"), prior.mean=rep(0,11), prior.scale=rep(2.5,11), prior.df=rep(Inf,11), drop.baseline=FALSE) display (M10) } \keyword{models} \keyword{methods} \keyword{regression} arm/man/display.Rd0000644000176200001440000001162415155406662013556 0ustar liggesusers\name{display} %\docType{genericFunction} \alias{display} \alias{display,lm-method} \alias{display,bayesglm-method} %\alias{display,bayesglm.h-method} \alias{display,glm-method} \alias{display,merMod-method} \alias{display,polr-method} \alias{display,svyglm-method} \title{Functions for Processing lm, glm, mer, polr and svyglm Output} \description{This generic function gives a clean printout of lm, glm, mer, polr and svyglm objects.} \usage{ display (object, ...) \S4method{display}{lm}(object, digits=2, detail=FALSE) \S4method{display}{bayesglm}(object, digits=2, detail=FALSE) %\S4method{display}{bayesglm.h}(object, digits=2, detail=FALSE) \S4method{display}{glm}(object, digits=2, detail=FALSE) \S4method{display}{merMod}(object, digits=2, detail=FALSE) \S4method{display}{polr}(object, digits=2, detail=FALSE) \S4method{display}{svyglm}(object, digits=2, detail=FALSE) } \arguments{ \item{object}{The output of a call to lm, glm, mer, polr, svyglm or related regressions function with n data points and k predictors.} \item{...}{further arguments passed to or from other methods.} \item{digits}{number of significant digits to display.} \item{detail}{defaul is \code{FALSE}, if \code{TRUE}, display p-values or z-values} } \details{This generic function gives a clean printout of lm, glm, mer and polr objects, focusing on the most pertinent pieces of information: the coefficients and their standard errors, the sample size, number of predictors, residual standard deviation, and R-squared. Note: R-squared is automatically displayed to 2 digits, and deviances are automatically displayed to 1 digit, no matter what. } \value{Coefficients and their standard errors, the sample size, number of predictors, residual standard deviation, and R-squared} \references{Andrew Gelman and Jennifer Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2006.} \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{suyusung@tsinghua.edu.cn}; Maria Grazia Pittau \email{grazia@stat.columbia.edu} } \note{Output are the model, the regression coefficients and standard errors, and the residual sd and R-squared (for a linear model), or the null deviance and residual deviance (for a generalized linear model). } \seealso{\code{\link[base]{summary}}, \code{\link[stats]{lm}}, \code{\link[stats]{glm}}, \code{\link[lme4]{lmer}}, \code{\link[MASS]{polr}}, \code{\link[survey]{svyglm}} } \examples{ # Here's a simple example of a model of the form, y = a + bx + error, # with 10 observations in each of 10 groups, and with both the # intercept and the slope varying by group. First we set up the model and data. group <- rep(1:10, rep(10,10)) group2 <- rep(1:10, 10) mu.a <- 0 sigma.a <- 2 mu.b <- 3 sigma.b <- 4 rho <- 0.56 Sigma.ab <- array (c(sigma.a^2, rho*sigma.a*sigma.b, rho*sigma.a*sigma.b, sigma.b^2), c(2,2)) sigma.y <- 1 ab <- mvrnorm (10, c(mu.a,mu.b), Sigma.ab) a <- ab[,1] b <- ab[,2] d <- rnorm(10) x <- rnorm (100) y1 <- rnorm (100, a[group] + b*x, sigma.y) y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) y3 <- rnorm (100, a[group] + b[group]*x + d[group2], sigma.y) y4 <- rbinom(100, 1, prob=invlogit(a[group] + b*x + d[group2])) # display a simple linear model M1 <- lm (y1 ~ x) display (M1) M1.sim <- sim(M1, n.sims=2) # display a simple logit model M2 <- glm (y2 ~ x, family=binomial(link="logit")) display (M2) M2.sim <- sim(M2, n.sims=2) # Then fit and display a simple varying-intercept model: M3 <- lmer (y1 ~ x + (1|group)) display (M3) M3.sim <- sim(M3, n.sims=2) # Then the full varying-intercept, varying-slope model: M4 <- lmer (y1 ~ x + (1 + x |group)) display (M4) M4.sim <- sim(M4, n.sims=2) # Then the full varying-intercept, logit model: M5 <- glmer (y2 ~ x + (1|group), family=binomial(link="logit")) display (M5) M5.sim <- sim(M5, n.sims=2) # Then the full varying-intercept, varying-slope logit model: M6 <- glmer (y2 ~ x + (1|group) + (0 + x |group), family=binomial(link="logit")) display (M6) M6.sim <- sim(M6, n.sims=2) # Then non-nested varying-intercept, varying-slop model: M7 <- lmer (y3 ~ x + (1 + x |group) + (1|group2)) display(M7) M7.sim <- sim(M7, n.sims=2) # Then the ordered logit model from polr M8 <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display(M8) M9 <- bayespolr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) display(M9) } \keyword{manip} \keyword{methods} arm/man/standardize.Rd0000644000176200001440000000610315167674734014427 0ustar liggesusers\name{standardize} %\docType{genericFunction} \alias{standardize} \alias{standardize,lm-method} \alias{standardize,glm-method} \alias{standardize,merMod-method} \alias{standardize,polr-method} \title{Function for Standardizing Regression Predictors by Centering and Dividing by 2 sd's} \description{Numeric variables that take on more than two values are each rescaled to have a mean of 0 and a sd of 0.5; Binary variables are rescaled to have a mean of 0 and a difference of 1 between their two categories; Non-numeric variables that take on more than two values are unchanged; Variables that take on only one value are unchanged } \usage{ \S4method{standardize}{lm}(object, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") \S4method{standardize}{glm}(object, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") \S4method{standardize}{merMod}(object, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") \S4method{standardize}{polr}(object, unchanged = NULL, standardize.y = FALSE, binary.inputs = "center") } \arguments{ \item{object}{an object of class \code{lm} or \code{glm}} \item{unchanged}{vector of names of parameters to leave unstandardized} \item{standardize.y}{ if TRUE, the outcome variable is standardized also} \item{binary.inputs}{options for standardizing binary variables} } \details{ "0/1" (rescale so that the lower value is 0 and the upper is 1) "-0.5/0.5" (rescale so that the lower value is -0.5 and upper is 0.5) "center" (rescale so that the mean of the data is 0 and the difference between the two categories is 1) "full" (rescale by subtracting the mean and dividing by 2 sd's) "leave.alone" (do nothing) } \references{Andrew Gelman. (2008). \dQuote{Scaling regression inputs by dividing by two standard deviations.} \emph{Statistics in Medicine} 27: 2865--2873. \url{https://sites.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 form <- y ~ x1 + x2 # input formula as an object M3 <- glm(form, family=binomial) M3.1 <- standardize(M3) } \keyword{manip} \keyword{models} \keyword{methods} arm/man/rescale.Rd0000644000176200001440000000321115155501721013510 0ustar liggesusers\name{rescale} \alias{rescale} \title{Function for Standardizing by Centering and Dividing by 2 sd's} \description{ This function standardizes a variable by centering and dividing by 2 sd's with exceptions for binary variables. } \usage{ rescale(x, binary.inputs="center") } \arguments{ \item{x}{a vector} \item{binary.inputs}{options for standardizing binary variables, default is \code{center}; \code{0/1} keeps original scale; \code{-0.5,0.5} rescales 0 as -0.5 and 1 as 0.5; \code{center} substracts the mean; and \code{full} substracts the mean and divids by 2 sd.} } \value{ the standardized vector } \references{Andrew Gelman. (2008). \dQuote{Scaling regression inputs by dividing by two standard deviations}. \emph{Statistics in Medicine} 27: 2865--2873. \url{https://sites.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{standardize}} } \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)) rescale(x, "full") rescale(y, "center") # For binary factor print(rescale(gl(2, 1), binary.inputs = "-0.5,0.5")) # Should return c(-0.5, 0.5) # For a 5-point Likert scale (e.g., levels: 1, 2, 3, 4, 5) print(rescale(factor(c(1, 2, 3, 4, 5)), binary.inputs = "center")) # Centered around the mean } \keyword{manip} arm/man/lalonde.Rd0000644000176200001440000000354415155505466013533 0ustar liggesusers\name{lalonde} \alias{lalonde} \docType{data} \title{Lalonde Dataset} \description{ Dataset used by Dehejia and Wahba (1999) to evaluate propensity score matching. } \usage{data(lalonde)} \format{ A data frame with 445 observations on the following 12 variables. \describe{ \item{age}{age in years.} \item{educ}{years of schooling.} \item{black}{indicator variable for blacks.} \item{hisp}{indicator variable for Hispanics.} \item{married}{indicator variable for martial status.} \item{nodegr}{indicator variable for high school diploma.} \item{re74}{real earnings in 1974.} \item{re75}{real earnings in 1975.} \item{re78}{real earnings in 1978.} \item{u74}{indicator variable for earnings in 1974 being zero.} \item{u75}{indicator variable for earnings in 1975 being zero.} \item{treat}{an indicator variable for treatment status.} } } \details{ Two demos are provided which use this dataset. The first, \code{DehejiaWahba}, replicates one of the models from Dehejia and Wahba (1999). The second demo, \code{AbadieImbens}, replicates the models produced by Abadie and Imbens. Many of these models are found to produce good balance for the Lalonde data. } \references{ Dehejia, Rajeev and Sadek Wahba. 1999.``Causal Effects in Non-Experimental Studies: Re-Evaluating the Evaluation of Training Programs.'' \emph{Journal of the American Statistical Association} 94 (448): 1053-1062. LaLonde, Robert. 1986. ``Evaluating the Econometric Evaluations of Training Programs.'' \emph{American Economic Review} 76:604-620. } \note{This documentation is adapted from \code{Matching} package.} \seealso{\code{\link{matching}}, \code{\link[Matching]{GenMatch}} \code{\link{balance}} } \examples{ data(lalonde) } \keyword{datasets} arm/man/multicomp.plot.Rd0000644000176200001440000000601115155406662015071 0ustar liggesusers\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} arm/man/mcsamp.Rd0000644000176200001440000001101215155406662013360 0ustar liggesusers\name{mcsamp} %\docType{genericFunction} \alias{mcsamp} \alias{mcsamp.default} \alias{mcsamp,merMod-method} %\alias{mcsamp,glmer-method} \title{Generic Function to Run \sQuote{mcmcsamp()} in lme4} \description{ The quick function for MCMC sampling for lmer and glmer objects and convert to Bugs objects for easy display. } \usage{ \method{mcsamp}{default}(object, n.chains=3, n.iter=1000, n.burnin=floor(n.iter/2), n.thin=max(1, floor(n.chains * (n.iter - n.burnin)/1000)), saveb=TRUE, deviance=TRUE, make.bugs.object=TRUE) \S4method{mcsamp}{merMod} (object, ...) %\S4method{mcsamp}{glmer} (object, ...) } \arguments{ \item{object}{\code{mer} objects from \code{lme4}} \item{n.chains}{number of MCMC chains} \item{n.iter}{number of iteration for each MCMC chain} \item{n.burnin}{number of burnin for each MCMC chain, Default is \code{n.iter/2}, that is, discarding the first half of the simulations.} \item{n.thin}{keep every kth draw from each MCMC chain. Must be a positive integer. Default is \code{max(1, floor(n.chains * (n.iter-n.burnin) / 1000))} which will only thin if there are at least 2000 simulations.} \item{saveb}{if 'TRUE', causes the values of the random effects in each sample to be saved.} \item{deviance}{compute deviance for \code{mer} objects. Only works for \code{\link[lme4]{lmer}} object} \item{make.bugs.object}{tranform the output into bugs object, default is TRUE} \item{\ldots}{further arguments passed to or from other methods.} } \details{ This function generates a sample from the posterior distribution of the parameters of a fitted model using Markov Chain Monte Carlo methods. It automatically simulates multiple sequences and allows convergence to be monitored. The function relies on \code{mcmcsamp} in \code{lme4}. } \value{ An object of (S3) class '"bugs"' suitable for use with the functions in the "R2WinBUGS" package. } \references{Andrew Gelman and Jennifer Hill, Data Analysis Using Regression and Multilevel/Hierarchical Models, Cambridge University Press, 2006. Douglas Bates and Deepayan Sarkar, lme4: Linear mixed-effects models using S4 classes. } \author{Andrew Gelman \email{gelman@stat.columbia.edu}; Yu-Sung Su \email{ys463@columbia.edu} } \seealso{\code{\link{display}}, \code{\link[lme4]{lmer}}, \code{\link{sim}} } \examples{ ## Here's a simple example of a model of the form, y = a + bx + error, ## with 10 observations in each of 10 groups, and with both the intercept ## and the slope varying by group. First we set up the model and data. ## # group <- rep(1:10, rep(10,10)) # group2 <- rep(1:10, 10) # mu.a <- 0 # sigma.a <- 2 # mu.b <- 3 # sigma.b <- 4 # rho <- 0.56 # Sigma.ab <- array (c(sigma.a^2, rho*sigma.a*sigma.b, # rho*sigma.a*sigma.b, sigma.b^2), c(2,2)) # sigma.y <- 1 # ab <- mvrnorm (10, c(mu.a,mu.b), Sigma.ab) # a <- ab[,1] # b <- ab[,2] # d <- rnorm(10) # # x <- rnorm (100) # y1 <- rnorm (100, a[group] + b*x, sigma.y) # y2 <- rbinom(100, 1, prob=invlogit(a[group] + b*x)) # y3 <- rnorm (100, a[group] + b[group]*x + d[group2], sigma.y) # y4 <- rbinom(100, 1, prob=invlogit(a[group] + b*x + d[group2])) # ## ## Then fit and display a simple varying-intercept model: # # M1 <- lmer (y1 ~ x + (1|group)) # display (M1) # M1.sim <- mcsamp (M1) # print (M1.sim) # plot (M1.sim) ## ## Then the full varying-intercept, varying-slope model: ## # M2 <- lmer (y1 ~ x + (1 + x |group)) # display (M2) # M2.sim <- mcsamp (M2) # print (M2.sim) # plot (M2.sim) ## ## Then the full varying-intercept, logit model: ## # M3 <- lmer (y2 ~ x + (1|group), family=binomial(link="logit")) # display (M3) # M3.sim <- mcsamp (M3) # print (M3.sim) # plot (M3.sim) ## ## Then the full varying-intercept, varying-slope logit model: ## # M4 <- lmer (y2 ~ x + (1|group) + (0+x |group), # family=binomial(link="logit")) # display (M4) # M4.sim <- mcsamp (M4) # print (M4.sim) # plot (M4.sim) # ## ## Then non-nested varying-intercept, varying-slop model: ## # M5 <- lmer (y3 ~ x + (1 + x |group) + (1|group2)) # display(M5) # M5.sim <- mcsamp (M5) # print (M5.sim) # plot (M5.sim) } \keyword{models} \keyword{methods} arm/man/extractDIC.mer.Rd0000644000176200001440000000155715155406662014671 0ustar liggesusers\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.Rd0000644000176200001440000000265615155406662015714 0ustar liggesusers\name{discrete.histogram} \alias{discrete.histogram} \alias{discrete.hist} \title{Histogram for Discrete Distributions} \description{Creates a prettier histogram for discrete distributions} \usage{ discrete.histogram (x, prob, prob2=NULL, prob3=NULL, xlab="x", xaxs.label=NULL, yaxs.label=NULL, bar.width=NULL, freq=FALSE, prob.col="blue", prob2.col="red", prob3.col="gray", ...) } \arguments{ \item{x}{The vector of x's} \item{prob}{The probabilities for the x's} \item{prob2}{A second vector of probabilities of the x's} \item{prob3}{A third vector of probabilities of the x's} \item{xlab}{Label for the x axis} \item{xaxs.label}{Label for the x's} \item{yaxs.label}{Label for the y axis} \item{bar.width}{Width of the bars} \item{freq}{If TRUE, shows a frequency histogram as opposed to probability.} \item{prob.col}{The color of the first set of histogram bars.} \item{prob2.col}{The color of the second set of histogram bars.} \item{prob3.col}{The color of the third set of histogram bars.} \item{...}{Additional arguments passed to function \code{plot}} } \details{This function displays a histogram for discrete probability distributions. } \examples{ a <- c(3,4,0,0,5,1,1,1,1,0) discrete.histogram (a) x <- c(0,1,3,4,5) p <- c(.3,.4,.1,.1,.1) discrete.histogram (x,p) x <- c(0,1,3,4,5) y <- c(3,4,1,1,1) discrete.histogram (x,y) } \keyword{dplot} arm/man/traceplot.Rd0000644000176200001440000000250715155406662014106 0ustar liggesusers\name{traceplot} %\docType{genericFunction} \alias{traceplot} \alias{traceplot.default} \alias{traceplot,mcmc.list-method} \alias{traceplot,bugs-method} \title{Trace plot of \sQuote{bugs} object} \usage{ \S4method{traceplot}{bugs}( x, mfrow = c( 1, 1 ), varname = NULL, match.head = TRUE, ask = TRUE, col = rainbow( x$n.chains ), lty = 1, lwd = 1, \dots) } \arguments{ \item{x}{A bugs object} \item{mfrow}{graphical parameter (see \code{par})} \item{varname}{vector of variable names to plot} \item{match.head}{ matches the variable names by the beginning of the variable names in bugs object} \item{ask}{logical; if \code{TRUE}, the user is \emph{ask}ed before each plot, see \code{par(ask=.)}.} \item{col}{graphical parameter (see \code{par})} \item{lty}{graphical parameter (see \code{par})} \item{lwd}{graphical parameter (see \code{par})} \item{\dots}{further graphical parameters} } \description{ Displays a plot of iterations \emph{vs.} sampled values for each variable in the chain, with a separate plot per variable. } \author{ Masanao Yajima \email{yajima@stat.columbia.edu}. Yu-Sung Su \email{suyusung@tsinghua.edu.cn} } \seealso{ \code{\link[coda]{densplot}}, \code{\link[coda]{plot.mcmc}}, \code{\link[coda]{traceplot}} } \keyword{hplot} arm/DESCRIPTION0000644000176200001440000000332515167714742012560 0ustar liggesusersPackage: arm Version: 1.15-3 Date: 2026-4-15 Title: Data Analysis Using Regression and Multilevel/Hierarchical Models Authors@R: c(person("Andrew", "Gelman", role = "aut", email = "gelman@stat.columbia.edu"), person("Yu-Sung", "Su", role = c("aut", "cre"), email = "suyusung@tsinghua.edu.cn", comment = c(ORCID = "0000-0001-5021-8209")), person("Masanao", "Yajima", role = "ctb", email = "yajima@bu.edu"), person("Jennifer", "Hill", role = "ctb", email = "jennifer.hill@nyu.edu"), person("Maria Grazia", "Pittau", role = "ctb", email = "grazia@stat.columbia.edu"), person("Jouni", "Kerman", role = "ctb", email = "jouni@kerman.com"), person("Tian", "Zheng", role = "ctb", email = "tzheng@stat.columbia.edu"), person("Vincent", "Dorie", role = "ctb", email = "vjd4@nyu.edu") ) Author: Andrew Gelman [aut], Yu-Sung Su [aut, cre] (ORCID: ), 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.6-1.1), 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: 2026-04-15 11:46:23 UTC; suyusung Repository: CRAN Date/Publication: 2026-04-15 14:00:02 UTC