2 added 329 characters in body
source | link

A little messy and not fully optimised. Though I have parallelised the edge cost function calls.

MyDijkstra[graph_, source_, target_, EdgeCostFunction_] := 
 Module[{vexl, sourceI, targetI, Q, n, dist, prev, alt, u, v, S},

  Qvexl = VertexList[graph];

  n = Length[Q];Length[vexl];
  {sourceI, targetI} = Position[vexl, #][[1, 1]] & /@ {source, target};

  Q = Range[n];

  dist = ConstantArray[\[Infinity], n];
  prev = ConstantArray[Indeterminate, n];

  dist[[source]]dist[[sourceI]] = 0;

  While[Length[Q] > 0,
   u = Q[[First@Ordering[dist[[#]] & /@ Q, 1]]];
   If[u == targettargetI, Break[]];
   Q = DeleteCases[Q, u];
 

   For[iv = 1Position[vexl, i#][[1, <=1]] Length[v& =/@ Rest@VertexOutComponent[graph, u, 1]]vexl[[u]], i++,1];
    alt = dist[[u]] + EdgeCostFunction[uParallelMap[EdgeCostFunction[vexl[[u]], v[[i]]];#] &, vexl[[v]]];

   For[i = If[alt1, i <= Length[v], i++,
    If[alt[[i]] < dist[[v[[i]]]],
      dist[[v[[i]]]] = alt;alt[[i]];
      prev[[v[[i]]]] = u;
     ];
 
    ];
  
  ];
 

  (*Reverse iterate the shortest path*)
  S = {};
  u = target;targetI;

  While[NumberQ@prev[[u]],
   PrependTo[S, u];
   u = prev[[u]];
   ];

  PrependTo[S, u];

  S
 {vexl[[S]], dist[[targetI]]}
]
MyDijkstra[graph_, source_, target_, EdgeCostFunction_] := 
 Module[{Q, n, dist, prev, u, v, S},

  Q = VertexList[graph];

  n = Length[Q];
  dist = ConstantArray[\[Infinity], n];
  prev = ConstantArray[Indeterminate, n];

  dist[[source]] = 0;

  While[Length[Q] > 0,
   u = Q[[First@Ordering[dist[[#]] & /@ Q, 1]]];
   If[u == target, Break[]];
   Q = DeleteCases[Q, u];
 

   For[i = 1, i <= Length[v = Rest@VertexOutComponent[graph, u, 1]], i++,
    alt = dist[[u]] + EdgeCostFunction[u, v[[i]]];
    If[alt < dist[[v[[i]]]],
     dist[[v[[i]]]] = alt;
     prev[[v[[i]]]] = u;
     ];
 
    ];
   ];
 

  (*Reverse iterate the shortest path*)
  S = {};
  u = target;

  While[NumberQ@prev[[u]],
   PrependTo[S, u];
   u = prev[[u]];
   ];

  PrependTo[S, u];

  S
  ]

A little messy and not fully optimised. Though I have parallelised the edge cost function calls.

MyDijkstra[graph_, source_, target_, EdgeCostFunction_] := 
 Module[{vexl, sourceI, targetI, Q, n, dist, prev, alt, u, v, S},

  vexl = VertexList[graph];

  n = Length[vexl];
  {sourceI, targetI} = Position[vexl, #][[1, 1]] & /@ {source, target};

  Q = Range[n];

  dist = ConstantArray[\[Infinity], n];
  prev = ConstantArray[Indeterminate, n];

  dist[[sourceI]] = 0;

  While[Length[Q] > 0,
   u = Q[[First@Ordering[dist[[#]] & /@ Q, 1]]];
   If[u == targetI, Break[]];
   Q = DeleteCases[Q, u];

   v = Position[vexl, #][[1, 1]] & /@ Rest@VertexOutComponent[graph, vexl[[u]], 1];
   alt = dist[[u]] + ParallelMap[EdgeCostFunction[vexl[[u]], #] &, vexl[[v]]];

   For[i = 1, i <= Length[v], i++,
    If[alt[[i]] < dist[[v[[i]]]],
      dist[[v[[i]]]] = alt[[i]];
      prev[[v[[i]]]] = u;
    ];
   ];
 
  ];

  (*Reverse iterate shortest path*)
  S = {};
  u = targetI;

  While[NumberQ@prev[[u]],
   PrependTo[S, u];
   u = prev[[u]];
  ];

  PrependTo[S, u];

  {vexl[[S]], dist[[targetI]]}
]
1
source | link

As @Szabolcs suggested I have created my own shortest path finder, based on Dijkstra's algorithm, which allows me to use an EdgeWeightFunction. It's pretty much a translation of the pseudocode on the wiki and I include it below. First I'll demonstrate its use.

Example Use

The code to generate the two graphs, g1 and g2 in my post above:

edges = {1 -> 2, 2 -> 3, 4 -> 3, 1 -> 4, 1 <-> 5, 2 <-> 6, 3 <-> 7, 4 <-> 8, 5 -> 6, 6 -> 7, 8 -> 7, 5 -> 8};
coords = {{-0.5, -0.5}, {0.5, -0.5}, {0.5, 0.5}, {-0.5, 0.5}, {-1., -1.}, {1., -1.}, {1., 1.}, {-1., 1.}};
weights1 = {1, 1, 1, 1, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25};
weights2 = {1, 1, 1, 1, 10, 10, 10, 10, 0.25, 0.25, 0.25, 0.25};


g1 = Graph[edges,
  EdgeLabelStyle -> Directive[Red, 12, Background -> White],
  EdgeLabels -> Thread[edges -> weights],
  VertexCoordinates -> coords,
  VertexLabels -> "Name",
  VertexStyle -> {1 -> Green, 3 -> Red}
 ]

g2 = Graph[edges,
  EdgeLabelStyle -> Directive[Red, 12, Background -> White],
  EdgeLabels -> Thread[edges -> weights],
  VertexCoordinates -> coords,
  VertexLabels -> "Name",
  VertexStyle -> {1 -> Green, 3 -> Red}
 ]

enter image description here

The paths given by the built in FindShortestPath:

FindShortestPath[g1, 1, 3]
FindShortestPath[g2, 1, 3]

{1, 5, 6, 7, 3}

{1, 2, 3}

And MyDijkstra:

MyDijkstra[g1, 1, 3, MyEdgeCost]
MyDijkstra[g2, 1, 3, MyEdgeCost]

{1, 5, 6, 7, 3}

{1, 2, 3}

Where we define the function MyEdgeCost as follows (change g1 to g2):

wam = WeightedAdjacencyMatrix[g1];
vexl = VertexList[g1];
order = Ordering[g1];

wamo = Transpose[Transpose[wam[[order]]][[order]]];

MyEdgeCost[s_, t_] := wamo[[s, t]]

The reordering of the WeightedAdjacencyMatrix is because WeightedAdjacencyMatrix makes a matrix with entries ordered according to the order returned by VertexList.

Performance

Now to the usefulness! Running MyDijkstra on g1 and g2 and counting the number of function calls we get 15 in the first case, and only 7 in the second. This is functionality that I want as I will now be able to calculate a greatly reduced number of edge costs (which are not known in advance and are expensive to compute) in my large (mostly unvisited) graph.

One can also use memoization to further reduce calls in both directions on undirected edges:

MyEdgeCost[s_, t_] := MyEdgeCost[s, t] = MyEdgeCost[t, s] = wamo[[s, t]]

(I have not attempted to optimise the below function as it is still very quick even on large graphs and certainly not a limiting factor in my implementations.)

The Function

MyDijkstra[graph_, source_, target_, EdgeCostFunction_] := 
 Module[{Q, n, dist, prev, u, v, S},

  Q = VertexList[graph];

  n = Length[Q];
  dist = ConstantArray[\[Infinity], n];
  prev = ConstantArray[Indeterminate, n];

  dist[[source]] = 0;

  While[Length[Q] > 0,
   u = Q[[First@Ordering[dist[[#]] & /@ Q, 1]]];
   If[u == target, Break[]];
   Q = DeleteCases[Q, u];


   For[i = 1, i <= Length[v = Rest@VertexOutComponent[graph, u, 1]], i++,
    alt = dist[[u]] + EdgeCostFunction[u, v[[i]]];
    If[alt < dist[[v[[i]]]],
     dist[[v[[i]]]] = alt;
     prev[[v[[i]]]] = u;
     ];

    ];
   ];


  (*Reverse iterate the shortest path*)
  S = {};
  u = target;

  While[NumberQ@prev[[u]],
   PrependTo[S, u];
   u = prev[[u]];
   ];

  PrependTo[S, u];

  S
  ]