How to create a 'shortest-path link matrix'?

Question

I am currently struggling with a problem in Mathematica.

I have a randomly generated weighted Barabasi-Albert graph and a corresponding demand matrix of the same size. I'm generating the graph with the following code:

generateBarabasiAlbertGraph[n_, l_] /; n >= 3 := 
 Module[{g = CycleGraph[3], vc, vl, el},
 Do[
 vc = VertexCount[g];
 vl = VertexList[g];
 el = EdgeList[g];
 ec = EdgeCount[g];
 wl = RandomInteger[{5, 20}, {ec}];
 graph = Graph[el, EdgeWeight -> wl, EdgeWeight -> "EdgeWeight"];
 el = Map[UndirectedEdge[vc + 1, #] &, 
   RandomSample[VertexDegree[g] -> vl, Min[l, vc]]
   ];
 g = Graph[Join[EdgeList[g], el], 
   VertexLabels -> Placed["Name", Before]], {n - 3}];
   g; 
];
v = RandomInteger[{5, 10}];
l = RandomInteger[{1, 2}];
generateBarabasiAlbertGraph[v, l];

I then calculate the shortest path from each vertex a to vertex b if vertex a has a demand from vertex b.

Now I would like to create a shortest-path link matrix for all shortest paths in the graph. (A similar graph appears in this paper by Kelly).

This is what I already figured out:

TableForm[Array[0 &, {EdgeCount[graph], 1}], TableHeadings -> {EdgeList[graph], {sp}}]

As you can see, I have the shortest-path 3-1-4 and need to replace the 0 at the corresponding row if this edge is used in the shortest path. So in this case I need a 1 in row 3 and 4

Any ideas?

Best, Julian

Answer 1

Judging from the paper you linked to and your own comments, I think what you really want is a directed Barabasi–Albert graph whose opposite edges have different weight. (Thus e.g. edge 1 -> 2 should have a different weight than 2 -> 1).

The code you posted generates an undirected BA graph, so allow me to suggest an alternative generating function based on the built-in command BarabasiAlbertGraphDistribution:

RandomDirectedWeightedBAGraph[n_, k_] :=
  WeightedAdjacencyGraph @ Replace[
    Normal @ AdjacencyMatrix @ RandomGraph @ BarabasiAlbertGraphDistribution[n, k],
    {1 :> RandomInteger[{n, 4n}], 0 -> Infinity},
    {2}
  ];

This first generates a random Barabasi–Albert graph, gets its AdjacencyMatrix, and replaces the non-zero entries with random weights, and uses that to construct a new graph.

We can now generate a (very simple) graph as follows:

graph = RandomDirectedWeightedBAGraph[3, 2];

It's not obvious from the graphical representation, but the edges do have different weights, as we can check with WeightedAdjacencyMatrix:

Normal @ WeightedAdjacencyMatrix @ graph

{
  {0,  6, 3}, 
  {3,  0, 7}, 
  {7, 10, 0}
}

Thus edge 1 -> 2 has weight 6, and edge 2 -> 1 has weight 3.

Since I don't know what your definition of 'demand' is, I'll compute the shortest paths for all possible vertex combinations:

allVertexPairs = Permutations[VertexList @ graph, {2}]

{{1, 2}, {1, 3}, {2, 1}, {2, 3}, {3, 1}, {3, 2}}

shortestPaths = FindShortestPath[graph, All, All] @@@ allVertexPairs

{{1, 2}, {1, 3}, {2, 1}, {2, 1, 3}, {3, 1}, {3, 2}}

Notice that the shortest path from vertex 2 to 3 is not simply 2 -> 3, but 2 -> 1 -> 3. This is because FindShortestPath takes the edge weight into account. The former path has distance 7, the latter 3 + 3.

We can now proceed to compute the 'shortest path link matrix':

shortestPathLinkMatrix = Outer[
  Boole @ MemberQ[#2, #1] &,
  EdgeList[graph],
  DirectedEdge @@@ Partition[#, 2, 1] & /@ shortestPaths,
  1
]

{
  {1, 0, 0, 0, 0, 0}, 
  {0, 1, 0, 1, 0, 0}, 
  {0, 0, 1, 1, 0, 0}, 
  {0, 0, 0, 0, 0, 0},
  {0, 0, 0, 0, 1, 0},
  {0, 0, 0, 0, 0, 1}
}

This can finally be plugged into TableForm to give the desired result:

 TableForm[shortestPathLinkMatrix, TableHeadings -> {EdgeList @ graph, shortestPaths}]

Answer 2

Taking an example of a shortest-path vertex list and an edgelist from your code:

spvertices = {4, 2, 1, 5};
edges = {1 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 3, 
         2 \[UndirectedEdge] 3, 4 \[UndirectedEdge] 2, 
         5 \[UndirectedEdge] 1, 6 \[UndirectedEdge] 2, 
         7 \[UndirectedEdge] 3, 8 \[UndirectedEdge] 2};
spath = Partition[spvertices, 2, 1];
(* {{4,2},{2,1},{1,5}} *)
xx =  Tr /@ Outer[Boole[Equal[##]] &, Sort /@ List @@@ edges, Sort /@ spath, 1];
(* or xx =Tr /@ Outer[Boole[Complement[##] == {}] &, List @@@ edges, spath, 1]; *)
(* {1,0,0,1,1,0,0,0} *)
TableForm[List /@ xx, TableHeadings -> {edges, {{4, 2, 1, 5}}}, TableAlignments ->Center]