# Creating a medium size graph with EdgeWeight is super slow

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


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}}

• 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 Dec 7, 2022 at 22:49
• 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. Dec 8, 2022 at 6:00
• I think it's a bug in EdgeWeight use with rules; I will report it to Wolfram. Dec 8, 2022 at 6:02

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} *)