File: symbol.freq.s

package info (click to toggle)
hmisc 4.2-0-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 3,332 kB
  • sloc: asm: 27,116; fortran: 606; ansic: 411; xml: 160; makefile: 2
file content (133 lines) | stat: -rw-r--r-- 3,264 bytes parent folder | download | duplicates (8)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
## marginals applies only to symbol="therm", orig.scale to symbol="circle"

symbol.freq <- function(x, y, symbol=c("thermometer","circle"), 
                        marginals=FALSE, orig.scale=FALSE,
                        inches=.25, width=.15, subset, srtx=0, ...)
{
  symbol <- match.arg(symbol)
  if(missing(subset))
    subset <- rep(TRUE, length(x))

  if(!is.logical(subset)) {
	s <- rep(FALSE,length(x))
	s[subset] <- FALSE
	subset <- s
  }

  xlab <- attr(x,'label')
  if(!length(xlab))
    xlab <- as.character(substitute(x))

  ylab <- attr(y,'label')
  if(!length(ylab))
    ylab <- as.character(substitute(y))
  
  s <- !(is.na(x) | is.na(y)) & subset
  x <- x[s]
  y <- y[s]
  f <- table(x, y)
  dx <- dimnames(f)[[1]]
  dy <- dimnames(f)[[2]]
  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,xlab=xlab,ylab=ylab,...)
    else
      symbols(xx,yy,circles=zz,inches=inches,smo=.02,
              xlab=xlab,ylab=ylab,axes=FALSE,...)

    title(sub=paste("n=",sum(s),sep=""),adj=0)
    if(marginals) {
      axis(1, at = 1:xp1, 
           labels = c(dx, "All/2"), srt=srtx,
           adj=if(srtx>0)1
           else .5)
      
      axis(2, at = 1:yp1, 
           labels = c(dy, "All/2"),adj=1)
    } else { #	if(!orig.scale) {
      axis(1, at=xp, labels=dx, srt=srtx,
           adj=if(srtx>0)1
           else .5)
      
      axis(2, at=yp, labels=dy)
    }

    return(invisible())
  }

  zz <- cbind(rep(width,length(zz)), inches*zz/maxn, rep(0,length(zz)))
  symbols(xx,yy,thermometers=zz,inches=FALSE,
          axes=FALSE,xlab=xlab,ylab=ylab,...) 
  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, 
         labels = c(dx, "All/2"), srt=srtx,
         adj=if(srtx>0)1
         else .5)
    
    axis(2, at = 1:yp1, 
         labels = c(dy, "All/2"),adj=1)
    abline(h=yp1-.5, lty=2)
    abline(v=xp1-.5, lty=2)
  } else {
    axis(1, at=xp, labels=dx, srt=srtx,
         adj=if(srtx>0)1
         else .5)
    
    axis(2, at=yp, labels=dy)
    cat("click left mouse button to position legend\n")
    xy <- locator(1)
    symbols(xy$x, xy$y, thermometers=cbind(width,inches*n/maxn,0), 
            inches=FALSE,add=TRUE,xlab=xlab,ylab=ylab)
    text(xy$x-width, xy$y, n,adj=1,cex=.5)
  }

  box()
  invisible()
}