2
$\begingroup$

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:

enter image description here

I wonder about two things:

  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[[1]] == f[[2]], {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?
$\endgroup$
  • $\begingroup$ 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" $\endgroup$ – Bill Jun 27 at 15:39
  • 1
    $\begingroup$ 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[[1]]==Rationalize[f[[2]]],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[[1]] == f[[2]] == f[[3]] == f[[4]] == f[[5]], x]. $\endgroup$ – MassDefect Jun 27 at 15:39
3
$\begingroup$
  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][[1]] &]
    (*    lots of output    *)
    
$\endgroup$
1
$\begingroup$

[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[451]= {0.0031283957326, {x -> 1.03846218702}} *)
$\endgroup$
1
$\begingroup$
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][[1]] & /@ (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} *)
$\endgroup$
1
$\begingroup$

A purely graphical approach for intersections:

Graphics`Mesh`MeshInit[];

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

intersections = DeleteDuplicatesBy[Round[#, 10^-3]&] @ 
   Graphics`Mesh`FindIntersections[plot[[1]]];

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

Show[plot, listplot, ImageSize -> Large]

enter image description here

$\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.