0
$\begingroup$

In the following code

reg = Import["https://i.stack.imgur.com/m9fyf.png"];
noeuds = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18};
arcs = {1 <->  2, 1 <->  3, 1 <-> 4, 2 <-> 3, 2 <-> 5, 2 <-> 6, 
       2 <-> 7, 3 <-> 4, 3 <-> 8, 4 <-> 8, 4 <-> 9, 5 <-> 6, 6 <-> 7, 
       6 <-> 9, 7 <-> 8, 7 <-> 9, 8 <-> 10, 9 <-> 10, 9 <-> 11, 10 <-> 12,
        11 <-> 12};
posom = {{6.5, 10}, {5, 7.9}, {7, 7.7}, {10, 7.7}, {2, 7}, {4, 
        6.2}, {6, 6.2}, {9, 6.2}, {5.5, 4}, {8, 4}, {6.5, 2}, {8.5, 
        2}, {10, 0}, {0.4, 9.35}, {0.3, 8}, {0.3, 7}, {0.3, 6}, {1, 2}};
Overlay[{reg, 
      Graph[noeuds, arcs, VertexCoordinates -> posom, 
       VertexSize -> {"Scaled", .02}, VertexLabels -> "Name", 
       ImageSize -> 700]}]

I have some difficulties to chose the place of the vertex for two reasons

I have not starting point on the graph to adjust the nodes. Secondly when I change the position of a node the graph is changed. How can I do ? Here is the picture ?

I wonder if there is a way to have a grid on the picture to position the nodes ?

France

$\endgroup$
  • 1
    $\begingroup$ Where is regions.png? $\endgroup$ – J. M. will be back soon May 24 '17 at 10:59
  • $\begingroup$ Sorry I just realized that the image was lacking. I have edited the post $\endgroup$ – cyrille.piatecki May 24 '17 at 12:05
  • $\begingroup$ I don't very understand why your graph have a edge about 4<->9,maybe I have missed something.. $\endgroup$ – yode May 25 '17 at 9:38
5
$\begingroup$

This answer is complementary to Halmir's answer.

After you adjusted the coordinates, you can copy the coordinates and use them as your final result.

In:

img = Import["https://i.stack.imgur.com/m9fyf.png"];
noeuds = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 
   18};
arcs = {1 <-> 2, 1 <-> 3, 1 <-> 4, 2 <-> 3, 2 <-> 5, 2 <-> 6, 2 <-> 7,
    3 <-> 4, 3 <-> 8, 4 <-> 8, 4 <-> 9, 5 <-> 6, 6 <-> 7, 6 <-> 9, 
   7 <-> 8, 7 <-> 9, 8 <-> 10, 9 <-> 10, 9 <-> 11, 10 <-> 12, 
   11 <-> 12};
posom = {{6.5, 10}, {5, 7.9}, {7, 7.7}, {10, 7.7}, {2, 7}, {4, 
    6.2}, {6, 6.2}, {9, 6.2}, {5.5, 4}, {8, 4}, {6.5, 2}, {8.5, 
    2}, {10, 0}, {0.4, 9.35}, {0.3, 8}, {0.3, 7}, {0.3, 6}, {1, 2}};
graph[vcs_] := 
 Graph[noeuds, arcs, VertexCoordinates -> vcs, 
  VertexSize -> {"Scaled", .02}, VertexLabels -> "Name"]
showMap[vcs_] := Show[{img, graph[vcs]}, ImageSize -> 700];
manipulateMap[] := 
 Manipulate[{cs = vcoord; showMap[vcoord]}, {{vcoord, 90 posom}, 
   Locator}]

Dynamic[cs]
manipulateMap[]

Out:

Mathematica graphics

Mathematica graphics

$\endgroup$
5
$\begingroup$

Well, maybe you can do some image processing to find center points of each regions but sometimes manual processing could be better (unless you have many cases).

Using Manipulate manually move your node and then by clicking + symbol paste snapshot

Manipulate[
 Show[{reg, 
   Graph[noeuds, arcs, VertexCoordinates -> vcoord, 
    VertexSize -> {"Scaled", .02}, VertexLabels -> "Name"]}, 
  ImageSize -> 700], {{vcoord, 90 posom}, Locator}]

enter image description here

DynamicModule[{vcoord = {{571.5`, 809.`}, {412.`, 730.`}, {568.5`, 
     707.`}, {755.`, 699.`}, {230.`, 653.`}, {352.5`, 600.`}, {503.`, 
     578.`}, {688.`, 585.`}, {413.5`, 395.`}, {657.5`, 413.`}, {524.`,
      275.`}, {772.5`, 313.`}, {954.`, 129.`}, {56.5`, 835.`}, {33.5`,
      738.`}, {37.5`, 649.`}, {48.5`, 540.`}, {147.5`, 281.`}}}, 
 Show[{reg, 
   Graph[noeuds, arcs, VertexCoordinates -> vcoord, 
    VertexSize -> {"Scaled", 0.02`}, VertexLabels -> "Name"]}, 
  ImageSize -> 700]]
$\endgroup$
  • $\begingroup$ Thanks to all the contributors. Each of your contribution was brillant and usefull. $\endgroup$ – cyrille.piatecki May 26 '17 at 15:29
5
$\begingroup$

I know you try to specify the vertices coordinate to get a graph with a adjacent relationshiop.But I want to provide a method to generate such graph by your map image directly.

Firstly,I will remove those texts and small islands by CommonestFilter

img = Import["https://i.stack.imgur.com/m9fyf.png"];
imgPro = CommonestFilter[img, 8]

Mathematica graphics

Let's build a image matrix.I mean I will replace every country with a difference integer in this matrix.I don't very content with this step resorted to DominantColors,and I hope to know this solution can be improved in furture by others.

imgMatrix = IntegerPart[ImageData[ImageAdd @@ MapIndexed[ImageMultiply[#, First[#2]] &, 
        Flatten[Image /@ Values[ComponentMeasurements[#, "Mask"]] & /@ 
        Rest[DominantColors[imgPro,Automatic,"CoverageImage", MinColorDistance -> .1]]]]]];

Of course,we can show this matrix by MatrixPlot

MatrixPlot[imgMatrix, ColorFunction -> Hue,ColorRules -> {0 -> White}]

Mathematica graphics

We can get the adjacent relation from this matrix by ComponentMeasurements

adj = ComponentMeasurements[imgMatrix, "Neighbors"]

Show the img and our graph in following

Row[{graph = SimpleGraph[
    Graph[Keys[adj], UndirectedEdge @@@ Flatten[Thread /@ adj]], 
    VertexCoordinates -> ComponentMeasurements[imgMatrix, "Centroid"],
     EdgeStyle -> Directive[Red, Thick], VertexStyle -> Blue, 
    VertexSize -> Medium], Show[img, graph]}]

Mathematica graphics

$\endgroup$
  • $\begingroup$ It's done automatically! $\endgroup$ – UnchartedWorks May 28 '17 at 12:38

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.