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#' @include layout.R 23 24################################################################### 25# Internal variables 26################################################################### 27 28# the environment containing all the plots 29.tkplot.env <- new.env() 30assign(".next", 1, .tkplot.env) 31 32################################################################### 33# Main function 34################################################################### 35 36 37 38#' Interactive plotting of graphs 39#' 40#' \code{tkplot} and its companion functions serve as an interactive graph 41#' drawing facility. Not all parameters of the plot can be changed 42#' interactively right now though, eg. the colors of vertices, edges, and also 43#' others have to be pre-defined. 44#' 45#' \code{tkplot} is an interactive graph drawing facility. It is not very well 46#' developed at this stage, but it should be still useful. 47#' 48#' It's handling should be quite straightforward most of the time, here are 49#' some remarks and hints. 50#' 51#' There are different popup menus, activated by the right mouse button, for 52#' vertices and edges. Both operate on the current selection if the vertex/edge 53#' under the cursor is part of the selection and operate on the vertex/edge 54#' under the cursor if it is not. 55#' 56#' One selection can be active at a time, either a vertex or an edge selection. 57#' A vertex/edge can be added to a selection by holding the \code{control} key 58#' while clicking on it with the left mouse button. Doing this again deselect 59#' the vertex/edge. 60#' 61#' Selections can be made also from the \code{Select} menu. The `Select some 62#' vertices' dialog allows to give an expression for the vertices to be 63#' selected: this can be a list of numeric R expessions separated by commas, 64#' like `\code{1,2:10,12,14,15}' for example. Similarly in the `Select some 65#' edges' dialog two such lists can be given and all edges connecting a vertex 66#' in the first list to one in the second list will be selected. 67#' 68#' In the color dialog a color name like 'orange' or RGB notation can also be 69#' used. 70#' 71#' The \code{tkplot} command creates a new Tk window with the graphical 72#' representation of \code{graph}. The command returns an integer number, the 73#' tkplot id. The other commands utilize this id to be able to query or 74#' manipulate the plot. 75#' 76#' \code{tk_close} closes the Tk plot with id \code{tkp.id}. 77#' 78#' \code{tk_off} closes all Tk plots. 79#' 80#' \code{tk_fit} fits the plot to the given rectangle 81#' (\code{width} and \code{height}), if some of these are \code{NULL} the 82#' actual physical width od height of the plot window is used. 83#' 84#' \code{tk_reshape} applies a new layout to the plot, its optional 85#' parameters will be collected to a list analogous to \code{layout.par}. 86#' 87#' \code{tk_postscript} creates a dialog window for saving the plot 88#' in postscript format. 89#' 90#' \code{tk_canvas} returns the Tk canvas object that belongs to a graph 91#' plot. The canvas can be directly manipulated then, eg. labels can be added, 92#' it could be saved to a file programmatically, etc. See an example below. 93#' 94#' \code{tk_coords} returns the coordinates of the vertices in a matrix. 95#' Each row corresponds to one vertex. 96#' 97#' \code{tk_set_coords} sets the coordinates of the vertices. A two-column 98#' matrix specifies the new positions, with each row corresponding to a single 99#' vertex. 100#' 101#' \code{tk_center} shifts the figure to the center of its plot window. 102#' 103#' \code{tk_rotate} rotates the figure, its parameter can be given either 104#' in degrees or in radians. 105#' 106#' @aliases tkplot tkplot.close tkplot.off tkplot.fit.to.screen tkplot.reshape 107#' tkplot.export.postscript tkplot.canvas tkplot.getcoords tkplot.setcoords 108#' tkplot.center tkplot.rotate tk_canvas tk_center tk_close tk_postscript 109#' tk_fit tk_coords tk_off tk_reshape tk_rotate tk_set_coords 110#' @param graph The \code{graph} to plot. 111#' @param canvas.width,canvas.height The size of the tkplot drawing area. 112#' @param tkp.id The id of the tkplot window to close/reshape/etc. 113#' @param window.close Leave this on the default value. 114#' @param width The width of the rectangle for generating new coordinates. 115#' @param height The height of the rectangle for generating new coordinates. 116#' @param newlayout The new layout, see the \code{layout} parameter of tkplot. 117#' @param norm Logical, should we norm the coordinates. 118#' @param coords Two-column numeric matrix, the new coordinates of the 119#' vertices, in absolute coordinates. 120#' @param degree The degree to rotate the plot. 121#' @param rad The degree to rotate the plot, in radian. 122#' @param \dots Additional plotting parameters. See \link{igraph.plotting} for 123#' the complete list. 124#' @return \code{tkplot} returns an integer, the id of the plot, this can be 125#' used to manipulate it from the command line. 126#' 127#' \code{tk_canvas} returns \code{tkwin} object, the Tk canvas. 128#' 129#' \code{tk_coords} returns a matrix with the coordinates. 130#' 131#' \code{tk_close}, \code{tk_off}, \code{tk_fit}, 132#' \code{tk_reshape}, \code{tk_postscript}, \code{tk_center} 133#' and \code{tk_rotate} return \code{NULL} invisibly. 134#' @author Gabor Csardi \email{csardi.gabor@@gmail.com} 135#' @seealso \code{\link{plot.igraph}}, \code{\link{layout}} 136#' @export 137#' @keywords graphs 138#' @section Examples: 139#' \preformatted{ 140#' g <- make_ring(10) 141#' tkplot(g) 142#' 143#' ## Saving a tkplot() to a file programmatically 144#' g <- make_star(10, center=10) %u% make_ring(9, directed=TRUE) 145#' E(g)$width <- sample(1:10, ecount(g), replace=TRUE) 146#' lay <- layout_nicely(g) 147#' 148#' id <- tkplot(g, layout=lay) 149#' canvas <- tk_canvas(id) 150#' tcltk::tkpostscript(canvas, file="/tmp/output.eps") 151#' tk_close(id) 152#' 153#' ## Setting the coordinates and adding a title label 154#' g <- make_ring(10) 155#' id <- tkplot(make_ring(10), canvas.width=450, canvas.height=500) 156#' 157#' canvas <- tk_canvas(id) 158#' padding <- 20 159#' coords <- norm_coords(layout_in_circle(g), 0+padding, 450-padding, 160#' 50+padding, 500-padding) 161#' tk_set_coords(id, coords) 162#' 163#' width <- as.numeric(tkcget(canvas, "-width")) 164#' height <- as.numeric(tkcget(canvas, "-height")) 165#' tkcreate(canvas, "text", width/2, 25, text="My title", 166#' justify="center", font=tcltk::tkfont.create(family="helvetica", 167#' size=20,weight="bold")) 168#' } 169#' 170tkplot <- function(graph, canvas.width=450, canvas.height=450, ...) { 171 172 if (!is_igraph(graph)) { 173 stop("Not a graph object") 174 } 175 176 # Libraries 177 requireNamespace("tcltk", quietly = TRUE) || 178 stop("tcl/tk library not available") 179 180 # Visual parameters 181 params <- i.parse.plot.params(graph, list(...)) 182 labels <- params("vertex", "label") 183 label.color <- .tkplot.convert.color(params("vertex", "label.color")) 184 label.font <- .tkplot.convert.font(params("vertex", "label.font"), 185 params("vertex", "label.family"), 186 params("vertex", "label.cex")) 187 label.degree <- params("vertex", "label.degree") 188 label.dist <- params("vertex", "label.dist") 189 vertex.color <- .tkplot.convert.color(params("vertex", "color")) 190 vertex.size <- params("vertex", "size") 191 vertex.frame.color <- .tkplot.convert.color(params("vertex", "frame.color")) 192 193 edge.color <- .tkplot.convert.color(params("edge", "color")) 194 edge.width <- params("edge", "width") 195 edge.labels <- params("edge", "label") 196 edge.lty <- params("edge", "lty") 197 loop.angle <- params("edge", "loop.angle") 198 arrow.mode <- params("edge", "arrow.mode") 199 edge.label.font <- .tkplot.convert.font(params("edge", "label.font"), 200 params("edge", "label.family"), 201 params("edge", "label.cex")) 202 edge.label.color <- params("edge", "label.color") 203 arrow.size <- params("edge", "arrow.size")[1] 204 curved <- params("edge", "curved") 205 curved <- rep(curved, length=ecount(graph)) 206 207 layout <- unname(params("plot", "layout")) 208 layout[,2] <- -layout[,2] 209 margin <- params("plot", "margin") 210 margin <- rep(margin, length=4) 211 212 # the new style parameters can't do this yet 213 arrow.mode <- i.get.arrow.mode(graph, arrow.mode) 214 215 # Edge line type 216 edge.lty <- i.tkplot.get.edge.lty(edge.lty) 217 218 # Create window & canvas 219 top <- tcltk::tktoplevel(background="lightgrey") 220 canvas <- tcltk::tkcanvas(top, relief="raised", 221 width=canvas.width, height=canvas.height, 222 borderwidth=2) 223 tcltk::tkpack(canvas, fill="both", expand=1) 224 225 # Create parameters 226 vertex.params <- sdf(vertex.color=vertex.color, 227 vertex.size=vertex.size, 228 label.font=label.font, 229 NROW=vcount(graph)) 230 231 params <- list(vertex.params=vertex.params, 232 edge.color=edge.color, label.color=label.color, 233 labels.state=1, edge.width=edge.width, 234 padding=margin*300+max(vertex.size)+5, 235 grid=0, label.degree=label.degree, 236 label.dist=label.dist, edge.labels=edge.labels, 237 vertex.frame.color=vertex.frame.color, 238 loop.angle=loop.angle, edge.lty=edge.lty, arrow.mode=arrow.mode, 239 edge.label.font=edge.label.font, 240 edge.label.color=edge.label.color, arrow.size=arrow.size, 241 curved=curved) 242 243 # The popup menu 244 popup.menu <- tcltk::tkmenu(canvas) 245 tcltk::tkadd(popup.menu, "command", label="Fit to screen", command=function() { 246 tk_fit(tkp.id)}) 247 248 # Different popup menu for vertices 249 vertex.popup.menu <- tcltk::tkmenu(canvas) 250 tcltk::tkadd(vertex.popup.menu, "command", label="Vertex color", 251 command=function() { 252 tkp <- .tkplot.get(tkp.id) 253 vids <- .tkplot.get.selected.vertices(tkp.id) 254 if (length(vids)==0) return(FALSE) 255 256 initialcolor <- tkp$params$vertex.params[vids[1], "vertex.color"] 257 color <- .tkplot.select.color(initialcolor) 258 if (color=="") return(FALSE) # Cancel 259 260 .tkplot.update.vertex.color(tkp.id, vids, color) 261 }) 262 tcltk::tkadd(vertex.popup.menu, "command", label="Vertex size", 263 command=function() { 264 tkp <- .tkplot.get(tkp.id) 265 vids <- .tkplot.get.selected.vertices(tkp.id) 266 if (length(vids)==0) return(FALSE) 267 268 initialsize <- tkp$params$vertex.params[1, "vertex.size"] 269 size <- .tkplot.select.number("Vertex size", initialsize, 1, 20) 270 if (is.na(size)) return(FALSE) 271 272 .tkplot.update.vertex.size(tkp.id, vids, size) 273 }) 274 275 # Different popup menu for edges 276 edge.popup.menu <- tcltk::tkmenu(canvas) 277 tcltk::tkadd(edge.popup.menu, "command", label="Edge color", 278 command=function() { 279 tkp <- .tkplot.get(tkp.id) 280 eids <- .tkplot.get.selected.edges(tkp.id) 281 if (length(eids)==0) return(FALSE) 282 283 initialcolor <- ifelse(length(tkp$params$edge.color)>1, 284 tkp$params$edge.color[eids[1]], 285 tkp$params$edge.color) 286 color <- .tkplot.select.color(initialcolor) 287 if (color=="") return(FALSE) # Cancel 288 289 .tkplot.update.edge.color(tkp.id, eids, color) 290 }) 291 tcltk::tkadd(edge.popup.menu, "command", label="Edge width", 292 command=function() { 293 tkp <- .tkplot.get(tkp.id) 294 eids <- .tkplot.get.selected.edges(tkp.id) 295 if (length(eids)==0) return(FALSE) 296 297 initialwidth <- ifelse(length(tkp$params$edge.width)>1, 298 tkp$params$edge.width[eids[1]], 299 tkp$params$edge.width) 300 width <- .tkplot.select.number("Edge width", initialwidth, 1, 10) 301 if (is.na(width)) return(FALSE) # Cancel 302 303 .tkplot.update.edge.width(tkp.id, eids, width) 304 }) 305 306 307 # Create plot object 308 tkp <- list(top=top, canvas=canvas, graph=graph, coords=layout, 309 labels=labels, params=params, popup.menu=popup.menu, 310 vertex.popup.menu=vertex.popup.menu, 311 edge.popup.menu=edge.popup.menu) 312 tkp.id <- .tkplot.new(tkp) 313 tcltk::tktitle(top) <- paste("Graph plot", as.character(tkp.id)) 314 315 # The main pull-down menu 316 main.menu <- tcltk::tkmenu(top) 317 tcltk::tkadd(main.menu, "command", label="Close", command=function() { 318 tk_close(tkp.id, TRUE)}) 319 select.menu <- .tkplot.select.menu(tkp.id, main.menu) 320 tcltk::tkadd(main.menu, "cascade", label="Select", menu=select.menu) 321 layout.menu <- .tkplot.layout.menu(tkp.id, main.menu) 322 tcltk::tkadd(main.menu, "cascade", label="Layout", menu=layout.menu) 323 view.menu <- tcltk::tkmenu(main.menu) 324 tcltk::tkadd(main.menu, "cascade", label="View", menu=view.menu) 325 tcltk::tkadd(view.menu, "command", label="Fit to screen", command=function() { 326 tk_fit(tkp.id)}) 327 tcltk::tkadd(view.menu, "command", label="Center on screen", command=function() { 328 tk_center(tkp.id)}) 329 tcltk::tkadd(view.menu, "separator") 330 view.menu.labels <- tcltk::tclVar(1) 331 view.menu.grid <- tcltk::tclVar(0) 332 tcltk::tkadd(view.menu, "checkbutton", label="Labels", 333 variable=view.menu.labels, command=function() { 334 .tkplot.toggle.labels(tkp.id)}) 335# grid canvas object not implemented in tcltk (?) :( 336# tcltk::tkadd(view.menu, "checkbutton", label="Grid", 337# variable=view.menu.grid, command=function() { 338# .tkplot.toggle.grid(tkp.id)}) 339 tcltk::tkadd(view.menu, "separator") 340 rotate.menu <- tcltk::tkmenu(view.menu) 341 tcltk::tkadd(view.menu, "cascade", label="Rotate", menu=rotate.menu) 342 sapply(c(-90,-45,-15,-5,-1,1,5,15,45,90), 343 function(deg) { 344 tcltk::tkadd(rotate.menu, "command", 345 label=paste(deg, "degree"), command=function() { 346 tk_rotate(tkp.id, degree=deg) 347 }) 348 }) 349 export.menu <- tcltk::tkmenu(main.menu) 350 tcltk::tkadd(main.menu, "cascade", label="Export", menu=export.menu) 351 tcltk::tkadd(export.menu, "command", label="Postscript", command=function() { 352 tk_postscript(tkp.id)}) 353 tcltk::tkconfigure(top, "-menu", main.menu) 354 355 # plot it 356 .tkplot.create.edges(tkp.id) 357 .tkplot.create.vertices(tkp.id) 358 # we would need an update here 359 tk_fit(tkp.id, canvas.width, canvas.height) 360 361 # Kill myself if window was closed 362 tcltk::tkbind(top, "<Destroy>", function() tk_close(tkp.id, FALSE)) 363 364################################################################### 365# The callbacks for interactive editing 366################################################################### 367 368 tcltk::tkitembind(canvas, "vertex||label||edge", "<1>", function(x, y) { 369 tkp <- .tkplot.get(tkp.id) 370 canvas <- .tkplot.get(tkp.id, "canvas") 371 .tkplot.deselect.all(tkp.id) 372 .tkplot.select.current(tkp.id) 373# tcltk::tkitemraise(canvas, "current") 374 }) 375 tcltk::tkitembind(canvas, "vertex||label||edge", "<Control-1>", function(x,y) { 376 canvas <- .tkplot.get(tkp.id, "canvas") 377 curtags <- as.character(tcltk::tkgettags(canvas, "current")) 378 seltags <- as.character(tcltk::tkgettags(canvas, "selected")) 379 if ("vertex" %in% curtags && "vertex" %in% seltags) { 380 if ("selected" %in% curtags) { 381 .tkplot.deselect.current(tkp.id) 382 } else { 383 .tkplot.select.current(tkp.id) 384 } 385 } else if ("edge" %in% curtags && "edge" %in% seltags) { 386 if ("selected" %in% curtags) { 387 .tkplot.deselect.current(tkp.id) 388 } else { 389 .tkplot.select.current(tkp.id) 390 } 391 } else if ("label" %in% curtags && "vertex" %in% seltags) { 392 vtag <- curtags[pmatch("v-", curtags)] 393 tkid <- as.numeric(tcltk::tkfind(canvas, "withtag", 394 paste(sep="", "vertex&&", vtag))) 395 vtags <- as.character(tcltk::tkgettags(canvas, tkid)) 396 if ("selected" %in% vtags) { 397 .tkplot.deselect.vertex(tkp.id, tkid) 398 } else { 399 .tkplot.select.vertex(tkp.id, tkid) 400 } 401 } else { 402 .tkplot.deselect.all(tkp.id) 403 .tkplot.select.current(tkp.id) 404 } 405 }) 406 tcltk::tkitembind(canvas, "vertex||edge||label", "<Shift-Alt-1>", function(x, y) { 407 canvas <- .tkplot.get(tkp.id, "canvas") 408 tcltk::tkitemlower(canvas, "current") 409 }) 410 tcltk::tkitembind(canvas, "vertex||edge||label", "<Alt-1>", function(x, y) { 411 canvas <- .tkplot.get(tkp.id, "canvas") 412 tcltk::tkitemraise(canvas, "current") 413 }) 414 tcltk::tkbind(canvas, "<3>", function(x, y) { 415 canvas <- .tkplot.get(tkp.id, "canvas") 416 tags <- as.character(tcltk::tkgettags(canvas, "current")) 417 if ("label" %in% tags) { 418 vtag <- tags[ pmatch("v-", tags) ] 419 vid <- as.character(tcltk::tkfind(canvas, "withtag", 420 paste(sep="", "vertex&&", vtag))) 421 tags <- as.character(tcltk::tkgettags(canvas, vid)) 422 } 423 if ("selected" %in% tags) { 424 # The selection is active 425 } else { 426 # Delete selection, single object 427 .tkplot.deselect.all(tkp.id) 428 .tkplot.select.current(tkp.id) 429 } 430 tags <- as.character(tcltk::tkgettags(canvas, "selected")) 431 ## TODO: what if different types of objects are selected 432 if ("vertex" %in% tags || "label" %in% tags) { 433 menu <- .tkplot.get(tkp.id, "vertex.popup.menu") 434 } else if ("edge" %in% tags) { 435 menu <- .tkplot.get(tkp.id, "edge.popup.menu") 436 } else { 437 menu <- .tkplot.get(tkp.id, "popup.menu") 438 } 439 x <- as.integer(x) + as.integer(tcltk::tkwinfo("rootx", canvas)) 440 y <- as.integer(y) + as.integer(tcltk::tkwinfo("rooty", canvas)) 441 tcltk::.Tcl(paste("tk_popup", tcltk::.Tcl.args(menu, x, y))) 442 }) 443 if (tkp$params$label.dist==0) tobind <- "vertex||label" 444 else tobind <- "vertex" 445 tcltk::tkitembind(canvas, tobind, "<B1-Motion>", function(x, y) { 446 tkp <- .tkplot.get(tkp.id) 447 x <- as.numeric(x) 448 y <- as.numeric(y) 449 width <- as.numeric(tcltk::tkwinfo("width", tkp$canvas)) 450 height <- as.numeric(tcltk::tkwinfo("height", tkp$canvas)) 451 if (x < 10) { x <- 10 } 452 if (x > width-10) { x <- width-10 } 453 if (y < 10) { y <- 10 } 454 if (y > height-10) { y <- height-10 } 455 456 # get the id 457 tags <- as.character(tcltk::tkgettags(tkp$canvas, "selected")) 458 id <- as.numeric(strsplit(tags[pmatch("v-", tags)], 459 "-", fixed=TRUE)[[1]][2]) 460 if (is.na(id)) { return() } 461 # move the vertex 462 .tkplot.set.vertex.coords(tkp.id, id, x, y) 463 .tkplot.update.vertex(tkp.id, id, x, y) 464 }) 465 if (tkp$params$label.dist!=0) { 466 tcltk::tkitembind(canvas, "label", "<B1-Motion>", function(x,y) { 467 tkp <- .tkplot.get(tkp.id) 468 x <- as.numeric(x) 469 y <- as.numeric(y) 470 # get the id 471 tags <- as.character(tcltk::tkgettags(tkp$canvas, "selected")) 472 id <- as.numeric(strsplit(tags[pmatch("v-", tags)], 473 "-", fixed=TRUE)[[1]][2]) 474 if (is.na(id)) { return() } 475 phi <- pi+atan2(tkp$coords[id,2]-y, tkp$coords[id,1]-x) 476 .tkplot.set.label.degree(tkp.id, id, phi) 477 .tkplot.update.label(tkp.id, id, tkp$coords[id,1], tkp$coords[id,2]) 478 }) 479 } 480 481 # We don't need these any more, they are stored in the environment 482 rm(tkp, params, layout, vertex.color, edge.color, top, canvas, 483 main.menu, layout.menu, view.menu, export.menu, label.font, label.degree, 484 vertex.frame.color, vertex.params) 485 486 tkp.id 487} 488 489################################################################### 490# Internal functions handling data about layouts for the GUI 491################################################################### 492 493.tkplot.addlayout <- function(name, layout.data) { 494 if (!exists(".layouts", envir=.tkplot.env)) { 495 assign(".layouts", list(), .tkplot.env) 496 } 497 498 assign("tmp", layout.data, .tkplot.env) 499 cmd <- paste(sep="", ".layouts[[\"", name, "\"]]", " <- tmp") 500 eval(parse(text=cmd), .tkplot.env) 501 rm("tmp", envir=.tkplot.env) 502} 503 504.tkplot.getlayout <- function(name) { 505 cmd <- paste(sep="", ".layouts[[\"", name, "\"]]") 506 eval(parse(text=cmd), .tkplot.env) 507} 508 509.tkplot.layouts.newdefaults <- function(name, defaults) { 510 assign("tmp", defaults, .tkplot.env) 511 for (i in seq(along=defaults)) { 512 cmd <- paste(sep="", '.layouts[["', name, '"]]$params[[', i, 513 ']]$default <- tmp[[', i, ']]') 514 eval(parse(text=cmd), .tkplot.env) 515 } 516} 517 518.tkplot.getlayoutlist <- function() { 519 eval(parse(text="names(.layouts)"), .tkplot.env) 520} 521 522.tkplot.getlayoutname <- function(name) { 523 cmd <- paste(sep="", '.layouts[["', name, '"]]$name') 524 eval(parse(text=cmd), .tkplot.env) 525} 526 527.tkplot.addlayout("random", 528 list(name="Random", f=layout_randomly, params=list())) 529.tkplot.addlayout("circle", 530 list(name="Circle", f=layout_in_circle, params=list())) 531.tkplot.addlayout("fruchterman.reingold", 532 list(name="Fruchterman-Reingold", 533 f=layout_with_fr, 534 params=list( 535 niter=list(name="Number of iterations", 536 type="numeric", 537 default=500), 538 start.temp=list(name="Start temperature", 539 type="expression", 540 default=expression(sqrt(vcount(.tkplot.g))))) 541 ) 542 ) 543.tkplot.addlayout("kamada.kawai", 544 list(name="Kamada-Kawai", 545 f=layout_with_kk, 546 params=list( 547 maxiter=list(name="Maximum number of iterations", 548 type="expression", 549 default=expression(50 * vcount(.tkplot.g))), 550 kkconst=list(name="Vertex attraction constant", 551 type="expression", 552 default=expression(vcount(.tkplot.g)))) 553 ) 554 ) 555.tkplot.addlayout("reingold.tilford", 556 list(names="Reingold-Tilford", 557 f=layout_as_tree, 558 params=list( 559 root=list(name="Root vertex", 560 type="numeric", 561 default=1) 562 ) 563 ) 564 ) 565 566################################################################### 567# Other public functions, misc. 568################################################################### 569 570#' @rdname tkplot 571#' @export 572 573tk_close <- function(tkp.id, window.close=TRUE) { 574 if (window.close) { 575 cmd <- paste(sep="", "tkp.", tkp.id, "$top") 576 top <- eval(parse(text=cmd), .tkplot.env) 577 tcltk::tkbind(top, "<Destroy>", "") 578 tcltk::tkdestroy(top) 579 } 580 cmd <- paste(sep="", "tkp.", tkp.id) 581 rm(list=cmd, envir=.tkplot.env) 582 invisible(NULL) 583} 584 585#' @rdname tkplot 586#' @export 587 588tk_off <- function() { 589 eapply(.tkplot.env, function(tkp) { tcltk::tkdestroy(tkp$top) }) 590 rm(list=ls(.tkplot.env), envir=.tkplot.env) 591 invisible(NULL) 592} 593 594#' @rdname tkplot 595#' @export 596 597tk_fit <- function(tkp.id, width=NULL, height=NULL) { 598 tkp <- .tkplot.get(tkp.id) 599 if (is.null(width)) { 600 width <- as.numeric(tcltk::tkwinfo("width", tkp$canvas)) 601 } 602 if (is.null(height)) { 603 height <- as.numeric(tcltk::tkwinfo("height", tkp$canvas)) 604 } 605 coords <- .tkplot.get(tkp.id, "coords") 606 # Shift to zero 607 coords[,1] <- coords[,1]-min(coords[,1]) 608 coords[,2] <- coords[,2]-min(coords[,2]) 609 # Scale 610 coords[,1] <- coords[,1] / max(coords[,1]) * 611 (width-(tkp$params$padding[2]+tkp$params$padding[4])) 612 coords[,2] <- coords[,2] / max(coords[,2]) * 613 (height-(tkp$params$padding[1]+tkp$params$padding[3])) 614 # Padding 615 coords[,1] <- coords[,1]+tkp$params$padding[2] 616 coords[,2] <- coords[,2]+tkp$params$padding[3] 617 # Store 618 .tkplot.set(tkp.id, "coords", coords) 619 # Update 620 .tkplot.update.vertices(tkp.id) 621 invisible(NULL) 622} 623 624#' @rdname tkplot 625#' @export 626 627tk_center <- function(tkp.id) { 628 tkp <- .tkplot.get(tkp.id) 629 width <- as.numeric(tcltk::tkwinfo("width", tkp$canvas)) 630 height <- as.numeric(tcltk::tkwinfo("height", tkp$canvas)) 631 coords <- .tkplot.get(tkp.id, "coords") 632 canvas.center.x <- width/2 633 canvas.center.y <- height/2 634 coords <- .tkplot.get(tkp.id, "coords") 635 r1 <- range(coords[,1]) 636 r2 <- range(coords[,2]) 637 coords.center.x <- (r1[1]+r1[2])/2 638 coords.center.y <- (r2[1]+r2[2])/2 639 # Shift to center 640 coords[,1] <- coords[,1]+canvas.center.x-coords.center.x 641 coords[,2] <- coords[,2]+canvas.center.y-coords.center.y 642 # Store 643 .tkplot.set(tkp.id, "coords", coords) 644 # Update 645 .tkplot.update.vertices(tkp.id) 646 invisible(NULL) 647} 648 649#' @rdname tkplot 650#' @param params Extra parameters in a list, to pass to the layout function. 651#' @export 652 653tk_reshape <- function(tkp.id, newlayout, ..., params) { 654 tkp <- .tkplot.get(tkp.id) 655 new_coords <- do_call(newlayout, .args=c(list(tkp$graph), list(...), params)) 656 .tkplot.set(tkp.id, "coords", new_coords) 657 tk_fit(tkp.id) 658 .tkplot.update.vertices(tkp.id) 659 invisible(NULL) 660} 661 662#' @rdname tkplot 663#' @export 664 665tk_postscript <- function(tkp.id) { 666 667 tkp <- .tkplot.get(tkp.id) 668 669 filename <- tcltk::tkgetSaveFile(initialfile="Rplots.eps", 670 defaultextension="eps", 671 title="Export graph to PostScript file") 672 tcltk::tkpostscript(tkp$canvas, file=filename) 673 invisible(NULL) 674} 675 676#' @rdname tkplot 677#' @export 678 679tk_coords <- function(tkp.id, norm=FALSE) { 680 coords <- .tkplot.get(tkp.id, "coords") 681 coords[,2] <- max(coords[,2]) - coords[,2] 682 if (norm) { 683 # Shift 684 coords[,1] <- coords[,1]-min(coords[,1]) 685 coords[,2] <- coords[,2]-min(coords[,2]) 686 # Scale 687 coords[,1] <- coords[,1] / max(coords[,1])-0.5 688 coords[,2] <- coords[,2] / max(coords[,2])-0.5 689 } 690 coords 691} 692 693#' @rdname tkplot 694#' @export 695 696tk_set_coords <- function(tkp.id, coords) { 697 stopifnot(is.matrix(coords), ncol(coords)==2) 698 .tkplot.set(tkp.id, "coords", coords) 699 .tkplot.update.vertices(tkp.id) 700 invisible(NULL) 701} 702 703#' @rdname tkplot 704#' @export 705 706tk_rotate <- function(tkp.id, degree=NULL, rad=NULL) { 707 coords <- .tkplot.get(tkp.id, "coords") 708 709 if (is.null(degree) && is.null(rad)) { 710 rad <- pi/2 711 } else if (is.null(rad) && !is.null(degree)) { 712 rad <- degree/180*pi 713 } 714 715 center <- c(mean(range(coords[,1])), mean(range(coords[,2]))) 716 phi <- atan2(coords[,2]-center[2], coords[,1]-center[1]) 717 r <- sqrt((coords[,1]-center[1])**2 + (coords[,2]-center[2])**2) 718 719 phi <- phi + rad 720 721 coords[,1] <- r * cos(phi) 722 coords[,2] <- r * sin(phi) 723 724 .tkplot.set(tkp.id, "coords", coords) 725 tk_center(tkp.id) 726 invisible(NULL) 727} 728 729#' @rdname tkplot 730#' @export 731 732tk_canvas <- function(tkp.id) { 733 .tkplot.get(tkp.id)$canvas 734} 735 736################################################################### 737# Internal functions, handling the internal environment 738################################################################### 739 740.tkplot.new <- function(tkp) { 741 id <- get(".next", .tkplot.env) 742 assign(".next", id+1, .tkplot.env) 743 assign("tmp", tkp, .tkplot.env) 744 cmd <- paste("tkp.", id, "<- tmp", sep="") 745 eval(parse(text=cmd), .tkplot.env) 746 rm("tmp", envir=.tkplot.env) 747 id 748} 749 750.tkplot.get <- function(tkp.id, what=NULL) { 751 if (is.null(what)) { 752 get(paste("tkp.", tkp.id, sep=""), .tkplot.env) 753 } else { 754 cmd <- paste("tkp.", tkp.id, "$", what, sep="") 755 eval(parse(text=cmd), .tkplot.env) 756 } 757} 758 759.tkplot.set <- function(tkp.id, what, value) { 760 assign("tmp", value, .tkplot.env) 761 cmd <- paste(sep="", "tkp.", tkp.id, "$", what, "<-tmp") 762 eval(parse(text=cmd), .tkplot.env) 763 rm("tmp", envir=.tkplot.env) 764 TRUE 765} 766 767.tkplot.set.params <- function(tkp.id, what, value) { 768 assign("tmp", value, .tkplot.env) 769 cmd <- paste(sep="", "tkp.", tkp.id, "$params$", what, "<-tmp") 770 eval(parse(text=cmd), .tkplot.env) 771 rm("tmp", envir=.tkplot.env) 772 TRUE 773} 774 775.tkplot.set.vertex.coords <- function(tkp.id, id, x, y) { 776 cmd <- paste(sep="", "tkp.", tkp.id, "$coords[",id,",]<-c(",x,",",y,")") 777 eval(parse(text=cmd), .tkplot.env) 778 TRUE 779} 780 781.tkplot.set.label.degree <- function(tkp.id, id, phi) { 782 tkp <- .tkplot.get(tkp.id) 783 784 if (length(tkp$params$label.degree)==1) { 785 label.degree <- rep(tkp$params$label.degree, times=vcount(tkp$graph)) 786 label.degree[id] <- phi 787 assign("tmp", label.degree, .tkplot.env) 788 cmd <- paste(sep="", "tkp.", tkp.id, "$params$label.degree <- tmp") 789 eval(parse(text=cmd), .tkplot.env) 790 rm("tmp", envir=.tkplot.env) 791 } else { 792 cmd <- paste(sep="", "tkp.", tkp.id, "$params$label.degree[", id, 793 "] <- ", phi) 794 eval(parse(text=cmd), .tkplot.env) 795 } 796 TRUE 797} 798 799################################################################### 800# Internal functions, creating and updating canvas objects 801################################################################### 802 803# Creates a new vertex tk object 804.tkplot.create.vertex <- function(tkp.id, id, label, x=0, y=0) { 805 tkp <- .tkplot.get(tkp.id) 806 vertex.size <- tkp$params$vertex.params[id, "vertex.size"] 807 vertex.color <- tkp$params$vertex.params[id, "vertex.color"] 808 vertex.frame.color <- ifelse(length(tkp$params$vertex.frame.color)>1, 809 tkp$params$vertex.frame.color[id], 810 tkp$params$vertex.frame.color) 811 item <- tcltk::tkcreate(tkp$canvas, "oval", x-vertex.size, y-vertex.size, 812 x+vertex.size, y+vertex.size, width=1, 813 outline=vertex.frame.color, fill=vertex.color) 814 tcltk::tkaddtag(tkp$canvas, "vertex", "withtag", item) 815 tcltk::tkaddtag(tkp$canvas, paste("v-", id, sep=""), "withtag", item) 816 if (!is.na(label)) { 817 label.degree <- ifelse(length(tkp$params$label.degree)>1, 818 tkp$params$label.degree[id], 819 tkp$params$label.degree) 820 label.color <- if (length(tkp$params$label.color)>1) { 821 tkp$params$label.color[id] 822 } else { 823 tkp$params$label.color 824 } 825 label.dist <- tkp$params$label.dist 826 label.x <- x+label.dist*cos(label.degree)* 827 (vertex.size+6+4*(ceiling(log10(id)))) 828 label.y <- y+label.dist*sin(label.degree)* 829 (vertex.size+6+4*(ceiling(log10(id)))) 830 if (label.dist==0) 831 { afill <- label.color } 832 else 833 { afill <- "red" } 834 litem <- tcltk::tkcreate(tkp$canvas, "text", label.x, label.y, 835 text=as.character(label), state="normal", 836 fill=label.color, activefill=afill, 837 font=tkp$params$vertex.params[id, "label.font"]) 838 tcltk::tkaddtag(tkp$canvas, "label", "withtag", litem) 839 tcltk::tkaddtag(tkp$canvas, paste("v-", id, sep=""), "withtag", litem) 840 } 841 item 842} 843 844# Create all vertex objects and move them into correct position 845.tkplot.create.vertices <- function(tkp.id) { 846 tkp <- .tkplot.get(tkp.id) 847 n <- vcount(tkp$graph) 848 849 # Labels 850 labels <- i.get.labels(tkp$graph, tkp$labels) 851 852 mapply(function(v, l, x, y) .tkplot.create.vertex(tkp.id, v, l, x, y), 853 1:n, labels, tkp$coords[,1], tkp$coords[,2]) 854} 855 856.tkplot.update.label <- function(tkp.id, id, x, y) { 857 tkp <- .tkplot.get(tkp.id) 858 vertex.size <- tkp$params$vertex.params[id, "vertex.size"] 859 label.degree <- ifelse(length(tkp$params$label.degree)>1, 860 tkp$params$label.degree[id], 861 tkp$params$label.degree) 862 label.dist <- tkp$params$label.dist 863 label.x <- x+label.dist*cos(label.degree)* 864 (vertex.size+6+4*(ceiling(log10(id)))) 865 label.y <- y+label.dist*sin(label.degree)* 866 (vertex.size+6+4*(ceiling(log10(id)))) 867 tcltk::tkcoords(tkp$canvas, paste("label&&v-", id, sep=""), 868 label.x, label.y) 869} 870 871.tkplot.update.vertex <- function(tkp.id, id, x, y) { 872 tkp <- .tkplot.get(tkp.id) 873 vertex.size <- tkp$params$vertex.params[id, "vertex.size"] 874 # Vertex 875 tcltk::tkcoords(tkp$canvas, paste("vertex&&v-", id, sep=""), 876 x-vertex.size, y-vertex.size, 877 x+vertex.size, y+vertex.size) 878 # Label 879 .tkplot.update.label(tkp.id, id, x, y) 880 881 # Edges 882 edge.from.ids <- as.numeric(tcltk::tkfind(tkp$canvas, "withtag", 883 paste("from-", id, sep=""))) 884 edge.to.ids <- as.numeric(tcltk::tkfind(tkp$canvas, "withtag", 885 paste("to-", id, sep=""))) 886 for (i in seq(along=edge.from.ids)) { 887 .tkplot.update.edge(tkp.id, edge.from.ids[i]) 888 } 889 for (i in seq(along=edge.to.ids)) { 890 .tkplot.update.edge(tkp.id, edge.to.ids[i]) 891 } 892} 893 894.tkplot.update.vertices <- function(tkp.id) { 895 tkp <- .tkplot.get(tkp.id) 896 n <- vcount(tkp$graph) 897 mapply(function(v, x, y) .tkplot.update.vertex(tkp.id, v, x, y), 1:n, 898 tkp$coords[,1], tkp$coords[,2]) 899} 900 901# Creates tk object for edge 'id' 902.tkplot.create.edge <- function(tkp.id, from, to, id) { 903 tkp <- .tkplot.get(tkp.id) 904 from.c <- tkp$coords[from,] 905 to.c <- tkp$coords[to,] 906 edge.color <- ifelse(length(tkp$params$edge.color)>1, 907 tkp$params$edge.color[id], 908 tkp$params$edge.color) 909 edge.width <- ifelse(length(tkp$params$edge.width)>1, 910 tkp$params$edge.width[id], 911 tkp$params$edge.width) 912 edge.lty <- ifelse(length(tkp$params$edge.lty)>1, 913 tkp$params$edge.lty[[id]], 914 tkp$params$edge.lty) 915 arrow.mode <- ifelse(length(tkp$params$arrow.mode)>1, 916 tkp$params$arrow.mode[[id]], 917 tkp$params$arrow.mode) 918 arrow.size <- tkp$params$arrow.size 919 curved <- tkp$params$curved[[id]] 920 arrow <- c("none", "first", "last", "both")[arrow.mode+1] 921 922 if (from != to) { 923 ## non-loop edge 924 if (is.logical(curved)) curved <- curved * 0.5 925 if (curved != 0) { 926 smooth <- TRUE 927 midx <- (from.c[1]+to.c[1])/2 928 midy <- (from.c[2]+to.c[2])/2 929 spx <- midx - curved * 1/2 * (from.c[2]-to.c[2]) 930 spy <- midy + curved * 1/2 * (from.c[1]-to.c[1]) 931 coords <- c(from.c[1], from.c[2], spx, spy, to.c[1], to.c[2]) 932 } else { 933 smooth <- FALSE 934 coords <- c(from.c[1], from.c[2], to.c[1], to.c[2]) 935 } 936 args <- c(list(tkp$canvas, "line"), 937 coords, 938 list(width=edge.width, activewidth=2*edge.width, 939 arrow=arrow, arrowshape=arrow.size * c(10, 10, 5), 940 fill=edge.color, activefill="red", dash=edge.lty, 941 tags=c("edge", paste(sep="", "edge-", id), 942 paste(sep="", "from-", from), 943 paste(sep="", "to-", to))), smooth=smooth) 944 do.call(tcltk::tkcreate, args) 945 } else { 946 ## loop edge 947 ## the coordinates are not correct but we will call update anyway... 948 tcltk::tkcreate(tkp$canvas, "line", from.c[1], from.c[2], 949 from.c[1]+20, from.c[1]-10, from.c[2]+30, from.c[2], 950 from.c[1]+20, from.c[1]+10, from.c[1], from.c[2], 951 width=edge.width, activewidth=2*edge.width, 952 arrow=arrow, arrowshape=arrow.size * c(10,10,5), dash=edge.lty, 953 fill=edge.color, activefill="red", smooth=TRUE, 954 tags=c("edge", "loop", paste(sep="", "edge-", id), 955 paste(sep="", "from-", from), 956 paste(sep="", "to-", to))) 957 958 } 959 960 edge.label <- ifelse(length(tkp$params$edge.labels)>1, 961 tkp$params$edge.labels[id], 962 tkp$params$edge.labels) 963 if (!is.na(edge.label)) { 964 label.color <- ifelse(length(tkp$params$edge.label.color)>1, 965 tkp$params$edge.label.color[id], 966 tkp$params$edge.label.color) 967 ## not correct for loop edges but we will update anyway... 968 label.x <- (to.c[1]+from.c[1])/2 969 label.y <- (to.c[2]+from.c[2])/2 970 litem <- tcltk::tkcreate(tkp$canvas, "text", label.x, label.y, 971 text=as.character(edge.label), state="normal", 972 fill=label.color, 973 font=tkp$params$edge.label.font) 974 tcltk::tkaddtag(tkp$canvas, "label", "withtag", litem) 975 tcltk::tkaddtag(tkp$canvas, paste(sep="", "edge-", id), "withtag", litem) 976 } 977} 978 979# Creates all edges 980.tkplot.create.edges <- function(tkp.id) { 981 tkp <- .tkplot.get(tkp.id) 982 n <- ecount(tkp$graph) 983 edgematrix <- as_edgelist(tkp$graph, names=FALSE) 984 mapply(function(from, to, id) .tkplot.create.edge(tkp.id, from, to, id), 985 edgematrix[,1], 986 edgematrix[,2], 1:nrow(edgematrix)) 987} 988 989# Update an edge with given itemid (not edge id!) 990.tkplot.update.edge <- function(tkp.id, itemid) { 991 tkp <- .tkplot.get(tkp.id) 992 tags <- as.character(tcltk::tkgettags(tkp$canvas, itemid)) 993 from <- as.numeric(substring(grep("from-", tags, value=TRUE, fixed=TRUE),6)) 994 to <- as.numeric(substring(grep("to-", tags, value=TRUE, fixed=TRUE),4)) 995 from.c <- tkp$coords[from,] 996 to.c <- tkp$coords[to,] 997 998 edgeid <- as.numeric(substring(tags[ pmatch("edge-", tags) ], 6)) 999 1000 if (from != to) { 1001 phi <- atan2(to.c[2]-from.c[2], to.c[1]-from.c[1]) 1002 r <- sqrt( (to.c[1]-from.c[1])^2 + (to.c[2]-from.c[2])^2 ) 1003 vertex.size <- tkp$params$vertex.params[to, "vertex.size"] 1004 vertex.size2 <- tkp$params$vertex.params[from, "vertex.size"] 1005 curved <- tkp$params$curved[[edgeid]] 1006 to.c[1] <- from.c[1] + (r-vertex.size)*cos(phi) 1007 to.c[2] <- from.c[2] + (r-vertex.size)*sin(phi) 1008 from.c[1] <- from.c[1] + vertex.size2*cos(phi) 1009 from.c[2] <- from.c[2] + vertex.size2*sin(phi) 1010 if (is.logical(curved)) curved <- curved * 0.5 1011 if (curved == 0) { 1012 tcltk::tkcoords(tkp$canvas, itemid, from.c[1], from.c[2], to.c[1], to.c[2]) 1013 } else { 1014 midx <- (from.c[1]+to.c[1])/2 1015 midy <- (from.c[2]+to.c[2])/2 1016 spx <- midx - curved * 1/2 * (from.c[2]-to.c[2]) 1017 spy <- midy + curved * 1/2 * (from.c[1]-to.c[1]) 1018 tcltk::tkcoords(tkp$canvas, itemid, from.c[1], from.c[2], spx, spy, 1019 to.c[1], to.c[2]) 1020 } 1021 } else { 1022 vertex.size <- tkp$params$vertex.params[to, "vertex.size"] 1023 loop.angle <- ifelse(length(tkp$param$loop.angle)>1, 1024 tkp$params$loop.angle[edgeid], 1025 tkp$params$loop.angle) 1026 xx <- from.c[1] + cos(loop.angle/180*pi)*vertex.size 1027 yy <- from.c[2] + sin(loop.angle/180*pi)*vertex.size 1028 cc <- matrix(c(xx,yy, xx+20,yy-10, xx+30,yy, xx+20,yy+10, xx,yy), 1029 ncol=2, byrow=TRUE) 1030 1031 phi <- atan2(cc[,2]-yy, cc[,1]-xx) 1032 r <- sqrt((cc[,1]-xx)**2 + (cc[,2]-yy)**2) 1033 phi <- phi+loop.angle/180*pi 1034 cc[,1] <- xx+r*cos(phi) 1035 cc[,2] <- yy+r*sin(phi) 1036 tcltk::tkcoords(tkp$canvas, itemid, cc[1,1], cc[1,2], cc[2,1], cc[2,2], 1037 cc[3,1], cc[3,2], cc[4,1], cc[4,2], cc[5,1]+0.001, cc[5,2]+0.001) 1038 } 1039 1040 edge.label <- ifelse(length(tkp$params$edge.labels)>1, 1041 tkp$params$edge.labels[edgeid], 1042 tkp$params$edge.labels) 1043 if (!is.na(edge.label)) { 1044 if (from != to) { 1045 label.x <- (to.c[1]+from.c[1])/2 1046 label.y <- (to.c[2]+from.c[2])/2 1047 } else { 1048 ## loops 1049 label.x <- xx+cos(loop.angle/180*pi)*30 1050 label.y <- yy+sin(loop.angle/180*pi)*30 1051 } 1052 litem <- as.numeric(tcltk::tkfind(tkp$canvas, "withtag", 1053 paste(sep="", "label&&edge-", edgeid))) 1054 tcltk::tkcoords(tkp$canvas, litem, label.x, label.y) 1055 } 1056} 1057 1058.tkplot.toggle.labels <- function(tkp.id) { 1059 .tkplot.set.params(tkp.id, "labels.state", 1060 1 - .tkplot.get(tkp.id, "params")$labels.state) 1061 tkp <- .tkplot.get(tkp.id) 1062 state <- ifelse(tkp$params$labels.state==1, "normal", "hidden") 1063 tcltk::tkitemconfigure(tkp$canvas, "label", "-state", state) 1064} 1065 1066.tkplot.toggle.grid <- function(tkp.id) { 1067 .tkplot.set.params(tkp.id, "grid", 1068 1 - .tkplot.get(tkp.id, "params")$grid) 1069 tkp <- .tkplot.get(tkp.id) 1070 state <- ifelse(tkp$params$grid==1, "normal", "hidden") 1071 if (state=="hidden") { 1072 tcltk::tkdelete(tkp$canvas, "grid") 1073 } else { 1074 tcltk::tkcreate(tkp$canvas, "grid", 0, 0, 10, 10, tags=c("grid")) 1075 } 1076} 1077 1078.tkplot.update.vertex.color <- function(tkp.id, vids, newcolor) { 1079 tkp <- .tkplot.get(tkp.id) 1080 vparams <- tkp$params$vertex.params 1081 vparams[vids, "vertex.color"] <- newcolor 1082 .tkplot.set(tkp.id, "params$vertex.params", vparams) 1083 tcltk::tkitemconfigure(tkp$canvas, "selected&&vertex", "-fill", newcolor) 1084} 1085 1086.tkplot.update.edge.color <- function(tkp.id, eids, newcolor) { 1087 tkp <- .tkplot.get(tkp.id) 1088 colors <- tkp$params$edge.color 1089 if (length(colors)==1 && length(eids)==ecount(tkp$graph)) { 1090 ## Uniform color -> uniform color 1091 .tkplot.set(tkp.id, "params$edge.color", newcolor) 1092 } else if (length(colors)==1) { 1093 ## Uniform color -> nonuniform color 1094 colors <- rep(colors, ecount(tkp$graph)) 1095 colors[eids] <- newcolor 1096 .tkplot.set(tkp.id, "params$edge.color", colors) 1097 } else if (length(eids)==ecount(tkp$graph)) { 1098 ## Non-uniform -> uniform 1099 .tkplot.set(tkp.id, "params$edge.color", newcolor) 1100 } else { 1101 ## Non-uniform -> non-uniform 1102 colors[eids] <- newcolor 1103 .tkplot.set(tkp.id, "params$edge.color", colors) 1104 } 1105 1106 tcltk::tkitemconfigure(tkp$canvas, "selected&&edge", "-fill", newcolor) 1107} 1108 1109.tkplot.update.edge.width <- function(tkp.id, eids, newwidth) { 1110 tkp <- .tkplot.get(tkp.id) 1111 widths <- tkp$params$edge.width 1112 if (length(widths)==1 && length(eids)==ecount(tkp$graph)) { 1113 ## Uniform width -> uniform width 1114 .tkplot.set(tkp.id, "params$edge.width", newwidth) 1115 } else if (length(widths)==1) { 1116 ## Uniform width -> nonuniform width 1117 widths <- rep(widths, ecount(tkp$graph)) 1118 widths[eids] <- newwidth 1119 .tkplot.set(tkp.id, "params$edge.width", widths) 1120 } else if (length(eids)==ecount(tkp$graph)) { 1121 ## Non-uniform -> uniform 1122 .tkplot.set(tkp.id, "params$edge.width", newwidth) 1123 } else { 1124 ## Non-uniform -> non-uniform 1125 widths[eids] <- newwidth 1126 .tkplot.set(tkp.id, "params$edge.width", widths) 1127 } 1128 1129 tcltk::tkitemconfigure(tkp$canvas, "selected&&edge", "-width", newwidth) 1130} 1131 1132 1133.tkplot.update.vertex.size <- function(tkp.id, vids, newsize) { 1134 tkp <- .tkplot.get(tkp.id) 1135 vparams <- tkp$params$vertex.params 1136 vparams[vids, "vertex.size"] <- newsize 1137 .tkplot.set(tkp.id, "params$vertex.params", vparams) 1138 sapply(vids, function(id) { 1139 .tkplot.update.vertex(tkp.id, id, tkp$coords[id,1], tkp$coords[id,2]) 1140 }) 1141} 1142 1143.tkplot.get.numeric.vector <- function(...) { 1144 labels <- list(...) 1145 if (length(labels)==0) return(FALSE) 1146 1147 answers <- as.list(rep("", length(labels))) 1148 dialog <- tcltk::tktoplevel() 1149 vars <- lapply(answers, tcltk::tclVar) 1150 1151 retval <- list() 1152 1153 OnOK <- function() { 1154 retval <<- lapply(vars, tcltk::tclvalue) 1155 tcltk::tkdestroy(dialog) 1156 } 1157 1158 OK.but <- tcltk::tkbutton(dialog, text=" OK ", command=OnOK) 1159 for (i in seq(along=labels)) { 1160 tcltk::tkgrid(tcltk::tklabel(dialog, text=labels[[i]])) 1161 tmp <- tcltk::tkentry(dialog, width="40",textvariable=vars[[i]]) 1162 tcltk::tkgrid(tmp) 1163 tcltk::tkbind(tmp, "<Return>", OnOK) 1164 } 1165 tcltk::tkgrid(OK.but) 1166 tcltk::tkwait.window(dialog) 1167 1168 retval <- lapply(retval, function(v) 1169 { eval(parse(text=paste("c(", v, ")"))) }) 1170 return (retval) 1171} 1172 1173.tkplot.select.number <- function(label, initial, low=1, high=100) { 1174 dialog <- tcltk::tktoplevel() 1175 SliderValue <- tcltk::tclVar(as.character(initial)) 1176 SliderValueLabel <- tcltk::tklabel(dialog,text=as.character(tcltk::tclvalue(SliderValue))) 1177 tcltk::tkgrid(tcltk::tklabel(dialog,text=label), SliderValueLabel) 1178 tcltk::tkconfigure(SliderValueLabel, textvariable=SliderValue) 1179 slider <- tcltk::tkscale(dialog, from=high, to=low, 1180 showvalue=F, variable=SliderValue, 1181 resolution=1, orient="horizontal") 1182 OnOK <- function() { 1183 SliderValue <<- as.numeric(tcltk::tclvalue(SliderValue)) 1184 tcltk::tkdestroy(dialog) 1185 } 1186 OnCancel <- function() { 1187 SliderValue <<- NA 1188 tcltk::tkdestroy(dialog) 1189 } 1190 OK.but <- tcltk::tkbutton(dialog, text=" OK ", command=OnOK) 1191 cancel.but <- tcltk::tkbutton(dialog, text=" Cancel ", command=OnCancel) 1192 tcltk::tkgrid(slider) 1193 tcltk::tkgrid(OK.but, cancel.but) 1194 1195 tcltk::tkwait.window(dialog) 1196 return(SliderValue) 1197} 1198 1199################################################################### 1200# Internal functions, vertex and edge selection 1201################################################################### 1202 1203.tkplot.deselect.all <- function(tkp.id) { 1204 canvas <- .tkplot.get(tkp.id, "canvas") 1205 ids <- as.numeric(tcltk::tkfind(canvas, "withtag", "selected")) 1206 for (i in ids) { 1207 .tkplot.deselect.this(tkp.id, i) 1208 } 1209} 1210 1211.tkplot.select.all.vertices <- function(tkp.id) { 1212 canvas <- .tkplot.get(tkp.id, "canvas") 1213 vertices <- as.numeric(tcltk::tkfind(canvas, "withtag", "vertex")) 1214 for (i in vertices) { 1215 .tkplot.select.vertex(tkp.id, i) 1216 } 1217} 1218 1219.tkplot.select.some.vertices <- function(tkp.id, vids) { 1220 canvas <- .tkplot.get(tkp.id, "canvas") 1221 vids <- unique(vids) 1222 for (i in vids) { 1223 tkid <- as.numeric(tcltk::tkfind(canvas, "withtag", 1224 paste(sep="", "vertex&&v-", i))) 1225 .tkplot.select.vertex(tkp.id, tkid) 1226 } 1227} 1228 1229.tkplot.select.all.edges <- function(tkp.id, vids) { 1230 canvas <- .tkplot.get(tkp.id, "canvas") 1231 edges <- as.numeric(tcltk::tkfind(canvas, "withtag", "edge")) 1232 for (i in edges) { 1233 .tkplot.select.edge(tkp.id, i) 1234 } 1235} 1236 1237.tkplot.select.some.edges <- function(tkp.id, from, to) { 1238 canvas <- .tkplot.get(tkp.id, "canvas") 1239 fromtags <- sapply(from, function(i) { paste(sep="", "from-", i) }) 1240 totags <- sapply(from, function(i) { paste(sep="", "to-", i) }) 1241 edges <- as.numeric(tcltk::tkfind(canvas, "withtag", "edge")) 1242 for (i in edges) { 1243 tags <- as.character(tcltk::tkgettags(canvas, i)) 1244 ftag <- tags[ pmatch("from-", tags) ] 1245 ttag <- tags[ pmatch("to-", tags) ] 1246 if (ftag %in% fromtags && ttag %in% totags) { 1247 .tkplot.select.edge(tkp.id, i) 1248 } 1249 } 1250} 1251 1252.tkplot.select.vertex <- function(tkp.id, tkid) { 1253 canvas <- .tkplot.get(tkp.id, "canvas") 1254 tcltk::tkaddtag(canvas, "selected", "withtag", tkid) 1255 tcltk::tkitemconfigure(canvas, tkid, "-outline", "red", 1256 "-width", 2) 1257} 1258 1259.tkplot.select.edge <- function(tkp.id, tkid) { 1260 canvas <- .tkplot.get(tkp.id, "canvas") 1261 tcltk::tkaddtag(canvas, "selected", "withtag", tkid) 1262 tcltk::tkitemconfigure(canvas, tkid, "-dash", "-") 1263} 1264 1265.tkplot.select.label <- function(tkp.id, tkid) { 1266 canvas <- .tkplot.get(tkp.id, "canvas") 1267 tcltk::tkaddtag(canvas, "selected", "withtag", tkid) 1268} 1269 1270.tkplot.deselect.vertex <- function(tkp.id, tkid) { 1271 canvas <- .tkplot.get(tkp.id, "canvas") 1272 tcltk::tkdtag(canvas, tkid, "selected") 1273 tkp <- .tkplot.get(tkp.id) 1274 tags <- as.character(tcltk::tkgettags(canvas, tkid)) 1275 id <- as.numeric(substring(tags[pmatch("v-", tags)], 3)) 1276 vertex.frame.color <- ifelse(length(tkp$params$vertex.frame.color)>1, 1277 tkp$params$vertex.frame.color[id], 1278 tkp$params$vertex.frame.color) 1279 tcltk::tkitemconfigure(canvas, tkid, "-outline", vertex.frame.color, 1280 "-width", 1) 1281} 1282 1283.tkplot.deselect.edge <- function(tkp.id, tkid) { 1284 canvas <- .tkplot.get(tkp.id, "canvas") 1285 tcltk::tkdtag(canvas, tkid, "selected") 1286 tkp <- .tkplot.get(tkp.id) 1287 tags <- as.character(tcltk::tkgettags(canvas, tkid)) 1288 id <- as.numeric(substring(tags[pmatch("edge-", tags)], 6)) 1289 edge.lty <- ifelse(length(tkp$params$edge.lty)>1, 1290 tkp$params$edge.lty[[id]], 1291 tkp$params$edge.lty) 1292 tcltk::tkitemconfigure(canvas, tkid, "-dash", edge.lty) 1293} 1294 1295.tkplot.deselect.label <- function(tkp.id, tkid) { 1296 canvas <- .tkplot.get(tkp.id, "canvas") 1297 tcltk::tkdtag(canvas, tkid, "selected") 1298} 1299 1300.tkplot.select.current <- function(tkp.id) { 1301 canvas <- .tkplot.get(tkp.id, "canvas") 1302 tkid <- as.numeric(tcltk::tkfind(canvas, "withtag", "current")) 1303 .tkplot.select.this(tkp.id, tkid) 1304} 1305 1306.tkplot.deselect.current <- function(tkp.id) { 1307 canvas <- .tkplot.get(tkp.id, "canvas") 1308 tkid <- as.numeric(tcltk::tkfind(canvas, "withtag", "current")) 1309 .tkplot.deselect.this(tkp.id, tkid) 1310} 1311 1312.tkplot.select.this <- function(tkp.id, tkid) { 1313 canvas <- .tkplot.get(tkp.id, "canvas") 1314 tags <- as.character(tcltk::tkgettags(canvas, tkid)) 1315 if ("vertex" %in% tags) { 1316 .tkplot.select.vertex(tkp.id, tkid) 1317 } else if ("edge" %in% tags) { 1318 .tkplot.select.edge(tkp.id, tkid) 1319 } else if ("label" %in% tags) { 1320 tkp <- .tkplot.get(tkp.id) 1321 if (tkp$params$label.dist == 0) { 1322 id <- tags[pmatch("v-", tags)] 1323 tkid <- as.character(tcltk::tkfind(canvas, "withtag", 1324 paste(sep="", "vertex&&", id))) 1325 .tkplot.select.vertex(tkp.id, tkid) 1326 } else { 1327 .tkplot.select.label(tkp.id, tkid) 1328 } 1329 } 1330} 1331 1332.tkplot.deselect.this <- function(tkp.id, tkid) { 1333 canvas <- .tkplot.get(tkp.id, "canvas") 1334 tags <- as.character(tcltk::tkgettags(canvas, tkid)) 1335 if ("vertex" %in% tags) { 1336 .tkplot.deselect.vertex(tkp.id, tkid) 1337 } else if ("edge" %in% tags) { 1338 .tkplot.deselect.edge(tkp.id, tkid) 1339 } else if ("label" %in% tags) { 1340 tkp <- .tkplot.get(tkp.id) 1341 if (tkp$params$label.dist == 0) { 1342 id <- tags[pmatch("v-", tags)] 1343 tkid <- as.character(tcltk::tkfind(canvas, "withtag", 1344 paste(sep="", "vertex&&", id))) 1345 .tkplot.deselect.vertex(tkp.id, tkid) 1346 } else { 1347 .tkplot.deselect.label(tkp.id, tkid) 1348 } 1349 } 1350} 1351 1352.tkplot.get.selected.vertices <- function(tkp.id) { 1353 canvas <- .tkplot.get(tkp.id, "canvas") 1354 tkids <- as.numeric(tcltk::tkfind(canvas, "withtag", "vertex&&selected")) 1355 1356 ids <- sapply(tkids, function(tkid) { 1357 tags <- as.character(tcltk::tkgettags(canvas, tkid)) 1358 id <- as.numeric(substring(tags [pmatch("v-", tags)], 3)) 1359 id}) 1360 1361 ids 1362} 1363 1364.tkplot.get.selected.edges <- function(tkp.id) { 1365 canvas <- .tkplot.get(tkp.id, "canvas") 1366 tkids <- as.numeric(tcltk::tkfind(canvas, "withtag", "edge&&selected")) 1367 1368 ids <- sapply(tkids, function(tkid) { 1369 tags <- as.character(tcltk::tkgettags(canvas, tkid)) 1370 id <- as.numeric(substring(tags [pmatch("edge-", tags)], 6)) 1371 id}) 1372 1373 ids 1374} 1375 1376################################################################### 1377# Internal functions: manipulating the UI 1378################################################################### 1379 1380.tkplot.select.menu <- function(tkp.id, main.menu) { 1381 select.menu <- tcltk::tkmenu(main.menu) 1382 1383 tcltk::tkadd(select.menu, "command", label="Select all vertices", 1384 command=function() { 1385 .tkplot.deselect.all(tkp.id) 1386 .tkplot.select.all.vertices(tkp.id) 1387 }) 1388 tcltk::tkadd(select.menu, "command", label="Select all edges", 1389 command=function() { 1390 .tkplot.deselect.all(tkp.id) 1391 .tkplot.select.all.edges(tkp.id) 1392 }) 1393 tcltk::tkadd(select.menu, "command", label="Select some vertices...", 1394 command=function() { 1395 vids <- .tkplot.get.numeric.vector("Select vertices") 1396 .tkplot.select.some.vertices(tkp.id, vids[[1]]) 1397 }) 1398 tcltk::tkadd(select.menu, "command", label="Select some edges...", 1399 command=function() { 1400 fromto <- .tkplot.get.numeric.vector("Select edges from vertices", 1401 "to vertices") 1402 .tkplot.select.some.edges(tkp.id, fromto[[1]], fromto[[2]]) 1403 }) 1404 tcltk::tkadd(select.menu, "separator") 1405 tcltk::tkadd(select.menu, "command", label="Deselect everything", 1406 command=function() { .tkplot.deselect.all(tkp.id) }) 1407 1408 select.menu 1409} 1410 1411.tkplot.layout.menu <- function(tkp.id, main.menu) { 1412 layout.menu <- tcltk::tkmenu(main.menu) 1413 1414 sapply(.tkplot.getlayoutlist(), function(n) { 1415 tcltk::tkadd(layout.menu, "command", label=.tkplot.getlayoutname(n), 1416 command=function() { 1417 .tkplot.layout.dialog(tkp.id, n) 1418 }) 1419 }) 1420 1421 layout.menu 1422} 1423 1424.tkplot.layout.dialog <- function(tkp.id, layout.name) { 1425 layout <- .tkplot.getlayout(layout.name) 1426 1427 # No parameters 1428 if (length(layout$params)==0) { 1429 return(tk_reshape(tkp.id, layout$f, params=list())) 1430 } 1431 1432 submit <- function() { 1433 realparams <- params <- vector(mode="list", length(layout$params)) 1434 names(realparams) <- names(params) <- names(layout$params) 1435 for (i in seq(along=layout$params)) { 1436 realparams[[i]] <- 1437 params[[i]] <- switch(layout$params[[i]]$type, 1438 "numeric"=as.numeric(tcltk::tkget(values[[i]])), 1439 "character"=as.character(tcltk::tkget(values[[i]])), 1440 "logical"=as.logical(tcltk::tclvalue(values[[i]])), 1441 "choice"=as.character(tcltk::tclvalue(values[[i]])), 1442 "initial"=as.logical(tcltk::tclvalue(values[[i]])), 1443 "expression"=as.numeric(tcltk::tkget(values[[i]])) 1444 ) 1445 if (layout$params[[i]]$type=="initial" && 1446 params[[i]]) { 1447 realparams[[i]] <- tk_coords(tkp.id, norm=TRUE) 1448 } 1449 } 1450 if (as.logical(tcltk::tclvalue(save.default))) { 1451 .tkplot.layouts.newdefaults(layout.name, params) 1452 } 1453 tcltk::tkdestroy(dialog) 1454 tk_reshape(tkp.id, layout$f, params=realparams) 1455 } 1456 1457 dialog <- tcltk::tktoplevel(.tkplot.get(tkp.id, "top")) 1458 1459 tcltk::tkwm.title(dialog, paste("Layout parameters for graph plot", tkp.id)) 1460 tcltk::tkwm.transient(dialog, .tkplot.get(tkp.id, "top")) 1461 1462 tcltk::tkgrid(tcltk::tklabel(dialog, text=paste(layout$name, "layout"), 1463 font=tcltk::tkfont.create(family="helvetica",size=20,weight="bold")), 1464 row=0, column=0, columnspan=2, padx=10, pady=10) 1465 1466 row <- 1 1467 values <- list() 1468 for (i in seq(along=layout$params)) { 1469 1470 tcltk::tkgrid(tcltk::tklabel(dialog, text=paste(sep="", layout$params[[i]]$name, ":")), 1471 row=row, column=0, sticky="ne", padx=5, pady=5) 1472 1473 if (layout$params[[i]]$type %in% c("numeric", "character")) { 1474 values[[i]] <- tcltk::tkentry(dialog) 1475 tcltk::tkinsert(values[[i]], 0, as.character(layout$params[[i]]$default)) 1476 tcltk::tkgrid(values[[i]], row=row, column=1, sticky="nw", padx=5, pady=5) 1477 } else if (layout$params[[i]]$type=="logical") { 1478 values[[i]] <- tcltk::tclVar(as.character(layout$params[[i]]$default)) 1479 tmp <- tcltk::tkcheckbutton(dialog, onvalue="TRUE", offvalue="FALSE", 1480 variable=values[[i]]) 1481 tcltk::tkgrid(tmp, row=row, column=1, sticky="nw", padx=5, pady=5) 1482 } else if (layout$params[[i]]$type=="choice") { 1483 tmp.frame <- tcltk::tkframe(dialog) 1484 tcltk::tkgrid(tmp.frame, row=row, column=1, sticky="nw", padx=5, pady=5) 1485 values[[i]] <- tcltk::tclVar(layout$params[[i]]$default) 1486 for (j in 1:length(layout$params[[i]]$values)) { 1487 tmp <- tcltk::tkradiobutton(tmp.frame, variable=values[[i]], 1488 value=layout$params[[i]]$values[j], 1489 text=layout$params[[i]]$values[j]) 1490 tcltk::tkpack(tmp, anchor="nw") 1491 } 1492 } else if (layout$params[[i]]$type=="initial") { 1493 values[[i]] <- tcltk::tclVar(as.character(layout$params[[i]]$default)) 1494 tcltk::tkgrid(tcltk::tkcheckbutton(dialog, onvalue="TRUE", offvalue="FALSE", 1495 variable=values[[i]]), 1496 row=row, column=1, sticky="nw", padx=5, pady=5) 1497 } else if (layout$param[[i]]$type=="expression") { 1498 values[[i]] <- tcltk::tkentry(dialog) 1499 .tkplot.g <- .tkplot.get(tkp.id, "graph") 1500 tcltk::tkinsert(values[[i]], 0, as.character(eval(layout$params[[i]]$default))) 1501 tcltk::tkgrid(values[[i]], row=row, column=1, sticky="nw", padx=5, pady=5) 1502 } 1503 1504 row <- row + 1 1505 1506 } # for along layout$params 1507 1508 tcltk::tkgrid(tcltk::tklabel(dialog, text="Set these as defaults"), sticky="ne", 1509 row=row, column=0, padx=5, pady=5) 1510 save.default <- tcltk::tclVar("FALSE") 1511 tcltk::tkgrid(tcltk::tkcheckbutton(dialog, onvalue="TRUE", offvalue="FALSE", 1512 variable=save.default, text=""), row=row, 1513 column=1, sticky="nw", padx=5, pady=5) 1514 row <- row + 1 1515 1516 tcltk::tkgrid(tcltk::tkbutton(dialog, text="OK", command=submit), row=row, column=0) 1517 tcltk::tkgrid(tcltk::tkbutton(dialog, text="Cancel", 1518 command=function() { tcltk::tkdestroy(dialog); invisible(TRUE) }), 1519 row=row, column=1) 1520} 1521 1522.tkplot.select.color <- function(initialcolor) { 1523 1524 color <- tcltk::tclvalue(tcltk::tcl("tk_chooseColor", initialcolor=initialcolor, 1525 title="Choose a color")) 1526 return(color); 1527} 1528 1529################################################################### 1530# Internal functions: other 1531################################################################### 1532 1533#' @importFrom grDevices palette 1534 1535.tkplot.convert.color <- function(col) { 1536 if (is.numeric(col)) { 1537 ## convert numeric color based on current palette 1538 p <- palette() 1539 col <- col %% length(p) 1540 col[col==0] <- length(p) 1541 col <- palette()[col] 1542 } else if (is.character(col) && any(substr(col,1,1)=="#" & nchar(col)==9)) { 1543 ## drop alpha channel, tcltk doesn't support it 1544 idx <- substr(col,1,1)=="#" & nchar(col)==9 1545 col[idx] <- substr(col[idx],1,7) 1546 } 1547 1548 ## replace NA's with "" 1549 col[is.na(col)] <- "" 1550 1551 col 1552} 1553 1554.tkplot.convert.font <- function(font, family, cex) { 1555 tk.fonts <- as.character(tcltk::tkfont.names()) 1556 if (as.character(font) %in% tk.fonts) { 1557 ## already defined Tk font 1558 as.character(font) 1559 } else { 1560 ## we create a font from familiy, font & cex 1561 font <- as.numeric(font) 1562 family <- as.character(family) 1563 cex <- as.numeric(cex) 1564 1565 ## multiple sizes 1566 if (length(cex) > 1) { 1567 return(sapply(cex, .tkplot.convert.font, font=font, family=family)) 1568 } 1569 1570 ## set slant & weight 1571 if (font==2) { 1572 slant <- "roman" 1573 weight <- "bold" 1574 } else if (font==3) { 1575 slant <- "italic" 1576 weight <- "normal" 1577 } else if (font==4) { 1578 slant <- "italic" 1579 weight <- "bold" 1580 } else { 1581 slant <- "roman" 1582 weight <- "normal" 1583 } 1584 1585 ## set tkfamily 1586 if (family=="symbol" || font==5) { 1587 tkfamily <- "symbol" 1588 } else if (family=="serif") { 1589 tkfamily <- "Times" 1590 } else if (family=="sans") { 1591 tkfamily <- "Helvetica" 1592 } else if (family=="mono") { 1593 tkfamily <- "Courier" 1594 } else { 1595 ## pass the family and see what happens 1596 tkfamily <- family 1597 } 1598 1599 newfont <- tcltk::tkfont.create(family=tkfamily, slant=slant, weight=weight, 1600 size=as.integer(12*cex)) 1601 as.character(newfont) 1602 } 1603} 1604 1605i.tkplot.get.edge.lty <- function(edge.lty) { 1606 1607 if (is.numeric(edge.lty)) { 1608 lty <- c( " ", "", "-", ".", "-.", "--", "--.") 1609 edge.lty <- lty[edge.lty %% 7 + 1] 1610 } else if (is.character(edge.lty)) { 1611 wh <- edge.lty %in% c("blank", "solid", "dashed", "dotted", "dotdash", 1612 "longdash", "twodash") 1613 lty <- c( " ", "", "-", ".", "-.", "--", "--.") 1614 names(lty) <- c("blank", "solid", "dashed", "dotted", "dotdash", 1615 "longdash", "twodash") 1616 edge.lty[wh] <- lty[ edge.lty[wh] ] 1617 } 1618 edge.lty 1619} 1620