Re: Identifying clusters of adjacent points on a lattice — Solution

*To*: mathgroup at smc.vnet.net*Subject*: [mg81425] Re: Identifying clusters of adjacent points on a lattice — Solution*From*: Gareth Russell <russell at njit.edu>*Date*: Sun, 23 Sep 2007 04:29:00 -0400 (EDT)*References*: <fcvr81$7r9$1@smc.vnet.net>

Hi again, Daniel Lichtblau pointed me towards WeakComponents[]. I contructed a function around that to process a binary matrix such that each connected patch of 1's is replaced by a patch of distinct integers 1, 2, ... n where n is the total number of patches. I takes about 1 second to process a 100 by 100 matrix with approx 250 patches. The last line can easily be altered to produce {x,y,i} triples. I post it in here in case it's useful to anyone. Gareth findPatches[m_] := Module[{x, y, indexMatrix, rowEdges, colEdges, allIndices, clusterIndices, soloIndices, xy, groups}, Needs["GraphUtilities`"]; x = Length[m[[1]]]; y = Length[m]; indexMatrix = Table[i*x + j, {i, 0, y - 1}, {j, 0, x - 1}]; rowEdges = DeleteCases[ Flatten[ Table[ If[{m[[i, j]], m[[i, j + 1]]} == {1, 1}, indexMatrix[[i, j]] -> indexMatrix[[i, j + 1]], 0], {i, 1, y}, {j, 1, x - 1}]], _Integer]; colEdges = DeleteCases[ Flatten[ Table[ If[{m[[i, j]], m[[i + 1, j]]} == {1, 1}, indexMatrix[[i, j]] -> indexMatrix[[i + 1, j]], 0], {j, 1, x}, {i, 1, y - 1}]], _Integer]; allIndices = Flatten[Extract[indexMatrix, Position[m, 1]]]; clusterIndices = WeakComponents[Join[rowEdges, colEdges]]; soloIndices = Complement[allIndices, Flatten[clusterIndices]]; xy = Map[{Floor[#/x] + 1, Mod[#, x] + 1} &, Join[clusterIndices, Map[{#} &, soloIndices]], {2}]; groups = Range[Length[xy]]; Normal[SparseArray[ Flatten[Table[Map[# -> groups[[i]] &, xy[[i]]], {i, 1, Length[groups]}], 1],{y,x}]] ] On 2007-09-21 03:18:25 -0400, Gareth Russell <russell at njit.edu> said: > Hi, > > Is there any way to use the built-in clustering routines to find > clusters of ajacent elements on a 2d lattice? For example, I might > generate a 'map' with > > SeedRandom[1]; > testMap = =E2=80=A8 Last[CellularAutomaton[{1018, {2, {{0, 2, 0}, {2, 1, 2}, > {0, 2, 0}}}, {1, =E2=80=A8 1}}, Table[If[Random[Real] < 0.1, 1, 0], {100}, > {100}], 10]]; > > I would then like to find and label the separate 'patches' consisting > of clusters of 1's. Ultimately, I'm looking for a list of {x,y,id} > triples where the x and y are the coordinates of each 1 and the id is a > number that identifies the patch to which that element belongs, but the > trick is to find the clusters. I can't see how any of the included > options for FindClusters would perform this particular test (each > cluster must consist of elements connected to at least one other > element by a distance of 1). > > Of perhaps there is another way? > > Thanks, > > Gareth -- Gareth Russell NJIT