2
$\begingroup$

I used the locator pane to map a network, specifically the Maryland Power Grid. What I would like is to have some sort of numbering of the vertices on the unconnected network, how to make an adjacency matrix for the network to then use that to connect the network, and show either in color or shape that some vertices are different (i.e. loads and generators). It might be worthy to note that I first recorded the loads then the generators from left to right, consequently the last 13 vertices are generators. Here is the code I used for the locator pane, The Maryland Power Grid picture I imported to record vertices, and the resulting network. The locator pane code makes the x and y coordinates unitary.

Locator Pane Code

 im= Import["http://esm.versar.com/pprp/ceir16/Images/Figure2_20.jpg"];
Module[{picturesize,i,bigger,imagesizes},
picturesize=675;
values={};
i=1;
imagesizes=ImageDimensions[im];bigger=1;
DynamicModule[{pt={0,0}},
If[imagesizes[[1]]<imagesizes[[2]], bigger=2];
TableForm@{
    Button["Record!",AppendTo[values,{i,pt}];i++;],
    LocatorPane[
        Dynamic@pt,
        Dynamic@Graphics[
            Join[
                {Inset[im,{0,0},{0,0},{1,1}]}

            ],
        PlotRange->{{0,imagesizes[[1]]/imagesizes[[bigger]]},{0,imagesizes[[2]]/imagesizes[[bigger]]}},
        ImageSize->picturesize]
],
Dynamic[N@pt],
Dynamic[MatrixForm@values]
}]
]

The Maryland Power Grid I used with the locator pane

enter image description here

The resulting unconnected network enter image description here

The locator pane also returned an array of points in the form {n, {x,y}} where n is the vertex number recorded chronologically (I tried to do them from left to right) and the x and y are the x and y unitary coordinates.

({
  {1, {0.0996, 0.4195}},
  {2, {0.1046, 0.392}},
  {3, {0.1144, 0.468}},
  {4, {0.1164, 0.4415}},
  {5, {0.1432, 0.4455}},
  {6, {0.1442, 0.376}},
  {7, {0.147, 0.5085}},
  {8, {0.16, 0.4965}},
  {9, {0.1628, 0.5305}},
  {10, {0.1708, 0.484}},
  {11, {0.1776, 0.379}},
  {12, {0.1836, 0.4335}},
  {13, {0.1856, 0.408}},
  {14, {0.1936, 0.4495}},
  {15, {0.2034, 0.5295}},
  {16, {0.1974, 0.3595}},
  {17, {0.2122, 0.4395}},
  {18, {0.2152, 0.4465}},
  {19, {0.2252, 0.3555}},
  {20, {0.229, 0.4415}},
  {21, {0.2716, 0.3535}},
  {22, {0.2952, 0.313}},
  {23, {0.3258, 0.4265}},
  {24, {0.3446, 0.475}},
  {25, {0.3476, 0.4315}},
  {26, {0.3536, 0.408}},
  {27, {0.3584, 0.3545}},
  {28, {0.3694, 0.3665}},
  {29, {0.3732, 0.384}},
  {30, {0.393, 0.3535}},
  {31, {0.395, 0.4205}},
  {32, {0.4028, 0.3625}},
  {33, {0.4028, 0.378}},
  {34, {0.4088, 0.3525}},
  {35, {0.4108, 0.4345}},
  {36, {0.4286, 0.4505}},
  {37, {0.4336, 0.405}},
  {38, {0.4434, 0.247}},
  {39, {0.4542, 0.303}},
  {40, {0.4532, 0.4415}},
  {41, {0.4612, 0.3515}},
  {42, {0.469, 0.3455}},
  {43, {0.47, 0.3685}},
  {44, {0.477, 0.391}},
  {45, {0.4888, 0.31}},
  {46, {0.4948, 0.3315}},
  {47, {0.4958, 0.371}},
  {48, {0.4986, 0.217}},
  {49, {0.4918, 0.4375}},
  {50, {0.5214, 0.376}},
  {51, {0.5244, 0.3455}},
  {52, {0.5284, 0.4315}},
  {53, {0.5294, 0.457}},
  {54, {0.5302, 0.471}},
  {55, {0.5302, 0.2875}},
  {56, {0.554, 0.243}},
  {57, {0.554, 0.323}},
  {58, {0.554, 0.299}},
  {59, {0.559, 0.231}},
  {60, {0.559, 0.2575}},
  {61, {0.559, 0.2725}},
  {62, {0.5628, 0.244}},
  {63, {0.5668, 0.221}},
  {64, {0.5668, 0.316}},
  {65, {0.5708, 0.1755}},
  {66, {0.5816, 0.2665}},
  {67, {0.5836, 0.224}},
  {68, {0.5916, 0.152}},
  {69, {0.5806, 0.307}},
  {70, {0.5826, 0.3365}},
  {71, {0.5876, 0.32}},
  {72, {0.5974, 0.242}},
  {73, {0.5984, 0.2845}},
  {74, {0.6044, 0.2865}},
  {75, {0.5856, 0.397}},
  {76, {0.5906, 0.3605}},
  {77, {0.5916, 0.388}},
  {78, {0.6014, 0.3385}},
  {79, {0.6054, 0.388}},
  {80, {0.6132, 0.299}},
  {81, {0.6132, 0.2865}},
  {82, {0.6142, 0.2745}},
  {83, {0.6182, 0.375}},
  {84, {0.6252, 0.245}},
  {85, {0.6252, 0.3355}},
  {86, {0.629, 0.3605}},
  {87, {0.63, 0.371}},
  {88, {0.63, 0.388}},
  {89, {0.633, 0.474}},
  {90, {0.635, 0.3535}},
  {91, {0.641, 0.3525}},
  {92, {0.639, 0.411}},
  {93, {0.6438, 0.3585}},
  {94, {0.6458, 0.4355}},
  {95, {0.6488, 0.473}},
  {96, {0.6548, 0.2695}},
  {97, {0.6576, 0.38}},
  {98, {0.6646, 0.4455}},
  {99, {0.6736, 0.3685}},
  {100, {0.6764, 0.4415}},
  {101, {0.6774, 0.396}},
  {102, {0.6902, 0.402}},
  {103, {0.6932, 0.373}},
  {104, {0.6962, 0.473}},
  {105, {0.6972, 0.453}},
  {106, {0.718, 0.389}},
  {107, {0.7268, 0.292}},
  {108, {0.7228, 0.4335}},
  {109, {0.7288, 0.457}},
  {110, {0.7426, 0.296}},
  {111, {0.7406, 0.4235}},
  {112, {0.7644, 0.295}},
  {113, {0.7624, 0.457}},
  {114, {0.7802, 0.4225}},
  {115, {0.7802, 0.2855}},
  {116, {0.7822, 0.3355}},
  {117, {0.797, 0.4315}},
  {118, {0.799, 0.4495}},
  {119, {0.8028, 0.4415}},
  {120, {0.8168, 0.1235}},
  {121, {0.8088, 0.459}},
  {122, {0.8226, 0.1045}},
  {123, {0.8186, 0.3465}},
  {124, {0.8168, 0.468}},
  {125, {0.8286, 0.244}},
  {126, {0.8256, 0.2825}},
  {127, {0.8266, 0.329}},
  {128, {0.8226, 0.38}},
  {129, {0.8196, 0.4345}},
  {130, {0.8394, 0.167}},
  {131, {0.8532, 0.291}},
  {132, {0.8602, 0.1245}},
  {133, {0.8652, 0.1085}},
  {134, {0.8898, 0.166}},
  {135, {0.8938, 0.133}},
  {136, {0.9164, 0.221}},
  {137, {0.9244, 0.153}},
  {138, {0.9284, 0.1845}},
  {139, {0.1076, 0.4125}},
  {140, {0.1224, 0.3445}},
  {141, {0.15, 0.4205}},
  {142, {0.4028, 0.4215}},
  {143, {0.4642, 0.33}},
  {144, {0.467, 0.3395}},
  {145, {0.5362, 0.242}},
  {146, {0.548, 0.2525}},
  {147, {0.5638, 0.131}},
  {148, {0.6102, 0.1775}},
  {149, {0.629, 0.3435}},
  {150, {0.64, 0.456}},
  {151, {0.6458, 0.317}},
  {152, {0.6488, 0.3535}},
  {153, {0.6508, 0.385}},
  {154, {0.6538, 0.3365}},
  {155, {0.6636, 0.328}},
  {156, {0.6626, 0.161}},
  {157, {0.6764, 0.3555}},
  {158, {0.6854, 0.456}},
  {159, {0.7002, 0.465}},
  {160, {0.708, 0.387}},
  {161, {0.715, 0.4345}},
  {162, {0.716, 0.2635}},
  {163, {0.7812, 0.1815}},
  {164, {0.8958, 0.1925}}
 })
$\endgroup$
  • $\begingroup$ You locator code is unnecessary if you use Mathematica 9+ since the functionality is already integrated in the Coordinates Tool found in the suggestion bar. $\endgroup$ – paw Sep 9 '14 at 6:28
2
$\begingroup$

I was bored and took some time to try and answer this question. The extraction of a graph directly from the provided image is very difficult. There are several things that make it particularly painful like disconnected lines between vertices, open ends, multiple lines and vertices very close together and plenty of vertices with degree 1 and 2 to name just a few.

But Mathematica can help to make the manual reconstruction less painful. I'll use this little region of the provided network to illustrate my method:

i = Import["http://i.imgur.com/llCgdJN.jpg"];
i2 = ImageTake[ImageResize[i, 900], {150, 999}, {650, 999}]

enter image description here

We begin by extracting the positions and colors of the vertices with Mathematicas Coordinates Tool and save them in the variables coord and colors.

enter image description here

coord = {{17.`, 217.`}, {29.`, 246.`}, {44.`, 249.`}, {66.`, 
    249.`}, {83.`, 238.`}, {84.`, 288.`}, {125.`, 332.`}, {121.`, 
    300.`}, {129.`, 282.`}, {156.`, 244.`}, {128.`, 236.`}, {130.`, 
    197.`}, {220.`, 174.`}, {231.`, 138.`}, {199.`, 146.`}, {83.`, 
    136.`}, {142.`, 121.`}, {228.`, 106.`}, {193.`, 119.`}, {196.`, 
    86.`}, {168.`, 62.`}, {163.`, 79.`}, {119.`, 77.`}, {125.`, 59.`}};
colors = {{22, 18, 25}, {203, 203, 210}, {194, 200, 209}, {213, 210, 
    221}, {203, 199, 200}, {199, 198, 205}, {198, 197, 209}, {201, 
    198, 199}, {198, 200, 204}, {194, 200, 210}, {192, 201, 
    204}, {205, 204, 206}, {208, 200, 205}, {194, 199, 203}, {24, 19, 
    14}, {20, 21, 12}, {200, 200, 202}, {192, 204, 207}, {194, 204, 
    200}, {197, 210, 212}, {199, 199, 206}, {202, 206, 206}, {200, 
    198, 205}, {197, 198, 206}};
type = Mean[#] & /@ colors;

Next we will generate the edges with the help of a little interface I made. First the right voltage is selected. To generate an edge one has to click and hold the left mouse button near the start vertex, drag the mouse to the final vertex and let go. The edge will automatically snap to the closest vertex. The code and the result for the example region:

Dynamic@SetterBar[
  Dynamic@x, {1 -> "500kV", 2 -> "230kV", 3 -> "138kV", 4 -> "115kV"},
   Background -> connectionTypeColor[x]]
connectionTypeColor[s_] := Dynamic@Switch[s,
    1, RGBColor[{0.83, 0.25, 0.40}],
    2, RGBColor[{0.99, 0.56, 0.14}],
    3, RGBColor[{0.0, 0.62, 0.34}],
    4, RGBColor[{0.17, 0.44, 0.71}]
    ];

edgeList = {};
DynamicModule[{p = {}, l = {}, cl = {}, g = {}},
 EventHandler[Dynamic@Show[i2, g],
  "MouseDown" :> (
    start = Flatten@Nearest[coord, MousePosition["Graphics"]];
    sVertex = Flatten@Position[coord, start];
    AppendTo[cl, start];
    ),
  "MouseUp" :> (
    end = Flatten@Nearest[coord, MousePosition["Graphics"]];
    eVertex = Flatten@Position[coord, end];
    AppendTo[cl, end];
    AppendTo[g, 
     Graphics[{connectionTypeColor[x], Thick, Line[Sort@cl], l}, 
      PlotRange -> 1, Frame -> True]];
    AppendTo[edgeList, Flatten@{sVertex, eVertex, x}];
    cl = {};
    )]]

enter image description here

At last we generate the graph colorcoded by vertex and edge type.

edgeStyle = #[[1]] -> #[[2]] & /@ 
   Transpose[{Flatten[{#1 <-> #2} & @@@ 
       edgeList], connectionTypeColor[#] & /@ edgeList[[All, 3]]}];

vertexStyle = #[[1]] -> #[[2]] & /@ 
   Transpose[{Range[Length@type], GrayLevel[#/255] & /@ type}];

g = Graph[Flatten[{#1 <-> #2} & @@@ edgeList], 
  EdgeStyle -> Flatten@{Thick, edgeStyle},
  VertexStyle -> vertexStyle,
  EdgeWeight -> edgeList[[All, 3]]]

enter image description here

There is probably plenty of room for improvements and I'm happy to receive your comments.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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