Skip to main content

How to add new nodes to an existing graph with fixed (coordinates) nodes?


I'm ultimately trying to create a directed graph with some of the nodes in fixed positions and the other nodes placed around them in "acceptable" positions.


It's better if I ask the question by showing an example of the code. E.g. I have this graph:


node = {11, 12, 13, 14, 15, 16};
edges = {11 -> 14, 11 -> 16, 12 -> 16, 12 -> 15, 13 -> 15, 13 -> 16,
14 -> 16, 14 -> 15, 15 -> 16, 15 -> 13, 16 -> 15, 16 -> 14};
vertexposition = {{6.51493919050084`, 44.04756585632944`},

{75.59445680043342`, 50.47455242214042`},
{87.32825501506514`, 13.395648943951699`},
{28.795707353492418`, 3.420138063734413`},
{60.729164933330765`, 16.915777496473908`},
{51.85158892659126`, 25.803692768150313`}};

Show[
Graph[node, edges, VertexCoordinates -> vertexposition, Frame -> True,
VertexSize -> {"Scaled", .02}, VertexLabels -> "Name"]
, FrameTicks -> True, ImageSize -> 600]


I have these fixed critical nodes with positions that are important to me, however I have many other nodes that I want to add to the graph and connect to these nodes without having to specifically add their coordinates.


For example, I want to remove the connection between node $11$ and node $14$ but add three arbitrary nodes that link in series to connect nodes $11$ and $14$ without having to define their position, and have mathematica put an "appropriate" default position for them. That is, I don't want to add the nodes and have them all bunch up at the origin; the graph should look more organic.


Here's the kicker, I want to add edgeweights to all the nodes and don't necessarily want them to space out according to the edgeweights.



Answer



The following code is made after OP's response. It fullfils what I think it should. Except that there is no way to manually delete notes, I wanted to do this neatly but I've run out of time. :)


Previous code can be found in edit history.


There is a Checkbox which will enable Locators (for additional node). It seems it can not be done easier without EventHandler and PassEventsUp/Down.


Description:




  • Click -> select a node

  • Click again -> unselect

  • Click no other node -> create new node between

  • New node can be dragged since it is a locator. (after switching checkbox)


new:



  • If you create new node, the order matters, so if you click on 11 and then 12, then the connection 11->12 will be replaced but 12->11 will not, it will create new loop.





DynamicModule[{acc, new, newEdg, newNodes, newPos, newInd},

Grid[{{
LocatorPane[Dynamic@newPos,

Dynamic[
Graph[
Map[f, node~Join~newNodes],
edges,
VertexCoordinates -> (vertexposition~Join~newPos), VertexLabels -> "Name",

VertexSize -> {Sequence @@ Thread[node -> Table[{"Scaled", .05}, {6}]],
{"Scaled", .02}},
ImageSize -> 600, EdgeShapeFunction -> {Arrow[#, 2] &},
VertexLabelStyle -> {Bold, 20}, AspectRatio -> Automatic,
Frame -> True, FrameTicks -> All, PlotRange -> {{0, 100}, {0, 60}}]
], Appearance -> None]
,
Column[{
Checkbox[Dynamic@loc],
If[loc, "Locators on", "Locators off"]

}]
}}]
,
Initialization :> (
new = {}; acc = {}; newNodes = {}; newPos = {}; loc = False;
f := If[loc, #,
Style[Button[#,
Which[
acc == {#}, acc = {}
,

Length@acc == 1, AppendTo[acc, #];
AppendTo[newPos,
Mean[Pick[(vertexposition~Join~newPos), (node~Join~newNodes), #][[1]] & /@ acc]];
newInd = Last[node~Join~newNodes] + 1;
AppendTo[newNodes, newInd];
edges = DeleteCases[edges, Rule @@ acc];
AppendTo[edges, #] & /@ {First@acc -> newInd, newInd -> Last@acc};
acc = {};
,
True, acc = {#}]

], If[MemberQ[acc, #], Red, Blue]]] &;

node = {11, 12, 13, 14, 15, 16};
edges = {11 -> 14, 11 -> 16, 12 -> 16, 12 -> 15, 13 -> 15,
13 -> 16, 14 -> 16, 14 -> 15, 15 -> 16, 15 -> 13, 16 -> 15,
16 -> 14};
vertexposition = {{6.51, 44.04}, {75.59, 50.47}, {87.32, 13.39}, {28.79, 3.42},
{60.72, 16.91}, {51.85, 25.80}};)]

enter image description here



Comments

Popular posts from this blog

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...