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
|
intersectDiagram<-function(x,pct=FALSE,show.nulls=FALSE,xnames=NULL,
sep="+",mar=c(0,0,3,0),main="Intersection Diagram",cex=1,col=NULL,
minspacing=NA,all.intersections=FALSE,include=NULL,
null.label="Non-set") {
matchParts<-function(x,table,ignore.case=TRUE) {
for(pattern in 1:length(x)) {
match_index<-grep(x[pattern],table,ignore.case=ignore.case)
if(length(match_index)) return(match_index)
}
return(0)
}
if(!inherits(x,"intersectList")) {
if(is.matrix(x) || is.data.frame(x)) {
if(is.data.frame(x))
x<-as.matrix(x)
x<-makeIntersectList(x,xnames=xnames,sep=sep)
}
if(!inherits(x,"intersectList"))
stop("x must be a matrix, data frame or intersectList")
}
oldmar<-par("mar")
par(mar=mar)
# attribute labels
attributes<-x[[length(x)]]
# get all the names for the individual attributes
if(is.null(include)) include<-attributes
# total number of attributes
nattributes<-length(attributes)
# peel off the number of objects and the attributes for display
x[[length(x)]]<-NULL
nobjects<-x[[length(x)]]
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<-ifelse(nobjects > objectsums[maxlevel],
nobjects,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("[",sep,"]",sep="")
# display the empty plot
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
# now step through the intersections in this level
for(intersect in 1:length(intersections)) {
# check if this intersection is to be displayed
if(matchParts(include,blocknames[intersect])) {
# 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 for this rectangle
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]
# start at the left edge of the sliced rectangle
offset<-0
# step through the slices
for(slice in 1:ncol) {
# first draw the 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 left edge of the next slice
offset<-offset+xinc
}
# draw a box around the sliced 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 for this rectangle
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 or no attributes
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(null.label,nonset,sep="\n"),cex=cex)
}
# restore the original plot parameters
par(mar=oldmar)
# stick the number of objects and attributes back on
x[[length(x) + 1]]<-nobjects
x[[length(x) + 1]]<-attributes
invisible(x)
}
|
