1
$\begingroup$

I am inexperienced with Mathematica, so I apologize if I advertise my ignorance.

I am trying to write a code that will assign a measure of 'disconnectedness' to a finite set $S$ of points in the plane. In other words, I would like to define a function $\kappa$ that maps finite subsets of $\mathbb R^2$ to nonnegative real numbers. So if the points in $S$ all appear in one big clump, then $\kappa(S)$ should be small. One the other hand, if the points in $S$ appear in two or more clumps, then $\kappa(S)$ should be large.

One such measure might be obtained as follows. For each $\varepsilon>0$, define a graph $G_\varepsilon(S)$ with vertex set $S$ in which two points in $S$ are adjacent in the graph $G_\varepsilon(S)$ if and only if the (Euclidean) distance between them is less than $\varepsilon$. We would then let $$\kappa(S)=\inf\{\varepsilon:G_\varepsilon(S)\text{ is a connected graph}\}.$$
This works theoretically, but it seems as though it would be very computationally difficult to evaluate $\kappa(S)$ for, say, $1000$ different sets $S$, each having $1000$ elements. Even if the computing time were not an issue, I still would not know how to tell Mathematica to form the graphs $G_\varepsilon(S)$. I also would not know how to get Mathematica to determine whether or not $G_\varepsilon(S)$ is a connected graph.

Is there a nice way of coding some sort of 'disconnectedness measure', even if it is not the one I have described here?

$\endgroup$
1
$\begingroup$

Here's a brute-force way to implement the one you described:

These are the points:

pts = RandomReal[1, {1000, 3}];

These are their pairwise distances:

dm = DistanceMatrix[pts];

Test connectedness for a given epsilon:

epsilon = 0.15;
ConnectedGraphQ@AdjacencyGraph@UnitStep[epsilon - dm]
(* True *)

Find a good approximation to the threshold epsilon using binary search:

Clear[binarySearch];
binarySearch[f_, n_, min_, max_] :=     
 Module[{left = min, right = max, mid},
  If[f[min] && Not@f[max], Return[$Failed]];
  Do[
   mid = (left + right)/2;
   If[f[mid],
    right = mid,
    left = mid
    ],
   {n}
   ];
  mid
  ]

binarySearch[
 ConnectedGraphQ@AdjacencyGraph@UnitStep[# - dm] &,
 50,
 0., 0.25
]

(* 0.123056 *)
$\endgroup$
  • $\begingroup$ This could be made faster by starting with a Delaunay triangulation instead of a complete distance matrix. Cannot update the answer now, sorry. $\endgroup$ – Szabolcs Mar 20 '17 at 10:31

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.