1
$\begingroup$

Background:

The question is derive form this post.I have a another thinking about it.Some points in a suface you can give a certain equation but some points you cannot.So I wanna get a method to process that no equation case. Something method like signal filtering.It should be more smoother then before. As this meanning,but these points in 1D:

enter image description here

So I make some pseudo-data like following.Can we donn't use equation of circle(like fitting a circle) to process messPoint2D?

SeedRandom[322]
point2D = RandomPoint[Circle[{0, 0}, 2], 50];
messPoint2D = point2D /. a_Real :> a + RandomReal[{-.3, .3}]

{{2.03482,-0.0505514},{-2.12001,-0.817728},{-1.74035,-1.63313},{1.78539,-1.13954},{1.89574,0.558508},{-0.768103,1.96266},{1.9696,-0.234131},{1.33527,1.72081},{-1.34696,1.11191},{1.70215,-0.457756},{1.49434,-1.4612},{-0.827573,1.96794},{1.68644,-0.589807},{0.0611676,-1.77899},{0.751324,-1.77146},{-1.14019,-1.784},{1.87253,0.479152},{1.66679,-1.33623},{-1.93342,0.640445},{1.69974,-0.807108},{2.0371,-0.0763891},{-1.43967,1.73074},{-1.66722,0.433916},{1.56104,-1.16691},{1.59916,1.19086},{0.772323,-1.86247},{-1.89905,-0.775599},{-0.73034,2.12354},{-2.02256,0.366491},{-1.06331,-1.7122},{0.331255,-2.01548},{-1.69992,-0.419732},{-0.199849,1.77909},{2.13569,0.986909},{1.7007,-1.43682},{-2.02245,-0.394945},{1.84753,-1.0587},{-1.79648,-0.260515},{1.5658,1.64252},{-2.08078,0.917446},{2.20509,0.134297},{0.00486855,-1.80853},{-1.95518,0.0733502},{1.21364,1.50024},{0.558922,2.21009},{2.13153,-0.130213},{-1.51461,-1.57134},{-1.92186,0.354744},{1.69165,-0.971832},{-0.848805,-1.48607}}

Let's visualize it

Graphics[Point[messPoint2D]]

enter image description here

It's too rough.So I try to smooth it

smoothPoint2D = 
  Catenate[MeanFilter[#[[Most@Last@FindShortestTour[#]]], {3, 0}] & /@
     GatherBy[messPoint2D, Last[#] < 0 &]];

Show it in a graphics

Graphics@Point[smoothPoint2D]

enter image description here

We have a bad try obviously.Furthermore if the points is in a ellipse,the MeanFilter will give a worse result.Such the points like this:

SeedRandom[322]
point3D = 
  RandomPoint[
   RegionBoundary@DiscretizeRegion@Ellipsoid[{0, 0, 0}, {4, 3, 2}], 
   50];
messPoint3D = point3D /. a_Real :> a + RandomReal[{-.3, .3}]

{{2.07207,-1.74115,0.99079},{-1.00152,-1.87601,1.44575},{0.614248,-3.15193,0.669161},{0.506019,1.6797,-1.26587},{-0.697259,1.68684,-1.38891},{-2.7229,-1.45861,-0.980062},{-1.91229,-0.597374,1.64356},{-2.63553,-1.40528,1.21356},{-3.54036,-0.964002,-0.683493},{0.113757,-2.12893,-1.32791},{0.365527,2.21043,1.4537},{-1.79497,-1.96956,1.46747},{2.61934,-0.640953,-1.57529},{3.68277,-0.163062,0.119088},{-1.10108,2.63133,0.77401},{1.0603,1.02331,1.918},{3.45375,-0.375101,-0.600496},{0.854518,-1.56796,-1.63765},{1.37402,0.0916543,-1.62574},{-2.26586,-2.1045,-0.618894},{2.20182,-2.27725,0.736805},{-0.877823,1.18774,-1.77738},{-1.50583,-2.50576,0.317816},{2.70735,-1.74998,1.10437},{2.66755,-1.23068,-0.69978},{3.2197,-1.6254,0.309938},{-0.891931,2.87209,0.836711},{-1.52483,-1.17109,1.74934},{0.301247,3.06736,0.0764326},{-2.147,2.43088,0.240942},{3.79116,0.333534,0.0275468},{-0.174168,3.11093,-0.388287},{-2.42676,-0.934665,-1.50067},{-3.6411,0.668195,-0.675299},{-2.68546,0.159208,1.4389},{1.13681,-3.06672,0.120309},{-1.63009,-2.20641,-0.81025},{-4.06233,0.572647,-0.447319},{-3.23295,-0.715793,1.32005},{2.32172,2.72233,-0.162109},{-4.04731,-0.301951,-0.389709},{1.51613,-2.88289,-0.325647},{-2.66844,1.89623,0.86255},{-0.185447,2.58316,0.785376},{3.4009,-0.0871182,0.966895},{1.89572,2.42516,-0.430788},{1.89118,1.7872,1.40493},{1.77714,2.7319,0.544681},{0.061336,1.74055,-1.41376},{3.72806,-0.487459,-0.0564766}}

Graphics3D[Point[messPoint3D]]

enter image description here

So how to make this rough points in a surfaces to be like more smooth?

$\endgroup$
  • $\begingroup$ Hmm, haven't you and I gone through this before? :-) Would this old question of your not be relevant? Behaviour of RegionDistance with Ellipse? $\endgroup$ – MarcoB Mar 21 '16 at 21:11
  • $\begingroup$ @MarcoB I have upate it.But I don't I really sure I have cnvey clearly the diffrence in this two question. $\endgroup$ – yode Mar 21 '16 at 22:10
  • $\begingroup$ Related: "Smoothing ListContourPlot contours." $\endgroup$ – Alexey Popkov Mar 21 '16 at 23:28
  • $\begingroup$ @AlexeyPopkov Thank your for your link~It's seem lack of a 3D-points similar method still. $\endgroup$ – yode Mar 21 '16 at 23:59
  • $\begingroup$ @yode Regarding updated part of your question: you have faced this known bug. $\endgroup$ – Alexey Popkov Mar 22 '16 at 1:38
2
$\begingroup$
fst = FindShortestTour[mess];
Show[ListPlot[mess, PlotStyle -> {PointSize[Large], Red}], 
     ParametricPlot[ BSplineFunction[mess[[Last@fst]], SplineClosed -> True][t], 
                    {t, 0, 1}]]

Mathematica graphics

$\endgroup$
  • $\begingroup$ How to get the point that has been processed?Maybe the 'RegionNearest' can be help.But the 3d points? $\endgroup$ – yode Mar 21 '16 at 23:07
  • $\begingroup$ @yode What do you mean by "How to get the point that has been processed?"? ... All points have been processed ... $\endgroup$ – Dr. belisarius Mar 21 '16 at 23:10
  • $\begingroup$ We just get a Bspline curve? $\endgroup$ – yode Mar 21 '16 at 23:14
  • $\begingroup$ @yode yup. That's the Spline defined by those points. Take a look at the docs $\endgroup$ – Dr. belisarius Mar 21 '16 at 23:41
  • $\begingroup$ Ok.Sounds reasonable,too.:) $\endgroup$ – yode Mar 21 '16 at 23:51
0
$\begingroup$

As the @Alexey Popkov's suggestion that avoid the question to so long.I post some progress as a answer:

As the @Dr. belisarius's version 9.0 have no RegionNearest,So I update current progress in here(Every credit should be took by Dr. belisarius).The 2D point can be like this:

bezierCurve = 
  Graphics@BezierCurve[
    messPoint2D[[Last@FindShortestTour[messPoint2D]]], 
    SplineClosed -> True];
targetPoint2D = 
  RegionNearest[DiscretizeGraphics@bezierCurve, #] & /@ messPoint2D;
Show[bezierCurve, 
 Graphics[{Blue, Point[messPoint2D], Red, Point[targetPoint2D]}]]

enter image description here

But something unforeseen happen(just mention here.it have no influence to be a solution),I found the region of bezierCurve different to its graphics

DiscretizeGraphics@bezierCurve

enter image description here


As the @Alexey Popkov's comments.We replace BezierCurve with BSplineCurve.Then the process have a beautiful improvement.

bezierCurve = 
  Graphics@BSplineCurve[
    messPoint2D[[Last@FindShortestTour[messPoint2D]]], 
    SplineClosed -> True];
targetPoint2D = 
  RegionNearest[DiscretizeGraphics@bezierCurve, #] & /@ messPoint2D;
Show[bezierCurve, 
 Graphics[{Blue, Point[messPoint2D], Red, Point[targetPoint2D]}]]

enter image description here

$\endgroup$

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.