Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
1  
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. –  Szabolcs 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) –  kguler Apr 12 '12 at 5:38
    
this answer might be of help. –  Heike Apr 12 '12 at 8:32
add comment

3 Answers

up vote 14 down vote accepted

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:

Mathematica graphics

Pasted graph:

Mathematica graphics

share|improve this answer
    
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. " –  ndroock1 Apr 13 '12 at 11:51
add comment

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

   reset[];

   )]

Mathematica graphics

share|improve this answer
add comment

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

enter image description here

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]]]}]
share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.