1## marginals applies only to symbol="therm", orig.scale to symbol="circle" 2 3symbol.freq <- function(x, y, symbol=c("thermometer","circle"), 4 marginals=FALSE, orig.scale=FALSE, 5 inches=.25, width=.15, subset, srtx=0, ...) 6{ 7 symbol <- match.arg(symbol) 8 if(missing(subset)) 9 subset <- rep(TRUE, length(x)) 10 11 if(!is.logical(subset)) { 12 s <- rep(FALSE,length(x)) 13 s[subset] <- FALSE 14 subset <- s 15 } 16 17 xlab <- attr(x,'label') 18 if(!length(xlab)) 19 xlab <- as.character(substitute(x)) 20 21 ylab <- attr(y,'label') 22 if(!length(ylab)) 23 ylab <- as.character(substitute(y)) 24 25 s <- !(is.na(x) | is.na(y)) & subset 26 x <- x[s] 27 y <- y[s] 28 f <- table(x, y) 29 dx <- dimnames(f)[[1]] 30 dy <- dimnames(f)[[2]] 31 if(orig.scale) 32 xp <- as.numeric(dimnames(f)[[1]]) 33 else 34 xp <- 1:length(dimnames(f)[[1]]) 35 36 xp1 <- length(xp)+1 37 if(orig.scale) 38 yp <- as.numeric(dimnames(f)[[2]]) 39 else 40 yp <- 1:length(dimnames(f)[[2]]) 41 42 yp1 <- length(yp)+1 43 m <- nrow(f) * ncol(f) 44 xx <- single(m) 45 yy <- single(m) 46 zz <- single(m) 47 k <- 0 48 for(i in 1:nrow(f)) { 49 for(j in 1:ncol(f)) { 50 k <- k + 1 51 xx[k] <- xp[i] 52 yy[k] <- yp[j] 53 if(f[i, j] > 0) 54 zz[k] <- f[i, j] 55 else zz[k] <- NA 56 } 57 } 58 59 maxn <- max(f) 60 n <- 10^round(log10(maxn)) 61 if(marginals) { 62 xx <- c(xx, rep(xp1, length(yp))) 63 yy <- c(yy, yp) 64 zz <- c(zz, table(y)/2) 65 xx <- c(xx, xp) 66 yy <- c(yy, rep(yp1, length(xp))) 67 zz <- c(zz, table(x)/2) 68 xx <- c(xx, xp1) 69 yy <- c(yy, yp1) 70 zz <- c(zz, n) 71 } 72 73 if(symbol=="circle") { 74 ## zz <- inches*sqrt(zz/maxn) 75 zz <- sqrt(zz) 76 if(orig.scale) 77 symbols(xx,yy,circles=zz,inches=inches, 78 smo=.02,xlab=xlab,ylab=ylab,...) 79 else 80 symbols(xx,yy,circles=zz,inches=inches,smo=.02, 81 xlab=xlab,ylab=ylab,axes=FALSE,...) 82 83 title(sub=paste("n=",sum(s),sep=""),adj=0) 84 if(marginals) { 85 axis(1, at = 1:xp1, 86 labels = c(dx, "All/2"), srt=srtx, 87 adj=if(srtx>0)1 88 else .5) 89 90 axis(2, at = 1:yp1, 91 labels = c(dy, "All/2"),adj=1) 92 } else { # if(!orig.scale) { 93 axis(1, at=xp, labels=dx, srt=srtx, 94 adj=if(srtx>0)1 95 else .5) 96 97 axis(2, at=yp, labels=dy) 98 } 99 100 return(invisible()) 101 } 102 103 zz <- cbind(rep(width,length(zz)), inches*zz/maxn, rep(0,length(zz))) 104 symbols(xx,yy,thermometers=zz,inches=FALSE, 105 axes=FALSE,xlab=xlab,ylab=ylab,...) 106 title(sub=paste("n=",sum(s),sep=""),adj=0) 107 if(marginals) { 108 text(xp1-width, yp1, n, adj=1, cex=.5) 109 axis(1, at = 1:xp1, 110 labels = c(dx, "All/2"), srt=srtx, 111 adj=if(srtx>0)1 112 else .5) 113 114 axis(2, at = 1:yp1, 115 labels = c(dy, "All/2"),adj=1) 116 abline(h=yp1-.5, lty=2) 117 abline(v=xp1-.5, lty=2) 118 } else { 119 axis(1, at=xp, labels=dx, srt=srtx, 120 adj=if(srtx>0)1 121 else .5) 122 123 axis(2, at=yp, labels=dy) 124 cat("click left mouse button to position legend\n") 125 xy <- locator(1) 126 symbols(xy$x, xy$y, thermometers=cbind(width,inches*n/maxn,0), 127 inches=FALSE,add=TRUE,xlab=xlab,ylab=ylab) 128 text(xy$x-width, xy$y, n,adj=1,cex=.5) 129 } 130 131 box() 132 invisible() 133} 134