Created
May 30, 2011 15:10
-
-
Save hpiwowar/999036 to your computer and use it in GitHub Desktop.
Plots Hmisc summary formula responses with confidence intervals
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ### Heather Piwowar | |
| # Modifications to add confidence intervals added by Heather Piwowar | |
| # Based on dotchart2{Hmisc} | |
| dotchart2.CIs = | |
| function (data, labels, groups = NULL, gdata = NA, horizontal = TRUE, | |
| pch = 16, xlab = "", ylab = "", auxdata, auxgdata = NULL, | |
| auxtitle, lty = if (.R.) 1 else 2, lines = TRUE, dotsize = 0.8, | |
| cex = par("cex"), cex.labels = cex, cex.group.labels = cex.labels * | |
| 1.25, sort. = TRUE, add = FALSE, dotfont = par("font"), | |
| groupfont = 2, reset.par = add, xaxis = TRUE, width.factor = 1.1, | |
| lcolor = if (.R.) "gray" else par("col"), ...) | |
| { | |
| if (.R. && !add) { | |
| plot.new() | |
| par(new = TRUE) | |
| } | |
| ieaux <- if (missing(auxdata)) | |
| FALSE | |
| else is.expression(auxdata) | |
| mtextsrt <- function(..., srt = 0) if (.R.) | |
| mtext(..., las = 1) | |
| else mtext(..., srt = srt) | |
| ndata <- length(data) | |
| if (missing(labels)) { | |
| if (!is.null(names(data))) | |
| labels <- names(data) | |
| else labels <- paste("#", seq(along = ndata)) | |
| } | |
| else labels <- rep(as.character(labels), length = ndata) | |
| if (missing(groups)) { | |
| glabels <- NULL | |
| gdata <- NULL | |
| } | |
| else { | |
| if (!sort.) { | |
| ug <- unique(as.character(groups)) | |
| groups <- factor(as.character(groups), levels = ug) | |
| } | |
| groups <- oldUnclass(groups) | |
| glabels <- levels(groups) | |
| gdata <- rep(gdata, length = length(glabels)) | |
| ord <- order(groups, seq(along = groups)) | |
| groups <- groups[ord] | |
| data <- data[ord] | |
| labels <- labels[ord] | |
| if (!missing(auxdata)) | |
| auxdata <- auxdata[ord] | |
| } | |
| alldat <- c(data, gdata) | |
| if (!missing(auxdata)) { | |
| auxdata <- c(auxdata, auxgdata) | |
| if (!ieaux) | |
| auxdata <- format(auxdata) | |
| } | |
| alllab <- paste(c(labels, glabels), "") | |
| tcex <- par("cex") | |
| tmai <- par("mai") | |
| oldplt <- par("plt") | |
| if (reset.par) | |
| on.exit(par(mai = tmai, cex = tcex, usr = tusr)) | |
| par(cex = cex) | |
| mxlab <- 0.1 + max(strwidth(labels, units = "inches", cex = cex.labels), | |
| if (length(glabels)) strwidth(glabels, units = "inches", | |
| cex = cex.group.labels)) * width.factor | |
| if (horizontal) { | |
| tmai2 <- tmai[3:4] | |
| if (!missing(auxdata)) | |
| tmai2[2] <- 0.2 + width.factor * max(strwidth(if (ieaux) auxdata else format(auxdata), | |
| units = "inches", cex = cex.labels)) | |
| par(mai = c(tmai[1], mxlab, tmai2)) | |
| if (!add) | |
| plot(alldat, seq(along = alldat), type = "n", ylab = "", | |
| axes = FALSE, xlab = "", ...) | |
| plot(alldat, seq(along = alldat), type = "n", ylab = "", | |
| axes = FALSE, xlab = "", ...) | |
| logax <- par("xaxt") == "l" | |
| } | |
| else { | |
| par(mai = c(mxlab, tmai[2:4])) | |
| if (!add) | |
| plot(seq(along = alldat), alldat, type = "n", xlab = "", | |
| axes = FALSE, ylab = "", ...) | |
| logax <- par("yaxt") == "l" | |
| } | |
| tusr <- par("usr") | |
| if (!add && logax) { | |
| if (horizontal) | |
| abline(v = 10^tusr[1:2], h = tusr[3:4]) | |
| else abline(v = tusr[1:2], h = 10^tusr[3:4]) | |
| } | |
| else if (!add) | |
| abline(v = tusr[1:2], h = tusr[3:4]) | |
| den <- ndata + 2 * length(glabels) + 1 | |
| if (horizontal) { | |
| if (!add && xaxis) | |
| mgp.axis(1, axistitle = xlab) | |
| delt <- (-(tusr[4] - tusr[3]))/den | |
| ypos <- seq(tusr[4], by = delt, length = ndata) | |
| } | |
| else { | |
| if (!add) | |
| mgp.axis(2, axistitle = xlab) | |
| delt <- (tusr[2] - tusr[1])/den | |
| ypos <- seq(tusr[1], by = delt, length = ndata) | |
| } | |
| if (!missing(groups)) { | |
| ypos1 <- ypos + 2 * delt * (if (length(groups) > 1) | |
| cumsum(c(1, diff(groups) > 0)) | |
| else 1) | |
| diff2 <- c(3 * delt, diff(ypos1)) | |
| ypos2 <- ypos1[abs(diff2 - 3 * delt) < abs(0.001 * delt)] - | |
| delt | |
| ypos <- c(ypos1, ypos2) - delt | |
| } | |
| ypos <- ypos + delt | |
| nongrp <- 1:ndata | |
| if (horizontal) { | |
| xmin <- par("usr")[1] | |
| if (!add && lines) | |
| abline(h = ypos[nongrp], lty = lty, lwd = 1, col = lcolor) | |
| points(alldat, ypos, pch = pch, cex = dotsize * cex, | |
| font = dotfont) | |
| for (i in nongrp) { ##HAP (note, not in vertical plots yet) | |
| N = as.numeric(auxdata[i]) | |
| CIs = binconf(alldat[i]*N, N, method="wilson") | |
| lines(c(CIs[2], CIs[3]), c(ypos[i],ypos[i]), col="blue", lwd=1) | |
| } | |
| if (!add && !missing(auxdata)) { | |
| faux <- if (ieaux) | |
| auxdata | |
| else paste(" ", format(auxdata), sep = "") | |
| upedge <- par("usr")[4] | |
| outerText(faux, ypos[nongrp], adj = 1, cex = cex.labels) | |
| if (!missing(auxtitle)) { | |
| auxtitle <- paste(" ", auxtitle, sep = "") | |
| outerText(auxtitle, upedge + strheight(auxtitle, | |
| cex = cex.labels)/2, adj = 1, cex = cex.labels, | |
| setAside = faux[1]) | |
| } | |
| } | |
| if (!add) { | |
| labng <- alllab[nongrp] | |
| bracket <- substring(labng, 1, 1) == "[" | substring(labng, | |
| nchar(labng), nchar(labng)) == "]" | |
| yposng <- ypos[nongrp] | |
| s <- !bracket | |
| if (!is.na(any(s)) && any(s)) | |
| mtextsrt(paste(labng[s], ""), 2, 0, at = yposng[s], | |
| srt = 0, adj = 1, cex = cex.labels) | |
| s <- bracket | |
| if (!is.na(any(s)) && any(s)) { | |
| if (.R.) | |
| text(rep(par("usr")[1], sum(s)), yposng[s], | |
| labng[s], adj = 1, cex = cex.labels, srt = 0, | |
| xpd = NA) | |
| else if (.SV4. && under.unix) | |
| text(rep(par("usr")[1], sum(s)), yposng[s], | |
| labng[s], adj = 1, cex = cex.labels, srt = 0) | |
| else { | |
| xmin <- par("usr")[1] - max(nchar(labng[s])) * | |
| 0.5 * cex.labels * par("1em")[1] | |
| text(rep(xmin, sum(s)), yposng[s], labng[s], | |
| adj = 0, cex = cex.labels, srt = 0) | |
| } | |
| } | |
| if (!missing(groups)) | |
| mtextsrt(paste(alllab[-nongrp], ""), 2, 0, at = ypos[-nongrp], | |
| srt = 0, adj = 1, cex = cex.group.labels, font = groupfont) | |
| } | |
| } | |
| else { | |
| if (!add && lines) | |
| abline(v = ypos[nongrp], lty = lty, lwd = 1, col = lcolor) | |
| points(ypos, alldat, pch = pch, cex = dotsize * cex, | |
| font = dotfont) | |
| if (!add) | |
| mtextsrt(alllab[nongrp], 1, 0, at = ypos[nongrp], | |
| srt = 90, adj = 1, cex = cex.labels) | |
| if (!add && !missing(groups)) | |
| mtextsrt(alllab[-nongrp], 1, 0, at = ypos[-nongrp], | |
| srt = 90, adj = 1, cex = cex.group.labels, font = groupfont) | |
| } | |
| plt <- par("plt") | |
| if (horizontal) { | |
| frac <- (oldplt[2] - oldplt[1])/(oldplt[2] - plt[1]) | |
| umin <- tusr[2] - (tusr[2] - tusr[1]) * frac | |
| tusr <- c(umin, tusr[2:4]) | |
| } | |
| else { | |
| frac <- (oldplt[4] - oldplt[3])/(oldplt[4] - plt[3]) | |
| umin <- tusr[4] - (tusr[4] - tusr[3]) * frac | |
| tusr <- c(tusr[1:2], umin, tusr[4]) | |
| } | |
| invisible() | |
| } | |
| # Based on plot.summary.formula.response{Hmisc} | |
| plot.summary.formula.response.CIs = | |
| function (x, which = 1, vnames = c("labels", "names"), xlim, | |
| xlab, pch = c(16, 1, 2, 17, 15, 3, 4, 5, 0), superposeStrata = TRUE, | |
| dotfont = 1, add = FALSE, reset.par = TRUE, main, subtitles = TRUE, | |
| ...) | |
| { | |
| stats <- x | |
| stats <- oldUnclass(stats) | |
| vnames <- match.arg(vnames) | |
| ul <- vnames == "labels" | |
| at <- attributes(stats) | |
| ns <- length(at$strat.levels) | |
| if (ns > 1 && length(which) > 1) | |
| stop("cannot have a vector for which if > 1 strata present") | |
| if (ns < 2) | |
| superposeStrata <- FALSE | |
| vn <- if (ul) | |
| at$vlabel | |
| else at$vname | |
| Units <- at$vunits | |
| vn <- ifelse(Units == "", vn, paste(vn, " [", Units, "]", | |
| sep = "")) | |
| vn <- vn[vn != ""] | |
| d <- dim(stats) | |
| n <- d[1] | |
| nstat <- d[2]/ns | |
| vnd <- factor(rep(vn, at$nlevels)) | |
| dn <- dimnames(stats) | |
| if (missing(xlim)) | |
| xlim <- range(stats[, nstat * ((1:ns) - 1) + 1 + which], | |
| na.rm = TRUE) | |
| if (missing(main)) | |
| main <- at$funlab | |
| nw <- length(which) | |
| pch <- rep(pch, length = if (superposeStrata) ns else nw) | |
| dotfont <- rep(dotfont, length = nw) | |
| opar <- if (.R.) | |
| par(no.readonly = TRUE) | |
| else par() | |
| if (reset.par) | |
| on.exit(par(opar)) | |
| if (superposeStrata) | |
| Ns <- apply(stats[, nstat * ((1:ns) - 1) + 1], 1, sum) | |
| for (is in 1:ns) { | |
| for (w in 1:nw) { | |
| js <- nstat * (is - 1) + 1 + which[w] | |
| z <- stats[, js] | |
| if (missing(xlab)) | |
| xlab <- if (nw > 1) | |
| dn[[2]][js] | |
| else at$ylabel | |
| dotchart2.CIs(z, groups = vnd, xlab = xlab, xlim = xlim, | |
| auxdata = if (superposeStrata) | |
| Ns | |
| else stats[, js - which[w]], auxtitle = "N", | |
| sort = FALSE, pch = pch[if (superposeStrata) | |
| is | |
| else w], dotfont = dotfont[w], add = add | w > | |
| 1 | (is > 1 && superposeStrata), reset.par = FALSE, | |
| ...) | |
| lines(0.3, 0.7) | |
| if (ns > 1 && !superposeStrata) | |
| title(paste(paste(main, if (main != "") | |
| " "), at$strat.levels[is])) | |
| else if (main != "") | |
| title(main) | |
| if (ns == 1 && subtitles) { | |
| title(sub = paste("N=", at$n, sep = ""), adj = 0, | |
| cex = 0.6) | |
| if (at$nmiss > 0) | |
| title(sub = paste("N missing=", at$nmiss, sep = ""), | |
| cex = 0.6, adj = 1) | |
| } | |
| } | |
| } | |
| if (superposeStrata) { | |
| Key <- if (.R.) | |
| function(x = NULL, y = NULL, lev, pch) { | |
| oldpar <- par(usr = c(0, 1, 0, 1), xpd = NA) | |
| on.exit(par(oldpar)) | |
| if (is.list(x)) { | |
| y <- x$y | |
| x <- x$x | |
| } | |
| if (!length(x)) | |
| x <- 0 | |
| if (!length(y)) | |
| y <- 1 | |
| rlegend(x, y, legend = lev, pch = pch, ...) | |
| invisible() | |
| } | |
| else function(x = NULL, y = NULL, lev, pch, ...) { | |
| if (length(x)) { | |
| if (is.list(x)) { | |
| y <- x$y | |
| x <- x$x | |
| } | |
| key(x = x, y = y, text = list(lev), points = list(pch = pch), | |
| transparent = TRUE, ...) | |
| } | |
| else key(text = list(lev), points = list(pch = pch), | |
| transparent = TRUE, ...) | |
| invisible() | |
| } | |
| formals(Key) <- list(x = NULL, y = NULL, lev = at$strat.levels, | |
| pch = pch) | |
| storeTemp(Key) | |
| } | |
| invisible() | |
| } |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment