The easiest way most likely depends on the nature of the function. The function referred to in a comment by the OP seems to be like one in another post that it is concave down. The solution in such a case is quite simple and would consist at most of one interval. However, if the interval is to be $[-2,2]$, then it is not exactly that function. An oscillatory function is quite different, and the easy solution to a concave/convex function would probably not solve the oscillatory case.
Dealing with the more general case, then, I can think of two "easiest" solutions. One involving NDSolve
is likely to be quite robust. The other uses Plot
, may be less robust, but is likely to be faster. For highly oscillatory functions, some tweaking of the number of PlotPoints
might be required. (An extremely oscillatory function is likely to require some manual adjustment in all cases, anyway.) Both methods assume that the function is continuous over the interval. A discontinuous function may be handled by applying the methods here to the intervals over which the function is continuous.
NDSolve
method
higher[f_, k_, {a_, b_}] :=
Module[{ifun, in, s, t, x1},
Reap[
NDSolve[{ifun[t] == f[t],
in[a] == Boole[f[a] > k], x1[a] == a,
s'[t] == 1, s[a] == a,
WhenEvent[f[t] > k, {in[t] -> 1, x1[t] -> t}],
WhenEvent[f[t] < k, If[in[t] == 1, Sow[{x1[t], t}, Interval]]; {in[t] -> 0}]},
ifun, {t, a, b}, DiscreteVariables -> {in, x1}],
Interval][[2, 1]]
]
[Note: I may have found a bug using Reap
with NDSolve
. I had to use a tag with Sow
/Reap
here, because extra data was sown. I chose Interval
for the tag; anything would have done.]
Plot
/zero-crossings method
I used Mr.Wizard's adaptation of David Carraher's zero-crossings function, which can be found here: Find zero crossing in a list.
davidZC2[l_] := SparseArray[#]["AdjacencyLists"] & /.
SApos_ :> With[{c = SApos[l]}, {c[[#]], c[[# + 1]]}\[Transpose] &@
SApos@Differences@Sign@l[[c]]]
higher2[f_, k_, {a_, b_}] :=
(plot = Plot[f[s], {s, a, b}, PlotRange -> All];
With[{xy = First@Cases[plot, Line[p_] :> p, Infinity]},
Partition[
Join[
If[f[a] > k, {a}, {}],
Block[{s},
s /. FindRoot[
f[s] == k,
{s, Mean[xy[[#, 1]]], Sequence @@ xy[[#, 1]]}
] & /@ davidZC2[xy[[All, 2]] - k]
],
If[f[b] > k, {b}, {}]
],
2]])
(The plot
is stored in a global variable for inspection in case the result seems questionable.)
Examples
From Why `FindMaximum` doesn't work in my example:
n = 200000;
k = 2 n - 50;
μ = 10^-5;
ν = 10^-5;
qhat = k/(2 n);
Clear[fun];
fun[s_?NumericQ] := Log[(E^(4 n qhat s) (1 - qhat)^(-1 + 4 n μ) qhat^(-1 + 4 n ν))/
NIntegrate[E^(4 n qhat s) (1 - qhat)^(-1 + 4 n μ) qhat^(-1 + 4 n ν),
{qhat, 1/(4 n + 1), 1 - 1/(4 n + 1)},
MaxRecursion -> 12]]
higher[fun, 0.1, {0, 2}]
(* {{0.0109522, 0.266125}} *)
higher2[fun, 0.1, {0, 2}]
(* {{0.0109522, 0.266125}} *)
Random example:
g[x_?NumericQ] := NIntegrate[x Sin[20 t] Exp[-t^3], {t, 0, x}];
higher2[g, 0.05, {-2, 2}]
Show[plot, PlotRange -> {{-2, 2}, {0.05, .1}}, Frame -> True]
(*
{{-1.93866, -1.78522}, {-1.6299, -1.48044}, {-1.31331, -1.18644},
{-0.963237, -0.923499}, {0.738644, 0.853318}, {1.02542, 2}}
*)

{x, a, b}
or over all real numbersx
? $\endgroup$ – Michael E2 Jan 21 '15 at 21:43Reduce[-x^3 + 3 x^2 - 2 x + 5 > 48/10, x]
works on the sample function...but I'm not sure what kind of difficult functions you have in mind. Would numerical approximations be satisfactory, or do you desire symbolic solutions? $\endgroup$ – Michael E2 Jan 21 '15 at 21:45Log[(E^(4 n qhat s) (1 - qhat)^(-1 + 4 n \[Mu]) qhat^(-1 + 4 n \[Nu]))/ NIntegrate[ E^(4 n qhat s) (1 - qhat)^(-1 + 4 n \[Mu]) qhat^(-1 + 4 n \[Nu]), {qhat, 1/(4 n + 1), 1 - 1/(4 n + 1)}, MaxRecursion -> 12]]
. Thanks $\endgroup$ – Remi.b Jan 21 '15 at 21:50