Removing cells from Voronoi mesh if they exceed a certain area or circumference

Question

I start with the example in Finding the perimeter, area and number of sides of a Voronoi cell with RunnyKine's answer:

pts = RandomReal[4, {20, 2}];
vor = VoronoiMesh[pts, {{0, 4}, {0, 4}}]; (* bounded Voronoi diagram *)
HighlightMesh[vor, {Style[2, White], Style[1, Thick, Red], Labeled[2, "Index"]}]

How can I remove cells which exceed a certain threshold of area or circumference?

I do not want to display such cells and also not consider them when calculation the mean area, mean circumference or when showing corresponding histograms for vortices, area, and circumference.

In the upper plot: is it possible e.g. to show how to remove from vor the smallest cell concerning area (probably number 5) and the largest concerning area (probably number 17).

RunnyKine showed in his answer how to determine the cell areas:

cells = MeshCells[vor, 2]; (* The polygons that make up the Voronoi diagram *) 
cellcoord = Map[MeshCoordinates[vor][[#]] &, cells, {2}];
areas = Area /@ cellcoord;

And also he measured the perimeters:

RegionMeasure /@ (MeshPrimitives[vor, 2] /. Polygon[{x_, y__}] :> Line[{x, y, x}])

Answer 1

So this would create a mesh region where we've removed all the cells whose area is larger than the average area,

pts = RandomReal[4, {20, 2}];
vor = VoronoiMesh[
  pts, {{0, 4}, {0, 
    4}}];
HighlightMesh[vor, {Style[2, 
   White], Style[1, Thick, Red], Labeled[2, "Index"]}]
vor2 = Show[
    Graphics /@ 
     Select[MeshPrimitives[vor, 2], 
      Area[#] < Mean[PropertyValue[{vor, 2}, MeshCellMeasure]] &]] // 
   DiscretizeGraphics;
HighlightMesh[vor2, {Style[2, White], Style[1, Thick, Red], 
  Labeled[2, "Index"]}]

If it is necessary that the new cells have the same index number, that would be a bit trickier I think.

For the perimeter, it's convenient to define an auxilliary function,

polygonPerimeter[Polygon[{x_, y__}]] := RegionMeasure[Line[{x, y, x}]];

vor2 = Show[
    Graphics /@ 
     Select[MeshPrimitives[vor, 2], 
      polygonPerimeter[#] < 
        Mean[polygonPerimeter /@ MeshPrimitives[vor, 2]] &]] // 
   DiscretizeGraphics;
HighlightMesh[vor2, {Style[2, White], Style[1, Thick, Red], 
  Labeled[2, "Index"]}]

You could show the different cells together, highlighting based on whether they are smaller or larger than the mean,

pts = RandomReal[4, {20, 2}];
vor = VoronoiMesh[pts, {{0, 4}, {0, 4}}];
vor12 = DiscretizeGraphics[Show[Graphics /@ #]] & /@ 
   GatherBy[MeshPrimitives[vor, 2], 
    Area[#] > Mean[PropertyValue[{vor, 2}, MeshCellMeasure]] &];
Show[
 HighlightMesh[vor12[[1]], {Style[2, Blue], Style[1, Thick, Black]}],
 HighlightMesh[vor12[[2]], {Style[2, Red], Style[1, Thick, Black]}]
 ]

And finally, if you wanted to keep only the four-sided regions,

vor2 = Show[
    Graphics /@ 
     Select[MeshPrimitives[vor, 2], 
      Length[First[List @@ #]] == 4 &]] // DiscretizeGraphics;
HighlightMesh[vor2, {Style[2, White], Style[1, Thick, Red], 
  Labeled[2, "Index"]}]

Answer 2

Maybe do something like this:

BlockRandom[SeedRandom[42]; pts = RandomReal[4, {20, 2}]] (* for reproducibility *)
vor = VoronoiMesh[pts, {{0, 4}, {0, 4}}];

plist = MapIndexed[{Text[#2[[1]], RegionCentroid[#1]], FaceForm[], 
                    EdgeForm[Directive[Thick, Red]], #} &, MeshPrimitives[vor, 2]];

{Graphics[plist, PlotRange -> {{0, 4}, {0, 4}}], 
 Graphics[Select[plist,
          (ArcLength[RegionBoundary[Last[#]]] < 4 && Area[Last[#]] < 0.8) &],
          PlotRange -> {{0, 4}, {0, 4}}]} // GraphicsRow

where ArcLength[RegionBoundary[(* polygon *)]] directly computes the perimeter.

Answer 3

I'll do something like this to build a new MeshRegion with only the smallest cells:

SeedRandom[0]
pts = RandomReal[4, {20, 2}];
vor = VoronoiMesh[pts, {{0, 4}, {0, 4}}]

vor2 = MeshRegion[
  MeshCoordinates[vor],
  With[{a = PropertyValue[{vor, 2}, MeshCellMeasure]}, 
   With[{m = Mean[a]}, Pick[MeshCells[vor, 2], UnitStep[a - m], 0]]]
  ]

---

You can also define a function to filter a mesh like this

Clear[filterVoronoiMesh]
filterVoronoiMesh[mesh_MeshRegion, at : _ : Automatic, 
  pt : _ : Automatic, np : _ : _] :=
 With[{
   a = PropertyValue[{mesh, 2}, MeshCellMeasure],
   p = RegionMeasure@*RegionBoundary /@ MeshPrimitives[mesh, 2],
   n = Length @@@ MeshCells[mesh, 2]
   },
  With[{
    aq = at /. Automatic -> LessEqualThan@Mean[a],
    pq = pt /. Automatic -> LessEqualThan@Mean[p],
    nq = MatchQ[np]
    },
   MeshRegion[
    MeshCoordinates[mesh],
    Pick[MeshCells[mesh, 2], 
     Boole[aq /@ a] + Boole[pq /@ p] + Boole[nq /@ n], 3]]
   ]]

The arguments are:

• the mesh to be filtered
• a predicate to select cells by the area (for example LessEqualThan[10]; if Automatic or missing use LessEqualThan the mean area value)
• a predicate to select cells by perimeter (for example GreaterThan[5]; if Automatic or missing use LessEqualThan the mean perimeter value)
• a pattern for the number of vertices (if missing any number pass the filter)

For example:

SeedRandom[0]
pts = RandomReal[4, {40, 2}];
vor = VoronoiMesh[pts, {{0, 4}, {0, 4}}]
filterVoronoiMesh[vor]

Or

filterVoronoiMesh[vor, Automatic, Automatic, 4 | 6]