5
$\begingroup$

I have a list of vertices:

{{1454.16552734375`, 942.5`}, {337.9480285644531`, 407.9453125`}, 
 {318.0152587890625`, 428.353515625`}, {342.0124816894531`, 403.962646484375`}, 
 {277.94842529296875`, 486.03125`}, {1198.7965087890625`, 1234.8741455078125`},
 {312.4529724121094`, 434.356689453125`}, {1142.8619384765625`, 1274.6539916992188`}, 
 {1216.492431640625`, 1218.9954833984375`}, {1179.011962890625`, 1250.852294921875`}, 
 {688.2337646484375`, 1314.6601257324219`}, {733.9116821289062`, 1330.8984069824219`},
 {627.462158203125`, 1283.3348999023438`}, {583.695556640625`, 1239.4417114257812`}, 
 {1511.9337158203125`, 652.8341674804688`}, {1511.9337158203125`, 642.1658325195312`}, 
 {651.5089721679688`, 1299.1900024414062`}, {1272.906494140625`, 1154.5545959472656`},
 {1085.2890625`, 1306.9449462890625`}, {599.6814575195312`, 1258.9429016113281`}, 
 {272.437255859375`, 539.4434814453125`}, {287.7309265136719`, 461.513427734375`}, 
 {608.1034545898438`, 1267.4883422851562`}, {268.2161865234375`, 663.7935180664062`}, 
 {1156.6552734375`, 397.2230224609375`}, {763.6713256835938`, 1335.1801147460938`}, 
 {310.9466857910156`, 860.0018310546875`}, {263.71783447265625`, 637.33642578125`}, 
 {886.817626953125`, 305.4976806640625`}, {366.3626403808594`, 382.657470703125`}};

I want to build disks with the same radius on every vertex in the list and then increase the disks’ radius gradually. At some point, all the disks will create a hole inside, like this

center hole

I record this radius (r = 264 now) and continue to increase the radius of the disks until the center hole is reduced and split into two holes (r = 510 now), as shows below:

enter image description here

Actually there are two holes in there:

Actually there are 2 holes

I make a note of the radius again.

When one of the center holes is destroyed, I'll take note of the radius again, and once more when the hole in the center is finally filled in.

This is called r-ball persistence diagram and I'm trying to implement it in Mathematica.

So, how to do this automatically with Mathematica ? I'm trying "FOR" loop with increased radius every steps and use RegionDifference[] and RegionIntersection[] in the loop to find hole region, but it's computationally expensive and takes long time. Also RegionDifference[]doesnt return empty region when it couldn't find the difference.

$\endgroup$
6
$\begingroup$

Here is a function that counts the connected components in an image representation of your system:

ClearAll[compcount]
compcount[radius_, vertices_] := Length[
  ComponentMeasurements[
    Image@Graphics[{Black, EdgeForm[None], Disk[#, radius] & /@ vertices}],
    "Count"
  ]
]

We then estimate a range within which the "hole birth" happens, using Manipulate manually:

Manipulate[
 Graphics[{Black, EdgeForm[None], Disk[#, r] & /@ vert}],
 {r, 100, 1000, 1}
]

manipulate

By eye only, it seems that the formation of the hole happens for a radius value between 260 and 270.

We then repeatedly apply the component count function within that range, and find the first value of radius for which a second connected component appears (i.e. the hole):

minradius = 
 FirstCase[Table[{r, compcount[r, vert]}, {r, 260, 270, 1}], {r_, 2} :> r]

(* Out: 264 *)

We use the Manipulate again to roughly estimate for what value of the radius the hole closes up:

almost closed

I roughly estimated $505\le r\le 520$. I then fed each case in that interval to the component measurement function, and looked for the first case in which only one component was present (i.e. the hole has closed):

maxradius = 
 FirstCase[Table[{r, compcount[r, vert]}, {r, 505, 520, 1}], {r_, 1} :> r]

(* Out: 515 *)

Here are the two situations:

GraphicsRow[
  Function[radius,
    Graphics[{Black, EdgeForm[None], Disk[#, radius] & /@ vert}]
  ] /@ {264, 515}
]

hole, no hole

$\endgroup$
  • $\begingroup$ One could refine this a bit with a bisection search: Start with a with two components and b with one compontent. Then compute the number f[c] of components of c=(a+b)/2. If f[c] is 1, set b=c, else a=c. Afterwards continue until, say Abs[b-a]<1. $\endgroup$ – Henrik Schumacher May 4 '18 at 22:56
  • $\begingroup$ The big first hole was born when disk radius is more or equal than half the longest Euclidean distance between two close vertices (r=264).It dies at r=510 and form 2 holes. At r=511, one of the holes dies and there's 1 hole left and then it dies at r=512. $\endgroup$ – Dat Pham Hoang May 4 '18 at 23:24

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.