10
$\begingroup$

Is it possible to make a dynamic graph with an ability to drag vertices?

In other words let vertices behave like Locators and change its VertexCoordinates annotations and keep VertexShapeFunction and EdgeShapeFunction rendering.

$\endgroup$
15
$\begingroup$
SeedRandom[1]
rg = RandomGraph[{5, 8}]

rg1 = Graph[rg, 
  VertexShapeFunction -> (GraphElementData["Star"][#, #2, {1, 1} /15] &), 
  EdgeShapeFunction -> "CurvedArc", 
  ImageSize -> Large, 
  PlotRangePadding -> Scaled[.2], 
  PlotRange -> CoordinateBounds[GraphEmbedding[rg]]]

enter image description here

DynamicModule[{pts = GraphEmbedding[rg1]}, 
 LocatorPane[Dynamic[pts], 
  Dynamic[Graph[rg1, VertexCoordinates -> pts]], 
  Appearance -> None]]

enter image description here

| improve this answer | |
$\endgroup$
  • $\begingroup$ Thanks! Works wonderfully! $\endgroup$ – swish Oct 23 at 20:20
8
$\begingroup$

Here's something to just update VertexCoordinates/maintain all Graph styling. It looks like kglr answered while I was writing this, but worth noting that this allows you to also make use of Graphics options so you can set a PlotRange and the like

interactiveGraph // ClearAll
Options[interactiveGraph] =
  DeleteDuplicatesBy[First]@
   Join[
    Options[LocatorPane],
    Options[Graphics]
    ];
Format[
  interactiveGraph[g : Dynamic[data_, ops___], 
   locopts : OptionsPattern[]], StandardForm] :=
 DynamicModule[
  {
   coords,
   updateFuncs,
   pr
   },
  coords = (VertexCoordinates /. AbsoluteOptions[data, VertexCoordinates]);
  pr = Replace[
    OptionValue[Graphics, FilterRules[{locopts}, Options[Graphics]], PlotRange],
    {
     All | Automatic -> Dynamic[{{-.1, -.1}, {.1, .1}} + CoordinateBoundingBox[coords]],
     {ymin_?NumericQ, ymax_?NumericQ} :>
      Transpose[{CoordinateBounds[coords][[1]], {ymin, ymax}}],
     {x_List, y_List} :> Transpose[{x, y}]
     }
    ];
  LocatorPane[
   Dynamic[
    coords, 
    Function[
     Set[coords, #];
     Set[data, Graph[data, VertexCoordinates -> coords]]
     ]
    ],
   Graphics[
    Dynamic@First[Show@data],
    Sequence @@ FilterRules[{locopts}, Options[Graphics]]
    ],
   pr,
   Sequence @@ FilterRules[{locopts, Appearance -> None}, Options[LocatorPane]]
   ]
  ]

enter image description here

| improve this answer | |
$\endgroup$
  • $\begingroup$ Thanks! Works great, but with Automatic PlotRange vertices are resizing during draging. Some AspectRatio issue I think. $\endgroup$ – swish Oct 23 at 20:27

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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