5
$\begingroup$

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

enter image description here

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} *)
Improve this question
$\endgroup$
14
  • $\begingroup$ The two curves have different domains of definition. If so, your "duplicate" condition is that they should be "coincident" (which should then be defined as appropriate) at the intersection of the two domains; did I understand your requirement correctly? $\endgroup$ – J. M.'s ennui♦ Oct 4 '16 at 22:03
  • $\begingroup$ How about evaluating them at a set of random points? $\endgroup$ – mikado Oct 4 '16 at 22:03
  • $\begingroup$ @J.M. Absolutely. We could say that if half of a curve is part of the other, then only the other should be conserved, for example. $\endgroup$ – anderstood Oct 4 '16 at 22:03
  • $\begingroup$ @mikado Their parametrizations are different, so that's not so easy: for $t=0$ you could get $(0,0,0)$ for one curve and $(1,2,3)$ for another, even if both curves are the same (= they carry the same information). $\endgroup$ – anderstood Oct 4 '16 at 22:06
  • $\begingroup$ Although I could not load Mathematica.m with data = Get["https..., as in the question, I was able to download the 8 MB file directly to disk. Unfortunately, Mathematica 11.0.1 has been struggling for over 45 minutes to load the code. Therefore, I suggest that you provide a notebook file with say, ten InterpolatingFunctions that illustrate the issues involved with your question. $\endgroup$ – bbgodfrey Oct 5 '16 at 0:52
2
$\begingroup$

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.

Improve this answer
$\endgroup$
5
  • $\begingroup$ The main problem with this approach is that if there are two (or more) parametrizations of the same curve which are very different, it may fail. For example if $f$ and $g$ have the same graph but $f(t)=g(t+50)$. I'll try on larger sets to see if this suffices for my case. Thank you. $\endgroup$ – anderstood Oct 5 '16 at 4:49
  • $\begingroup$ @anderstood If parameter offset is a major issue, it can be accommodated by doing the comparison with a range of offsets and finding the one, if any, for which compare is small. If parameter dilatation is the issue instead, then different dilations can be tried in the same way, although the cost of doing so could be high. Without have more information on the curves, I would suggest first eliminating duplicates as I did in my answer, then running a second pass eliminating similar curves with offset parameters, and finally eliminating similar curves with dilated parameters. $\endgroup$ – bbgodfrey Oct 5 '16 at 12:26
  • $\begingroup$ @anderstood A more robust but potentially much more expensive approach would be to find the minimum distance between a point on one curve and the entire second curve, Then, if it is small, do the same for several more points. If all are small, a match can be assumed. I recommend that you create a file of many typical curves, each defined much more coarsely, so that I and others have something to work with. For now, all I can add is that my solution solves the problem as embodied in the sample curves provided. $\endgroup$ – bbgodfrey Oct 5 '16 at 12:37
  • $\begingroup$ @anderstood, is it possible for "non-duplicate" curves to intersect in more than one point, without coinciding? $\endgroup$ – J. M.'s ennui♦ Oct 5 '16 at 13:15
  • $\begingroup$ @J.M. They could have more than two intersections, but this almost never happens if you don't precisely look for an intersection (if you choose a point on a curve and another curve passes through this point, then both curves are the same). That's the approach I used in my edit. $\endgroup$ – anderstood Oct 5 '16 at 16:02
0
$\begingroup$

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] &)]
Improve this answer
$\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.