1 2##============================================================================== 3# plotmat: plots transition matrices 4##============================================================================== 5 6plotmat <- function(A, pos=NULL, curve=NULL, name=NULL, absent=0, 7 relsize=1, lwd=2, lcol="black", box.size=0.1, box.type ="circle", 8 box.prop =1, box.col="white", box.lcol=lcol, box.lwd=lwd, 9 shadow.size = 0.01, shadow.col="grey", dr=0.01, dtext= 0.3, 10 self.lwd=1, self.cex=1, self.shiftx=box.size, self.shifty=NULL, 11 self.arrpos=NULL, arr.lwd=lwd, arr.lcol=lcol, arr.tcol = lcol, 12 arr.col="black", 13 arr.type="curved", arr.pos=0.5, arr.length=0.4, arr.width=arr.length/2, 14 endhead=FALSE, mx=0.0, my=0.0, box.cex=1, 15 txt.col = "black",txt.xadj=0.5,txt.yadj=0.5, txt.font=1, 16 prefix="", cex = 1, cex.txt=cex, add = FALSE, main="", cex.main = cex, 17 segment.from = 0, segment.to = 1, latex = FALSE, ...) { 18 19 Parse <- function(x, ...) 20 if (! latex) parse(text = x, ...) else x 21 22 Rep <- function (x, ...) 23 if (is.null(x)) x else rep(x, ...) 24 25 ncomp <- nrow(A) 26 if (is.null(name)) 27 name <- rownames(A) 28 if (is.null(name)) 29 name <- colnames(A) 30 if (is.null(name)) 31 name <- 1:max(dim(A)) 32 33 # remove column names and row names 34 if (is.matrix(A)) 35 A <- matrix(nrow=nrow(A), ncol=ncol(A), data=A) 36 37 if (length (box.size) < ncomp) 38 box.size <- Rep(box.size, length.out=ncomp) 39 if (length (box.prop) < ncomp) 40 box.prop <- Rep(box.prop, length.out=ncomp) 41 if (length (box.type) < ncomp) 42 box.type <- Rep(box.type, length.out=ncomp) 43 if (length (box.col) < ncomp) 44 box.col <- Rep(box.col , length.out=ncomp) 45 if (length (box.lcol) < ncomp) 46 box.lcol <- Rep(box.lcol, length.out=ncomp) 47 if (length (box.cex) < ncomp) 48 box.cex <- Rep(box.cex , length.out=ncomp) 49 if (length (box.lwd) < ncomp) 50 box.lwd <- Rep(box.lwd , length.out=ncomp) 51 if (length (txt.col) < ncomp) 52 txt.col <- Rep(txt.col , length.out=ncomp) 53 if (length (txt.xadj) < ncomp) 54 txt.xadj <- Rep(txt.xadj, length.out=ncomp) 55 if (length (txt.yadj) < ncomp) 56 txt.yadj <- Rep(txt.yadj, length.out=ncomp) 57 if (length (txt.font) < ncomp) 58 txt.font <- Rep(txt.font, length.out=ncomp) 59 60 if (length (shadow.size) < ncomp) 61 shadow.size <- Rep(shadow.size, length.out=ncomp) 62 if (length (shadow.col) < ncomp) 63 shadow.col <- Rep(shadow.col , length.out=ncomp) 64 selflwd <- self.lwd 65 selfcex <- self.cex 66 selfarrpos <- self.arrpos 67 if (length (selfarrpos) < ncomp) 68 selfarrpos<- Rep(selfarrpos, length.out=ncomp) 69 if (length (selflwd) < ncomp) 70 selflwd<- Rep(selflwd, length.out=ncomp) 71 if (length (selfcex) < ncomp) 72 selfcex<- Rep(selfcex, length.out=ncomp) 73 if (length (self.shiftx) < ncomp) 74 self.shiftx<- Rep(self.shiftx, length.out=ncomp) 75 if (is.null(self.shifty)) 76 self.shifty <- self.shiftx*box.prop 77 if (length(self.shifty) < ncomp) 78 self.shifty<- Rep(self.shifty, length.out=ncomp) 79 if (is.null(curve)) 80 curve <- NA 81 if (length(curve)==1) 82 curve <- matrix(nrow=ncomp, ncol=ncomp, curve) 83 if (length(arr.pos)==1) 84 arr.pos <- matrix(nrow=ncomp, ncol=ncomp, arr.pos) 85 86 arrwidth <- arr.width # can be a matrix... 87 arrlength <- arr.length 88 arrlwd <- arr.lwd 89 arrlcol <- arr.lcol 90 arrtcol <- arr.tcol 91 arrcol <- arr.col 92 arrtype <- arr.type 93 cextxt <- cex.txt 94 95 if (length(arrwidth) ==1) 96 arrwidth <- matrix(nrow=ncomp, ncol=ncomp, arrwidth) 97 if (length(arrlength)==1) 98 arrlength <- matrix(nrow=ncomp, ncol=ncomp, arrlength) 99 if (length(arrlwd) ==1) 100 arrlwd <- matrix(nrow=ncomp, ncol=ncomp, arrlwd) 101 if (length(arrlcol) ==1) 102 arrlcol <- matrix(nrow=ncomp, ncol=ncomp, arrlcol) 103 if (length(arrtcol) ==1) 104 arrtcol <- matrix(nrow=ncomp, ncol=ncomp, arrtcol) 105 if (length(arrcol) ==1) 106 arrcol <- matrix(nrow=ncomp, ncol=ncomp, arrcol) 107 if (length(arrtype) ==1) 108 arrtype <- matrix(nrow=ncomp, ncol=ncomp, arrtype) 109 if (length(cextxt) ==1) 110 cextxt <- matrix(nrow=ncomp, ncol=ncomp, cextxt) 111 if (length(segment.from ) ==1) 112 seg.from <- matrix(nrow=ncomp, ncol=ncomp, segment.from) 113 if (length(segment.to ) ==1) 114 seg.to <- matrix(nrow=ncomp, ncol=ncomp, segment.to) 115 116 xlim <- c(0, 1) 117 118 if (relsize != 1) { 119 xx <- 1/relsize - 1 120 xlim <- c(-xx, 1+xx) 121 } 122 if (!add) 123 openplotmat(main=main, xlim=xlim, ylim=xlim, cex.main=cex.main) 124 125 # coordinates of boxes 126 elpos <- coordinates(pos, mx, my, ncomp, relsize=relsize) 127 if (nrow(elpos) != ncomp) 128 stop ("element position and coefficient matrix not compatible") 129 pin <- par ("pin") # size of plotting region, inches 130 131 # maximal radius of box (circle, rectangele, ...) 132 rad <- max(box.size) # relative size of circle 133 drad <- rad*dtext 134 rad2 <- rad*pin[1]/pin[2] # rad2 to make circles round 135 136 AA<-NULL 137 RR<-NULL 138 DD<-NULL 139 GG<-NULL 140 TT<-NULL # output matrices 141 142 ## ARROWS between boxes: all elements in A not equal to 'absent' 143 nonzero <- which (A != absent, arr.ind=TRUE) 144 145 if (length(nonzero)>0) { 146 for (i in 1:nrow(nonzero)) { 147 ii <- nonzero[i, ] 148 arrpos <- arr.pos[ii[1], ii[2]] 149 arr.width <- arrwidth[ii[1], ii[2]] 150 arr.length <- arrlength[ii[1], ii[2]] 151 arr.lwd <- arrlwd[ii[1], ii[2]] 152 arr.lcol <- arrlcol[ii[1], ii[2]] 153 arr.col <- arrcol[ii[1], ii[2]] 154 arr.tcol <- arrtcol[ii[1], ii[2]] 155 arr.type <- arrtype[ii[1], ii[2]] 156 cex.txt <- cextxt[ii[1], ii[2]] 157 segment <- c(seg.from[ii[1], ii[2]],seg.to[ii[1], ii[2]]) 158 pos1 <- elpos[ii[1], ] # pos to 159 pos2 <- elpos[ii[2], ] # pos from 160 dpos <- pos1-pos2 161 angle <- atan(dpos[2]/dpos[1])*180/pi # angle between both 162 txt <- paste(prefix, A[ii[1], ii[2]], sep="") # text to write 163 AA <- c(AA, angle) 164 mid <- 0.5*(pos1+pos2) # midpoint of ellipsoid arrow 165 166 if (is.nan(angle)) { # pos1=pos2: self arrow 167 rx <- rad*self.cex 168 ry <- rad2*self.cex 169 shiftx <- self.shiftx[ii[1]] 170 shifty <- self.shifty[ii[1]]*pin[1]/pin[2] 171 self.lwd <- selflwd[ii[1]] 172 self.cex <- selfcex[ii[1]] 173 self.arrpos <- selfarrpos[ii[1]] 174 mid <- mid+c(shiftx, shifty) 175 if (is.null(self.arrpos)) { 176 ifelse (shiftx < 0, meanpi <-3*pi/2, meanpi <-pi/2) 177 } else 178 meanpi <- self.arrpos 179 180 plotellipse(rx=rx, ry=ry, mid=mid, from=0, to=2*pi, 181 lwd=self.lwd, dr=dr, lcol=arr.lcol) 182 183 ell <- getellipse(rx=ry, ry=ry, mid=mid, 184 from=1.01*meanpi, to=0.99*meanpi, dr=-0.002) 185 Arrows(ell[1,1], ell[1,2], ell[nrow(ell),1], ell[nrow(ell),2], 186 arr.col=arr.col, lcol=arr.lcol, arr.length=arr.length*0.5, 187 arr.width=arr.width, lwd=arr.lwd, arr.type=arr.type) 188 DD <- rbind(DD, c(ell[nrow(ell), 1], ell[nrow(ell), 2])) 189 190 if(cex.txt>0 && txt!= "") 191 text(mid[1], mid[2], Parse(txt), adj=c(0.5, 0.5), cex=cex.txt, col=arr.tcol) 192 TT <- rbind(TT, c(mid[1], mid[2], 0.5, 0.5)) 193 cycle 194 195 } else { # arrow between different components 196 dst <- dist(rbind(pos1, pos2)) 197 ry <- curve[ii[1], ii[2]]*dst 198 if (is.na(ry)) 199 ry<-rad*dst 200 201 ifelse (angle<0, xadj <- 0, xadj <-1) 202 ifelse (angle<0, yadj <- 0, yadj <-0.5) 203 if (angle == 0) { 204 xadj= 0.5 205 yadj=0 206 } 207 208 adj <- c(xadj, yadj) 209 if (ry==0) { # straight line 210 mid1<-straightarrow (from=pos2, to=pos1, lwd=arr.lwd, 211 arr.type=arr.type, arr.length=arr.length, 212 arr.pos=arrpos, arr.width=arr.width, 213 arr.col=arr.col, lcol=arr.lcol, 214 endhead=endhead, segment = segment) 215 216 DD <- rbind(DD, mid1) 217 if (angle>0) adj=c(0, 1) 218 mpos <- mid1- (adj-0.5)* drad 219 220 if(cex.txt>0&& txt!= "") 221 text(mpos[1], mpos[2], Parse(txt), adj=adj, cex=cex.txt, col=arr.tcol) 222 TT <- rbind(TT, c(mpos[1], mpos[2], adj)) 223 } else { # curved line 224 225 from <- 0 226 to <- pi 227 if (pos2[1]==pos1[1] & pos2[2]>pos1[2]) 228 adj <- c(1 , 1) 229 if (pos2[1]==pos1[1] & pos2[2]<pos1[2]) 230 adj <- c(0 , 1) 231 if (pos2[1]<=pos1[1]) { 232 from <- pi 233 to <- 2*pi 234 } 235 if (pos2[1] < pos1[1] & angle>=0) 236 adj <- c(0 , 1) 237 if (pos2[1] < pos1[1] & angle<0) 238 adj <- c(1 , 0) 239 if (segment [1] != 0) 240 From <- segment[1] * to + (1-segment[1]) * from 241 else 242 From <- from 243 244 if (segment [2] != 1) 245 To <- segment[2] * to + (1-segment[2]) * from 246 else 247 To <- to 248 249 meanpi <- arrpos * to+ (1-arrpos) * from 250 if (endhead) To<-meanpi 251 252 plotellipse(rx=dst/2, ry=ry, mid=mid, angle=angle, from=From, 253 to=To, lwd=arr.lwd, dr=dr, lcol=arr.lcol) 254 ell <- getellipse(rx=dst/2, ry=ry, mid=mid, angle=angle, 255 from=1.001*meanpi, to=0.999*meanpi, dr=-0.002) 256 Arrows(ell[1,1], ell[1,2], ell[nrow(ell),1], ell[nrow(ell),2], 257 arr.col=arr.col,lcol=arr.lcol, code=1, arr.length=arr.length, 258 arr.width=arr.width, lwd=arr.lwd, arr.type=arr.type) 259 DD <- rbind(DD, c(ell[nrow(ell),1], ell[nrow(ell),2])) 260 ell <- getellipse(rx=dst/2, ry=ry+drad, mid=mid, angle=angle, 261 from=meanpi, to=meanpi) 262 if(cex.txt>0 && txt!= "") 263 text(ell[1,1], ell[1,2], Parse(txt), adj=adj, cex=cex.txt, col=arr.tcol) 264 TT <- rbind(TT, c(ell[1, 1], ell[1, 2], adj)) 265 } 266 } # end i 267 GG <- c (GG, txt) 268 RR <- c (RR, ry)} 269 270 } # end length (nonzero) 271 272 ## BOXES 273 radii <- NULL 274 for (i in 1:nrow(A)) { 275 p <- elpos[i, ] 276 # radius of box (circle) 277 rad <- box.size[i] # relative size of circle 278 rad2 <- rad*pin[1]/pin[2]*box.prop[i] # used to make circles round 279 radii <- rbind(radii, c(rad, rad2)) 280 281 shadowbox(box.type=box.type[i], mid=p, radx=rad, rady=rad2, 282 lcol=box.lcol[i], lwd=box.lwd[i], shadow.size=shadow.size[i], 283 shadow.col=shadow.col[i], box.col=box.col[i], dr=dr, ...) 284 textplain(mid=p, height=rad2, lab=name[i], cex=box.cex[i], col=txt.col[i], 285 adj = c(txt.xadj[i], txt.yadj[i]), font = txt.font[i]) 286 287 } # end i 288 289 rect <- cbind(elpos-radii, elpos+radii) 290 colnames(elpos) <- colnames(radii) <- c("x", "y") 291 colnames(rect) <- c("xleft", "ybot", "xright", "ytop") 292 plotmat <-list (arr=data.frame(nonzero, Angle=AA, Value=GG, rad=RR, 293 ArrowX=DD[,1], ArrowY=DD[,2], 294 TextX=TT[,1], TextY=TT[,2]), 295 comp=elpos, radii=radii, rect=rect) 296} # end function PLOTMAT 297 298