Minimum spanning Tree from a weighted adjacency graph

Question

Note: Cross-posted at http://community.wolfram.com/groups/-/m/t/137658?p_p_auth=8QnKtT9I

I have a really big graph, 40x40. Here is my code

g = WeightedAdjacencyGraph[{{∞, ∞, ∞, 
    427, 668, 495, 377, 678, ∞, 
    177, ∞, ∞, 870, ∞, 869, 624, 300, 
    609, 131, ∞, 251, ∞, ∞, ∞,
     856, 221, 514, ∞, 591, 762, 182, 56, ∞, 884, 
    412, 273, 636, ∞, ∞, 
    774}, {∞, ∞, 262, ∞, ∞, 
    508, 472, 799, ∞, 956, 578, 363, 940, 143, ∞, 
    162, 122, 910, ∞, 729, 802, 941, 922, 573, 531, 539, 
    667, 607, ∞, 920, ∞, ∞, 315, 649, 
    937, ∞, 185, 102, 636, 289}, {∞, 
    262, ∞, ∞, 926, ∞, 958, 158, 647, 
    47, 621, 264, 81, ∞, 402, 813, 649, 386, 252, 391, 264, 
    637, 349, ∞, ∞, ∞, 108, ∞,
     727, 225, 578, 699, ∞, 898, 294, ∞, 575, 168,
     432, 833}, {427, ∞, ∞, ∞, 
    366, ∞, ∞, 635, ∞, 32, 962, 468, 
    893, 854, 718, 427, 448, 916, 258, ∞, 760, 909, 529, 
    311, 404, ∞, ∞, 588, 680, 875, ∞, 
    615, ∞, 409, 758, 221, ∞, ∞, 76, 
    257}, {668, ∞, 926, 
    366, ∞, ∞, ∞, 250, 268, ∞,
     503, 944, ∞, 677, ∞, 727, 793, 457, 981, 
    191, ∞, ∞, ∞, 351, 969, 925, 987, 
    328, 282, 589, ∞, 873, 477, ∞, ∞, 
    19, 450, ∞, ∞, ∞}, {495, 
    508, ∞, ∞, ∞, ∞, \
∞, 765, 711, 819, 305, 302, 926, ∞, ∞, 
    582, ∞, 861, ∞, 683, 
    293, ∞, ∞, 66, ∞, 
    27, ∞, ∞, 290, ∞, 786, ∞, 
    554, 817, 33, ∞, 54, 506, 386, 381}, {377, 472, 
    958, ∞, ∞, ∞, ∞, \
∞, ∞, 120, 42, ∞, 134, 219, 457, 639, 
    538, 374, ∞, ∞, ∞, 
    966, ∞, ∞, ∞, ∞, \
∞, 449, 120, 797, 358, 232, 550, ∞, 305, 997, 662,
     744, 686, 239}, {678, 799, 158, 635, 250, 
    765, ∞, ∞, ∞, 35, ∞, 106, 
    385, 652, 160, ∞, 890, 812, 605, 
    953, ∞, ∞, ∞, 79, ∞, 712, 
    613, 312, 452, ∞, 978, 900, ∞, 
    901, ∞, ∞, 225, 533, 770, 
    722}, {∞, ∞, 647, ∞, 268, 
    711, ∞, ∞, ∞, 283, ∞, 
    172, ∞, 663, 236, 36, 403, 286, 
    986, ∞, ∞, 810, 761, 574, 53, 
    793, ∞, ∞, 777, 330, 936, 883, 
    286, ∞, 174, ∞, ∞, ∞, 828,
     711}, {177, 956, 47, 32, ∞, 819, 120, 35, 
    283, ∞, 50, ∞, 565, 36, 767, 684, 344, 489, 
    565, ∞, ∞, 103, 810, 463, 733, 665, 494, 644, 
    863, 25, 385, ∞, 342, 
    470, ∞, ∞, ∞, 730, 582, 
    468}, {∞, 578, 621, 962, 503, 305, 
    42, ∞, ∞, 50, ∞, 155, 
    519, ∞, ∞, 256, 990, 801, 154, 53, 474, 650, 
    402, ∞, ∞, ∞, 
    966, ∞, ∞, 406, 989, 772, 932, 7, ∞,
     823, 391, ∞, ∞, 933}, {∞, 363, 264,
     468, 944, 302, ∞, 106, 172, ∞, 
    155, ∞, ∞, ∞, 380, 438, ∞,
     41, 266, ∞, ∞, 104, 867, 609, ∞, 
    270, 861, ∞, ∞, 165, ∞, 675, 250, 
    686, 995, 366, 191, ∞, 433, ∞}, {870, 940, 81,
     893, ∞, 926, 134, 385, ∞, 565, 
    519, ∞, ∞, 313, 
    851, ∞, ∞, ∞, 248, 220, ∞,
     826, 359, 829, ∞, 234, 198, 145, 409, 68, 
    359, ∞, 814, 218, 186, ∞, ∞, 929, 
    203, ∞}, {∞, 143, ∞, 854, 
    677, ∞, 219, 652, 663, 36, ∞, ∞, 
    313, ∞, 132, ∞, 433, 
    598, ∞, ∞, 168, 
    870, ∞, ∞, ∞, 128, 437, ∞,
     383, 364, 966, 227, ∞, ∞, 807, 
    993, ∞, ∞, 526, 17}, {869, ∞, 402, 
    718, ∞, ∞, 457, 160, 236, 767, ∞, 
    380, 851, 132, ∞, ∞, 596, 903, 613, 
    730, ∞, 261, ∞, 142, 379, 885, 
    89, ∞, 848, 258, 112, ∞, 
    900, ∞, ∞, 818, 639, 268, 
    600, ∞}, {624, 162, 813, 427, 727, 582, 
    639, ∞, 36, 684, 256, 
    438, ∞, ∞, ∞, ∞, 539, 379,
     664, 561, 542, ∞, 999, 585, ∞, ∞, 
    321, 398, ∞, ∞, 950, 68, 193, ∞, 
    697, ∞, 390, 588, 848, ∞}, {300, 122, 649, 
    448, 793, ∞, 538, 890, 403, 344, 
    990, ∞, ∞, 433, 596, 
    539, ∞, ∞, 73, ∞, 
    318, ∞, ∞, 500, ∞, 968, ∞,
     291, ∞, ∞, 765, 196, 504, 757, ∞, 
    542, ∞, 395, 227, 148}, {609, 910, 386, 916, 457, 861, 
    374, 812, 286, 489, 801, 41, ∞, 598, 903, 
    379, ∞, ∞, ∞, 946, 136, 
    399, ∞, 941, 707, 156, 757, 258, 251, ∞, 
    807, ∞, ∞, ∞, 461, 
    501, ∞, ∞, 
    616, ∞}, {131, ∞, 252, 258, 
    981, ∞, ∞, 605, 986, 565, 154, 266, 
    248, ∞, 613, 664, 73, ∞, ∞, 
    686, ∞, ∞, 575, 627, 817, 282, ∞, 
    698, 398, 222, ∞, 
    649, ∞, ∞, ∞, ∞, \
∞, 654, ∞, ∞}, {∞, 729, 
    391, ∞, 191, 683, ∞, 
    953, ∞, ∞, 53, ∞, 220, ∞, 
    730, 561, ∞, 946, 686, ∞, ∞, 389, 
    729, 553, 304, 703, 455, 857, 260, ∞, 991, 182, 351, 
    477, 867, ∞, ∞, 889, 217, 853}, {251, 802, 
    264, 760, ∞, 
    293, ∞, ∞, ∞, ∞, 
    474, ∞, ∞, 168, ∞, 542, 318, 
    136, ∞, ∞, ∞, ∞, 
    392, ∞, ∞, ∞, 267, 407, 27, 651, 80,
     927, ∞, 974, 977, ∞, ∞, 457, 
    117, ∞}, {∞, 941, 637, 
    909, ∞, ∞, 966, ∞, 810, 103, 650, 
    104, 826, 870, 261, ∞, ∞, 399, ∞, 
    389, ∞, ∞, ∞, 
    202, ∞, ∞, ∞, ∞, 867, 140,
     403, 962, 785, ∞, 511, ∞, 1, ∞, 
    707, ∞}, {∞, 922, 349, 
    529, ∞, ∞, ∞, ∞, 761, 810,
     402, 867, 359, ∞, ∞, 
    999, ∞, ∞, 575, 729, 
    392, ∞, ∞, 388, 939, ∞, 
    959, ∞, 83, 463, 361, ∞, ∞, 512, 
    931, ∞, 224, 690, 369, ∞}, {∞, 
    573, ∞, 311, 351, 66, ∞, 79, 574, 
    463, ∞, 609, 829, ∞, 142, 585, 500, 941, 627, 
    553, ∞, 202, 388, ∞, 164, 829, ∞, 
    620, 523, 639, 936, ∞, ∞, 490, ∞, 
    695, ∞, 505, 109, ∞}, {856, 531, ∞, 
    404, 969, ∞, ∞, ∞, 53, 
    733, ∞, ∞, ∞, ∞, 
    379, ∞, ∞, 707, 817, 
    304, ∞, ∞, 939, 164, ∞, ∞,
     616, 716, 728, ∞, 889, 349, ∞, 963, 150, 
    447, ∞, 292, 586, 264}, {221, 
    539, ∞, ∞, 925, 27, ∞, 712, 793, 
    665, ∞, 270, 234, 128, 885, ∞, 968, 156, 282, 
    703, ∞, ∞, ∞, 
    829, ∞, ∞, ∞, 
    822, ∞, ∞, ∞, 736, 576, ∞,
     697, 946, 443, ∞, 205, 194}, {514, 667, 
    108, ∞, 987, ∞, ∞, 613, ∞,
     494, 966, 861, 198, 437, 89, 321, ∞, 757, ∞, 
    455, 267, ∞, 959, ∞, 
    616, ∞, ∞, ∞, 349, 156, 
    339, ∞, 102, 790, 359, ∞, 439, 938, 809, 
    260}, {∞, 607, ∞, 588, 328, ∞, 449, 
    312, ∞, 644, ∞, ∞, 
    145, ∞, ∞, 398, 291, 258, 698, 857, 
    407, ∞, ∞, 620, 716, 
    822, ∞, ∞, 293, 486, 943, ∞, 
    779, ∞, 6, 880, 116, 775, ∞, 
    947}, {591, ∞, 727, 680, 282, 290, 120, 452, 777, 
    863, ∞, ∞, 409, 383, 
    848, ∞, ∞, 251, 398, 260, 27, 867, 83, 523, 
    728, ∞, 349, 293, ∞, 212, 684, 505, 341, 384, 
    9, 992, 507, 48, ∞, ∞}, {762, 920, 225, 875, 
    589, ∞, 797, ∞, 330, 25, 406, 165, 68, 364, 
    258, ∞, ∞, ∞, 222, ∞, 651,
     140, 463, 639, ∞, ∞, 156, 486, 
    212, ∞, ∞, 349, 723, ∞, ∞,
     186, ∞, 36, 240, 752}, {182, ∞, 
    578, ∞, ∞, 786, 358, 978, 936, 385, 
    989, ∞, 359, 966, 112, 950, 765, 807, ∞, 991, 
    80, 403, 361, 936, 889, ∞, 339, 943, 
    684, ∞, ∞, 965, 302, 676, 725, ∞, 
    327, 134, ∞, 147}, {56, ∞, 699, 615, 
    873, ∞, 232, 900, 883, ∞, 772, 
    675, ∞, 227, ∞, 68, 196, ∞, 649, 
    182, 927, 962, ∞, ∞, 349, 
    736, ∞, ∞, 505, 349, 965, ∞, 474, 
    178, 833, ∞, ∞, 555, 
    853, ∞}, {∞, 315, ∞, ∞, 
    477, 554, 550, ∞, 286, 342, 932, 250, 814, ∞, 
    900, 193, 504, ∞, ∞, 351, ∞, 
    785, ∞, ∞, ∞, 576, 102, 779, 341, 
    723, 302, 474, ∞, 
    689, ∞, ∞, ∞, 
    451, ∞, ∞}, {884, 649, 898, 409, ∞, 
    817, ∞, 901, ∞, 470, 7, 686, 
    218, ∞, ∞, ∞, 
    757, ∞, ∞, 477, 974, ∞, 512, 490, 
    963, ∞, 790, ∞, 384, ∞, 676, 178, 
    689, ∞, 245, 596, 445, ∞, ∞, 
    343}, {412, 937, 294, 758, ∞, 33, 305, ∞, 
    174, ∞, ∞, 995, 186, 807, ∞, 
    697, ∞, 461, ∞, 867, 977, 511, 
    931, ∞, 150, 697, 359, 6, 9, ∞, 725, 
    833, ∞, 245, ∞, 949, ∞, 
    270, ∞, 112}, {273, ∞, ∞, 221, 
    19, ∞, 997, ∞, ∞, ∞, 823, 
    366, ∞, 993, 818, ∞, 542, 
    501, ∞, ∞, ∞, ∞, \
∞, 695, 447, 946, ∞, 880, 992, 
    186, ∞, ∞, ∞, 596, 949, ∞,
     91, ∞, 768, 273}, {636, 185, 575, ∞, 450, 54,
     662, 225, ∞, ∞, 391, 
    191, ∞, ∞, 639, 
    390, ∞, ∞, ∞, ∞, \
∞, 1, 224, ∞, ∞, 443, 439, 116, 
    507, ∞, 327, ∞, ∞, 445, ∞,
     91, ∞, 248, ∞, 344}, {∞, 102, 
    168, ∞, ∞, 506, 744, 533, ∞, 
    730, ∞, ∞, 929, ∞, 268, 588, 
    395, ∞, 654, 889, 457, ∞, 690, 505, 
    292, ∞, 938, 775, 48, 36, 134, 555, 451, ∞, 
    270, ∞, 248, ∞, 371, 680}, {∞, 636, 
    432, 76, ∞, 386, 686, 770, 828, 582, ∞, 433, 
    203, 526, 600, 848, 227, 616, ∞, 217, 117, 707, 369, 
    109, 586, 205, 809, ∞, ∞, 240, ∞, 
    853, ∞, ∞, ∞, 768, ∞, 
    371, ∞, 540}, {774, 289, 833, 257, ∞, 381, 
    239, 722, 711, 468, 933, ∞, ∞, 
    17, ∞, ∞, 148, ∞, ∞, 
    853, ∞, ∞, ∞, ∞, 264, 194,
     260, 947, ∞, 752, 147, ∞, ∞, 343, 
    112, 273, 344, 680, 540, ∞}}, 

  VertexLabels -> {1 -> "1", 2 -> "2", 3 -> "3", 4 -> "4", 5 -> "5", 
    6 -> "6", 7 -> "7", 8 -> "8", 9 -> "9", 10 -> "10", 11 -> "11", 
    12 -> "12", 13 -> "13", 14 -> "14", 15 -> "15", 16 -> "16", 
    17 -> "17", 18 -> "18", 19 -> "19", 20 -> "20", 21 -> "21", 
    22 -> "22", 23 -> "23", 24 -> "24", 25 -> "25", 26 -> "26", 
    27 -> "27", 28 -> "28", 29 -> "29", 30 -> "30", 31 -> "31", 
    32 -> "32", 33 -> "33", 34 -> "34", 35 -> "35", 36 -> "36", 
    37 -> "37", 38 -> "38", 39 -> "39", 40 -> "40"}, 
  VertexStyle -> {RGBColor[1, 0.7, 0]}, 
  VertexShapeFunction -> {"Square"}]

I want to create MinimumSpanningTree out of this. I'm trying:

MinimumSpanningTree[g]

and of course it's not working. I know there is something terribly wrong here. But I'm a beginner with Mathematica and I can't figure it out. Any help?

Answer 1

Here is code for Kruskal's algorithm that I cribbed and mildly altered from this MSE post.

Kruskal[gr_Graph] := 
 Module[{adjmat = Normal[WeightedAdjacencyMatrix[g]], n, vpairs, 
   jj = 0, hh, pair, dist, c1, c2, c1c2},
  adjmat = adjmat /. 0 -> Infinity;
  n = Length[adjmat];
  Do[hh[k] = {k}, {k, n}];
  vpairs = 
   Sort[Flatten[
     Table[{adjmat[[k, l]], {k, l}}, {k, 1, n - 1}, {l, k + 1, n}], 
     1]];
  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[Rule, vpairs[[jj, 2]]]];
       c1c2 = Union[c1, c2];
       Do[hh[c1c2[[k]]] = c1c2, {k, Length[c1c2]}];
       If[Length[hh[pair[[1]]]] == n, Break[]];];]]]]]

Your example has this graph.

We run it through Kruskal and show the result.

Timing[tree = Kruskal[g];]

Out[166]= {0.010000, Null}

Graph[tree, 
 VertexLabels -> {1 -> "1", 2 -> "2", 3 -> "3", 4 -> "4", 5 -> "5", 
   6 -> "6", 7 -> "7", 8 -> "8", 9 -> "9", 10 -> "10", 11 -> "11", 
   12 -> "12", 13 -> "13", 14 -> "14", 15 -> "15", 16 -> "16", 
   17 -> "17", 18 -> "18", 19 -> "19", 20 -> "20", 21 -> "21", 
   22 -> "22", 23 -> "23", 24 -> "24", 25 -> "25", 26 -> "26", 
   27 -> "27", 28 -> "28", 29 -> "29", 30 -> "30", 31 -> "31", 
   32 -> "32", 33 -> "33", 34 -> "34", 35 -> "35", 36 -> "36", 
   37 -> "37", 38 -> "38", 39 -> "39", 40 -> "40"}, 
 VertexStyle -> {RGBColor[1, 0.7, 0]}, 
 VertexShapeFunction -> {"Square"}]

Well, at least it's a tree, so that much is promising. I have not tried to verify that it is correct in other respects-- I suppose I could have something reversed and found a maximal spanning tree.

Answer 2

In recent versions, this can be done using FindSpanningTree.

IGraph/M also has IGSpanningTree, which preserved edge weights in the result (unlike FindSpanningTree, which discards them).

Answer 3

You can also work with the list of existing edges, Extract them together with corresponding weights, and sort that lowest weight first.

edges = Module[{edges, weights},
   edges = EdgeList@g;
   weights = With[{a = WeightedAdjacencyMatrix@g},
     a[[Sequence @@ #]] & /@ edges];
   SortBy[Thread[edges -> weights], Last]];

Now add next edge to the tree unless doing so would create a cycle.

kruskal = Fold[
  With[{g = Append[#1, #2]},
    If[AcyclicGraphQ@Graph@g, g, #1]] &,
  {}, First /@ edges];

This didn't take any substantial time here but I guess testing for cycle would be a problem with larger dimension. Then one would be better off with testing for connectivity with union-find on the tree vertices. I put EdgeStyle -> Directive[Opacity[.1]] in your graph construction.

GraphicsRow[{g, HighlightGraph[g,
   Style[#, Directive[Thick, Black]] & /@ kruskal]}]

Answer 4

MinimumSpanningTree depends on Combinatorica package and it is tricky to negotiate compatibilities. I had some problems with getting your graph to work. In the following mat is just your weight matrix and you can choose whatever layout and style for in-built Graph in last line:

g = WeightedAdjacencyGraph[mat];
adj = AdjacencyMatrix[g] // Normal;
Needs["Combinatorica`"];
comgo = FromAdjacencyMatrix[adj];
minspant = MinimumSpanningTree[comgo];
sysgo = UndirectedEdge @@@ Flatten[minspant[[1]], 1];
System`Graph[sysgo, GraphLayout -> "SpringEmbedding", 
 VertexLabels -> "Name"]

This yields minimum spanning tree: