1# IGraph R package 2# Copyright (C) 2003-2012 Gabor Csardi <csardi.gabor@gmail.com> 3# 334 Harvard street, Cambridge, MA 02139 USA 4 5# This program is free software; you can redistribute it and/or modify 6# it under the terms of the GNU General Public License as published by 7# the Free Software Foundation; either version 2 of the License, or 8# (at your option) any later version. 9# 10# This program is distributed in the hope that it will be useful, 11# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# GNU General Public License for more details. 14# 15# You should have received a copy of the GNU General Public License 16# along with this program; if not, write to the Free Software 17# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 18# 02110-1301 USA 19# 20################################################################### 21 22 23 24#' Plotting of graphs 25#' 26#' \code{plot.igraph} is able to plot graphs to any R device. It is the 27#' non-interactive companion of the \code{tkplot} function. 28#' 29#' One convenient way to plot graphs is to plot with \code{\link{tkplot}} 30#' first, handtune the placement of the vertices, query the coordinates by the 31#' \code{\link{tk_coords}} function and use them with \code{plot} to 32#' plot the graph to any R device. 33#' 34#' @aliases plot.graph 35#' @param x The graph to plot. 36#' @param axes Logical, whether to plot axes, defaults to FALSE. 37#' @param add Logical scalar, whether to add the plot to the current device, or 38#' delete the device's current contents first. 39#' @param xlim The limits for the horizontal axis, it is unlikely that you want 40#' to modify this. 41#' @param ylim The limits for the vertical axis, it is unlikely that you want 42#' to modify this. 43#' @param mark.groups A list of vertex id vectors. It is interpreted as a set 44#' of vertex groups. Each vertex group is highlighted, by plotting a colored 45#' smoothed polygon around and \dQuote{under} it. See the arguments below to 46#' control the look of the polygons. 47#' @param mark.shape A numeric scalar or vector. Controls the smoothness of the 48#' vertex group marking polygons. This is basically the \sQuote{shape} 49#' parameter of the \code{\link[graphics]{xspline}} function, its possible 50#' values are between -1 and 1. If it is a vector, then a different value is 51#' used for the different vertex groups. 52#' @param mark.col A scalar or vector giving the colors of marking the 53#' polygons, in any format accepted by \code{\link[graphics]{xspline}}; e.g. 54#' numeric color ids, symbolic color names, or colors in RGB. 55#' @param mark.border A scalar or vector giving the colors of the borders of 56#' the vertex group marking polygons. If it is \code{NA}, then no border is 57#' drawn. 58#' @param mark.expand A numeric scalar or vector, the size of the border around 59#' the marked vertex groups. It is in the same units as the vertex sizes. If a 60#' vector is given, then different values are used for the different vertex 61#' groups. 62#' @param \dots Additional plotting parameters. See \link{igraph.plotting} for 63#' the complete list. 64#' @return Returns \code{NULL}, invisibly. 65#' @author Gabor Csardi \email{csardi.gabor@@gmail.com} 66#' @seealso \code{\link{layout}} for different layouts, 67#' \code{\link{igraph.plotting}} for the detailed description of the plotting 68#' parameters and \code{\link{tkplot}} and \code{\link{rglplot}} for other 69#' graph plotting functions. 70#' @method plot igraph 71#' @export 72#' @export plot.igraph 73#' @importFrom grDevices rainbow 74#' @importFrom graphics plot polygon text par 75#' @keywords graphs 76#' @examples 77#' 78#' g <- make_ring(10) 79#' plot(g, layout=layout_with_kk, vertex.color="green") 80#' 81plot.igraph <- function(x, 82 # SPECIFIC: ##################################### 83 axes=FALSE, add=FALSE, 84 xlim=c(-1,1), ylim=c(-1,1), 85 mark.groups=list(), mark.shape=1/2, 86 mark.col=rainbow(length(mark.groups), alpha=0.3), 87 mark.border=rainbow(length(mark.groups), alpha=1), 88 mark.expand=15, 89 ...) { 90 91 graph <- x 92 if (!is_igraph(graph)) { 93 stop("Not a graph object") 94 } 95 96 vc <- vcount(graph) 97 98 ################################################################ 99 ## Visual parameters 100 params <- i.parse.plot.params(graph, list(...)) 101 vertex.size <- 1/200 * params("vertex", "size") 102 label.family <- params("vertex", "label.family") 103 label.font <- params("vertex", "label.font") 104 label.cex <- params("vertex", "label.cex") 105 label.degree <- params("vertex", "label.degree") 106 label.color <- params("vertex", "label.color") 107 label.dist <- params("vertex", "label.dist") 108 labels <- params("vertex", "label") 109 shape <- igraph.check.shapes(params("vertex", "shape")) 110 111 edge.color <- params("edge", "color") 112 edge.width <- params("edge", "width") 113 edge.lty <- params("edge", "lty") 114 arrow.mode <- params("edge", "arrow.mode") 115 edge.labels <- params("edge", "label") 116 loop.angle <- params("edge", "loop.angle") 117 edge.label.font <- params("edge", "label.font") 118 edge.label.family <- params("edge", "label.family") 119 edge.label.cex <- params("edge", "label.cex") 120 edge.label.color <- params("edge", "label.color") 121 elab.x <- params("edge", "label.x") 122 elab.y <- params("edge", "label.y") 123 arrow.size <- params("edge", "arrow.size")[1] 124 arrow.width <- params("edge", "arrow.width")[1] 125 curved <- params("edge", "curved") 126 if (is.function(curved)) { curved <- curved(graph) } 127 128 layout <- params("plot", "layout") 129 margin <- params("plot", "margin") 130 margin <- rep(margin, length=4) 131 rescale <- params("plot", "rescale") 132 asp <- params("plot", "asp") 133 frame <- params("plot", "frame") 134 main <- params("plot", "main") 135 sub <- params("plot", "sub") 136 xlab <- params("plot", "xlab") 137 ylab <- params("plot", "ylab") 138 139 palette <- params("plot", "palette") 140 if (!is.null(palette)) { 141 old_palette <- palette(palette) 142 on.exit(palette(old_palette), add = TRUE) 143 } 144 145 # the new style parameters can't do this yet 146 arrow.mode <- i.get.arrow.mode(graph, arrow.mode) 147 148 ################################################################ 149 ## create the plot 150 maxv <- max(vertex.size) 151 if (vc > 0 && rescale) { 152 # norm layout to (-1, 1) 153 layout <- norm_coords(layout, -1, 1, -1, 1) 154 xlim <- c(xlim[1]-margin[2]-maxv, xlim[2]+margin[4]+maxv) 155 ylim <- c(ylim[1]-margin[1]-maxv, ylim[2]+margin[3]+maxv) 156 } 157 if (!add) { 158 plot(0, 0, type="n", xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, 159 axes=axes, frame=frame, asp=asp, main=main, sub=sub) 160 } 161 162 ################################################################ 163 ## Mark vertex groups 164 if (!is.list(mark.groups) && is.numeric(mark.groups)) { 165 mark.groups <- list(mark.groups) 166 } 167 168 mark.shape <- rep(mark.shape, length=length(mark.groups)) 169 mark.border <- rep(mark.border, length=length(mark.groups)) 170 mark.col <- rep(mark.col, length=length(mark.groups)) 171 mark.expand <- rep(mark.expand, length=length(mark.groups)) 172 173 for (g in seq_along(mark.groups)) { 174 v <- V(graph)[mark.groups[[g]]] 175 if (length(vertex.size)==1) { 176 vs <- vertex.size 177 } else { 178 vs <- rep(vertex.size, length=vcount(graph))[v] 179 } 180 igraph.polygon(layout[v,,drop=FALSE], 181 vertex.size=vs, 182 expand.by=mark.expand[g]/200, 183 shape=mark.shape[g], 184 col=mark.col[g], 185 border=mark.border[g]) 186 } 187 188 ################################################################ 189 ## calculate position of arrow-heads 190 el <- as_edgelist(graph, names=FALSE) 191 loops.e <- which(el[,1] == el[,2]) 192 nonloops.e <- which(el[,1] != el[,2]) 193 loops.v <- el[,1] [loops.e] 194 loop.labels <- edge.labels[loops.e] 195 loop.labx <- if (is.null(elab.x)) { 196 rep(NA, length(loops.e)) 197 } else { 198 elab.x[loops.e] 199 } 200 loop.laby <- if (is.null(elab.y)) { 201 rep(NA, length(loops.e)) 202 } else { 203 elab.y[loops.e] 204 } 205 edge.labels <- edge.labels[nonloops.e] 206 elab.x <- if (is.null(elab.x)) NULL else elab.x[nonloops.e] 207 elab.y <- if (is.null(elab.y)) NULL else elab.y[nonloops.e] 208 el <- el[nonloops.e,,drop=FALSE] 209 210 edge.coords <- matrix(0, nrow=nrow(el), ncol=4) 211 edge.coords[,1] <- layout[,1][ el[,1] ] 212 edge.coords[,2] <- layout[,2][ el[,1] ] 213 edge.coords[,3] <- layout[,1][ el[,2] ] 214 edge.coords[,4] <- layout[,2][ el[,2] ] 215 if ( length(unique(shape)) == 1) { 216 ## same vertex shape for all vertices 217 ec <- .igraph.shapes[[ shape[1] ]]$clip(edge.coords, el, 218 params=params, end="both") 219 } else { 220 ## different vertex shapes, do it by "endpoint" 221 shape <- rep(shape, length=vcount(graph)) 222 ec <- edge.coords 223 ec[,1:2] <- t(sapply(seq(length=nrow(el)), function(x) { 224 .igraph.shapes[[ shape[el[x,1]] ]]$clip(edge.coords[x,,drop=FALSE], 225 el[x,,drop=FALSE], 226 params=params, end="from") 227 })) 228 ec[,3:4] <- t(sapply(seq(length=nrow(el)), function(x) { 229 .igraph.shapes[[ shape[el[x,2]] ]]$clip(edge.coords[x,,drop=FALSE], 230 el[x,,drop=FALSE], 231 params=params, end="to") 232 })) 233 } 234 235 x0 <- ec[,1] ; y0 <- ec[,2] ; x1 <- ec[,3] ; y1 <- ec[,4] 236 237 ################################################################ 238 ## add the loop edges 239 if (length(loops.e) > 0) { 240 ec <- edge.color 241 if (length(ec)>1) { ec <- ec[loops.e] } 242 243 point.on.cubic.bezier <- function(cp, t) { 244 245 c <- 3 * (cp[2,] - cp[1,]) 246 b <- 3 * (cp[3,] - cp[2,]) - c 247 a <- cp[4,] - cp[1,] - c - b 248 249 t2 <- t*t; 250 t3 <- t*t*t 251 252 a*t3 + b*t2 + c*t + cp[1,] 253 } 254 255 compute.bezier <- function(cp, points) { 256 dt <- seq(0, 1, by=1/(points-1)) 257 sapply(dt, function(t) point.on.cubic.bezier(cp, t)) 258 } 259 260 plot.bezier <- function(cp, points, color, width, arr, lty, arrow.size, arr.w) { 261 p <- compute.bezier( cp, points ) 262 polygon(p[1,], p[2,], border=color, lwd=width, lty=lty) 263 if (arr==1 || arr==3) { 264 igraph.Arrows(p[1,ncol(p)-1], p[2,ncol(p)-1], p[1,ncol(p)], p[2,ncol(p)], 265 sh.col=color, h.col=color, size=arrow.size, 266 sh.lwd=width, h.lwd=width, open=FALSE, code=2, width=arr.w) 267 } 268 if (arr==2 || arr==3) { 269 igraph.Arrows(p[1,2], p[2,2], p[1,1], p[2,1], 270 sh.col=color, h.col=color, size=arrow.size, 271 sh.lwd=width, h.lwd=width, open=FALSE, code=2, width=arr.w) 272 } 273 } 274 275 loop <- function(x0, y0, cx=x0, cy=y0, color, angle=0, label=NA, 276 width=1, arr=2, lty=1, arrow.size=arrow.size, 277 arr.w=arr.w, lab.x, lab.y) { 278 279 rad <- angle 280 center <- c(cx,cy) 281 cp <- matrix( c(x0,y0, x0+.4,y0+.2, x0+.4,y0-.2, x0,y0), 282 ncol=2, byrow=TRUE) 283 phi <- atan2(cp[,2]-center[2], cp[,1]-center[1]) 284 r <- sqrt((cp[,1]-center[1])**2 + (cp[,2]-center[2])**2) 285 286 phi <- phi + rad 287 288 cp[,1] <- cx+r*cos(phi) 289 cp[,2] <- cy+r*sin(phi) 290 291 if (is.na(width)) { width <- 0 } 292 293 plot.bezier(cp, 50, color, width, arr=arr, lty=lty, arrow.size=arrow.size, arr.w=arr.w) 294 295 if (is.language(label) || !is.na(label)) { 296 lx <- x0+.3 297 ly <- y0 298 phi <- atan2(ly-center[2], lx-center[1]) 299 r <- sqrt((lx-center[1])**2 + (ly-center[2])**2) 300 301 phi <- phi + rad 302 303 lx <- cx+r*cos(phi) 304 ly <- cy+r*sin(phi) 305 306 if (!is.na(lab.x)) { lx <- lab.x } 307 if (!is.na(lab.y)) { ly <- lab.y } 308 309 text(lx, ly, label, col=edge.label.color, font=edge.label.font, 310 family=edge.label.family, cex=edge.label.cex) 311 } 312 } 313 314 ec <- edge.color 315 if (length(ec)>1) { ec <- ec[loops.e] } 316 vs <- vertex.size 317 if (length(vertex.size)>1) { vs <- vs[loops.v] } 318 ew <- edge.width 319 if (length(edge.width)>1) { ew <- ew[loops.e] } 320 la <- loop.angle 321 if (length(loop.angle)>1) { la <- la[loops.e] } 322 lty <- edge.lty 323 if (length(edge.lty)>1) { lty <- lty[loops.e] } 324 arr <- arrow.mode 325 if (length(arrow.mode)>1) { arr <- arrow.mode[loops.e] } 326 asize <- arrow.size 327 if (length(arrow.size)>1) { asize <- arrow.size[loops.e] } 328 xx0 <- layout[loops.v,1] + cos(la) * vs 329 yy0 <- layout[loops.v,2] - sin(la) * vs 330 mapply(loop, xx0, yy0, 331 color=ec, angle=-la, label=loop.labels, lty=lty, 332 width=ew, arr=arr, arrow.size=asize, arr.w=arrow.width, 333 lab.x=loop.labx, lab.y=loop.laby) 334 } 335 336 ################################################################ 337 ## non-loop edges 338 if (length(x0) != 0) { 339 if (length(edge.color)>1) { edge.color <- edge.color[nonloops.e] } 340 if (length(edge.width)>1) { edge.width <- edge.width[nonloops.e] } 341 if (length(edge.lty)>1) { edge.lty <- edge.lty[nonloops.e] } 342 if (length(arrow.mode)>1) { arrow.mode <- arrow.mode[nonloops.e] } 343 if (length(arrow.size)>1) { arrow.size <- arrow.size[nonloops.e] } 344 if (length(curved)>1) { curved <- curved[nonloops.e] } 345 if (length(unique(arrow.mode))==1) { 346 lc <-igraph.Arrows(x0, y0, x1, y1, h.col=edge.color, sh.col=edge.color, 347 sh.lwd=edge.width, h.lwd=1, open=FALSE, code=arrow.mode[1], 348 sh.lty=edge.lty, h.lty=1, size=arrow.size, 349 width=arrow.width, curved=curved) 350 lc.x <- lc$lab.x 351 lc.y <- lc$lab.y 352 } else { 353 ## different kinds of arrows drawn separately as 'arrows' cannot 354 ## handle a vector as the 'code' argument 355 curved <- rep(curved, length=ecount(graph))[nonloops.e] 356 lc.x <- lc.y <- numeric(length(curved)) 357 for (code in 0:3) { 358 valid <- arrow.mode==code 359 if (!any(valid)) { next } 360 ec <- edge.color ; if (length(ec)>1) { ec <- ec[valid] } 361 ew <- edge.width ; if (length(ew)>1) { ew <- ew[valid] } 362 el <- edge.lty ; if (length(el)>1) { el <- el[valid] } 363 lc <- igraph.Arrows(x0[valid], y0[valid], x1[valid], y1[valid], 364 code=code, sh.col=ec, h.col=ec, sh.lwd=ew, h.lwd=1, 365 h.lty=1, sh.lty=el, open=FALSE, size=arrow.size, 366 width=arrow.width, curved=curved[valid]) 367 lc.x[valid] <- lc$lab.x 368 lc.y[valid] <- lc$lab.y 369 } 370 } 371 if (!is.null(elab.x)) { lc.x <- ifelse(is.na(elab.x), lc.x, elab.x) } 372 if (!is.null(elab.y)) { lc.y <- ifelse(is.na(elab.y), lc.y, elab.y) } 373 text(lc.x, lc.y, labels=edge.labels, col=edge.label.color, 374 family=edge.label.family, font=edge.label.font, cex=edge.label.cex) 375 } 376 377 rm(x0, y0, x1, y1) 378 379 ################################################################ 380 # add the vertices 381 if (vc > 0) { 382 if (length(unique(shape)) == 1) { 383 .igraph.shapes[[ shape[1] ]]$plot(layout, params=params) 384 } else { 385 sapply(seq(length=vcount(graph)), function(x) { 386 .igraph.shapes[[ shape[x] ]]$plot(layout[x,,drop=FALSE], v=x, 387 params=params) 388 }) 389 } 390 } 391 392 ################################################################ 393 # add the labels 394 par(xpd=TRUE) 395 x <- layout[,1]+label.dist*cos(-label.degree)* 396 (vertex.size+6*8*log10(2))/200 397 y <- layout[,2]+label.dist*sin(-label.degree)* 398 (vertex.size+6*8*log10(2))/200 399 if (vc > 0) { 400 if (length(label.family)==1) { 401 text(x, y, labels=labels, col=label.color, family=label.family, 402 font=label.font, cex=label.cex) 403 } else { 404 if1 <- function(vect, idx) if (length(vect)==1) vect else vect[idx] 405 sapply(seq_len(vcount(graph)), function(v) { 406 text(x[v], y[v], labels=if1(labels, v), col=if1(label.color, v), 407 family=if1(label.family, v), font=if1(label.font, v), 408 cex=if1(label.cex, v)) 409 }) 410 } 411 } 412 rm(x, y) 413 invisible(NULL) 414} 415 416 417 418#' 3D plotting of graphs with OpenGL 419#' 420#' Using the \code{rgl} package, \code{rglplot} plots a graph in 3D. The plot 421#' can be zoomed, rotated, shifted, etc. but the coordinates of the vertices is 422#' fixed. 423#' 424#' Note that \code{rglplot} is considered to be highly experimental. It is not 425#' very useful either. See \code{\link{igraph.plotting}} for the possible 426#' arguments. 427#' 428#' @aliases rglplot rglplot.igraph 429#' @param x The graph to plot. 430#' @param \dots Additional arguments, see \code{\link{igraph.plotting}} for the 431#' details 432#' @return \code{NULL}, invisibly. 433#' @author Gabor Csardi \email{csardi.gabor@@gmail.com} 434#' @seealso \code{\link{igraph.plotting}}, \code{\link{plot.igraph}} for the 2D 435#' version, \code{\link{tkplot}} for interactive graph drawing in 2D. 436#' @export 437#' @keywords graphs 438#' @export 439#' @examples 440#' 441#' \dontrun{ 442#' g <- make_lattice( c(5,5,5) ) 443#' coords <- layout_with_fr(g, dim=3) 444#' rglplot(g, layout=coords) 445#' } 446#' 447rglplot <- function(x, ...) 448 UseMethod("rglplot", x) 449 450#' @method rglplot igraph 451#' @export 452 453rglplot.igraph <- function(x, ...) { 454 455 graph <- x 456 if (!is_igraph(graph)) { 457 stop("Not a graph object") 458 } 459 460 create.edge <- function(v1, v2, r1, r2, ec, ew, am, as) { 461 ## these could also be parameters: 462 aw <- 0.005*3*as # arrow width 463 al <- 0.005*4*as # arrow length 464 465 dist <- sqrt(sum((v2-v1)^2)) # distance of the centers 466 467 if (am==0) { 468 edge <- rgl::qmesh3d(c(-ew/2,-ew/2,dist,1, ew/2,-ew/2,dist,1, ew/2,ew/2,dist,1, 469 -ew/2,ew/2,dist,1, -ew/2,-ew/2,0,1, ew/2,-ew/2,0,1, 470 ew/2,ew/2,0,1, -ew/2,ew/2,0,1), 471 c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 4,1,5,8)) 472 } else if (am==1) { 473 edge <- rgl::qmesh3d(c(-ew/2,-ew/2,dist,1, ew/2,-ew/2,dist,1, 474 ew/2,ew/2,dist,1, -ew/2,ew/2,dist,1, 475 -ew/2,-ew/2,al+r1,1, ew/2,-ew/2,al+r1,1, 476 ew/2,ew/2,al+r1,1, -ew/2,ew/2,al+r1,1, 477 -aw/2,-aw/2,al+r1,1, aw/2,-aw/2,al+r1,1, 478 aw/2,aw/2,al+r1,1, -aw/2,aw/2,al+r1,1, 0,0,r1,1), 479 c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 4,1,5,8, 480 9,10,11,12, 9,12,13,13, 9,10,13,13, 10,11,13,13, 481 11,12,13,13)) 482 } else if (am==2) { 483 box <- dist-r2-al 484 edge <- rgl::qmesh3d(c(-ew/2,-ew/2,box,1, ew/2,-ew/2,box,1, ew/2,ew/2,box,1, 485 -ew/2,ew/2,box,1, -ew/2,-ew/2,0,1, ew/2,-ew/2,0,1, 486 ew/2,ew/2,0,1, -ew/2,ew/2,0,1, 487 -aw/2,-aw/2,box,1, aw/2,-aw/2,box,1, aw/2,aw/2,box,1, 488 -aw/2,aw/2,box,1, 0,0,box+al,1), 489 c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 4,1,5,8, 490 9,10,11,12, 9,12,13,13, 9,10,13,13, 10,11,13,13, 491 11,12,13,13)) 492 } else { 493 edge <- rgl::qmesh3d(c(-ew/2,-ew/2,dist-al-r2,1, ew/2,-ew/2,dist-al-r2,1, 494 ew/2,ew/2,dist-al-r2,1, -ew/2,ew/2,dist-al-r2,1, 495 -ew/2,-ew/2,r1+al,1, ew/2,-ew/2,r1+al,1, 496 ew/2,ew/2,r1+al,1, -ew/2,ew/2,r1+al,1, 497 -aw/2,-aw/2,dist-al-r2,1, aw/2,-aw/2,dist-al-r2,1, 498 aw/2,aw/2,dist-al-r2,1, -aw/2,aw/2,dist-al-r2,1, 499 -aw/2,-aw/2,r1+al,1, aw/2,-aw/2,r1+al,1, 500 aw/2,aw/2,r1+al,1, -aw/2,aw/2,r1+al,1, 501 0,0,dist-r2,1, 0,0,r1,1), 502 c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 4,1,5,8, 503 9,10,11,12, 9,12,17,17, 9,10,17,17, 10,11,17,17, 504 11,12,17,17, 505 13,14,15,16, 13,16,18,18, 13,14,18,18, 14,15,18,18, 506 15,16,18,18)) 507 } 508 509 510 ## rotate and shift it to its position 511 phi<- -atan2(v2[2]-v1[2],v1[1]-v2[1])-pi/2 512 psi<- acos((v2[3]-v1[3])/dist) 513 rot1 <- rbind(c(1,0,0),c(0,cos(psi),sin(psi)), c(0,-sin(psi),cos(psi))) 514 rot2 <- rbind(c(cos(phi),sin(phi),0),c(-sin(phi),cos(phi),0), c(0,0,1)) 515 rot <- rot1 %*% rot2 516 edge <- rgl::transform3d(edge, rgl::rotationMatrix(matrix=rot)) 517 edge <- rgl::transform3d(edge, rgl::translationMatrix(v1[1], v1[2], v1[3])) 518 519 ## we are ready 520 rgl::shade3d(edge, col=ec) 521 } 522 523 create.loop <- function(v, r, ec, ew, am, la, la2, as) { 524 aw <- 0.005*3*as 525 al <- 0.005*4*as 526 wi <- aw*2 # size of the loop 527 wi2 <- wi+aw-ew # size including the arrow heads 528 hi <- al*2+ew*2 529 gap <- wi-2*ew 530 531 if (am==0) { 532 edge <- rgl::qmesh3d(c(-wi/2,-ew/2,0,1, -gap/2,-ew/2,0,1, 533 -gap/2,ew/2,0,1, -wi/2,ew/2,0,1, 534 -wi/2,-ew/2,hi-ew+r,1, -gap/2,-ew/2,hi-ew+r,1, 535 -gap/2,ew/2,hi-ew+r,1, -wi/2,ew/2,hi-ew+r,1, 536 wi/2,-ew/2,0,1, gap/2,-ew/2,0,1, 537 gap/2,ew/2,0,1, wi/2,ew/2,0,1, 538 wi/2,-ew/2,hi-ew+r,1, gap/2,-ew/2,hi-ew+r,1, 539 gap/2,ew/2,hi-ew+r,1, wi/2,ew/2,hi-ew+r,1, 540 -wi/2,-ew/2,hi+r,1, -wi/2,ew/2,hi+r,1, 541 wi/2,-ew/2,hi+r,1, wi/2,ew/2,hi+r,1 542 ), 543 c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 544 1,4,18,17, 545 9,10,11,12, 13,14,15,16, 9,10,14,13, 10,11,15,14, 546 11,12,16,15, 9,12,20,19, 547 5,13,19,17, 17,18,20,19, 8,16,20,18, 6,7,15,14 548 )) 549 } else if (am==1 || am==2) { 550 edge <- rgl::qmesh3d(c(-wi/2,-ew/2,r+al,1, -gap/2,-ew/2,r+al,1, 551 -gap/2,ew/2,r+al,1, -wi/2,ew/2,r+al,1, 552 -wi/2,-ew/2,hi-ew+r,1, -gap/2,-ew/2,hi-ew+r,1, 553 -gap/2,ew/2,hi-ew+r,1, -wi/2,ew/2,hi-ew+r,1, 554 wi/2,-ew/2,0,1, gap/2,-ew/2,0,1, 555 gap/2,ew/2,0,1, wi/2,ew/2,0,1, 556 wi/2,-ew/2,hi-ew+r,1, gap/2,-ew/2,hi-ew+r,1, 557 gap/2,ew/2,hi-ew+r,1, wi/2,ew/2,hi-ew+r,1, 558 -wi/2,-ew/2,hi+r,1, -wi/2,ew/2,hi+r,1, 559 wi/2,-ew/2,hi+r,1, wi/2,ew/2,hi+r,1, 560 # the arrow 561 -wi2/2,-aw/2,r+al,1, -wi2/2+aw,-aw/2,r+al,1, 562 -wi2/2+aw,aw/2,r+al,1, -wi2/2,aw/2,r+al,1, 563 -wi2/2+aw/2,0,r,1 564 ), 565 c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 566 1,4,18,17, 567 9,10,11,12, 13,14,15,16, 9,10,14,13, 10,11,15,14, 568 11,12,16,15, 9,12,20,19, 569 5,13,19,17, 17,18,20,19, 8,16,20,18, 6,7,15,14, 570 # the arrow 571 21,22,23,24, 21,22,25,25, 22,23,25,25, 23,24,25,25, 572 21,24,25,25 573 )) 574 } else if (am==3) { 575 edge <- rgl::qmesh3d(c(-wi/2,-ew/2,r+al,1, -gap/2,-ew/2,r+al,1, 576 -gap/2,ew/2,r+al,1, -wi/2,ew/2,r+al,1, 577 -wi/2,-ew/2,hi-ew+r,1, -gap/2,-ew/2,hi-ew+r,1, 578 -gap/2,ew/2,hi-ew+r,1, -wi/2,ew/2,hi-ew+r,1, 579 wi/2,-ew/2,r+al,1, gap/2,-ew/2,r+al,1, 580 gap/2,ew/2,r+al,1, wi/2,ew/2,r+al,1, 581 wi/2,-ew/2,hi-ew+r,1, gap/2,-ew/2,hi-ew+r,1, 582 gap/2,ew/2,hi-ew+r,1, wi/2,ew/2,hi-ew+r,1, 583 -wi/2,-ew/2,hi+r,1, -wi/2,ew/2,hi+r,1, 584 wi/2,-ew/2,hi+r,1, wi/2,ew/2,hi+r,1, 585 # the arrows 586 -wi2/2,-aw/2,r+al,1, -wi2/2+aw,-aw/2,r+al,1, 587 -wi2/2+aw,aw/2,r+al,1, -wi2/2,aw/2,r+al,1, 588 -wi2/2+aw/2,0,r,1, 589 wi2/2,-aw/2,r+al,1, wi2/2-aw,-aw/2,r+al,1, 590 wi2/2-aw,aw/2,r+al,1, wi2/2,aw/2,r+al,1, 591 wi2/2-aw/2,0,r,1 592 ), 593 c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 594 1,4,18,17, 595 9,10,11,12, 13,14,15,16, 9,10,14,13, 10,11,15,14, 596 11,12,16,15, 9,12,20,19, 597 5,13,19,17, 17,18,20,19, 8,16,20,18, 6,7,15,14, 598 # the arrows 599 21,22,23,24, 21,22,25,25, 22,23,25,25, 23,24,25,25, 600 21,24,25,25, 601 26,27,28,29, 26,27,30,30, 27,28,30,30, 28,29,30,30, 602 26,29,30,30 603 )) 604 } 605 606 # rotate and shift to its position 607 rot1 <- rbind(c(1,0,0),c(0,cos(la2),sin(la2)), c(0,-sin(la2),cos(la2))) 608 rot2 <- rbind(c(cos(la),sin(la),0),c(-sin(la),cos(la),0), c(0,0,1)) 609 rot <- rot1 %*% rot2 610 edge <- rgl::transform3d(edge, rgl::rotationMatrix(matrix=rot)) 611 edge <- rgl::transform3d(edge, rgl::translationMatrix(v[1], v[2], v[3])) 612 613 ## we are ready 614 rgl::shade3d(edge, col=ec) 615 } 616 617 # Visual parameters 618 params <- i.parse.plot.params(graph, list(...)) 619 labels <- params("vertex", "label") 620 label.color <- params("vertex", "label.color") 621 label.font <- params("vertex", "label.font") 622 label.degree <- params("vertex", "label.degree") 623 label.dist <- params("vertex", "label.dist") 624 vertex.color <- params("vertex", "color") 625 vertex.size <- (1/200) * params("vertex", "size") 626 loop.angle <- params("edge", "loop.angle") 627 loop.angle2 <- params("edge", "loop.angle2") 628 629 edge.color <- params("edge", "color") 630 edge.width <- (1/200) * params("edge", "width") 631 edge.labels <- params("edge","label") 632 arrow.mode <- params("edge","arrow.mode") 633 arrow.size <- params("edge","arrow.size") 634 635 layout <- params("plot", "layout") 636 rescale <- params("plot", "rescale") 637 638 # the new style parameters can't do this yet 639 arrow.mode <- i.get.arrow.mode(graph, arrow.mode) 640 641 # norm layout to (-1, 1) 642 if (ncol(layout)==2) { layout <- cbind(layout, 0) } 643 if (rescale) { 644 layout <- norm_coords(layout, -1, 1, -1, 1, -1, 1) 645 } 646 647 # add the edges, the loops are handled separately 648 el <- as_edgelist(graph, names=FALSE) 649 650 # It is faster this way 651 rgl::par3d(skipRedraw=TRUE) 652 653 # edges first 654 for (i in seq(length=nrow(el))) { 655 from <- el[i,1] 656 to <- el[i,2] 657 v1 <- layout[from,] 658 v2 <- layout[to,] 659 am <- arrow.mode; if (length(am)>1) { am <- am[i] } 660 ew <- edge.width; if (length(ew)>1) { ew <- ew[i] } 661 ec <- edge.color; if (length(ec)>1) { ec <- ec[i] } 662 r1 <- vertex.size; if (length(r1)>1) { r1 <- r1[from] } 663 r2 <- vertex.size; if (length(r2)>1) { r2 <- r2[to] } 664 665 if (from!=to) { 666 create.edge(v1,v2,r1,r2,ec,ew,am,arrow.size) 667 } else { 668 la <- loop.angle; if (length(la)>1) { la <- la[i] } 669 la2 <- loop.angle2; if (length(la2)>1) { la2 <- la2[i] } 670 create.loop(v1,r1,ec,ew,am,la,la2,arrow.size) 671 } 672 673 } 674 675 # add the vertices 676 if (length(vertex.size)==1) { vertex.size <- rep(vertex.size, nrow(layout)) } 677 rgl::rgl.spheres(layout[,1], layout[,2], layout[,3], radius=vertex.size, 678 col=vertex.color) 679 680 # add the labels, 'l1' is a stupid workaround of a mysterious rgl bug 681 labels[is.na(labels)] <- "" 682 x <- layout[,1]+label.dist*cos(-label.degree)* 683 (vertex.size+6*10*log10(2))/200 684 y <- layout[,2]+label.dist*sin(-label.degree)* 685 (vertex.size+6*10*log10(2))/200 686 z <- layout[,3] 687 l1 <- labels[1] 688 labels[1] <- "" 689 rgl::rgl.texts(x,y,z, labels, col=label.color, adj=0) 690 rgl::rgl.texts(c(0,x[1]), c(0,y[1]), c(0,z[1]), 691 c("",l1), col=c(label.color[1],label.color[1]), adj=0) 692 693 edge.labels[is.na(edge.labels)] <- "" 694 if (any(edge.labels != "")) { 695 x0 <- layout[,1][el[,1]] 696 x1 <- layout[,1][el[,2]] 697 y0 <- layout[,2][el[,1]] 698 y1 <- layout[,2][el[,2]] 699 z0 <- layout[,3][el[,1]] 700 z1 <- layout[,4][el[,2]] 701 rgl::rgl.texts((x0+x1)/2, (y0+y1)/2, (z0+z1)/2, edge.labels, 702 col=label.color) 703 } 704 705 # draw everything 706 rgl::par3d(skipRedraw=FALSE) 707 708 invisible(NULL) 709} 710 711# This is taken from the IDPmisc package, 712# slightly modified: code argument added 713 714#' @importFrom graphics par xyinch segments xspline lines polygon 715 716igraph.Arrows <- 717function (x1, y1, x2, y2, 718 code=2, 719 size= 1, 720 width= 1.2/4/cin, 721 open=TRUE, 722 sh.adj=0.1, 723 sh.lwd=1, 724 sh.col=if(is.R()) par("fg") else 1, 725 sh.lty=1, 726 h.col=sh.col, 727 h.col.bo=sh.col, 728 h.lwd=sh.lwd, 729 h.lty=sh.lty, 730 curved=FALSE) 731 ## Author: Andreas Ruckstuhl, refined by Rene Locher 732 ## Version: 2005-10-17 733{ 734 cin <- size * par("cin")[2] 735 width <- width * (1.2/4/cin) 736 uin <- if (is.R()) 737 1/xyinch() 738 else par("uin") 739 x <- sqrt(seq(0, cin^2, length = floor(35 * cin) + 2)) 740 delta <- sqrt(h.lwd)*par("cin")[2]*0.005 ## has been 0.05 741 x.arr <- c(-rev(x), -x) 742 wx2 <- width * x^2 743 y.arr <- c(-rev(wx2 + delta), wx2 + delta) 744 deg.arr <- c(atan2(y.arr, x.arr), NA) 745 r.arr <- c(sqrt(x.arr^2 + y.arr^2), NA) 746 747 ## backup 748 bx1 <- x1 ; bx2 <- x2 ; by1 <- y1 ; by2 <- y2 749 750 ## shaft 751 lx <- length(x1) 752 r.seg <- rep(cin*sh.adj, lx) 753 theta1 <- atan2((y1 - y2) * uin[2], (x1 - x2) * uin[1]) 754 th.seg1 <- theta1 + rep(atan2(0, -cin), lx) 755 theta2 <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1]) 756 th.seg2 <- theta2 + rep(atan2(0, -cin), lx) 757 x1d <- y1d <- x2d <- y2d <- 0 758 if (code %in% c(1,3)) { 759 x2d <- r.seg*cos(th.seg2)/uin[1] 760 y2d <- r.seg*sin(th.seg2)/uin[2] 761 } 762 if (code %in% c(2,3)) { 763 x1d <- r.seg*cos(th.seg1)/uin[1] 764 y1d <- r.seg*sin(th.seg1)/uin[2] 765 } 766 if (is.logical(curved) && all(!curved) || 767 is.numeric(curved) && all(!curved)) { 768 769 segments(x1+x1d, y1+y1d, x2+x2d, y2+y2d, lwd=sh.lwd, col=sh.col, lty=sh.lty) 770 phi <- atan2(y1-y2, x1-x2) 771 r <- sqrt( (x1-x2)^2 + (y1-y2)^2 ) 772 lc.x <- x2 + 2/3*r*cos(phi) 773 lc.y <- y2 + 2/3*r*sin(phi) 774 775 } else { 776 if (is.numeric(curved)) { 777 lambda <- curved 778 } else { 779 lambda <- as.logical(curved) * 0.5 780 } 781 lambda <- rep(lambda, length.out = length(x1)) 782 c.x1 <- x1+x1d 783 c.y1 <- y1+y1d 784 c.x2 <- x2+x2d 785 c.y2 <- y2+y2d 786 787 midx <- (x1+x2)/2 788 midy <- (y1+y2)/2 789 spx <- midx - lambda * 1/2 * (c.y2-c.y1) 790 spy <- midy + lambda * 1/2 * (c.x2-c.x1) 791 sh.col <- rep(sh.col, length=length(c.x1)) 792 sh.lty <- rep(sh.lty, length=length(c.x1)) 793 sh.lwd <- rep(sh.lwd, length=length(c.x1)) 794 lc.x <- lc.y <- numeric(length(c.x1)) 795 796 for (i in seq_len(length(c.x1))) { 797 ## Straight line? 798 if (lambda[i] == 0) { 799 segments(c.x1[i], c.y1[i], c.x2[i], c.y2[i], 800 lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i]) 801 phi <- atan2(y1[i] - y2[i], x1[i] - x2[i]) 802 r <- sqrt( (x1[i] - x2[i])^2 + (y1[i] - y2[i])^2 ) 803 lc.x[i] <- x2[i] + 2/3*r*cos(phi) 804 lc.y[i] <- y2[i] + 2/3*r*sin(phi) 805 806 } else { 807 spl <- xspline(x=c(c.x1[i],spx[i],c.x2[i]), 808 y=c(c.y1[i],spy[i],c.y2[i]), shape=1, draw=FALSE) 809 lines(spl, lwd=sh.lwd[i], col=sh.col[i], lty=sh.lty[i]) 810 if (code %in% c(2,3)) { 811 x1[i] <- spl$x[3*length(spl$x)/4] 812 y1[i] <- spl$y[3*length(spl$y)/4] 813 } 814 if (code %in% c(1,3)) { 815 x2[i] <- spl$x[length(spl$x)/4] 816 y2[i] <- spl$y[length(spl$y)/4] 817 } 818 lc.x[i] <- spl$x[2/3 * length(spl$x)] 819 lc.y[i] <- spl$y[2/3 * length(spl$y)] 820 } 821 } 822 } 823 824 ## forward arrowhead 825 if (code %in% c(2,3)) { 826 theta <- atan2((by2 - y1) * uin[2], (bx2 - x1) * uin[1]) 827 Rep <- rep(length(deg.arr), lx) 828 p.x2 <- rep(bx2, Rep) 829 p.y2 <- rep(by2, Rep) 830 ttheta <- rep(theta, Rep) + rep(deg.arr, lx) 831 r.arr <- rep(r.arr, lx) 832 if(open) lines((p.x2 + r.arr * cos(ttheta)/uin[1]), 833 (p.y2 + r.arr*sin(ttheta)/uin[2]), 834 lwd=h.lwd, col = h.col.bo, lty=h.lty) else 835 polygon(p.x2 + r.arr * cos(ttheta)/uin[1], p.y2 + r.arr*sin(ttheta)/uin[2], 836 col = h.col, lwd=h.lwd, 837 border=h.col.bo, lty=h.lty) 838 } 839 840 ## backward arrow head 841 if (code %in% c(1,3)) { 842 x1 <- bx1; y1 <- by1 843 tmp <- x1 ; x1 <- x2 ; x2 <- tmp 844 tmp <- y1 ; y1 <- y2 ; y2 <- tmp 845 theta <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1]) 846 lx <- length(x1) 847 Rep <- rep(length(deg.arr), lx) 848 p.x2 <- rep(x2, Rep) 849 p.y2 <- rep(y2, Rep) 850 ttheta <- rep(theta, Rep) + rep(deg.arr, lx) 851 r.arr <- rep(r.arr, lx) 852 853 if(open) lines((p.x2 + r.arr * cos(ttheta)/uin[1]), 854 (p.y2 + r.arr*sin(ttheta)/uin[2]), 855 lwd=h.lwd, col = h.col.bo, lty=h.lty) else 856 polygon(p.x2 + r.arr * cos(ttheta)/uin[1], p.y2 + r.arr*sin(ttheta)/uin[2], 857 col = h.col, lwd=h.lwd, 858 border=h.col.bo, lty=h.lty) 859 } 860 861 list(lab.x=lc.x, lab.y=lc.y) 862 863} # Arrows 864 865#' @importFrom graphics xspline 866 867igraph.polygon <- function(points, vertex.size=15/200, expand.by=15/200, 868 shape=1/2, col="#ff000033", border=NA) { 869 870 by <- expand.by 871 pp <- rbind(points, 872 cbind(points[,1]-vertex.size-by, points[,2]), 873 cbind(points[,1]+vertex.size+by, points[,2]), 874 cbind(points[,1], points[,2]-vertex.size-by), 875 cbind(points[,1], points[,2]+vertex.size+by)) 876 877 cl <- convex_hull(pp) 878 xspline(cl$rescoords, shape=shape, open=FALSE, col=col, border=border) 879} 880 881