1
$\begingroup$

I have discovered that creating medium-size (10k vertices, 40k edges) edge-weighted graphs takes impossibly long.

My motivation is solving AdventOfCode 2021 day 15, which can be formulated as a problem of finding the shortest path in an edge-weighted graph. The vertices of the graph correspond to the elements of a matrix. The vertices are connected horizontally and vertically but not diagonally, and the cost of moving from one to another is the value of the target element. For example, given a matrix

parse[s_] := ToExpression[Characters /@ StringSplit[s]];
a = parse@"1163751742
1381373672
2136511328
3694931569
7463417111
1319128137
1359912421
3125421639
1293138521
2311944581";

we can constructed a weighted graph:

weightedGraph[a_] := With[{n = Length@a},
   Graph[
    Cases[
     Flatten[
      Table[{x, y} \[DirectedEdge] # & /@ {{x, y - 1}, {x, 
          y + 1}, {x - 1, y}, {x + 1, y}}, {x, n}, {y, n}], 3],
     {_, _} \[DirectedEdge] {x_, y_} /; (1 <= x <= n && 
        1 <= y <= n)],
    EdgeWeight -> {{_, _} \[DirectedEdge] {x_, y_} :> a[[x, y]]}]];
g = weightedGraph@a

enter image description here

and find the lowest-cost path from the top left corner to the bottom right corner of the matrix (answer 40 matches the example in the AdventOfCode problem description).

lowestRisk[a_] := 
  With[{path = 
     FindShortestPath[weightedGraph@a, {1, 1}, Dimensions@a, 
      Method -> "Dijkstra"]}, 
   Total[a[[#[[1]], #[[2]]]] & /@ Rest@path]];
lowestRisk@a (* 40 *)

I discovered that even for the smaller graph of Part 1, which corresponds to a 100x100 matrix, my lowestRisk calculation takes about 45 seconds, and apparently most of it is taken by weightedGraph (while I naively thought that somehow FindShortestPath is the culprit):

a = parse@Import["https://pastebin.com/raw/jgKqC6DT", "Text"];
g = weightedGraph@a; // AbsoluteTiming (* {44.6422, Null} *)

Such a long calculation time makes solving Part 2, involving 500x500 matrices, completely impractical - the code to create the weighted graph takes many dozens of minutes, I stopped the calculation before it was even complete.

Am I missing something obvious here? Are there any faster ways to create weighted graphs?

Update.

The above effect can be demonstrated in a more straightforward way: using a graph construct inspired by EdgeWeight documentation page, compare the time it takes to create weighted graph:

In[63]:= Table[{2^n, 
  First@AbsoluteTiming[
    Graph[#[[1]] \[DirectedEdge] #[[2]] & /@ Tuples[Range[2^n], 2], 
      EdgeWeight -> {_?(OddQ[First[#]] &) -> -1}];]}, {n, 7}]

Out[63]= {{2, 0.000095}, {4, 0.000086}, {8, 0.000231}, {16, 
  0.001516}, {32, 0.023079}, {64, 0.301492}, {128, 4.52603}}

with time to create just the graph:

Table[{2^n, 
  First@AbsoluteTiming[
    Graph[#[[1]] \[DirectedEdge] #[[2]] & /@ 
       Tuples[Range[2^n], 2]];]}, {n, 7}]

{{2, 0.000067}, {4, 0.000053}, {8, 0.000107}, {16, 0.000377}, {32, 
  0.001166}, {64, 0.005321}, {128, 0.023285}}
$\endgroup$
3
  • 1
    $\begingroup$ It's slow because of the use of pattern matching in the edge weight specification. Look up IGEdgeMap in the IGraph/M package for a fast and convenient solution $\endgroup$
    – Szabolcs
    Dec 7, 2022 at 22:49
  • $\begingroup$ I don't understand this. In my updated example above, EdgeWeight via rules for n = 7 takes 4 seconds. However, if we create an unweighted graph first g = Graph[#[[1]] \[DirectedEdge] #[[2]] & /@ Tuples[Range[2^7], 2]]; (which takes 0.02 seconds), and manually apply the rules to the list of edges, e.g. (EdgeList@g) /. {_?(Head[#] === DirectedEdge && OddQ[First[#]] &) -> -1, _DirectedEdge -> 0} // AbsoluteTiming, it takes only another 0.02 seconds. Rule application should be very fast for such small lists. $\endgroup$
    – Victor K.
    Dec 8, 2022 at 6:00
  • $\begingroup$ I think it's a bug in EdgeWeight use with rules; I will report it to Wolfram. $\endgroup$
    – Victor K.
    Dec 8, 2022 at 6:02

1 Answer 1

2
$\begingroup$

The problem seems to be with defining EdgeWeight via rules. A solution, inspired by Medium-sized graph won't build, is to create the graph using an explicit list of edge weights:

edges[a_] := With[{n = Length@a},
  Cases[
   Table[{x, y} \[DirectedEdge] # & /@ {{x, y - 1}, {x, 
       y + 1}, {x - 1, y}, {x + 1, y}}, {x, n}, {y, n}],
   {_, _} \[DirectedEdge] {x_, y_} /; (1 <= x <= n && 1 <= y <= n), 
   Infinity]]

weightedGraph2[a_] := 
 Graph[edges@a, 
  EdgeWeight -> (a[[#[[1]], #[[2]]]] & /@ (Last /@ edges@a))]

lowestRisk[a_] := 
 With[{path = 
    FindShortestPath[weightedGraph2@a, {1, 1}, Dimensions@a, 
     Method -> "Dijkstra"]}, 
  Total[a[[#[[1]], #[[2]]]] & /@ Rest@path]]

lowestRisk@
  parse@Import["https://pastebin.com/raw/jgKqC6DT", 
    "Text"] // AbsoluteTiming (* {0.287795, 390} *)
$\endgroup$

Your Answer

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

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