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

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

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.

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]