Forget about it. Change the test a bit more (a PolynomialQ
test is missing yet) and drop the degree condition
In[112]:= Clear[mrbQHumble]
mrbQHumble[x_?NumericQ] :=
Block[{a1 = CoefficientList[First[RootApproximant[x]][y], y],
a2 = CoefficientList[First[RootApproximant[1/x]][y], y]},
If[Length[a1] == Length[a2] && FreeQ[a1, y] &&
FreeQ[a2, y], (a1 == Reverse[a2]) || (a1 == -Reverse[a2]),
Missing[]]
]
In[114]:= l0 = RandomReal[{-19, 53}, 100]
Out[114]= {-1.38507, 49.4481, 24.7934, 11.0104, 3.86794, 7.93207, \
48.0579, -9.44529, 48.7661, -14.129, -14.7824, -6.62547, 40.7146, \
-9.87912, -11.0193, 23.8705, -13.5526, 2.14101, 4.57075, -10.0782, \
-3.5094, -5.45227, 30.0554, 39.6618, 3.95229, 13.3368, 43.1726, \
25.5232, 4.30698, -9.89652, 25.0371, 44.8908, 31.7411, -10.7786, \
42.8577, 39.8379, -12.9649, -10.6592, -0.0523882, 24.5372, 52.9216, \
-12.2468, 27.3211, 25.072, -10.8939, 21.1145, -14.224, 52.6378, \
-12.6092, -4.91945, 52.327, 24.0178, 9.16044, 52.1168, 31.1463, \
16.357, 13.9551, 31.295, -8.99637, 43.5836, -14.6001, 34.3883, \
30.7991, 17.0297, -18.3356, -4.35444, 4.17391, 38.1627, 6.66596, \
28.9392, 51.549, -6.69014, 14.7294, -3.10411, 21.2488, 13.6281, \
5.75214, 1.00631, 44.6239, 22.1666, 39.5046, 47.7347, 26.2585, \
52.7089, 50.2851, 13.368, -5.99931, 31.8238, 5.17775, 24.6661, \
9.58021, 19.6149, 7.77517, -6.62582, 16.2579, 46.4658, 15.8527, \
52.8861, -8.88976, 10.9706}
In[115]:= And @@ DeleteMissing[mrbQHumble /@ l0]
During evaluation of In[115]:= First::normal: Nonatomic expression expected at position 1 in First[7335/7289]. >>
During evaluation of In[115]:= First::normal: Nonatomic expression expected at position 1 in First[7289/7335]. >>
Out[115]= False
and the wrong-doer is
In[118]:= RootApproximant[1/l0[[61]]]
Out[118]= Root[-7 - 102 #1 - 2 #1^2 - 72 #1^3 + 4 #1^4 + 65 #1^5 + 44 #1^6 &, 1]
In[119]:= RootApproximant[l0[[61]]]
Out[119]= Root[57 + 118 #1 - #1^2 + 139 #1^3 - 43 #1^4 + 11 #1^5 + #1^6 &, 1]
In[120]:= l0[[61]]
Out[120]= -14.6001