4
$\begingroup$

I want to generate a MeshRegion from ParametricPlot3D, e.g. the hemisphere (the PlotPoint is used to get small numbers of vertices)

g = ParametricPlot3D[{Cos[ϕ] Sin[θ], Sin[ϕ] Sin[θ], Cos[θ]}, {θ, 0, π/2},
 {ϕ, 0, 2 π}, PlotPoints -> {4, 4}, MaxRecursion -> 0, Mesh -> Full];
surf = DiscretizeGraphics[Normal@g];
{g, surf}

The number of vertices, as you may see is 10, but the generated MeshRegion has 42.

MeshCells[surf, 0] // Length

Many of vertices are duplicated. In fact they are distinct but their coordinates differ very little:

Counts@Round[MeshCoordinates[surf][[All]], .0001]
Counts@Round[MeshCoordinates[surf][[All]], 10.^-16]

is there any way to avoid such duplications ?

$\endgroup$
  • $\begingroup$ @Anjan - how to paste greek letters in the post ? I have searched the forum a bit but did not find. $\endgroup$ – sebqas Sep 23 '17 at 14:30
  • $\begingroup$ It's a plugin. See this mathematica.meta.stackexchange.com/a/1044/19742 $\endgroup$ – Anjan Kumar Sep 23 '17 at 17:33
  • $\begingroup$ it's nice, thanks $\endgroup$ – sebqas Sep 24 '17 at 20:45
4
$\begingroup$

Summary

I find that discretised regions often run into difficulties here (along with the related problem that many of the higher dimensional cells have essentially negligible measure). I know of no way to avoid the issue, but the following function should fix it:

fixMesh[meshregion_] := Module[{meshpts, polys},
  meshpts = 
   Mean /@ Gather[MeshPrimitives[meshregion, 0][[;; , 1]], 
     Norm[#1 - #2] < 10^-5 &];
  polys = 
   Select[Polygon /@ 
     Map[First@Nearest[meshpts, #] &, 
      MeshPrimitives[meshregion, 2][[;; , 1]], {2}], 
    RegionMeasure[#] > 10^-8 &];
  DiscretizeGraphics[Graphics3D[polys]]
  ]

Then

fixMesh[surf]

will return the correct mesh region with no duplicated points.

An explanation

There are two steps in the fixMesh function. The first finds the "proper" vertices of the mesh. I have just taken the mean of all points deemed sufficiently close. There are certainly more accurate ways (there's no guarantee that this mean actually lies within the region being discretised, although it won't be out by very much), but it's nice and simple.

newmeshpts = Mean /@ Gather[MeshPrimitives[surf, 0][[;; , 1]], Norm[#1 - #2] < 10^-5 &];
Length@newmeshpts

10

The cut-off 10^-5 was chosen as the smallest threshold that yields the right number of points.

The second step is to replace all the vertices in the mesh polygons (MeshPrimitives[surf, 2]) by the Nearest corrected point in newmeshpts

newpolys = Polygon /@ 
  Map[First@Nearest[newmeshpts, #] &, MeshPrimitives[surf, 2][[;; , 1]], {2}]]

We're not done yet -- some of these polygons now have zero measure because all their vertices are the same point:

RegionMeasure /@ newpolys

{0.122818, 0.177201, 0.122818, 0.378348, 0.37835, 0.378347, 0.177201, 0., 0.306921, 0.122818, 0.306922, 0.177201, 0., 0.436876, 0.306922, 0.43688, 1.86265*10^-9, 0., 0.436879, 0., 3.72529*10^-9}

So we just Select those with non-negligible measure:

newpolys = Select[newpolys, RegionMeasure[#] > 10^-8 &];
Length@newpolys

15

Now we have all our polygons, and just need to turn it back into a mesh. A simple way to do that is

newmesh = DiscretizeGraphics[Graphics3D[newpolys]]

enter image description here

Looks okay, but let's check

Length@MeshPrimitives[newmesh, 0]
Length@MeshPrimitives[newmesh, 2]

10

15

$\endgroup$
  • $\begingroup$ Many thanks, for the function and its expalnation. It works. Sometimes it required the proper tuning for the size of the Norm[..] and RegionMeasure[..], dependently on the particular mesh. $\endgroup$ – sebqas Sep 23 '17 at 14:33
  • $\begingroup$ @sebqas I'm glad it works. Don't forget that you can accept an answer if your question has been answered to your satisfaction. $\endgroup$ – aardvark2012 Oct 5 '17 at 7:19

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.