# Generating graphs interactively (GUI)

I want to create graphs interactively using a GUI. I thought of using a ClickPane[] environment. The code I have (in part borrowed from the Documentation) works perfectly to generate a visual representation of the graph:

DynamicModule[{vertex, g},
vertex = {};
g = Graph[{}];
Dynamic@EventHandler[
Framed@Graphics[{Point[vertex], Line[vertex]}, PlotRange -> 1],
"MouseDown" :>
AppendTo[vertex, Round[MousePosition["Graphics"], 0.1]],


The problem I am facing is how to generate a real graph, not just an image of it, so I can work on it with Mathematica. If I evaluate the code above outside a DynamicModule[], and try to visualise the graph g, a blank image is returned.

I would like to use the two cartesian points that define each Line[] as vertices, but Mathematica does not allow me to do that (from what I have read). VertexCoordinates is not really helpful since it's only an option, and not a primitive.

I'm wondering if there's a way to register a MouseClick as a number, for example first, second, third, etc. and then use that information to add vertices to a blank graph. My attempt at this workaround has failed. I wrote a For[] loop that counted how many points there were in vertex and assigned a letter to each position. The graph then generated will always be a straight line, unless I define the VertexCoordinates, but then I still have to create the edges in an automatic and reliable way, which is beyond me for now.

How should I proceed to generate such graphs?

EDIT: Turns out I was wrong. There is such functionality available in Mathematica. While Heike's answer is great for what I need to do (I can fully customize the graph creation process), the interested should take a look at the following: GraphEdit and GraphEditor.

• There are actually two graph editors that come with Mathematica. One is GraphEdit from the GraphUtilities  package, which you have discovered, and another one is a GUIKit example, also called GraphEdit I like the latter one a bit better. Mar 8 '12 at 13:36
• If you use GraphPlot to produce the graph and then double-click the output you can edit the vertices and edges of the graph interactively without losing the connections (requires some care with mouse focus)
– kglr
Apr 12 '12 at 5:38
• this answer might be of help. Apr 12 '12 at 8:32

You could do create a simple graph editing tool to create a graph from scratch by doing something like this. To add edges you just click and drag.

DynamicModule[{pt1, pt2, ind1, ind2, pts = {}, edges = {}, cedge = {}},
Manipulate[
EventHandler[
Dynamic@Graphics[
{Line[pts[[#]] & /@ edges],
cedge, {Red, PointSize[Medium], Point[pts]}}, PlotRange -> 1],
{"MouseDown" :>
(pt2 = pt1 = Round[MousePosition["Graphics"], 0.1];
ind1 = PadRight[Flatten[Position[pts, pt1]], 1, Length[pts] + 1][[1]]),
"MouseDragged" :>
(pt2 = Round[MousePosition["Graphics"], 0.1];
cedge = {Gray, Dashed, Line[{pt1, pt2}]}),
"MouseUp" :>
(pt2 = Round[MousePosition["Graphics"], 0.1];
If[ind1 == Length[pts] + 1, AppendTo[pts, pt1]];
ind2 = PadRight[Flatten[Position[pts, pt2]], 1, Length[pts] + 1][[1]];
If[ind2 == Length[pts] + 1, AppendTo[pts, pt2]];
If[ind1 =!= ind2, AppendTo[edges, {ind1, ind2}]];
cedge = {})}],

Row[{Button["Paste",
Print[Graph[Range[Length[pts]], edges, VertexCoordinates -> pts]]],
Button["Clear", pts = {}; edges = {}]}]]]


Screenshot:

Pasted graph:

• Heike, this is very close to what I am looking for, except that I want to be able to select and drag the points. - Anyway, I tried this code and when I click the Paste button after I added some vertices and edges I get the following message: " Null is not a Graphics primitive or directive. " Apr 13 '12 at 11:51
• Worked well for me. Mathematica 10.3.0 / Win 7. Feb 2 '16 at 14:25

This is a bit more complicated, but I did this for a human experiment previously, so why not share it.

The code keeps track of nodes and edges of a graph that can be manipulated:

• new edges can be drawn by dragging the mouse from one node to the other
• edges can be deleted via right-click menu
• nodes can be moved by dragging while holding Ctrl
• node can be deleted via right-click menu
• new nodes can be added via the button above the graph

Known issues: sometimes the arrow indicating the position of the new edge is not displayed, because the EventHandler does not recognize the "MouseDragged" event. Still the edge is created correctly.

Edit

Added definition for Pos as it was a packaged function I forgot to include. Renamed it to firstPosition.

DynamicModule[{
$MaxNodes = 10, r = .1, range = {-2, 2}, snap = .4, defNodes = 5, nodes, nodeList = None, edgeList, nodeCoord, labels, selectedEdge, selectedNode, nodePos, tail, tailCoord, headCoord, arrowUp, edgeMenuUp, nodeMenuUp, nodeMenuPos, edgeMenuPos, key, reset, update, closestPoint, circleLayout, selectEdge, deselectEdge, moveEdge, snapEdge, deleteEdge, reverseEdge, selectNode, moveNode, deselectNode, addNode, deleteNode, firstPosition}, (* Initialization code *) firstPosition[list_, case_] := Position[list, case, 1, 1][[1, 1]]; arrowUp = edgeMenuUp = nodeMenuUp = False;(* switches to indicate if there is interaction with \ arrow/edge menu/node menu *) selectedNode = tail = {}; (* Output *) Deploy@EventHandler[ Column@{ Row@{Button["Add node", addNode[], ImageSize -> 100], Button["Reset", reset[], ImageSize -> 100], Button["Rearrange", circleLayout[], ImageSize -> 100]}, Panel[Graphics[ { Dynamic[{ AbsoluteThickness@1, Arrowheads@.04, EventHandler[ {If[selectedEdge === #, Darker@Red, Black], Dynamic[Arrow[(List @@ #) /. nodeCoord, r], TrackedSymbols :> {nodeCoord}], If[edgeMenuUp, Inset[ActionMenu[Dynamic["", (edgeMenuUp = False) &], { "reverse" :> reverseEdge@selectedEdge, "delete" :> (edgeMenuUp = False; deleteEdge@selectedEdge) }, Appearance -> None, ImageSize -> 20, AutoAction -> True], edgeMenuPos], {}]}, { {"MouseDown", 2} :> (selectedEdge = #; edgeMenuPos = MousePosition["Graphics", Graphics]; edgeMenuUp = True), {"MouseUp", 2} :> (selectedEdge = edgeMenuPos = {}; edgeMenuUp = False) }, PassEventsDown -> False, PassEventsUp -> False] } & /@ edgeList, TrackedSymbols :> {edgeList, edgeMenuPos, edgeMenuUp, selectedEdge}], AbsoluteThickness@1, GrayLevel@.5, Dynamic[If[arrowUp, Arrow[{tailCoord, headCoord}], {}], TrackedSymbols :> {arrowUp, headCoord, tailCoord}], EdgeForm@{Black, Opacity@.7}, Dynamic[( {EventHandler[{ Dynamic[{ If[selectedNode === #, Hue[1, 1, .7], Hue[.6, .2, .8]], Disk[# /. nodeCoord, r]}, TrackedSymbols :> {selectedNode, nodeCoord}], If[nodeMenuUp, Inset[ActionMenu[ Dynamic[ "", (nodeMenuUp = False) &], {"delete" :> (nodeMenuUp = False; deleteNode@selectedNode)}, Appearance -> None, ImageSize -> 20, AutoAction -> True], nodeMenuPos], {}]}, { "MouseDown" :> (If[(key = CurrentValue@"ControlKey"), selectNode@#, selectEdge@#]), "MouseDragged" :> (If[key, moveNode[], moveEdge[]]), "MouseUp" :> (If[key, deselectNode[], deselectEdge[]]; key = False), {"MouseDown", 2} :> (selectedNode = #; nodeMenuPos = MousePosition["Graphics", Graphics]; nodeMenuUp = True), {"MouseUp", 2} :> (selectedNode = nodeMenuPos = {}; nodeMenuUp = False) }, PassEventsDown -> False, PassEventsUp -> False], Dynamic[ Style[Text[# /. labels, # /. nodeCoord, Scaled@{-.6, -.6}], Gray, FontFamily -> "Ariel", 15], TrackedSymbols :> {nodeCoord}] } & /@ nodeList ), TrackedSymbols :> {nodeList, nodeMenuUp, nodeMenuPos(* do NOT put selectedNode here as it disables node movement! \ *)}] } , PlotRange -> {range, range}, Background -> White, PlotRangePadding -> 0, ImagePadding -> 15, ImageMargins -> 0, AspectRatio -> 1, Axes -> False, Frame -> False, FrameTicks -> All] , FrameMargins -> 0, ImageMargins -> 0, ImageSize -> {400, Automatic}]} , {{"MouseDown", 2} :> {}}, PassEventsDown -> True], Initialization :> ( (* accepts coordinates in the form: {1 -> Subscript[coord, 1], 3 -> Subscript[coord, 3], ...} *) closestPoint[pt_List, all_List, d_: Infinity] := Module[{dist}, dist = EuclideanDistance[pt, #] & /@ (Last /@ all); If[Min@dist > d, {}, all[[First@Ordering@dist, 1]]] ]; circleLayout[n_Integer] := N@Table[{Cos[2 \[Pi]/n i], Sin[2 \[Pi]/n i]}, {i, n}]; selectEdge[node_] := (tail = node; tailCoord = headCoord = node /. nodeCoord; arrowUp = True); moveEdge[] := If[tail =!= {}, headCoord = MousePosition["Graphics", Graphics]]; snapEdge[] := Module[{head, new}, head = closestPoint[MousePosition["Graphics", Graphics], nodeCoord, snap]; new = tail \[DirectedEdge] head; If[head =!= {} \[And] UnsameQ @@ new \[And] FreeQ[edgeList, new] \[And] FreeQ[edgeList, Reverse@new], edgeList = AppendTo[edgeList, new]]]; deselectEdge[] := (snapEdge[]; arrowUp = False; tail = tailCoord = headCoord = {}); deleteEdge[ edge_] := (edgeList = Delete[edgeList, firstPosition[edgeList, edge]]); reverseEdge[edge_] := (edgeList = edgeList /. edge -> Reverse@edge); selectNode[node_] := (selectedNode = node; nodePos = firstPosition[First /@ nodeCoord, node]); moveNode[] := (If[selectedNode =!= {}, nodeCoord[[nodePos, 2]] = MousePosition["Graphics", Graphics]]); deselectNode[] := (selectedNode = nodePos = {}); deleteNode[n_] := If[nodes > 0, nodes = nodes - 1; nodeList = DeleteCases[nodeList, n]; edgeList = DeleteCases[edgeList, _?(MemberQ[#, n] &)]; nodeCoord = DeleteCases[nodeCoord, _[n, _]]; ]; addNode[] := If[nodes <$MaxNodes, Block[{new},
nodes = nodes + 1;
new = Min@Complement[Range@$MaxNodes, nodeList]; nodeList = Append[nodeList, new]; nodeCoord = Append[nodeCoord, new -> RandomReal[range, 2]]; ]]; reset[] := ( selectedEdge = selectedNode = {}; labels = Thread[Range@$MaxNodes ->
Take[CharacterRange["A", "Z"], \$MaxNodes]];
update@defNodes;
);

update[n_] := (
nodes = n;
nodeList = Range@nodes;
edgeList = {};
);

reset[];

)]


• Great answer (+1). Is it possible to recover (or paste) the undirected graph? Mar 17 '20 at 22:27
• @samwolfe You can insert Button["Copy graph", CopyToClipboard@Graph[nodeList, edgeList, VertexCoordinates -> nodeCoord]] into the top button bar of the code and when pushed, it'll copy the actual graph to the clipboard. Is this what you wanted? (Disclaimer: this code is very old with some known bugs and limitations.) Mar 18 '20 at 9:40
• Thank you @Istvan. If you can, I started a follow-up question based on your answer, please take a look: mathematica.stackexchange.com/questions/216495/… Mar 18 '20 at 9:54

Perhaps Something like this:

Manipulate[
Graph[{1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 3,
3 \[UndirectedEdge] 1}, VertexCoordinates -> {p1, p2, p3},
PlotRange -> 1],
{{p1, {1, 1}}, Locator},
{{p2, {0, 1}}, Locator},
{{p3, {1, 0}}, Locator}]


Edit

A little more general:

k =  RandomGraph@{10, 10};
vc = AbsoluteOptions[k, VertexCoordinates] /. HoldPattern[_ -> l_] -> l;

DynamicModule[{pt = vc}, {LocatorPane[Dynamic@pt,
Dynamic[Subgraph[k, Range@VertexCount@k,
VertexCoordinates -> pt]]]}]


Here is a very quick and dirty solution which takes advantage of the new molecule editor just recently added in 12.2

MoleculeGraph[MoleculeDraw[]]
`

To make a graph, you can simply make a "molecule" where all of the atoms are vertices and all of the bonds are edges. And then use the built in MoleculeGraph function to convert it into a graph. Here's an example: