Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Graphs and Networks sorted by activeList of Directed Edges
https://community.wolfram.com/groups/-/m/t/1989313
Hi All,
I am terribly sorry about asking trivial things, but I am complete beginner when it comes to Mathematica.
I also have yet to master a skill of searching through previously posted questions and answers on this forum as I just registered.
I am trying to created a list of directed edges from a list of ordered pairs. So I start with
V = {1,2}
G = Tuples[{V, V}]
DirectedEdge /@ G
Unfortunately, I have extra curly brackets so my output is
{DirectedEdge[{1, 1}], DirectedEdge[{1, 2}], DirectedEdge[{2, 1}],
DirectedEdge[{2, 2}]}
Instead of what I really need
{DirectedEdge[1, 1], DirectedEdge[1, 2], DirectedEdge[2, 1],
DirectedEdge[2, 2]}
I am so sorry for bad formatting. I will fix things a bit later as I am in a hurry to fix the problem.Predrag Punosevac2020-05-28T18:28:00ZRandom regular digraphs
https://community.wolfram.com/groups/-/m/t/1989590
I am trying to do some experiments involving random regular digraphs. After a bit of poking around
https://www.math.cmu.edu/~af1p/BOOK.pdf
and
Computational Discrete Mathematics: Combinatorics and Graph Theory with Mathematica
https://www.amazon.com/Computational-Discrete-Mathematics-Combinatorics-Mathematica/dp/0521121469
the quickest thing I am coming up with is
DirectedGraph[
RandomGraph[DegreeGraphDistribution[{4, 4, 4, 4, 4, 4, 4, 4}]]]
This is almost what I need. The caveat is that DirectedGraph function is producing a directed graph from an undirected graph which makes output alway symmetric. I would like to avoid this limitation.
I have no problems producing random asymmetric digraphs from more primitive objects (list of vertices) but then I have a hard time with regularity condition.
Long story short. Can somebody give me some lead on this problem? Problem in its own right is probably trivial for a seasoned graph theorist but I am actually interested in dynamical systems which can be numerically simulated with random regular digraphs. I would like to get some kind numerical intuition about them.Predrag Punosevac2020-05-29T03:47:05ZFinding of the loops hidden in the Tokyo-Metropolitan-Highway
https://community.wolfram.com/groups/-/m/t/1987664
This project objective is to make analyses for Tokyo Metropolitan Highway known as "Syuto-Ko" that is very complex and narrow, with steep curves. "Syuto-Ko" is the highway network of Tokyo but also the hub of Japan highway network. Because Tokyo area is the collection center having about four hundreds years economical activity history, "Syuto-Ko" had to accept the complexity from the beggining of construction, but having the attractive feature.
For the loop finding and other analysis, Mathematica Graph functions are useful, however, we must prepare a graph expressing the highway root, junction, enterance, exit, and the parking-area. For this purpose, we can use a tool ["Graph Editor"][1] which can construct, edit, and convert to a graph from the map of nodes, paths, and labels. For example, over the number of 100 nodes of the map construction is not easy apparently. A graph construction of "Syuto-Ko", even if the parts of the network, may be difficult without the support of the tool.
Following figure is a part of Shuto-ko highway drawn by the "Graph Editor," constructed by step by steps. To keep the left, constructed highway map has the inter-change with doubled directions, and the junction point (JCT) has complex in-out directions. All the map are composed of labeled rectangles and the arrows.
![enter image description here][2]
Fig.1 Snap shot of working area of GraphEditor
Then, we can convert the map to a graph for the graph functions as following image. Data of Graph function is saved as a file from the GraphEditor command. Converter program source is as follows.
g = Get["graph"][[1 ;; 3]]; (* read the file *)
f[t_] := Map[Rule[t[[1]], #] &, t[[2]]]; (* define rule function *)
gl1 = Flatten@
Map[f, Transpose[{Flatten[g[[1]]],
g[[2]]}]]; (* construct vertex list of graph *)
gl1 = gl1 /.
Rule[x_, y_] /; x == y -> Nothing; (* remove self loop *)
gl2 = Map[Rule[#[[1, 1]], #[[2]]] &,
Transpose[{g[[1]],
g[[3]]}]];(* construct label list of graph *)
gg =
Graph[gl1, VertexLabels -> gl2, ImagePadding -> 50,
GraphLayout -> "SpringEmbedding"]
Unfortunately, the number of vertex labels may be limited, you may chose the labels, and can get a graph converted from the GraphEditor file.
gg = Graph[{$138 -> $24, $138 -> $104, $140 -> $146, $140 -> $144, \
$141 -> $110, $142 -> $141, $142 -> $146, $144 -> $145, $145 -> $91, \
$146 -> $28, $147 -> $144, $147 -> $141, $148 -> $147, $149 -> $92, \
$150 -> $156, $156 -> $12, $156 -> $19, $157 -> $102, $160 -> $149, \
$161 -> $164, $161 -> $163, $162 -> $160, $162 -> $164, $163 -> $93, \
$164 -> $150, $166 -> $160, $166 -> $163, $167 -> $148, $169 -> $174, \
$169 -> $171, $170 -> $167, $171 -> $54, $172 -> $170, $172 -> $174, \
$173 -> $171, $173 -> $170, $174 -> $14, $14 -> $16, $14 -> $18, $15 \
-> $178, $16 -> $20, $17 -> $178, $18 -> $134, $33 -> $42, $33 -> \
$44, $34 -> $60, $35 -> $32, $36 -> $42, $41 -> $44, $41 -> $35, $41 \
-> $34, $42 -> $50, $43 -> $42, $43 -> $34, $44 -> $38, $47 -> $41, \
$48 -> $74, $49 -> $48, $51 -> $49, $52 -> $53, $53 -> $172, $54 -> \
$55, $54 -> $51, $55 -> $122, $56 -> $53, $66 -> $33, $67 -> $56, $68 \
-> $67, $71 -> $73, $71 -> $75, $72 -> $47, $73 -> $59, $74 -> $72, \
$75 -> $77, $76 -> $72, $77 -> $81, $78 -> $88, $79 -> $83, $80 -> \
$116, $81 -> $83, $82 -> $78, $82 -> $80, $83 -> $68, $84 -> $86, $84 \
-> $89, $85 -> $37, $86 -> $66, $87 -> $85, $88 -> $85, $89 -> $79, \
$93 -> $95, $93 -> $109, $94 -> $93, $11 -> $21, $22 -> $11, $23 -> \
$138, $25 -> $162, $25 -> $26, $27 -> $25, $28 -> $29, $29 -> $169, \
$30 -> $142, $45 -> $30, $50 -> $71, $58 -> $52, $59 -> $58, $60 -> \
$87, $61 -> $161, $96 -> $13, $102 -> $166, $104 -> $106, $104 -> \
$105, $105 -> $140, $106 -> $25, $108 -> $11, $109 -> $105, $109 -> \
$108, $110 -> $108, $110 -> $106, $116 -> $76, $121 -> $82, $122 -> \
$121, $136 -> $15, $178 -> $173, $12 -> $153, $13 -> $157, $13 -> \
$19, $19 -> $84, $37 -> $157, $37 -> $12, $38 -> $40, $38 -> $117, \
$38 -> $155, $39 -> $43, $62 -> $112, $62 -> $117, $62 -> $39, $90 -> \
$101, $98 -> $90, $98 -> $117, $101 -> $39, $101 -> $155, $111 -> \
$112, $111 -> $40, $112 -> $119, $115 -> $90, $115 -> $39, $115 -> \
$40, $117 -> $123, $119 -> $98, $120 -> $115, $123 -> $177, $124 -> \
$120, $125 -> $124, $127 -> $125, $128 -> $132, $128 -> $129, $131 -> \
$132, $131 -> $127, $132 -> $168, $133 -> $129, $133 -> $127, $134 -> \
$139, $137 -> $182, $139 -> $151, $139 -> $176, $151 -> $133, $168 -> \
$176, $168 -> $137, $175 -> $151, $175 -> $137, $177 -> $179, $179 -> \
$128, $182 -> $17, $155 -> $111},
VertexLabels -> {$38 -> "箱1in", $39 -> "箱1out", $40 ->
"箱2out", $49 -> "銀座", $58 -> "銀座", $62 -> "箱2in", $90 ->
"R", $98 -> "R", $101 -> "R", $111 -> "R", $112 -> "R", $115 ->
"箱3in", $117 -> "箱3out", $119 -> "箱崎PA", $120 -> "福住", $123 ->
"福住", $124 -> "木場", $125 -> "枝川", $128 -> "辰1in", $155 -> "R"},
GraphLayout -> "SpringEmbedding"]
![enter image description here][3]
Fig.2 Converted graph from the working file
So, we can make next step for the analysis. Following example is a method to find loops hidden under the Tokyo Highway.
lg = FindCycle[gg, Infinity, All];
Length[lg]
We can find the longest loop way.
HighlightGraph[gg, lg[[77]]]
Red line is a loop found in the center of Tokyo area.
![enter image description here][4]
Sorry for Japanese labels in figures, and I don't recommend you to verify the result of loops, actually. Enjoy the virtual tour presented by Mathematica.
[1]: https://community.wolfram.com/groups/-/m/t/1100917?p_p_auth=vS6IRtZf
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=syutoko.png&userId=897049
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=highwaymap1.png&userId=897049
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=loop.png&userId=897049Hirokazu Kobayashi2020-05-28T14:11:04ZGraph Editor 2020 ver. powered by the Object Oriented Programing
https://community.wolfram.com/groups/-/m/t/1100917
GraphEditor[] is a tool for Graph editing. You can create a new and a complex graph. This new version resolved the issue on the program part using Event function.
GraphEditor shows that Mathematica event handling system is very useful and strong with OOP.
[Object-Oriented-Programming(OOP)][1] in Mathematica is a pathway to make an easy handling method for large number of targets that.
This GraphEditor program can
- make named vertex and arrows connecting with other vertices
- move objects around the board
- delete vertices and arrows
- save and load the graph
- convert to a Mathematica graph.
You can view [a sample movie][2] here.
Source code is here.
(* board *)
Module[{boardGraphics,
boardRatio = 1.4,
boardImageScale = 800,
boardDisable = False,
myStyle = {Medium, FontFamily -> "Helvetica"}},
(* graphics-box-class *)
box[nam_] := Module[{
textInputMode = False,
pos,
boxSize,
title = Null,
arrowLine = {},(* arrow leader *)
arrowPointList = {},
targetArrowList = {}},(* arrows graphics *)
(* graphics-arrow-class *)
arrowImage[nam[pointName_]] ^:= Module[{
delta,
bsize,
tpos,
arrowDrawback = 0},
EventHandler[(
delta = Abs[pos - (tpos = (boxPosGet[pointName]))];
bsize =
0.5*boxSizeGet[pointName]/(boardRatio*boardImageScale);
If[delta != {0, 0},
arrowDrawback =
Norm[delta]*If[Apply[ArcTan, delta] > Apply[ArcTan, bsize],
Abs[bsize[[2]]/delta[[2]]],
Abs[bsize[[1]]/delta[[1]]]]];
;
{Arrowheads[Medium],
Arrow[{pos, boxPosGet[pointName]}, {0, arrowDrawback}]}),
{"MouseClicked" :>
If[CurrentValue["CommandKey"],
boxArrowPointDelete[nam[pointName]]]
}, PassEventsUp -> False]
];(* end of arrow class *)
boxArrowPointList[nam[pointName_]] ^:=
AppendTo[arrowPointList, pointName];
boxArrowPointDelete[nam[pointName_]] ^:= (
arrowPointList =
Delete[arrowPointList,
Position[arrowPointList, pointName][[1]]]
);
boxPosSet[nam[x_]] ^:= (pos = x);
boxPosGet[nam] ^:= pos;
boxTitleSet[nam[x_]] ^:= title = x;
boxTitleGet[nam] ^:= title;
boxAPListSet[nam[x_]] ^:= arrowPointList = x;
boxAPListGet[nam] ^:= arrowPointList;
boxSizeSet[nam[x_]] ^:= boxSize = x;
boxSizeGet[nam] ^:= boxSize;
boxBoth[nam] ^:=
Which[
textInputMode == True,
(* graphics of text-input-
mode *)
{arrowLine, targetArrowList,
Text[
EventHandler[
InputField[Dynamic[title], String, FieldSize -> Small
, BaseStyle -> myStyle],
{"MouseEntered" :> None,
"DownArrowKeyDown" :> Paste["\n"],
"ReturnKeyDown" :> (boardDisable = False;
textInputMode = False;
boxSizeSet[
nam[ImageDimensions@
Rasterize@
Text@Framed[title, FrameMargins -> 5,
BaseStyle -> myStyle]]])
}, PassEventsUp -> False], pos]},
textInputMode == False,(* graphics-
mode *)
{Dynamic[{arrowLine, targetArrowList}],
EventHandler[
Text[Framed[title, FrameMargins -> 5, BaseStyle -> myStyle],
Dynamic[pos], Background -> LightGray],
{"MouseDragged" :> Switch[CurrentValue["OptionKey"],
True, (arrowLine =
Line[{boxPosGet[nam], MousePosition["Graphics"]}]),
False, (pos = MousePosition["Graphics"])
],(* end of if-current value *)
"MouseClicked" :>
Which[probe[$x[{nam, boardDisable}]]; (*
OOP probe program hook line *)
CurrentValue["CommandKey"], removeInst[nam],
CurrentValue["ShiftKey"], textInputMode = True;
boardDisable = True],
"MouseMoved" :> (pointName = nam),(*
get the name of another instance *)
"MouseUp" :> Which[
CurrentValue["OptionKey"],
(arrowLine = {};
boxArrowPointList[nam[pointName]];(*
append point to the list *)
(*
overide arrow instances *)
targetArrowList :=
Map[arrowImage[nam[#]] &, arrowPointList]),
True, arrowLine = {}(* safety eraser *)
],(*
end of if-shift-key *)
PassEventsUp -> False},
PassEventsUp -> False](* end of event-handler *)
}(*
end of graphics *)
];(* end of text-input-mode *)
buildUpArrowList[nam] ^:=
targetArrowList := Map[arrowImage[nam[#]] &, arrowPointList]
]; (* end of box-class *)
(* function to make box-instance with unique name *)
makeInst[newPos_] := (
newName = Unique[];
box[newName];(* make new box instance *)
boxPosSet[newName[newPos]];(* pop-up the instance on the board *)
boxSizeSet[
newName[ImageDimensions@
Rasterize@Text@Framed[Null, BaseStyle -> myStyle]]];
AppendTo[namList, newName];
targetList := Map[boxBoth, namList](* makeup graphics *)
);
(* function to remove box-instance *)
removeInst[
boxName_] :=
(namList =
Delete[namList, Position[namList, boxName][[1]]];
targetList = Map[boxBoth, namList]);
boardGraphics =
Graphics[Dynamic[targetList],
PlotRange -> {{0, boardRatio}, {0, 1.}},
ImageSize -> {boardRatio, 1}*boardImageScale];
delegate := (
Which[boardDisable == True, boardGraphics,
boardDisable == False, EventHandler[boardGraphics,
"MouseClicked" :> Which[
CurrentValue["OptionKey"] == True,
CreateDialog[
Pane[Column[{Button["Save",
Put[Map[
Map[#, namList] &, {List, boxAPListGet, boxTitleGet,
boxPosGet, boxSizeGet}], "graph"]; DialogReturn[]],
Button["Load", buildUp[Get["graph"]]; DialogReturn[]]}
], ImageMargins -> 5], Modal -> True,
WindowTitle -> "objects"]; boardDisable == False,
True, makeInst[MousePosition["Graphics"]]
], PassEventsUp -> False](*
end of EventHandler *)
]);(* end of delegate graphics *)
(* build up graphics from file *)
buildUp[{namListX_, boxAPList_, boxTitle_, boxPos_, boxSize_}] := (
Apply[Clear, namList = Flatten@namListX];
targetList = {};
Map[box, namList];
MapThread[boxPosSet[#1[#2]] &, {namList, boxPos}];
MapThread[boxSizeSet[#1[#2]] &, {namList, boxSize}];
MapThread[boxTitleSet[#1[#2]] &, {namList, boxTitle}];
MapThread[boxAPListSet[#1[#2]] &, {namList, boxAPList}];
Map[buildUpArrowList, namList];
Flatten@ReleaseHold[
MapThread[f[#1, #2] &, {namList, boxAPList}] /.
f[nam_, p_] -> Hold@Map[boxArrowPointList[nam, #] &, p]];
targetList = Map[boxBoth, namList];
boardDisable = False
);
](* end of Module *)
To start the program,
targetList = {}; namList = {};
SetDirectory[NotebookDirectory[]];
Framed@Deploy@Dynamic@delegate
then, you can see the blank board.
**Usage is as follows.**
**Board area:**
Click makes text-box, and with Option-key Click shows menu for data save to a file and load data from a file.
**Text-box:**
Drag moves text-box around
with Shift-key Click move into the title input mode, and Return-key move out to the graphics mode
with Command-key Click deletes text-box
with Option-key Drag the mouse into another text-box make connection with an arrow
**Arrow:**
with Command-key Click deletes arrow
Following is a sample code for saved data converter to the Mathematica Graph data.
g = Get["graph"][[1 ;; 3]]; (* read the file *)
f[t_] := Map[Rule[t[[1]], #] &, t[[2]]]; (* define rule function *)
gl1 = Flatten@
Map[f, Transpose[{Flatten[g[[1]]],
g[[2]]}]]; (* construct vertex list of graph *)
gl1 = gl1 /.
Rule[x_, y_] /; x == y -> Nothing; (* remove self loop *)
gl2 = Map[Rule[#[[1, 1]], #[[2]]] &,
Transpose[{g[[1]],
g[[3]]}]];(* construct label list of graph *)
gg =
Graph[gl1, VertexLabels -> gl2, ImagePadding -> 50,
GraphLayout -> "SpringEmbedding"]
Unfortunately, the number of vertex labels may be limited, you may chose the labels, and can get a graph converted from the GraphEditor file.
[1]: http://community.wolfram.com/groups/-/m/t/897081?p_p_auth=MM13qcBI
[2]: https://s3-ap-northeast-1.amazonaws.com/kobayashikorio/math_slides/graph.mp4
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=fig.1.png&userId=897049
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Fig.2.png&userId=897049
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Fig.3.png&userId=897049Hirokazu Kobayashi2017-05-22T12:41:36ZAlgorithm For Nearest Neighbor Undirected Weighted Graph
https://community.wolfram.com/groups/-/m/t/1984545
Version 1 for adjacency matrix input. See below for tabular data input.
Error reports and general feedback welcome.
&[Wolfram Notebook][1]
[1]: https://www.wolframcloud.com/obj/1a92894d-f33f-4c7f-9c9b-8ff8e0082807Richard Frost2020-05-24T22:31:50ZIs there a predefined DistanceFunction for numerically weighted graphs?
https://community.wolfram.com/groups/-/m/t/1983316
Here's a scaled-down example. I have graphs with weighted edges that I'd like to use in NearestNeighborGraph, Dendrogram, ClusteringTree, etc. So far I've only had success with Graph[] and GraphDistance[].
vertices = {"A", "B", "C", "D"} ;
adjM =
{{0, 0.1, 0.4, 0.2},
{0.1, 0, 0.1, 0.5},
{0.4, 0.1, 0, 0.2},
{0.2, 0.5, 0.2, 0}} ;
edges = Flatten[
Table[Table[
Annotation[
Extract[vertices, i] \[UndirectedEdge] Extract[vertices, j],
EdgeWeight -> Extract[Extract[adjM, i], j]], {j, i + 1, 4}], {i,
1, 3}]] ;
g4 = Graph[edges];
Graph[g4,
VertexLabels -> All,
VertexLabelStyle -> "Medium",
EdgeLabels -> "EdgeWeight",
EdgeLabelStyle -> Medium,
GraphLayout -> "RadialDrawing",
ImageSize -> Small]
GraphDistance[g4, "A", "C"]
0.2
NearestNeighborGraph[edges]
NearestFunction: The default distance function does not give a real number distance when applied to the point pair A\[UndirectedEdge]B and A\[UndirectedEdge]C
Dendrogram[edges]
(unweighted output)Richard Frost2020-05-23T03:19:56Z