Generating graphs interactively (GUI)

Question

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]], 
   "MouseDown" :> VertexAdd[g, {vertex}]]]

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.

Answer 1

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:

Answer 2

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, [email protected],
            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, [email protected],
        Dynamic[If[arrowUp, Arrow[{tailCoord, headCoord}], {}], 
         TrackedSymbols :> {arrowUp, headCoord, tailCoord}],

        EdgeForm@{Black, [email protected]},
        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;
     nodeCoord = Thread[nodeList -> circleLayout@nodes];
     edgeList = {};
     );

   reset[];

   )]

Answer 3

IGraph/M 0.6 includes IGGraphEditor[], an interactive editor for creating graphs. Here's an example of it in use:

This project is still in experimental stage, and all feedback is welcome! See the documentation on how to use this function. In short, Alt-click (Command-click on Mac) is used to create/delete vertices, or to delete edges.

Big thanks to @Kuba for programming this!

Answer 4

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:

Answer 5

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]]]}]