Delete duplicates in list of interpolating functions

Question

I have a list of several hundreds of InterpolatingFunction generated by numerical continuations based on different starting points. A list can be downloaded here [68Mb, that's what I needed to have something representative].

My problem is easily understood by plotting the InterpolatingFunction:

data = Import["list.m"];
Table[With[{fun = data[[i]]}, 
 ParametricPlot3D[fun[[1]], {t, fun[[2, 1]], fun[[2, 2]]}]], {i, 1, Length@data}]

In this figure, I manually circled "similar" curves. Two curves are considered "similar" when they overlap on an interval of non-zero length (let's say of length 1). For obvious reasons, I'd like to keep only one curve of each kind; only the longest one should be conserved. So in this example it would give me only 5 curves (one for each color). The difficulty is that each curve has a different parametrization, so the range of the parameter t is arbitrary (it has at least $0$ and is at most $[-100,100]$) and @bbgodfrey's approach fails now that I have added additional curves: it measures a larger difference between the number 1 and number -2 (second to last) than between number 1 and number 7 (the yellow one).

The following approach works, but I'm wondering if there are more efficient alternatives. For example, the above figure was generated in about 3 seconds, so maybe a graphical-based strategy could be better.

In the following code, I compare the point on the first curve corresponding to parameter $t=0$ to the closest point of each other curve. Note: if different curves may intersect in multiple points (e.g. curves red and yellow), the probability that they intersect at a specified location (here, the point of curve 1 for $t=0$) is extremely small.

Table[With[{pt0 = data[[1, 1]] /. t -> 0, fun = data[[i, 1]], 
tmin = data[[i, 2, 1]], tmax = data[[i, 2, 2]]},
NMinimize[{Norm[pt0 - fun], tmin < t < tmax}, t][[1]]], {i, Length@data}] // Chop

 (* {0, 0, 0, 0.883892, 0.883892, 3.17593, 2.97059, 0, 0, 0.883892, 0, 2.58457,
  0.883892, 2.97059, 2.58457, 2.58457, 2.58457, 0, 2.97059, 3.17593, 0,
  3.17593, 0.883892, 1.59063, 3.17593, 2.97059,  0.883892, 3.17593, 0, 3.17593} *)

Answer 1

The question describes the curves defined by triplets of InterpolatingFunctions as either largely overlapping or well separated in space, and the five curves provided in the file available for download certainly have this character. This suggests the following approach. Define

compare[n1_, n2_] := Module[{t1 = Max[data[[n1, 2, 1]], data[[n2, 2, 1]]], 
    t2 = Min[data[[n1, 2, 2]], data[[n2, 2, 2]]]}, 
    Mean@Table[Norm[data[[n1, 1]] - data[[n2, 1]]] /. t -> t0, {t0, t1, t2, (t2 - t1)/10}]]

which measures the distance between curves over their overlapping parameter ranges. Applying this function pairwise to the five curves yields

Table[compare[n1, n2], {n1, 5}, {n2, 5}] 

(* {{0, 1.07761, 2.16842, 31.53, 31.508}, 
    {1.07761, 0, 1.0965, 31.5188, 31.5321}, 
    {2.16842, 1.0965, 0, 31.5043, 31.5018}, 
    {31.53, 31.5188, 31.5043, 0, 0.485946}, 
    {31.508, 31.5321, 31.5018, 0.485946, 0}} *)

This approach effectively distinguishes among two groups of curves, the first three and the last two. Of course, if the actual set of curves to be sorted contains curves that are neither close nor far apart, then this approach may not work as well.

Although the Table above entails 25 calls to compare, five would have sufficed. For large sets of curves, overlapping curves would be eliminated as they were identified. At worst, the number of calls would be n(n-1)/2, if no curves largely overlapped. At best, the number of calls would be n-1, if all curves largely overlapped.

Answer 2

The following approach works, seems quite efficient, but relies on the assumption that the curves do not pass "too close" from each other; in particular, they should not intersect. It is not conservative, because if two different curves intersect, one of them will be lost. But this approach works in any dimension.

The idea is to take 100 points (actually, 101...) of each curve and compute the minimal distance between the two lists with DistanceMatrix. If it is smaller than a given threshold (here, 0.001), then the curves are considered identical (returns True).

areSolsEqualQ[sol1_, sol2_] := 
 Block[{tab1, tab2, domain1 = sol1[[1]]["Domain"] // Flatten, 
   domain2 = sol2[[1]]["Domain"] // Flatten},
  tab1 = Table[
    Through[sol1[t]], {t, Subdivide[domain1[[1]], domain1[[2]], 100]}];
  tab2 = Table[
    Through[sol2[t]], {t, Subdivide[domain2[[1]], domain2[[2]], 100]}];
  min = Min[DistanceMatrix[tab1, tab2]];
  If[min < 0.001, True, False]]

This comparison function can then be used with Union using the SameTest method:

Union[data, SameTest -> (areSolsEqualQ[#1, #2] &)]