Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I have a list of integer pixel positions, pts, and I wish to create one or more graph objects where vertices at these pixel positions share an edge if they are within one-anothers 8-cell Moore neighborhoods. To clarify what I mean by "one or more graph objects", I mean that the above process might generate disconnected graphs.

For an example, consider the contour pixels from my previous question: (Generating a list of contour pixels for a morphological component).

shape = Import["http://pixelduke.files.wordpress.com/2010/01/jnbdec2008-hello-world-example2.png"];
m = MorphologicalComponents[ColorNegate[ImageCrop[shape, {300, 100}]]];

mlist = Thinning[EdgeDetect[Image[m /. x_Integer /; x =!= # -> 0 // Rescale]]] & /@ Range[Length[ComponentMeasurements[m, "Count"]]];

pts = Position[ImageData[mlist[[6]]], 1];
Graphics[Point[pts]]

Where pts is an example set of pixel positions to be transformed into a graph object. In this case, there should be two disconnected graphs since mlist[[6]] represents the contour of the "o" in "Hello, World.".

I've seen other solutions for generating random geometric graphs here, for example (Is it possible for me to explicitly specify a point list for SpatialGraphDistribution?) however, is there a more efficient way to do this provided my connectivity rule?

Here's the way to do it using the method of Szabolcs from Is it possible for me to explicitly specify a point list for SpatialGraphDistribution?:

r = Sqrt[2];
distances = With[{tr = Transpose[pts]}, Function[point, Sqrt[Total[(point - tr)^2]]] /@ pts];
am = UnitStep[r - distances] - IdentityMatrix@Length[pts];

AdjacencyGraph[am, VertexCoordinates -> pts]

However, this is much too slow for larger points sets where we have something like Length[pts] = 10000 or so.

Also, and this may be grounds for a separate question, after construction of these simplified geometric graph objects, I would like to have some method of pruning away vertices when: (a) the vertex is strictly connected to two nearest-neighbors / has degree two, and (b) when the edges from the vertex to its two nearest neighbors fall along the same line / it is colinear with its two nearest-neighbors. In other words, I want to find the minimum set of vertices to give the set of connected edges the same morphology / geometry. It strikes me that there ought to be an automated routine for this in Mathematica 9, however, I can't seem to hunt one down.

share|improve this question
add comment

1 Answer

Here is a iterative method using Nest which seems to be faster then the approach you showed

dist = Compile[{{p1, _Real, 1}, {p2, _Real, 1}},
  Norm[p1 - p2] <= Sqrt[2], Parallelization -> True, 
  RuntimeAttributes -> {Listable}];

connect[ptsIn_List] := 
 With[{idMap = 
    Dispatch[Rule @@@ Transpose[{ptsIn, Range[Length[ptsIn]]}]]},
  Flatten[
   Last@Reap@Nest[
      Function[pts, With[{fst = First[pts], rst = Rest[pts]},
        With[{neigh = Pick[rst /. idMap, dist[fst, rst]], 
          id = fst /. idMap},
         Sow[UndirectedEdge[id, #] & /@ neigh];
         rst
         ]
        ]
       ], ptsIn, Length[ptsIn] - 1]
   ]
  ]

An example with about 5000 points finished in 7 seconds on my laptop. Here a smaller one

pts = (Reverse /@ 
      Position[ImageData[#, "Bit", DataReversed -> True], 
       1]) &@(ImageSubtract[Dilation[#, 1], #] &[
     Binarize[
      ColorNegate@Rasterize[Style["Mathematica", 20], "Image"]]]);
Graph[Range[Length[pts]], connect[pts], VertexCoordinates -> pts]

Mathematica graphics

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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