contingency graph

[Bernd Puschner <puschner@psyres-stuttgart.de>]

dear s-plus users,

some time ago frank harrell helped me (i wanted to graphically display
crosstabs) by poiting to the symbol.freq-function in the Hmisc library
(section 6.3 of http://hesweb1.med.virginia.edu/biostat/s/doc/splus.pdf). i
even got the source code (see below). unfortunately, i am not much of a
programming expert and have another question:
as i understand it, the size of the "thermometers" in symbol.freq relates to
the total percentage. is there any way to relate it to line percent since it
is this aspect which is most important to display from my data?

thanks for taking some time

bernd



symbol.freq <- function(x, y, symbol=c("thermometer","circle"),
                                                marginals=F, orig.scale=F,
                                                inches=.25, width=.15,
subset, srtx=0, ...)
{
  symbol <- match.arg(symbol)
  if(missing(subset)) subset <- rep(T, length(x))
  if(!is.logical(subset)) {
        s <- rep(F,length(x))
        s[subset] <- F
        subset <- s
  }
  s <- !(is.na(x) | is.na(y)) & subset
  x <- x[s]
  y <- y[s]
  f <- table(x, y)
  if(orig.scale) xp <- as.numeric(dimnames(f)[[1]])     else
  xp <- 1:length(dimnames(f)[[1]])
  xp1 <- length(xp)+1
  if(orig.scale) yp <- as.numeric(dimnames(f)[[2]])     else
  yp <- 1:length(dimnames(f)[[2]])
  yp1 <- length(yp)+1
  m <- nrow(f) * ncol(f)
  xx <- single(m)
  yy <- single(m)
  zz <- single(m)
  k <- 0
  for(i in 1:nrow(f)) {
        for(j in 1:ncol(f)) {
          k <- k + 1
          xx[k] <- xp[i]
          yy[k] <- yp[j]
          if(f[i, j] > 0)
                zz[k] <- f[i, j]
                else zz[k] <- NA
        }
  }
  maxn <- max(f)
  n <- 10^round(log10(maxn))
  if(marginals)                 {
        xx <- c(xx, rep(xp1, length(yp)))
        yy <- c(yy, yp)
        zz <- c(zz, table(y)/2)
        xx <- c(xx, xp)
        yy <- c(yy, rep(yp1, length(xp)))
        zz <- c(zz, table(x)/2)
        xx <- c(xx, xp1)
        yy <- c(yy, yp1)
        zz <- c(zz, n)                  }
  if(symbol=="circle")          {
        ##              zz <- inches*sqrt(zz/maxn)
        zz <- sqrt(zz)
        if(orig.scale)symbols(xx,yy,circles=zz,inches=inches,
                                                  smo=.02,...) else
        symbols(xx,yy,circles=zz,inches=inches,smo=.02,axes=F,...)
        title(sub=paste("n=",sum(s),sep=""),adj=0)
        if(!orig.scale) {
          axis(1, at=xp, label=dimnames(f)[[1]], srt=srtx, adj=if(srtx>0)1
else .5)
          axis(2, at=yp, label=dimnames(f)[[2]]) }
        return(invisible())             }
  zz <- cbind(rep(width,length(zz)), inches*zz/maxn, rep(0,length(zz)))
  symbols(xx,yy,thermometers=zz,inches=F,axes=F,...)
  title(sub=paste("n=",sum(s),sep=""),adj=0)
  if(marginals)                 {
        text(xp1-width, yp1, n, adj=1, cex=.5)
        axis(1, at = 1:xp1,
                 label = c(dimnames(f)[[1]], "All/2"),
srt=srtx,adj=if(srtx>0)1 else .5)
        axis(2, at = 1:yp1,
                 label = c(dimnames(f)[[2]], "All/2"),adj=1)
        abline(h=yp1-.5, lty=2)
        abline(v=xp1-.5, lty=2)
  }     else {
        axis(1, at=xp, label=dimnames(f)[[1]], srt=srtx,adj=if(srtx>0)1 else
.5)
        axis(2, at=yp, label=dimnames(f)[[2]])
        cat("click left mouse button to position legend\n")
        xy <- locator(1)
        symbols(xy,thermometers=cbind(width,inches*n/maxn,0),
                        inches=F,add=T)
        text(xy$x-width, xy$y, n,adj=1,cex=.5)
  }
  box()
  invisible()
}

puschner.vcf
Description: Visitenkarte für Bernd Puschner