How to convert the binarize-picture to a Region

Question

The Region of Mathematica is nice,and is the new conception of version 10.0.I can convenient get Area,Centroid and the RandomPoint from the Region.Now,I get a beautifull apple like this picture.

Then I Binarize it:

binapple = Binarize[pic, 0.91] // ColorNegate // FillingTransform

so I get the binarize-apple:

The question is how to convert the binarize-apple to a Region.Can anybody give some suggestion.I'll appreciate you sincerely.

Answer 1

Here's a partial answer which might lead you in the right direction. If we convert the binarized image into image data, we can establish a condition suitable for RegionPlot:

rp = With[{idata = ImageData[binapple], 
  xmax = First@ImageDimensions[binapple], 
  ymax = Last@ImageDimensions[binapple]},
 RegionPlot[
  idata[[IntegerPart@(ymax - y), IntegerPart@x]] == 1, {x, 1, 
   xmax}, {y, 1, ymax}]]

The problem with this approach is that one should be able to create an implicit region in a similar manner, however I am getting a part specification error message when I try:

With[{idata = ImageData[binapple], 
  xmax = First@ImageDimensions[binapple], 
  ymax = Last@ImageDimensions[binapple]},
 ImplicitRegion[
  idata[[IntegerPart@(ymax - IntegerPart@y), IntegerPart@x]] == 1 && 
   1 <= IntegerPart@x <= xmax && 1 <= IntegerPart@y <= ymax, {x, y}]]

I'll certainly update this half-answer once I find my error.

Note: One hackish way to get the region itself is to run BoundaryDiscretizeGraphics@rp[[1]]. We can wrap this all up in a function:

binaryImageToRegion[bimg_] := 
 With[{idata = ImageData[bimg], xmax = First@ImageDimensions[bimg], 
   ymax = Last@ImageDimensions[bimg]},
  BoundaryDiscretizeGraphics@
   First@RegionPlot[
     idata[[IntegerPart@(ymax - y), IntegerPart@x]] == 1, {x, 1, 
      xmax}, {y, 1, ymax}]]

So that binaryImageToRegion[binapple] gives:

The RegionPlot does add quite a bit of overhead, but I don't see a significant performance issue with your test case.

Answer 2

Another more or less direct construction, like rherman's:

Clear[square];
(* Create a square for each pixel in  pos  *)
square = Compile[{{pos, _Real, 2}},
   Block[{tp = Transpose[pos]},
    Transpose[
     {tp - 1, {tp[[1]], tp[[2]] - 1}, tp, {tp[[1]] - 1, tp[[2]]}},
     {2, 3, 1}
     ]
    ]
   ];

discretizeImage[img_] := Module[{pos, poly, coords, nf},
   pos = PixelValuePositions[img, 1];
   poly = square[pos];
   coords = DeleteDuplicates@Flatten[poly, 1];
   nf = Nearest[coords -> Automatic];
   MeshRegion[
    N@coords,
    Polygon[poly /. {x_Real, y_Real} :> First@nf[{x, y}]]
    ]
   ];

mesh = discretizeImage[binapple // DeleteSmallComponents]; // AbsoluteTiming
(*  {2.90293, Null}  *)

bmesh = BoundaryMesh@mesh

Answer 3

img = Import["https://i.sstatic.net/lkLgU.png"];

imgregion[im_] := 
 Polygon[Part[#, Last@FindShortestTour[#]] &@
   PixelValuePositions[
    MorphologicalPerimeter[
     Erosion[FillingTransform@ColorNegate@Binarize[im, 0.91], 2], 
     CornerNeighbors -> False], 1]]

RegionQ@imgregion[img]

True

RegionPlot[imgregion[img]]

Graphics[imgregion[img]]