# Sorting polynomials based on their y value and finding their intersection

I've got the following list of polynomials,

f=<|{"a", "b"} -> (2.88889 x + 158.568 x^2 + 972.426 x^3 +
2782.57 x^4 + 4689.15 x^5 + 6158.85 x^6 + 6193.35 x^7 +
4759.49 x^8 + 2828.1 x^9 + 1262.26 x^10 + 396.808 x^11 +
87.1035 x^12 + 15.9183 x^13 + 2.35827 x^14)/(2 x + 142 x^2 +
994 x^3 + 3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14), {"a",
"c"} -> (1.92593 x + 154.859 x^2 + 1000.11 x^3 + 2910.7 x^4 +
4824.12 x^5 + 6433.15 x^6 + 6287.79 x^7 + 4729.91 x^8 +
2616.64 x^9 + 1072.34 x^10 + 300.412 x^11 + 66.1224 x^12 +
9.79591 x^13 + 1.17914 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14), {"a",
"d"} -> (4.81481 x + 154.859 x^2 + 992.071 x^3 + 2876.3 x^4 +
4856.42 x^5 + 6212.28 x^6 + 6143.44 x^7 + 4685.55 x^8 +
2780.4 x^9 + 1173.81 x^10 + 376.34 x^11 + 87.7393 x^12 +
12.2449 x^13 + 1.76871 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14), {"a",
"e"} -> (1.92593 x + 154.859 x^2 + 1177.81 x^3 + 3305.38 x^4 +
5174.38 x^5 + 6568.7 x^6 + 6234.04 x^7 + 4385.35 x^8 +
2365.3 x^9 + 900.93 x^10 + 255.515 x^11 + 41.9623 x^12 +
6.12244 x^13 + 1.17914 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14), {"a",
"f"} -> (2.88889 x + 143.731 x^2 + 946.531 x^3 + 2706.91 x^4 +
4601.38 x^5 + 6048.02 x^6 + 6250.93 x^7 + 4803.85 x^8 +
2905.71 x^9 + 1305.46 x^10 + 423.878 x^11 + 103.634 x^12 +
18.9796 x^13 + 1.76871 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 + 4 x^14)|>;


I can plot then using,

Plot[f, {x, 0, 1.5}, PlotRange -> All]


which gives: 1. It can be seen at some point around 1 on x axis the lines are intersected, how can I know where is this point of intersection exactly? I know one can use

FindRoot[f[] == f[], {x, 1}]

which gives:

{x -> 1.03846}


but we have more than one equation, in fact all of the intersect on above point but I want to know if there is a general way?

1. How can I sort the polynomials based on the highest value they have on y axis?
• Reduce[poly1==poly2&&x>1,x,Reals] for every pair of your polynomials and I look at the roots near 1 and I round off to six digits then I get {x == 1.038468, x == 1.038475, x == 1.038463, x == 1.038454, x == 1.038463, x == 1.038460, x == 1.038464, x == 1.038460, x == 1.038465, x == 1.038462} so it is going to be hard to get "this point of intersection exactly" – Bill Jun 27 '19 at 15:39
• If you use Rationalize to remove the decimals from the equations and then solve them 2 at a time, they don't actually meet at exactly the same point. Solve[{Rationalize[f[]==Rationalize[f[]],8/10 < x < 2}, x, Reals] gives 1.03846837 but eqs 2 and 3 give 1.03846251. Are they supposed to cross at precisely the same point? Or are you okay with just finding the x-value where there is the minimum difference? If they were precisely equal, you would be able to sue something like Solve[f[] == f[] == f[] == f[] == f[], x]. – MassDefect Jun 27 '19 at 15:39

1. A robust way of finding the best candidate for the intersection is to minimize the variance between the different curves:

Minimize[Variance[f], x]
(*    {3.06909*10^-14, {x -> 1.03846}}    *)

2. Sort the polynomials in f by their maximum (you may want to constrain the domain in which the maximum is searched):

SortBy[f, Maximize[#, x][] &]
(*    lots of output    *)


[This is basically the same as @Roman's answer but in different language.]

Could minimize the sum of squares of pairwise differences. I discarded the denominators after checking they were all identical.

polys = Numerator[Values[f]];
pdiffs = Union[Flatten[Outer[Subtract, polys, polys]]];
FindMinimum[pdiffs.pdiffs, {x, 1}]

(* Out= {0.0031283957326, {x -> 1.03846218702}} *)

Clear["Global*"]


Rationalize the polynomials

f = <|{"a",
"b"} -> (2.88889 x + 158.568 x^2 + 972.426 x^3 + 2782.57 x^4 +
4689.15 x^5 + 6158.85 x^6 + 6193.35 x^7 + 4759.49 x^8 +
2828.1 x^9 + 1262.26 x^10 + 396.808 x^11 + 87.1035 x^12 +
15.9183 x^13 + 2.35827 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14) //
Rationalize[#, 0] &, {"a",
"c"} -> (1.92593 x + 154.859 x^2 + 1000.11 x^3 + 2910.7 x^4 +
4824.12 x^5 + 6433.15 x^6 + 6287.79 x^7 + 4729.91 x^8 +
2616.64 x^9 + 1072.34 x^10 + 300.412 x^11 + 66.1224 x^12 +
9.79591 x^13 + 1.17914 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14) //
Rationalize[#, 0] &, {"a",
"d"} -> (4.81481 x + 154.859 x^2 + 992.071 x^3 + 2876.3 x^4 +
4856.42 x^5 + 6212.28 x^6 + 6143.44 x^7 + 4685.55 x^8 +
2780.4 x^9 + 1173.81 x^10 + 376.34 x^11 + 87.7393 x^12 +
12.2449 x^13 + 1.76871 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14) //
Rationalize[#, 0] &, {"a",
"e"} -> (1.92593 x + 154.859 x^2 + 1177.81 x^3 + 3305.38 x^4 +
5174.38 x^5 + 6568.7 x^6 + 6234.04 x^7 + 4385.35 x^8 +
2365.3 x^9 + 900.93 x^10 + 255.515 x^11 + 41.9623 x^12 +
6.12244 x^13 + 1.17914 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14) //
Rationalize[#, 0] &, {"a",
"f"} -> (2.88889 x + 143.731 x^2 + 946.531 x^3 + 2706.91 x^4 +
4601.38 x^5 + 6048.02 x^6 + 6250.93 x^7 + 4803.85 x^8 +
2905.71 x^9 + 1305.46 x^10 + 423.878 x^11 + 103.634 x^12 +
18.9796 x^13 + 1.76871 x^14)/(2 x + 142 x^2 + 994 x^3 +
3068 x^4 + 5440 x^5 + 7516 x^6 + 8061 x^7 + 6591 x^8 +
4215 x^9 + 2029 x^10 + 694 x^11 + 181 x^12 + 33 x^13 +
4 x^14) // Rationalize[#, 0] &|>;


Finding the pairwise intersections near x == 1

intersections =
NSolve[{#, 4/5 < x < 6/5}, x,
WorkingPrecision -> \$MachinePrecision][] & /@ (Equal @@@
Subsets[f[[#]] & /@ Range[Length[f]], {2}])

(* {{x -> 1.038468378686529}, {x -> 1.038474882506591}, {x ->
1.038463033375997}, {x -> 1.038454109438708}, {x ->
1.038462513865996}, {x -> 1.038459695030974}, {x ->
1.038463914367546}, {x -> 1.038460391885017}, {x ->
1.038464706661657}, {x -> 1.038461704012336}} *)


The intersections are in the interval

MinMax[x /. intersections]

(* {1.038454109438708, 1.038474882506591} *)


A purely graphical approach for intersections:

GraphicsMeshMeshInit[];

plot = Plot[Evaluate @ Values @ f, {x, 0, 1.5}, PlotLegends -> (ToString /@ Keys[f])];

intersections = DeleteDuplicatesBy[Round[#, 10^-3]&] @
GraphicsMeshFindIntersections[plot[]];

listplot = ListPlot[List /@ intersections, BaseStyle -> PointSize[Large],
PlotLegends -> (ToString[#, StandardForm] & /@ intersections)];

Show[plot, listplot, ImageSize -> Large]
` 