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