# Finding radius when the hole is born and dead (persistence diagrams)

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

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:

Actually there are two holes in there:

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.

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

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):

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:

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):

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

(* Out: 515 *)

Here are the two situations:

GraphicsRow[