# 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. – Szabolcs Jun 8 '14 at 19:07
Can you provide the matrix? :) – Öskå Jun 8 '14 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 '14 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 '14 at 19:36
@Jazz In what way is the output of MorphologicalGraph incorrect? (I'm trying to understand the question.) – Szabolcs Jun 8 '14 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, Hue@.6]


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


-
Thank you so much! – Jazz Jun 8 '14 at 20:00
It should be working for any matrices as well, just notify me if you have an issue. – Öskå Jun 8 '14 at 20:03
@hftf aha I'm sorry :D You had the same? :) – Öskå Jun 8 '14 at 20:04
@Öskå - so nice ! would there be a way to show that the outermost columns are empty? – eldo Jun 8 '14 at 20:05
@Öskå: +1, nice, concise answer. – ciao Jun 8 '14 at 22:08
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å Jun 10 '14 at 0:31
Thank you @Öskå.. – kglr Jun 10 '14 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 '14 at 0:53
@eldo, thank you. Do you mean the image after Show[ArrayPlot[mtrx], arrayGraph[mtrx]] or the last image? – kglr Jun 10 '14 at 1:00
@kguler...very nice...centroids and neighbours just what was needed...always learning – ubpdqn Jun 10 '14 at 3:50

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å Jun 9 '14 at 9:56
@Öskå just my lazy way of dealing with coordinates...so feel free...have+1 your neat answer – ubpdqn Jun 9 '14 at 10:01

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

DeveloperPartitionMap[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
-

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


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,

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

-