6
$\begingroup$

This diagram from a Wikipedia article illustrates what I hope to accomplish in Mathematica:

I have a planar map in Graphics format. Here are two very simple examples with the same dual:

map1 = Graphics[{
    Orange, Rectangle[{0, 0}],
    Blue,   Rectangle[{1, 0}],
    Red,    Rectangle[{2, 0}]
}];
map2 = Graphics[{
    Orange, Disk[{0, 0}, 3],
    Blue,   Disk[{0, 0}, 2],
    Red,    Disk[{0, 0}, 1]
}];
Column[{map1, map2}]

I would like to write a function dual to find the dual graph of such a map. For example:

dual[map1]

(* Graph[{Orange -> Blue, Blue -> Red}] *)

dual[map2]

(* Graph[{Orange -> Blue, Blue -> Red}] *)

I might look into purchasing a copy of Mathematica in Action since I’ve heard that Chapter 17 contains some relevant code for finding the dual in the supplemental MapColoring package. It looks like the book uses the older (pre-version 8) Combinatorica graphs. Still, I’m not sure how to transform the map from Graphics into a better format.

$\endgroup$
8
$\begingroup$

Note: The following needs a properly color quantized image as input. Color quantization for general images is a problem on its own that depends on many factors and is not addressed below.

First we will go step by step, then wrapping up all of it in a function:

Import some discrete-colored image:

ii = Import["http://i.stack.imgur.com/9vdgV.png"]  

Mathematica graphics

Then we find the list of colors in that image:

ru = Union@Flatten[ImageData@ii, 1]
(* {{1., 0., 0., 1.}, {1., 0.882353, 0., 1.}} *)

For each color we separate in different binary images

selCol[i_Image, col_] := ImageApply[1 - Unitize@Tr[# - col] &, i]
cols = selCol[ii, #] & /@ ru

Mathematica graphics

Now, for each of these images we separate the Morphological Components and we form a new array where each of them is represented by a different number. Perhaps there is an easier way, but the following works:

cs = Fold[#1 + Unitize@#2 Max@#1 + #2 &,  MorphologicalComponents/@ cols];
Colorize@cs  

Mathematica graphics

For each component we need its neighbors to build up the edges:

nei = ComponentMeasurements[cs, "Neighbors"]
(* {1 -> {2, 4, 6, 8, 10}, 2 -> {1}, 4 -> {1}, 6 -> {1}, 8 -> {1}, 10 -> {1}} *)

And so we build our edges:

edges = DeleteDuplicates[Sort /@ Union @@ Thread /@ nei]
(* {1 -> 2, 1 -> 4, 1 -> 6, 1 -> 8, 1 -> 10} *)

Finally, for coloring the vertex we want to recover which color in the original image correspond to each vertex number:

ucs = Union@Flatten@cs;
colCorr = Extract[ImageData[ii], #] & /@ Position[cs, #, 2, 1] & /@ ucs
(* {{{1., 0., 0., 1.}}, {{1., 0.882353, 0., 1.}}, {{1., 0.882353, 0., 1.}}, 
    {{1., 0.882353, 0., 1.}}, {{1., 0.882353, 0., 1.}}, {{1., 0.882353, 0., 1.}}} 
*)

we now build the vertex coloring rules:

vStyle = Thread[ Rule[ucs, RGBColor @@@ Flatten[colCorr, 1]]]
(*
{1 -> RGBColor[1., 0., 0., 1.], 
 2 -> RGBColor[1., 0.882353, 0., 1.], 
 4 -> RGBColor[1., 0.882353, 0., 1.], 
 6 -> RGBColor[1., 0.882353, 0., 1.], 
 8 -> RGBColor[1., 0.882353, 0., 1.], 
 10 -> RGBColor[1., 0.882353, 0., 1.]}
 *)

And finally the Graph:

Graph[edges, VertexSize -> 0.2, VertexStyle -> vStyle, VertexLabels -> "Name"]  

Mathematica graphics


So now we will pack it into one function:

mkDual[ii_Image, OptionsPattern[{CornerNeighbors -> False}]] :=
 Module[{selCol, ru, cols, cs, nei, edges, ucs, colCorr, vStyle},
  selCol[i_Image, col_] := ImageApply[1 - Unitize@Tr[# - col] &, i];
  ru = Union@Flatten[ImageData@ii, 1];
  cols = selCol[ii, #] & /@ ru;
  cs = Fold[#1 + Unitize@#2 Max@#1 + #2 &,  MorphologicalComponents[#, 
                    CornerNeighbors -> OptionValue[CornerNeighbors]] & /@ cols];
  nei = ComponentMeasurements[cs, "Neighbors"];
  edges = DeleteDuplicates[Sort /@ Union @@ Thread /@ nei];
  ucs = Union@Flatten@cs;
  colCorr = Extract[ImageData[ii], #] & /@ Position[cs, #, 2, 1] & /@ ucs;
  vStyle = Thread[Rule[ucs, RGBColor @@@ Flatten[colCorr, 1]]];
  Graph[edges, VertexSize -> 0.2, VertexStyle -> vStyle, VertexLabels -> "Name"]]

and use it on color-quantized images of some country flags

riq = Import /@ 
       {"http://i.stack.imgur.com/TqpFO.png","http://i.stack.imgur.com/ZQwSA.png", 
        "http://i.stack.imgur.com/SyIt7.png","http://i.stack.imgur.com/g334k.png",
        "http://3.bp.blogspot.com/-vRxXWRa_4zk/UXz62fD9wRI/AAAAAAAAAs8/9bFvYHh8ozg/s1600/Antwerp+Flag.png"};
GraphicsGrid@Partition[Flatten[{#, mkDual[#, CornerNeighbors -> True]} & /@ riq[[1 ;; 4]]],  2]

Mathematica graphics

{#, mkDual[#, CornerNeighbors -> False]} &@riq[[5]]

Mathematica graphics

$\endgroup$
  • $\begingroup$ How do I determine the second argument to MorphologicalPerimeter? The .25 value doesn’t work automatically for most maps I try, like these: CountryData[#, "Flag"] /@ {"Burma", "Canada", "China", "Jamaica", "Malaysia"} $\endgroup$ – hftf Aug 7 '15 at 22:15
  • $\begingroup$ @hftf What would be the desired result for (for example) "Canada"? $\endgroup$ – Dr. belisarius Aug 7 '15 at 22:53
  • $\begingroup$ {Red -> White, Red -> White, Red -> White}. $\endgroup$ – hftf Aug 7 '15 at 22:59
  • $\begingroup$ @hftf Nah, that images may seem to have "plain" colors, but they haven't !Mathematica graphics $\endgroup$ – Dr. belisarius Aug 7 '15 at 23:26
  • $\begingroup$ I'm using the latest Mathematica. I believe the country flags now use vector Graphics. $\endgroup$ – hftf Aug 8 '15 at 2:40

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.