# Graph from binary matrix (not adjacency) respecting the original matrix positions

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}}
• See if MorphologicalGraph is what you need. Commented Jun 8, 2014 at 19:07
• Can you provide the matrix? :)
– Öskå
Commented Jun 8, 2014 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
Commented Jun 8, 2014 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
Commented Jun 8, 2014 at 19:36
• @Jazz In what way is the output of MorphologicalGraph incorrect? (I'm trying to understand the question.) Commented Jun 8, 2014 at 19:38

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],
Evaluate[FilterRules[{opts}, Options[ArrayPlot]]]]

g = binaryGraph[matOP, [email protected]]

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

The same can obviously be done with random matrices:

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

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

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}]

• It should be working for any matrices as well, just notify me if you have an issue.
– Öskå
Commented Jun 8, 2014 at 20:03
• @Öskå - so nice ! would there be a way to show that the outermost columns are empty?
– eldo
Commented Jun 8, 2014 at 20:05
• @eldo I'm afraid not, or I don't see how right now..
– Öskå
Commented Jun 8, 2014 at 20:12
• @Öskå: +1, nice, concise answer.
– ciao
Commented Jun 8, 2014 at 22:08
• @eldo How about now? I think it shows that the outermost columns are empty ;o)
– Öskå
Commented Jun 9, 2014 at 12:16
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]

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]]]

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

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

• That's brilliant! :)
– Öskå
Commented Jun 10, 2014 at 0:31
• @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
Commented Jun 10, 2014 at 0:53
• @eldo, thank you. Do you mean the image after Show[ArrayPlot[mtrx], arrayGraph[mtrx]] or the last image?
– kglr
Commented Jun 10, 2014 at 1:00
• @kguler - Yes, I see blue lines and points looking at Öska's answer, but I don't see the lines in your answer. This blue on black is difficult to see anyway.-
– eldo
Commented Jun 10, 2014 at 1:07
• @kguler...very nice...centroids and neighbours just what was needed...always learning Commented Jun 10, 2014 at 3:50

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]
]

Operations by line are:

• renumber elements
• find neighbors
• get rid of zeros and duplicates
• convert to neighboring pairs
• plot

Just another answer (not very efficient):

vis[m_] := Module[{n, gr},
n = SparseArray[m]["NonzeroPositions"];
gr = Union[
UndirectedEdge @@@ (Sort /@
Flatten[Map[
Function[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]

Some random small tests:

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

and visualizing:

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

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.

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.

Return[
DeleteDuplicates[
Sort /@ Flatten[
];

And the graph for your matrix then is simply.

Graph[myedges[
{{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.

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

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},
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@@@
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}}]]

mat = {{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, 1, 0, 0}};

pos = SparseArray[mat]["NonzeroPositions"];
NearestNeighborGraph[pos, DistanceFunction -> ChessboardDistance,
VertexCoordinates -> RotationTransform[-Pi/2]@pos]