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.
$\begingroup$
$\endgroup$
1
-
$\begingroup$ is this relevant/useful: Adjusting the vertices positions of a RandomGraph? $\endgroup$kglr– kglr2020-10-23 19:22:56 +00:00Commented Oct 23, 2020 at 19:22
Add a comment
|
2 Answers
$\begingroup$
$\endgroup$
1
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]]]
DynamicModule[{pts = GraphEmbedding[rg1]},
LocatorPane[Dynamic[pts],
Dynamic[Graph[rg1, VertexCoordinates -> pts]],
Appearance -> None]]
-
$\begingroup$ Thanks! Works wonderfully! $\endgroup$swish– swish2020-10-23 20:20:44 +00:00Commented Oct 23, 2020 at 20:20
$\begingroup$
$\endgroup$
1
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]]
]
]
-
$\begingroup$ Thanks! Works great, but with Automatic PlotRange vertices are resizing during draging. Some AspectRatio issue I think. $\endgroup$swish– swish2020-10-23 20:27:09 +00:00Commented Oct 23, 2020 at 20:27