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
|
pyramid.plot<-function (lx, rx, labels = NA, top.labels = c("Male", "Age",
"Female"), main = "", laxlab = NULL, raxlab = NULL, unit = "%",
lxcol, rxcol, gap = 1, space = 0.2, ppmar = c(4, 2, 4, 2),
labelcex = 1, add = FALSE, xlim, show.values = FALSE, ndig = 1,
do.first = NULL) {
if (any(c(lx, rx) < 0, na.rm = TRUE))
stop("Negative quantities not allowed")
lxdim <- dim(lx)
rxdim <- dim(rx)
ncats <- ifelse(!is.null(lxdim), dim(lx)[1], length(lx))
if (length(labels) == 1)
labels <- 1:ncats
ldim <- length(dim(labels))
nlabels <- ifelse(ldim, length(labels[, 1]), length(labels))
if (nlabels != ncats)
stop("lx and labels must all be the same length")
if (missing(xlim))
xlim <- rep(ifelse(!is.null(lxdim), ceiling(max(c(rowSums(lx),
rowSums(rx)), na.rm = TRUE)), ceiling(max(c(lx, rx),
na.rm = TRUE))), 2)
if (!is.null(laxlab) && xlim[1] < max(laxlab))
xlim[1] <- max(laxlab)
if (!is.null(raxlab) && xlim[2] < max(raxlab))
xlim[2] <- max(raxlab)
oldmar <- par("mar")
if (!add) {
par(mar = ppmar, cex.axis = labelcex)
plot(0, xlim = c(-(xlim[1] + gap), xlim[2] + gap), ylim = c(0,
ncats + 1), type = "n", axes = FALSE, xlab = "",
ylab = "", xaxs = "i", yaxs = "i", main = main)
if (!is.null(do.first))
eval(parse(text = do.first))
if (is.null(laxlab)) {
laxlab <- seq(xlim[1] - gap, 0, by = -1)
axis(1, at = -xlim[1]:-gap, labels = laxlab)
}
else axis(1, at = -(laxlab + gap), labels = laxlab)
if (is.null(raxlab)) {
raxlab <- 0:(xlim[2] - gap)
axis(1, at = gap:xlim[2], labels = raxlab)
}
else axis(1, at = raxlab + gap, labels = raxlab)
if (gap > 0) {
if (!is.null(lxdim))
axis(2, at = 1:ncats, labels = rep("", ncats),
pos = gap, tcl = -0.25)
else axis(2, at = 1:ncats * as.logical(rx + 1), labels = rep("",
ncats), pos = gap, tcl = -0.25)
if (!is.null(lxdim))
axis(4, at = 1:ncats, labels = rep("", ncats),
pos = -gap, tcl = -0.25)
else axis(4, at = 1:ncats * as.logical(lx + 1), labels = rep("",
ncats), pos = -gap, tcl = -0.25)
}
if (is.null(dim(labels))) {
if (gap)
text(0, 1:ncats, labels, cex = labelcex)
else {
text(xlim[1], 1:ncats, labels, cex = labelcex,
adj = 0)
text(xlim[2], 1:ncats, labels, cex = labelcex,
adj = 1)
}
}
else {
if (gap) {
lpos <- -gap
rpos <- gap
}
else {
lpos <- -xlim[1]
rpos <- xlim[2]
}
text(lpos, 1:ncats, labels[, 1], pos = 4, cex = labelcex,
adj = 0)
text(rpos, 1:ncats, labels[, 2], pos = 2, cex = labelcex,
adj = 1)
}
cat(xlim,"\n")
mtext(top.labels,side=3,line=0,
at=c(-(xlim[1]+gap)/2,0,(xlim[2]+gap)/2),
adj = 0.5, cex = labelcex)
if(length(unit) == 1) mtext(unit,1,2.5,at=0,cex=labelcex)
else
mtext(c(unit,unit),1,2.5,at=c(-(xlim[1]+gap)/2,(xlim[2]+gap)/2),
cex=labelcex)
}
halfwidth <- 0.5 - space/2
if (is.null(lxdim)) {
if (missing(lxcol))
lxcol <- rainbow(ncats)
if (missing(rxcol))
rxcol <- rainbow(ncats)
rect(-(lx + gap), 1:ncats - halfwidth, rep(-gap, ncats),
1:ncats + halfwidth, col = lxcol)
rect(rep(gap, ncats), 1:ncats - halfwidth, (rx + gap),
1:ncats + halfwidth, col = rxcol)
if (show.values) {
par(xpd = TRUE)
lxt <- formatC(lx, format = "f", digits = ndig)
rxt <- formatC(rx, format = "f", digits = ndig)
text(-(gap + lx), 1:ncats, lxt, pos = 2, cex = labelcex)
text(gap + rx, 1:ncats, rxt, pos = 4, cex = labelcex)
par(xpd = FALSE)
}
}
else {
nstack <- dim(lx)[2]
if (missing(lxcol))
lxcol <- rainbow(nstack)
if (missing(rxcol))
rxcol <- rainbow(nstack)
lxstart <- rxstart <- rep(gap, ncats)
for (i in 1:nstack) {
lxcolor <- rep(lxcol[i], ncats)
rxcolor <- rep(rxcol[i], ncats)
rect(-(lx[, i] + lxstart), 1:ncats - halfwidth, -lxstart,
1:ncats + halfwidth, col = lxcolor)
rect(rxstart, 1:ncats - halfwidth, rx[, i] + rxstart,
1:ncats + halfwidth, col = rxcolor)
lxstart <- lx[, i] + lxstart
rxstart <- rx[, i] + rxstart
}
}
return(oldmar)
}
|
