File: table.value.R

package info (click to toggle)
r-cran-ade4 1.7-5-1
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 7,924 kB
  • ctags: 92
  • sloc: ansic: 4,890; makefile: 2
file content (208 lines) | stat: -rw-r--r-- 7,350 bytes parent folder | download | duplicates (5)
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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
"table.prepare" <- function (x, y, row.labels, col.labels, clabel.row, clabel.col,
                             grid, pos) 
{
  cexrow <- par("cex") * clabel.row
  cexcol <- par("cex") * clabel.col
  wx <- range(x)
  wy <- range(y)
  maxx <- max(x)
  maxy <- max(y)
  minx <- min(x)
  miny <- min(y)
  dx <- diff(wx)/(length(x))
  dy <- diff(wy)/(length(y))
  if (cexrow > 0) {
    ## ncar <- max(nchar(paste(" ", row.labels, " ", sep = "")))
    ## strx <- par("cin")[1] * ncar * cexrow/2 + 0.1
    strx <- max(strwidth(paste(" ", row.labels, " ", sep = ""), units = "inches", cex=cexrow))
  }
  else strx <- 0.1
  if (cexcol > 0) {
    ##ncar <- max(nchar(paste(" ", col.labels, " ", sep = "")))
    ##stry <- par("cin")[1] * ncar * cexcol/2 + 0.1
    stry <- max(strwidth(paste(" ", col.labels, " ", sep = ""), units = "inches", cex=cexcol))
  }
  else stry <- 0.1
  if (pos == "righttop") {
    par(mai = c(0.1, 0.1, stry, strx))
    xlim <- wx + c(-dx, 2 * dx)
    ylim <- wy + c(-2 * dy, 2 * dy)
    plot.default(0, 0, type = "n", xlab = "", ylab = "", 
                 xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, 
                 xaxs = "i", yaxs = "i", frame.plot = FALSE)
    if (cexrow > 0) {
      for (i in 1:length(y)) {
        ynew <- seq(miny, maxy, le = length(y))
        ynew <- ynew[rank(y)]
        text(maxx + 2 * dx, ynew[i], row.labels[i], adj = 0, 
             cex = cexrow, xpd = NA)
        segments(maxx + 2 * dx, ynew[i], maxx + dx, y[i])
      }
    }
    if (cexcol > 0) {
      par(srt = 90)
      for (i in 1:length(x)) {
        xnew <- seq(minx, maxx, le = length(x))
        xnew <- xnew[rank(x)]
        text(xnew[i], maxy + 2 * dy, col.labels[i], adj = 0, 
             cex = cexcol, xpd = NA)
        segments(xnew[i], maxy + 2 * dy, x[i], maxy + 
                 dy)
      }
      par(srt = 0)
    }
    if (grid) {
      col <- "lightgray"
      for (i in 1:length(y)) segments(maxx + dx, y[i], 
                                      minx - dx, y[i], col = col)
      for (i in 1:length(x)) segments(x[i], miny - dy, 
                                      x[i], maxy + dy, col = col)
    }
    rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
    return(invisible())
  }
  if (pos == "phylog") {
    par(mai = c(0.1, 0.1, stry, strx))
    xlim <- wx + c(-dx, 2 * dx)
    ylim <- wy + c(-dy, 2 * dy)
    plot.default(0, 0, type = "n", xlab = "", ylab = "", 
                 xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, 
                 xaxs = "i", yaxs = "i", frame.plot = FALSE)
    if (cexrow > 0) {
      for (i in 1:length(y)) {
        ynew <- seq(miny, maxy, le = length(y))
        ynew <- ynew[rank(y)]
        text(maxx + 2 * dx, ynew[i], row.labels[i], adj = 0, 
             cex = cexrow, xpd = NA)
        segments(maxx + 2 * dx, ynew[i], maxx + dx, y[i])
      }
    }
    if (cexcol > 0) {
      par(srt = 90)
      xnew <- x[2:length(x)]
      x <- xnew
      for (i in 1:length(x)) {
        text(xnew[i], maxy + 2 * dy, col.labels[i], adj = 0, 
             cex = cexcol, xpd = NA)
        segments(xnew[i], maxy + 2 * dy, x[i], maxy + 
                 dy)
      }
      par(srt = 0)
    }
    minx <- min(x)
    if (grid) {
      col <- "lightgray"
      for (i in 1:length(y)) segments(maxx + dx, y[i], 
                                      minx - dx, y[i], col = col)
      for (i in 1:length(x)) segments(x[i], miny - dy, 
                                      x[i], maxy + dy, col = col)
    }
    rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
    rect(-dx, miny - dy, minx - dx, maxy + dy)
    return(c(0, minx - dx))
  }
  if (pos == "leftbottom") {
    par(mai = c(stry, strx, 0.05, 0.05))
    xlim <- wx + c(-2 * dx, dx)
    ylim <- wy + c(-2 * dy, dy)
    plot.default(0, 0, type = "n", xlab = "", ylab = "", 
                 xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, 
                 xaxs = "i", yaxs = "i", frame.plot = FALSE)
    if (cexrow > 0) {
      for (i in 1:length(y)) {
        ynew <- seq(miny, maxy, le = length(y))
        ynew <- ynew[rank(y)]
        w9 <- strwidth(row.labels[i], cex = cexrow)
        text(minx - w9 - 2 * dx, ynew[i], row.labels[i], 
             adj = 0, cex = cexrow, xpd = NA)
        segments(minx - 2 * dx, ynew[i], minx - dx, y[i])
      }
    }
    if (cexcol > 0) {
      par(srt = -90)
      for (i in 1:length(x)) {
        xnew <- seq(minx, maxx, le = length(x))
        xnew <- xnew[rank(x)]
        text(xnew[i], miny - 2 * dy, col.labels[i], adj = 0, 
             cex = cexcol, xpd = NA)
        segments(xnew[i], miny - 2 * dy, x[i], miny - 
                 dy)
      }
      par(srt = 0)
    }
    if (grid) {
      col <- "lightgray"
      for (i in 1:length(y)) segments(maxx + 2 * dx, y[i], 
                                      minx - dx, y[i], col = col)
      for (i in 1:length(x)) segments(x[i], miny - 2 * 
                                      dy, x[i], maxy + dy, col = col)
    }
    rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
    return(invisible())
  }
  if (pos == "paint") {
    
    dx <- diff(wx)/(length(x) - 1)/2
    dy <- diff(wy)/(length(y) - 1)/2

    par(mai = c(0.2, strx, stry, 0.1))
    xlim <- wx + c(-dx, dx)
    ylim <- wy + c(-dy, dy)
    plot.default(0, 0, type = "n", xlab = "", ylab = "", 
                 xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, 
                 xaxs = "i", yaxs = "i", frame.plot = TRUE)
    if (cexrow > 0) {
      ynew <- seq(miny, maxy, le = length(y))
      ynew <- ynew[rank(y)]
      ##w9 <- strwidth(row.labels, cex = cexrow)
      ##text(minx - w9 - 3 * dx/4, ynew, row.labels, adj = 0, cex = cexrow, xpd = NA)
      mtext(at =  ynew, side = 2, text = paste(row.labels," ", sep = ""), adj = 1, cex = cexrow, las = 1)
    }
    if (cexcol > 0) {
      xnew <- seq(minx, maxx, le = length(x))
      xnew <- xnew[rank(x)]
      ## par(srt = 90)
      ## text(xnew, maxy + 3 * dy/4, col.labels, adj = 0, cex = cexcol, xpd = NA)
      mtext(at = xnew, side = 3, text = paste(" ", col.labels, sep = ""), adj = 0, cex = cexcol, las = 2)
      par(srt = 0)
    }
    return(invisible())
  }
}


"table.value" <- function (df, x = 1:ncol(df), y = nrow(df):1, row.labels = row.names(df),
                           col.labels = names(df), clabel.row = 1, clabel.col = 1, csize = 1, 
                           clegend = 1, grid = TRUE) 
{
  opar <- par(mai = par("mai"), srt = par("srt"))
  on.exit(par(opar))
  table.prepare(x = x, y = y, row.labels = row.labels, col.labels = col.labels, 
                clabel.row = clabel.row, clabel.col = clabel.col, grid = grid, 
                pos = "righttop")
  xtot <- x[col(as.matrix(df))]
  ytot <- y[row(as.matrix(df))]
  coeff <- diff(range(xtot))/15
  z <- unlist(df)
  sq <- sqrt(abs(z))
  w1 <- max(sq)
  sq <- csize * coeff * sq/w1
  for (i in 1:length(z)) {
    if (sign(z[i]) >= 0) {
      symbols(xtot[i], ytot[i], squares = sq[i], bg = 1, 
              fg = 0, add = TRUE, inches = FALSE)
    }
    else {
      symbols(xtot[i], ytot[i], squares = sq[i], bg = "white", 
              fg = 1, add = TRUE, inches = FALSE)
    }
  }
  br0 <- pretty(z, 4)
  l0 <- length(br0)
  br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
  sq0 <- sqrt(abs(br0))
  sq0 <- csize * coeff * sq0/w1
  sig0 <- sign(br0)
  if (clegend > 0) 
    scatterutil.legend.bw.square(br0, sq0, sig0, clegend)
}