9
$\begingroup$

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

enter image description here

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}])
$\endgroup$
10
$\begingroup$

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

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$
  • $\begingroup$ No, the index ist not important ... that is great what you did. For the circumference: could you propose how to select in this case the cells (e.g. if they are below the mean circumference). Thank you. $\endgroup$ – mrz Mar 16 '16 at 16:11
  • $\begingroup$ I was almost there when you messaged :-D $\endgroup$ – Jason B. Mar 16 '16 at 16:13
  • $\begingroup$ If you look at the input form of vor, you can notice that this is a MeshRegion (so a list of coordinates and a list of Polygon). So you can assign a value to a case and will do follow the corresponding elements (If you want to keep the same index number). $\endgroup$ – physicien Mar 16 '16 at 16:17
  • $\begingroup$ @Jason B: Great ... great ... great ... it works perfect. Very last question and then I stop: how is the corresponding code when I want to select cells with a certain number of vortices and delete them? $\endgroup$ – mrz Mar 16 '16 at 16:27
  • $\begingroup$ I gotta run, but basically you need to be able to formulate a True/False test to run on the individual Polygon objects. Try the function on, say, MeshPrimitives[vor, 2][[1]] to see if it works, then use the Select trick above. $\endgroup$ – Jason B. Mar 16 '16 at 16:33
7
$\begingroup$

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

just feels like its missing

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

$\endgroup$
  • $\begingroup$ Another nice solution ... thanks a lot J.M. $\endgroup$ – mrz Mar 16 '16 at 20:43
7
$\begingroup$

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

Mathematica graphics


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]

Mathematica graphics

Or

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

Mathematica graphics

$\endgroup$
  • $\begingroup$ This ist absolutely more than great ... I can only vote for one :-( $\endgroup$ – mrz Mar 16 '16 at 17:58

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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