Wolfram Research

WeightedDistanceGraph

Contributed by: Ed Pegg Jr

Source Notebook

Given vertices, return a complete graph with edge weights equal to edge lengths

ResourceFunction["WeightedDistanceGraph"][vert]

Given the list of vertices vert, return a graph where edges are vertex pairs weighted by their Euclidean distance.

Examples

Basic Examples

The output based on the Kreisel-Kurz integral heptagon looks like a random complete graph:

In[1]:=
pts = (# {1/2227, Sqrt[2002]/2227} & /@
    {{0, 0}, {49595290, 0}, {26127018, 932064}, {32142553, 411864}, {17615968, 238464}, {7344908, 411864}, {19079044, -54168}});
g = ResourceFunction["WeightedDistanceGraph"][pts]
Out[2]=

The graph has edgeweights:

In[3]:=
WeightedAdjacencyMatrix[g] // MatrixForm
Out[3]=

Scope

The Wolfram Language has several graph functions which work on point sets which do not return weighted graphs. Operations on graphs without proper weighting can return unexpected results:

In[4]:=
v = RandomReal[1, {15, 2}];
g = {ResourceFunction["WeightedDistanceGraph"][v], NearestNeighborGraph[v, 3]};
Grid[{g, FindSpanningTree[#, Method -> "Kruskal"] & /@ g}]
Out[5]=

With weights given to edges, a method like Kruskal’s algorithm can work as expected:

In[6]:=
v = RandomReal[1, {20, 2}];
FindSpanningTree[ResourceFunction["WeightedDistanceGraph"][v], Method -> "Kruskal"]
Out[7]=

With weights given to edges, a method like Prim’s algorithm can work as expected:

In[8]:=
v = RandomReal[1, {20, 2}]; FindSpanningTree[
 ResourceFunction["WeightedDistanceGraph"][v], Method -> "Prim"]
Out[8]=

Possible Issues

Using weighted graphs for finding a minimal spanning tree doesn’t scale up well for larger graphs:

In[9]:=
FindSpanningTree[
  ResourceFunction["WeightedDistanceGraph"][Tuples[Range[7], {2}]], Method -> "Kruskal"] // Timing
Out[9]=

In these cases it’s better to go right to the algorithm, which is several thousand times faster:

In[10]:=
KruskalAlgorithm[pts_, type_] := Module[{n = Length[pts], vpairs, jj = 0, hh, pair, dist, c1, c2, c1c2, span}, Do[hh[k] = {k}, {k, n}];
   vpairs = SortBy[Flatten[
      Table[{Norm[pts[[k]] - pts[[l]]], {k, l}}, {k, 1, n - 1}, {l, k + 1, n}], 1], N[#[[1]]] &];
   span = First[Last[Reap[While[jj < Length[vpairs], jj++;
        {dist, pair} = vpairs[[jj]];
        {c1, c2} = {hh[pair[[1]]], hh[pair[[2]]]};
        If[c1 =!= c2, Sow[Apply[UndirectedEdge, vpairs[[jj, 2]]]];
         c1c2 = Union[c1, c2];
         Do[hh[c1c2[[k]]] = c1c2, {k, Length[c1c2]}];
         If[Length[hh[pair[[1]]]] == n, Break[]];];]]]];
   Which[type === "EdgeList", span, type === "Graph", Graph[span, VertexCoordinates -> Thread[Range[Length[pts]] -> pts]]]];
In[11]:=
KruskalAlgorithm[Tuples[Range[7], {2}], "Graph"] // Timing
Out[11]=

Resource History