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.

What to do

I have a binary matrix. My objective is to connect every close (without "jump") elements with value equal to 1, but I must keep the point positions, just like it's shown at the image.

Can somebody help me with it, please?

Test input thanks to @hftf:

{{0,1,0,0,1,0,1,0},
 {0,1,0,0,1,0,1,0},
 {0,0,1,0,1,0,1,0},
 {0,0,0,1,0,0,1,0},
 {0,0,0,0,1,1,0,0},
 {0,0,0,0,1,0,0,0}}
share|improve this question
    
See if MorphologicalGraph is what you need. –  Szabolcs Jun 8 at 19:07
    
Can you provide the matrix? :) –  Öskå Jun 8 at 19:28
    
@Öskå {{0,1,0,0,1,0,1,0}, {0,1,0,0,1,0,1,0}, {0,0,1,0,1,0,1,0}, {0,0,0,1,0,0,1,0}, {0,0,0,0,1,1,0,0}, {0,0,0,0,1,0,0,0}} –  hftf Jun 8 at 19:31
    
Unfortunately, I've tryed to use MorphologicalGraph and SkeletonTransform. Both are not helping me to find a graph similar to the image above. But thanks for you help, @Szabolcs. –  Jazz Jun 8 at 19:36
    
@Jazz In what way is the output of MorphologicalGraph incorrect? (I'm trying to understand the question.) –  Szabolcs Jun 8 at 19:38
show 7 more comments

5 Answers 5

up vote 16 down vote accepted
matOP = {{0, 1, 0, 0, 1, 0, 1, 0}, {0, 1, 0, 0, 1, 0, 1, 0}, {0, 0, 1, 0, 1, 0, 1, 0}, 
         {0, 0, 0, 1, 0, 0, 1, 0}, {0, 0, 0, 0, 1, 1, 0, 0}, {0, 0, 0, 0, 1, 0, 0, 0}};

$\left( \begin{array}{cccccccc} 0 & 1 & 0 & 0 & 1 & 0 & 1 & 0 \\ 0 & 1 & 0 & 0 & 1 & 0 & 1 & 0 \\ 0 & 0 & 1 & 0 & 1 & 0 & 1 & 0 \\ 0 & 0 & 0 & 1 & 0 & 0 & 1 & 0 \\ 0 & 0 & 0 & 0 & 1 & 1 & 0 & 0 \\ 0 & 0 & 0 & 0 & 1 & 0 & 0 & 0 \\ \end{array} \right)$

binaryGraph[mat_, col_] := Module[{pos, edge, dedge},
  pos = Position[mat, 1];
  edge = Select[Subsets[Range@Length@pos, {2}], 
    Last@# - First@# <= (Max@Dimensions@mat + 1) &]; 
  dedge = DeleteDuplicates[
    UndirectedEdge @@@ (Extract[edge, #] & /@ 
       With[{dist = N@(EuclideanDistance[pos[[#]], pos[[#2]]] & @@@ edge)}, 
        Flatten[Position[dist, #] & /@ 
          DeleteDuplicates@N@Select[dist, # <= Sqrt@2 &]]])];
  Graph[dedge, VertexCoordinates -> 
    Rule @@@ Thread[{Range@Length@pos, ({#2, -#1} & @@@ pos)}], 
    VertexStyle -> col, EdgeStyle -> col]]

arrayPlotGraph[mat_, graph_, sc_, opts : OptionsPattern[]] := 
 ArrayPlot[mat, Epilog -> 
   Inset[Show@graph, ImageScaled[{.5, .5}], 
     ImageScaled[{.5, .5}], ImageScaled@sc],
   PlotRangePadding -> 0, 
   Evaluate[FilterRules[{opts}, Options[ArrayPlot]]]]

g = binaryGraph[matOP, Hue@.6]

Mathematica graphics

arrayPlotGraph[matOP, g, .88, ImageSize -> 350]

Mathematica graphics

The same can obviously be done with random matrices:

SeedRandom@0;
mat = RandomInteger[{0, 1}, {20, 20}];
gg = binaryGraph[mat, Red]

Mathematica graphics

arrayPlotGraph[mat, gg, 1, ImageSize -> 350]

Mathematica graphics

If anyone had an idea about how to make ArrayPlot and Graph perfectly overlay at the right position without using ImageScaled@sc and playing around with sc please let me know :)


Note that the process can be reversed (except that last 0-columns and lonely 1 are lost):

rmat = SparseArray[# -> 1 & /@ 
  Rationalize /@ PropertyValue[g, VertexCoordinates]]
Row[MatrixPlot[#, ImageSize -> {200, 200}] & /@ {matOP, rmat}]

Mathematica graphics

share|improve this answer
    
Thank you so much! –  Jazz Jun 8 at 20:00
    
It should be working for any matrices as well, just notify me if you have an issue. –  Öskå Jun 8 at 20:03
    
@hftf aha I'm sorry :D You had the same? :) –  Öskå Jun 8 at 20:04
    
@Öskå - so nice ! would there be a way to show that the outermost columns are empty? –  eldo Jun 8 at 20:05
1  
@Öskå: +1, nice, concise answer. –  rasher Jun 8 at 22:08
show 3 more comments
mtrx = {{0, 1, 0, 0, 1, 0, 1, 0}, {0, 1, 0, 0, 1, 0, 1, 0},
        {0, 0, 1, 0, 1, 0, 1, 0}, {0, 0, 0, 1, 0, 0, 1, 0}, 
        {0, 0, 0, 0, 1, 1, 0, 0}, {0, 0, 0, 0, 1, 0, 0, 0}};

Once we re-number the elements of mtrx using a function like

renumber = Module[{i = 1}, # /. 1 :> i++] &; (* thanks: Mr.W *)

mtrx2 =renumber@mtrx 

ComponentMeasurements, with a little additional processing, provides evertything we need -- vertices, edges, vertex coordinates:

vertices =  ComponentMeasurements[mtrx2, "Label"][[All,1]];
centroids = ComponentMeasurements[mtrx2, "Centroid"];
neighbors = ComponentMeasurements[mtrx2, "Neighbors"];
edges = UndirectedEdge @@@DeleteDuplicates[Sort /@ Flatten[Thread /@ neighbors]];

Graph[vertices, edges, VertexCoordinates -> centroids]

enter image description here

ClearAll[arrayGraph];
arrayGraph[mat_, opts : OptionsPattern[]] := 
 Module[{m = Module[{i = 1}, mat /. 1 :> i++], edges, vcs, v},
  v = ComponentMeasurements[m, "Label"][[All, 1]];
  vcs = ComponentMeasurements[m, "Centroid"];
  edges = UndirectedEdge @@@ 
    DeleteDuplicates[Sort /@ Flatten[Thread /@ ComponentMeasurements[m, "Neighbors"]]];
 Graph[v, edges, VertexCoordinates -> vcs, opts]]

Show[ArrayPlot[mtrx], 
     arrayGraph[mtrx, VertexSize -> .3, EdgeStyle -> Directive[Thick, Red]]]

enter image description here

m2 = RandomInteger[{0, 1}, {20, 20}];
Show[ArrayPlot[m2], arrayGraph[m2, EdgeStyle -> Yellow]]

enter image description here

mat = RandomInteger[{0, 1}, {24, 10, 10}];
Grid[Partition[
       arrayGraph[#, ImageSize -> 120, VertexSize -> .4,
          EdgeStyle -> Directive[{Thick, Hue[RandomReal[]]}]] & /@ mat, 6],
  Background -> Black]

enter image description here

share|improve this answer
    
That's brilliant! :) –  Öskå Jun 10 at 0:31
    
Thank you @Öskå.. –  kguler Jun 10 at 0:32
    
@kguler - concerning the 2nd part of your answer (starting with ClearAll[arrayGraph]; I don't see any lines between the points. Maybe my display shipwrecked? Aside from this: Impressive! –  eldo Jun 10 at 0:53
    
@eldo, thank you. Do you mean the image after Show[ArrayPlot[mtrx], arrayGraph[mtrx]] or the last image? –  kguler Jun 10 at 1:00
1  
@kguler...very nice...centroids and neighbours just what was needed...always learning –  ubpdqn Jun 10 at 3:50
show 3 more comments

Just another answer (not very efficient):

vis[m_] := Module[{n, gr},
  n = SparseArray[m]["NonzeroPositions"];
  gr = Union[
    UndirectedEdge @@@ (Sort /@ 
       Flatten[Map[
         Function[u, 
          Thread[{w[u], 
            w /@ (Pick[n, 
               Or[Abs[u - #] == {1, 0}, Abs[u - #] == {0, 1}, 
                  Abs[u - #] == {1, 1}] & /@ n])}]], n], 1])];
  Graph[w /@ n, gr, VertexCoordinates -> ({#2, -#1} & @@@ n)]]

Using test matrix:

test = {{0, 1, 0, 0, 1, 0, 1, 0}, {0, 1, 0, 0, 1, 0, 1, 0}, {0, 0, 1, 
    0, 1, 0, 1, 0}, {0, 0, 0, 1, 0, 0, 1, 0}, {0, 0, 0, 0, 1, 1, 0, 
    0}, {0, 0, 0, 0, 1, 0, 0, 0}};

then

vis[test]

enter image description here

Some random small tests:

mat = RandomInteger[{0, 1}, {30, 10, 10}];
GraphicsRow[{ArrayPlot[#], vis[#]}] & /@ mat

and visualizing:

enter image description here

share|improve this answer
    
+1! I'm going to steal your ({#2, -#1} & @@@ n) if you don't mind.. :) –  Öskå Jun 9 at 9:56
    
@Öskå just my lazy way of dealing with coordinates...so feel free...have+1 your neat answer –  ubpdqn Jun 9 at 10:01
add comment

Using old-school GraphPlot:

Edit: the comments that broke the code have been removed.

input =
 {{0,1,0,0,1,0,1,0},
  {0,1,0,0,1,0,1,0},
  {0,0,1,0,1,0,1,0},
  {0,0,0,1,0,0,1,0},
  {0,0,0,0,1,1,0,0},
  {0,0,0,0,1,0,0,0}};

new = Module[{i = 1}, input /. 1 :> i++];

Developer`PartitionMap[Union @@ # &, %, {2, 2}, 1];

Union @@ DeleteCases[%, 0, {-1}];

Union @@ (Subsets[#, {2}] & /@ %);

GraphPlot[Rule @@@ %,
  VertexCoordinateRules -> Reverse[Most @ ArrayRules[new], 2]
]

enter image description here

Operations by line are:

  • renumber elements
  • find neighbors
  • get rid of zeros and duplicates
  • convert to neighboring pairs
  • plot
share|improve this answer
add comment

In this answer the goal is simply to build an adjancy matrix first, that gives you all the information about the graph. The great thing about the code is that you can change how the matrix is connected. For example, in your case you want diagonal components to be connected, here you can change to have only diagonal, only lateral or both. At the moment, is simply set by hand. If you want self connections then one can simply replace the array of positions

{#[[1,1]],....,#[[3,3]]} 

with

Flatten[#]

Otherwise this should allow you to generate the adjancy matrix.

myadjancyMatrixforcrystalC[crystal_] := 
     Module[{list = crystal, positions, newcrystal},
             positions = Position[list, 1];
      newcrystal = 
                SparseArray[# -> Range[Length[#]], Dimensions[list], 0] &[positions];
      Return[Map[DeleteCases[#,0] &, 
      {#[[1, 1]], #[[1, 2]], #[[1, 3]], #[[2, 1]], #[[2, 3]], #[[3, 1]], #[[3, 2]], #[[3, 3]]} & /@ (Function[{y}, 
      Take[ArrayPad[newcrystal,1], ##]&@@((# + {1, 1} + {-1, +1}) & /@ y)] /@ positions)]];
      ];

since I was dealing with huge matrixes at the time I wrote it, everything was kept as SparseMatrices, but it may not make much of a difference. Also I don't keep track of the positions of the points, but one could easily return that as part of the code too, to have a graph that can be overlaid over the matrix as some of the other answers, I might add that later.

Here is a small code to takes that adjancy matrix and generates undirected edges.

 myedges[adj_] := Module[{myadj = adj},
    Return[
      DeleteDuplicates[
       Sort /@ Flatten[
     MapIndexed[UndirectedEdge[First@#2, #1] &, myadj, {2}]]]];
  ];

And the graph for your matrix then is simply.

  Graph[myedges[
       myadjancyMatrixforcrystalC[
       {{0, 1, 0, 0, 1, 0, 1, 0}, 
        {0, 1, 0, 0,1, 0, 1, 0}, 
        {0, 0, 1, 0, 1, 0, 1, 0}, 
        {0, 0, 0, 1, 0, 0, 1, 0}, 
        {0, 0, 0, 0, 1, 1, 0, 0},
        {0, 0, 0, 0, 1, 0, 0, 0}}]]]

Since I didn't keep track of the positions it leads to the same topological graph.

enter image description here

As I mentioned you can also keep track of the positions in the first part of the code,

 myadjancyMatrixforcrystalC[crystal_] := 
     Module[{list = crystal, positions, newcrystal},
      positions = Position[list, 1];


 newcrystal = 
   SparseArray[# -> Range[Length[#]], Dimensions[list], 0] &[
    positions];

  Return[{Map[
    DeleteCases[#,0] &, {#[[1, 1]], #[[1, 2]], #[[1, 3]], #[[2, 1]], #[[2, 
       3]], #[[3, 1]], #[[3, 2]], #[[3, 3]]} & /@ (Function[{y}, 
      Take[ArrayPad[newcrystal, 
          1], ##] & @@ ((# + {1, 1} + {-1, +1}) & /@ y)] /@ 
     positions)], 
 Rule @@@ 
    Thread[{Range[Length[#]], #}] &@({1, -1}*# & /@ (Reverse /@ 
      positions))}];
 ];

Now the module myadjancyMatrixforcrystalC returns {adjancy_matrix,vertex->posisionts} , where the second component is given above by

 Rule@@@ 
    Thread[{Range[Length[#]], #}] &@({1, -1}*#&/@(Reverse /@ 
      positions))

which is simply vertexid->position, the rest of the math is simply due to the fact Position measures the upper left matrix location as {1,1} and increases as we go to further rows and columns, and therefore matches with results from say ArrayPlot

The positions can be added as option in Graph.

Graph[myedges[#[[1]]], VertexCoordinates -> #[[2]]] &[
  myadjancyMatrixforcrystalC[{{0, 1, 0, 0, 1, 0, 1, 0}, {0, 1, 0, 0, 1,
 0, 1, 0}, {0, 0, 1, 0, 1, 0, 1, 0}, {0, 0, 0, 1, 0, 0, 1, 0}, {0,
 0, 0, 0, 1, 1, 0, 0}, {0, 0, 0, 0, 1, 0, 0, 0}}]]

enter image description here

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.