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