9
$\begingroup$

I am studying Mr. Wizard's answer to this question which tries to identify elementary circles in a graph. That answer uses dynamic programming technique to simplify the code. The underlying guideline in the code is that, in Mathematica, more specific rules are applied before more general rules. Thus, the three functions with the same name f:

(* case 1 *)
f[x_, b___, x_] := (
   (f[##] = {}) & @@@ NestList[RotateLeft, {x, b}, Length@{x, b} - 1];
   {{x, b}}
);

(* case 2 *)
f[circle__] /; Signature@{circle} === 0 = {};

(* case 3 *)
f[circle___, vertex_] := 
  Join @@ (f[circle, vertex, #] & /@ ReplaceList[vertex, edges]);

will always be checked and evaluated in the order case1 -> case2 -> case3. Where the circle___ is initially an nonexistent expression and I slightly modify the variable names to make the code easier to understand. For example, when we evaluate f[1], firstly the pattern of case1 doesn't apply, so we come to case2 which is also not applicable due to the fact thatSignature@{1} is not 0. Finally we check that case3 is applicable and duo to SetDelayed we need to temporarily leave the evaluation of f[1] and try to compute f[1,2] and f[1,4] instead, and so on. We can use Trace[f[1]] or Trace[f[1], f[__]] to get a sense of the evaluation progress. But the results are nested expressions and not easy to recognize.

It will be helpful for us to understand the code better if we can find a way to visualize the dynamic progress. A first try can be made like this

op = {{1, 2}, {1, 4}, {2, 3}, {2, 5}, {3, 1}, {3, 6}, {4, 1}, {4, 
    6}, {5, 4}, {5, 2}, {6, 5}, {6, 3}};
vertices = Union @@ op;
edges = Rule @@@ op;

traceRes = Trace[f[1], f[__]];
traceResIndex = traceRes /. MapIndexed[#1 -> #2[[1]] &, 
    DeleteDuplicates@Flatten@traceRes];
pos = First@Position[traceResIndex, #] & /@ Flatten[traceResIndex];
pos = Sort[pos, Length[#1] <= Length[#2] &];
pos = Gather[pos, Length[#1] == Length[#2] &];

length = Length[pos];
i = 1;
linkedVretices = {};
With[{cmuopt = SystemOptions["CompileOptions"]},
  Internal`WithLocalSettings[
   SetSystemOptions[{
     "CompileOptions" -> "ListableFunctionCompileLength" -> Infinity,
     "CompileOptions" -> "MapCompileLength" -> Infinity
     }], (
    While[i + 1 <= length,
      linkedVretices = {
        linkedVretices,
        Map[
         Block[{subList, subLength, link, var},
           subList = pos[[i, #]];
           subLength = Length[subList];
           subList[[-1]] += 1;
           link = Select[pos[[i + 1]], #[[;; subLength]] == subList &];
           Thread[Rule[var, link]] /. var -> pos[[i, #]]
           ] &, Range@Length@pos[[i]]
         ]};
      i += 1;
      ];),
   SetSystemOptions[cmuopt]
   ]];
linkedVretices = Flatten[linkedVretices];
linkedVretices = Apply[traceRes[[##]] &, linkedVretices, {2}]

GraphPlot[linkedVretices, VertexLabeling -> True]

enter image description here

We can clearly understand the progress from the above graph. However, as the input data op gets a bit more complex, for example,

op = {{1, 2}, {1, 9}, {2, 3}, {2, 17}, {3, 4}, {3, 13}, {4, 1}, {4, 
    5}, {5, 4}, {5, 6}, {6, 16}, {6, 7}, {7, 8}, {7, 22}, {8, 5}, {8, 
    10}, {9, 1}, {9, 10}, {10, 8}, {10, 11}, {11, 12}, {11, 21}, {12, 
    9}, {12, 18}, {13, 14}, {13, 3}, {14, 15}, {14, 20}, {15, 
    16}, {15, 23}, {16, 13}, {16, 6}, {17, 2}, {17, 18}, {18, 
    19}, {18, 12}, {19, 24}, {19, 20}, {20, 17}, {20, 14}, {21, 
    11}, {21, 22}, {22, 7}, {22, 23}, {23, 15}, {23, 24}, {24, 
    19}, {24, 21}};

Then the result will be

GraphPlot[linkedVretices, VertexLabeling -> Tooltip]

enter image description here

or if we use CommunityGraphPlot

enter image description here

Now it is too complex for extracting useful information. I wonder if we can find a way to clearly visualize the progress, like only show some "local graph" in-progress? Such technique, although not very important for actually solving problems, can still be valuable for tracking.

$\endgroup$

1 Answer 1

6
$\begingroup$

You could reconstruct graph with some more information. Here, I add Tooltip wrapper to vertex to show NeighborhoodGraph of that vertex in distance 2:

g = Graph[linkedVretices];

Graph[
   Tooltip[#, 
   HighlightGraph[
   NeighborhoodGraph[g, #, 2, 
   VertexShapeFunction -> (Text[Pane[#2, 80], #1] &), 
   GraphLayout -> {"RadialEmbedding", "RootVertex" -> #}, 
   VertexStyle -> Black], #1]] & /@ VertexList[g], 
   EdgeList[g], 
   GraphStyle -> "LargeNetwork", GraphLayout -> {"RadialEmbedding"}]

Here, I add the rough version that select vertices by rectangle area and generate subgraph. I just create separate static window to show snapshot of selected subgraph, but you could easily make dynamic window that respect sub vertices.

First, some pre-computation:

g = Graph[linkedVretices, GraphLayout -> "RadialEmbedding"];
vcoord = GraphEmbedding[g];
{xrange, yrange} = {Min[#], Max[#]} & /@ Transpose[vcoord];
xwid = Abs[xrange[[2]] - xrange[[1]]];
ywid = Abs[yrange[[2]] - yrange[[1]]];
xrange = xrange + .1 xwid {-1, 1};
yrange = yrange + .1 ywid {-1, 1};
isize = {600, 600};
g = Graph[linkedVretices, VertexCoordinates -> vcoord, 
   PlotRange -> {xrange, yrange}, PerformanceGoal -> "Speed", 
   VertexShapeFunction -> "Point", ImageSize -> isize, 
   VertexStyle -> Black];
crule = Thread[vcoord -> VertexList[g]];

and generate Manipulate:

DynamicModule[{x, y, xmin, xmax, ymin, ymax, ptin, vin, subg},
 Manipulate[
  Overlay[{Dynamic[g], 
    Graphics[{{Opacity[.2], 
       Dynamic[Rectangle[pts[[1]], 
         pts[[2]]], {None, {x, y} = Transpose[pts];
         {xmin, xmax} = Through[{Min, Max}[x]];
         {ymin, ymax} = Through[{Min, Max}[y]];
         ptin = 
          Cases[vcoord, 
           x_ /; (xmin <= x[[1]] <= xmax && ymin <= x[[2]] <= ymax)];
         }]}, {Orange, Point[Dynamic@ptin]}}, 
     PlotRange -> {xrange, yrange}, ImageSize -> isize]}, All, 2],
  {{pts, {{xrange[[1]], yrange[[2]]}, {xrange[[1]] + xwid .2, 
      yrange[[2]] - ywid .2}}}, Locator},
  Button["Zoom", vin = ptin /. crule; 
   subg = Subgraph[g, vin, 
     VertexCoordinates -> vcoord[[VertexIndex[g, #] & /@ vin]], 
     VertexLabels -> Placed["Name", Tooltip]]; 
   CreateDialog[subg, WindowTitle -> "Zoom", 
     WindowFrameElements -> {"CloseBox", "ResizeArea"}, 
     WindowFloating -> True], 
   Method -> "Queued"]]
 ]

enter image description here

you could wrap this as one function.

$\endgroup$
3
  • $\begingroup$ This is a good idea! Actually I got inspired by your result: can we make a graph like this, say, by using mouse to select a rectangle area, we can then show a new sub-graph containing only the nodes inside that area? This will be quite useful... $\endgroup$
    – saturasl
    Jan 7, 2014 at 3:32
  • $\begingroup$ @saturasl I added code you mentioned...Hope this help $\endgroup$
    – halmir
    Jan 8, 2014 at 20:05
  • $\begingroup$ Excellent code! I will study it, thank you! $\endgroup$
    – saturasl
    Jan 10, 2014 at 6:22

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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