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
|
intersectDiagram<-function(x,pct=FALSE,show.nulls=FALSE,xnames=NULL,
namesep="+",mar=c(0,0,3,0),main="Intersection Diagram",cex=1,
col=NULL,minspacing=NA,all.intersections=FALSE) {
if(!match(class(x),"intersectList",0)) {
if(is.matrix(x) || is.data.frame(x)) {
if(is.data.frame(x)) x<-as.matrix(x)
x<-makeIntersectList(x,xnames=xnames,sep=namesep)
}
if(!match(class(x),"intersectList",0))
stop("x must be a matrix, data frame or intersectList")
}
oldmar<-par("mar")
par(mar=mar)
# attribute labels
attributes<-x[[length(x)]]
# total number of attributes
nattributes<-length(attributes)
# get rid of the attribute labels
x[[length(x)]]<-NULL
# total number of objects
nobjects<-x[[length(x)]]
# get rid of the total number of objects
x[[length(x)]]<-NULL
# number of intersection levels with at least one object
nlevels<-length(x)
# if no colors specified, use rainbow
if(is.null(col)) col<-c(rainbow(nattributes),NA)
else if(length(col) < nattributes) col<-rep(col,length.out=nattributes)
# total number of objects for each intersection level
objectsums<-sapply(x,sum)
# index of level with the most objects
maxlevel<-which.max(objectsums)
nNonZero<-function(x) return(sum(x>0))
# number of intersections with at least one member for each intersection level
# or all intersections if the somewhat dangerous "show everything" option is TRUE
if(all.intersections) nintersects<-sapply(x,length)
else nintersects<-sapply(x,nNonZero)
# maximum number of intersections in a given level
maxintersections<-max(nintersects)
# largest intersection set in x
maxn<-max(unlist(x))
# default to a minimum spacing of one tenth of the largest intersection set
if(is.na(minspacing)) minspacing<-0.1*maxn
# x limit that will hold the maximum number of objects and allow
# spacing for the maximum number of intersections in units of objects
maxx<-objectsums[maxlevel]+minspacing*maxintersections
# have to escape the separator in case it is "+" (default) or
# some other character that means something to some function
attsep<-paste("[",namesep,"]",sep="")
plot(0,xlim=c(0,maxx),ylim=c(0,nlevels+show.nulls),
main=main,xlab="",ylab="",type="n",axes=FALSE)
# step through each level of intersections
for(level in 1:nlevels) {
# determine the intersect level by the number of elements in the first name
intersectLevel<-length(unlist(strsplit(names(x[[level]][1]),attsep)))
# indices of intersections with at least one object in this level
# or just all of the intersections
if(all.intersections) intersections<-1:nintersects[[level]]
else intersections<-which(x[[level]] > 0)
# get all the names in this level with at least one object
blocknames<-names(x[[level]])[intersections]
# spacing between intersection sets in object units
spacing<-(maxx-objectsums[level])/nintersects[level]
# left edges of the rectangles in x positions
leftx<-c(0,cumsum(x[[level]][intersections]+spacing))+spacing/2
for(intersect in 1:length(intersections)) {
# make the label for the intersection
cellqnt<-ifelse(pct,
paste(round(100*x[[level]][intersections[intersect]]/nobjects,1),
"%",sep=""),
x[[level]][intersections[intersect]])
# indices of the colors to use
colindex<-
which(attributes %in% unlist(strsplit(blocknames[intersect],attsep)))
# number of colors
ncol<-length(colindex)
# width of each color slice
xinc<-x[[level]][intersections[intersect]]/ncol
# colors for the slices
slicecol<-col[colindex]
# offset for each successive slice
offset<-0
# step through the slices
for(slice in 1:ncol) {
# draw a rectangle with no border
rect(leftx[intersect]+offset,nlevels-level+show.nulls+0.1,
leftx[intersect]+offset+xinc,nlevels-level+show.nulls+0.9,
col=slicecol[slice],border=NA)
# move to the next slice
offset<-offset+xinc
}
# draw a box around the intersection rectangle
rect(leftx[intersect],nlevels-level+show.nulls+0.1,
leftx[intersect]+x[[level]][intersections[intersect]],
nlevels-level+show.nulls+0.9)
# display the label
boxed.labels(leftx[intersect]+x[[level]][intersections[intersect]]/2,
nlevels-level+show.nulls+0.5,paste(blocknames[intersect],
cellqnt,sep="\n"),cex=cex)
}
}
if(show.nulls) {
# number of objects with no set membership
nonset<-as.numeric(nobjects-sum(objectsums))
# left edge of the rectangle
leftnulls<-sum(par("usr")[1:2])/2-nonset/2
# draw the rectangle
if(nonset) rect(leftnulls,0.1,leftnulls+nonset,0.9)
# center of the rectangle
xpos<-leftnulls+nonset/2
# display the label
if(pct) nonset<-paste(round(100*nonset/nobjects,1),"%",sep="")
boxed.labels(xpos,0.5,paste("Non-members",nonset,sep="\n"),cex=cex)
}
par(mar = oldmar)
x[[length(x)+1]]<-nobjects
x[[length(x)+1]]<-nattributes
invisible(x)
}
|
