5
$\begingroup$

Lets say I have this binary picture (an array with 1's and 0's):

start = {{0, 1, 1, 1}, {1, 1, 0, 0}, {1, 1, 0, 1}, {1, 1, 0, 0}};
i = ArrayPlot[CellularAutomaton[<|"OuterTotalisticCode"->224,"Dimension"->2,"Neighborhood"->9|>,{start,0},{{{200}}}],Frame->False,ColorRules->{1->White,0->Black}]

enter image description here

Then I can extract the subimages e.g. by using:

subimages =  ComponentMeasurements[i, "Image", All, "PropertyAssociation"]["Image"]

enter image description here

This gives me 13 subimages which have one black pixel in between. (Note, that the blank entries above are white pixels and thus the result is correct.)

But now I would like to count subimages with two black pixels in between as one subimage. More precisely I would like to obtain only a result with 9 subimages as grouped as this:

enter image description here

Is there any obvious way to do it in Mathematica?

Edit:

The answers by @MarcoB and @kglr work for the specified example. Especially if one uses additionally an Erosion on the mask to trim down the boundaries. But the solution is not generally applicable, another example:

start = {{0, 1, 1, 1}, {1, 1, 0, 0}, {1, 1, 0, 1}, {1, 1, 0, 0}, {1, 1, 1, 1}};
i = ArrayPlot[CellularAutomaton[<|"OuterTotalisticCode" -> 224, "Dimension" -> 2,"Neighborhood" -> 9|>, {start, 0}, {{{400}}}], Frame -> False,ColorRules -> {1 -> White, 0 -> Black}];

The resulting image should be, as before, divided into subimages with 2 black cells in between, as this (the critical location where the suggested solutions fail is indicated with the arrow):

enter image description here

This was the proposed solution (with an added Erosion):

dilated = Dilation[i, DiskMatrix[1]];
mask = Erosion[MorphologicalComponents@dilated, 1];
subimages = ComponentMeasurements[{i, mask}, "Image"]

enter image description here

Image 4 was captured incorrectly. To me it seems that ComponentMeasurements applies a bounding box which is not desired. Any modification of the proposed solution that fixes this issue is appreciated!

Improve this question
$\endgroup$
4
  • $\begingroup$ What is the value of start in your code? $\endgroup$
    – MarcoB
    Commented May 12, 2020 at 16:51
  • $\begingroup$ sorry, thanks for asking, I edited. $\endgroup$
    – Mr Puh
    Commented May 12, 2020 at 16:52
  • $\begingroup$ Your edit changes the question substantially, to the point of invalidating all answers provided so far. Moving the goalposts like you just did is frowned upon because it wastes the effort put in by answer writers, and discourages further answers because people will be worried that you will substantially change the question yet again. Consider removing your edit, accepting an answer to your original question, and perhaps posting your new problem as a new question. $\endgroup$
    – MarcoB
    Commented May 13, 2020 at 13:37
  • $\begingroup$ @MarcoB I disagree with your statement. The first picture just served as an (arbitrary) example and the question was framed generally. While the provided solutions gave correct answers to the example they didn't give the correct answer to the (general) question. But if there won't be further answers I will accept one answer given and ask another question, yes. $\endgroup$
    – Mr Puh
    Commented May 13, 2020 at 13:58

3 Answers 3

Reset to default
4
$\begingroup$

Update:

start1 = {{0, 1, 1, 1}, {1, 1, 0, 0}, {1, 1, 0, 1}, {1, 1, 0, 0}};
ca1 = CellularAutomaton[<|"OuterTotalisticCode" -> 224, "Dimension" -> 2, 
"Neighborhood"->9|>, {start,0}, {{{200}}}];
i1 = ArrayPlot[ca1, Frame-> False, ColorRules -> {1 -> White, 0 -> Black}];

Using a combination of ArrayMesh and FindClusters with ChessboardDistance we get a list of clusters of polygon objects:

clusters1 = FindClusters[MeshPrimitives[ArrayMesh[ca1], 2],
  DistanceFunction -> (ChessboardDistance[RegionCentroid @ #, RegionCentroid @ #2]&)];

Show[i1, Graphics @ MapIndexed[{FaceForm[], EdgeForm[{ Dotted, Cyan}], 
     Scale[BoundingRegion[Join @@ (PolygonCoordinates /@ #), 
       "FastEllipse"], {1, 1} 1.1], EdgeForm[], Opacity[1], 
     FaceForm[ColorData[97]@#2[[1]]], #} &, clusters1]]

enter image description here

Multicolumn[Graphics[{EdgeForm[], FaceForm[White], #}, 
   Background -> Black, ImageSize -> Tiny, PlotRangePadding -> 1]& /@ 
 clusters1, 5]

enter image description here

start2 = {{0, 1, 1, 1}, {1, 1, 0, 0}, {1, 1, 0, 1}, {1, 1, 0, 0}, {1, 1, 1, 1}};
ca2 = CellularAutomaton[<|"OuterTotalisticCode" -> 224, "Dimension" -> 2, 
 "Neighborhood" -> 9|>, {start2, 0}, {{{400}}}];

i2 = ArrayPlot[ca2, Frame -> False, ColorRules -> {1 -> White, 0 -> Black}];


clusters2 = FindClusters[MeshPrimitives[ArrayMesh[ca2], 2],
 DistanceFunction -> (ChessboardDistance[RegionCentroid @ #,RegionCentroid @ #2]&)];

Show[i2, Graphics @ MapIndexed[{FaceForm[], EdgeForm[{ Dotted, Cyan}], 
   Scale[BoundingRegion[Join @@ (PolygonCoordinates /@ #), "FastEllipse"], 
     {1, 1} 1.1], 
   EdgeForm[], Opacity[1],  FaceForm[ColorData[97]@#2[[1]]], #} &, clusters2]]

enter image description here

Multicolumn[Graphics[{EdgeForm[], FaceForm[White], #}, 
   Background -> Black, ImageSize -> Tiny, PlotRangePadding -> 1]& /@ 
 clusters2, 5]

enter image description here

Original answer:

trim = Values @ ComponentMeasurements[MorphologicalTransform[Binarize @ i, "Max"], 
   "BoundingBox"];

ImageTrim[i, trim]

enter image description here

Improve this answer
$\endgroup$
3
  • 1
    $\begingroup$ Thanks for your answer, however your solution is not quite correct for a different example. Please have a look at the edit I made. Do you have any idea how to adjust it appropriately? $\endgroup$
    – Mr Puh
    Commented May 13, 2020 at 9:58
  • $\begingroup$ @MrPuh, I missed the two black cells in between bit (although it is boldfaced in your post:). $\endgroup$
    – kglr
    Commented May 13, 2020 at 10:01
  • 1
    $\begingroup$ Your answer was correct for the first example I provided! It just doesn't give the right result for a different example. Any thoughts on how to fix it is appreciated :) $\endgroup$
    – Mr Puh
    Commented May 13, 2020 at 10:04
8
$\begingroup$

One simple approach is to expand the small blocks using Dilation, then count the number of blocks that remain. Starting with your image i:

idil = Dilation[i, 2];
subidil = ComponentMeasurements[idil, "Image", All, "PropertyAssociation"]["Image"]

and you can see that subidil has the desired Length[subidil]=9 components.

This is an answer to the original question, which was: "to count subimages with two black pixels in between as one subimage". It is not an answer to the extended and revised (twice) question.

Improve this answer
$\endgroup$
4
  • $\begingroup$ This wouldn't give me the actual subimages though, but a "thicker" version. I tried Erosion afterwards but this doesn't really work. $\endgroup$
    – Mr Puh
    Commented May 12, 2020 at 17:32
  • $\begingroup$ You could use the output of subidil as masks on the original set if you want finer control. $\endgroup$
    – bill s
    Commented May 12, 2020 at 17:41
  • $\begingroup$ Not sure if I get what you mean. How would I do this? $\endgroup$
    – Mr Puh
    Commented May 12, 2020 at 17:52
  • $\begingroup$ Overlay each of the smaller older ones (in subimg) to its appropriate new larger one (in subidil). ComponentMeasurements will tell you where they are. $\endgroup$
    – bill s
    Commented May 12, 2020 at 18:43
6
$\begingroup$

Similar to what @bill proposed, but generating the separated images.

First, use dilation to "fuse together" the small features that are close by. Then use MorphologicalComponents to generate a mask identifying each of the dilated components. Finally, use that mask to extract the subimages of the original image that correspond to where the fused blobs are in the dilated image. 

dilated = Dilation[i, DiskMatrix[1]];
mask = MorphologicalComponents@dilated;
ComponentMeasurements[{i, mask}, "Image"]

separated components

Improve this answer
$\endgroup$
3
  • $\begingroup$ Thanks for your answer, however your solution is not quite correct for a different example. Please have a look at the edit I made. Do you have any idea how to adjust it appropriately? $\endgroup$
    – Mr Puh
    Commented May 13, 2020 at 9:58
  • $\begingroup$ @MrPuh Moving the goalposts like you just did is VERY unfriendly to those that put in the effort of writing an answer to your original question, only to see it invalidated because you had not thought the question through properly. Consider removing your edit, accepting an answer to the original question, and perhaps posting your new problem as a new question. $\endgroup$
    – MarcoB
    Commented May 13, 2020 at 13:35
  • $\begingroup$ Sorry if you feel I have moved the goalpost, I thought I just explained the question better with another example (it is still the same question: extracting subimages with 2 black cells in between). Your answer helped me in any way so your appreciated effort was by no means ineffectual. Thank you for that. I am not trying to downplay your answer, I am just trying to find a general answer to the (general) problem. $\endgroup$
    – Mr Puh
    Commented May 13, 2020 at 14:03

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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