1
$\begingroup$

I am finding the following minimum

FindMinimum[{
Abs[
ArgMax[f[q, n, b, b0, b1, t, s], b] - b1
]
}, {b1, -0.5}]

given q=3/5, b0=1, t=3/2, s=1 and obtain the following graph for n = {5,...,25}:

enter image description here

My question is about the values at 13, 16, and 24. Why am I having these irregular and apparently wrong values and is there a way to get rid of this problem? Is this a problem of precision? Also, is it possible to make this computation faster?

Update Upon requests in comments, I give the definitions here. Function f is

f[q_, n_, b_, b0_, b1_, t_, s_] := Sum[(Binomial[n - 1, k]*t^(n - 1 - k)/(1 + t)^(n - 1)*g[q, n, b, k*b0 + (n - 1 - k)*b1, s]), {k, 0, n - 1}]

where function g is

g[q_, n_, b_, B_, s_] = (q*(Probability[x + b + B + 1/2 s^2 Log[q/(1 - q)] > 0, 
 x \[Distributed] NormalDistribution[n, s*n^(1/2)]]) + (1 -
  q)*(Probability[x + b + B + 1/2 s^2 Log[q/(1 - q)] < 0, 
 x \[Distributed] NormalDistribution[-n, s*n^(1/2)]]))

Here is the plotting procedure, to make it easy for your replication. I set the function:

bb[q_, n_, b0_, t_, s_]:=b1/.Last[FindMinimum[{Abs[ArgMax[f[q,n,b,b0,b1,t,s],b]-b1]},{b1,-0.5}]]

and then plot with

DiscretePlot[bb[3/5,m,1,3/2,1],{m,5,25}]

In place of FindMinimum I used FindRoot as in

FindRoot[ArgMax[f[q,n,b,b0,b1,t,s],b]-b1==0,{b1,-0.5}]

and also, in another try, I got replaced Abs with conditions as in

FindMinimum[{ArgMax[f[q,n,b,b0,b1,t,s],b]-b1,ArgMax[f[q,n,b,b0,b1,t,s],b]-b1>0},{b1,-0.5}]

both of which did not help.

Finally, to show another proof that the problem with this deterministic computation is totally random, I present here one more plot, where I replace 1 with 1.0001 for parameter s.

Here is when s=1.0001

enter image description here

$\endgroup$
  • $\begingroup$ Could you explain "an expected normal probability of binomial values" further? $\endgroup$ – Dr. belisarius Feb 16 '16 at 15:06
  • $\begingroup$ @Dr.belisarius It is actually Sum[(Binomial[n - 1, k]*t^(n - 1 - k)/(1 + t)^(n - 1)*g[q, n, b, k*b0 + (n - 1 - k)*b1, s]), {k, 0, n - 1}] where the function g is really an error function (normal probability). $\endgroup$ – juror Feb 16 '16 at 15:13
  • 1
    $\begingroup$ edit the question to include the definition of f and g $\endgroup$ – george2079 Feb 16 '16 at 16:22
  • $\begingroup$ Please don't change the tags ... again $\endgroup$ – Dr. belisarius Feb 16 '16 at 16:27
  • $\begingroup$ @Dr.belisarius Ok. $\endgroup$ – juror Feb 16 '16 at 16:29
4
$\begingroup$

There are a few ways to improve on this situation. SOme involve making these functions into "black boxes" that only work for explicit numeric input. That removes all symbolic preprocessing, along with warning messages that get produced there. Another is to force use of a the interior point method. This can be done by adding a constraint e.g. b1<=0. Or use Newton's method; that also seems to give a viable result.

For either of the above there is an important subtlety. They like differentiable functions. We have an Abs defining the objective function. Since it is a discrepancy we are measuring, we can just as well use the square of the value. In here lurks another subtlety: we want the squaring to be explicitly seen in FindMinimum and not part of the black-box function.

Also it seems like a good idea to use the numeric arg-max since it will be faster. The reson is that "exact" ArgMax will punt to NMinimize when given approximate input, whereas NArgMax will invoke the typically faster FindMaximum.

So here is the code.

q = 3/5;
b0 = 1;
t = 3/2;
s = 1.0001;

f[q_, n_?NumberQ, b_, b0_, b1_, t_, s_] := 
 Sum[(Binomial[n - 1, k]*t^(n - 1 - k)/(1 + t)^(n - 1)*
    g1[q, n, b, k*b0 + (n - 1 - k)*b1, s]), {k, 0, n - 1}]

g[q_, n_, b_, B_, 
   s_] = (q*(Probability[x + b + B + 1/2 s^2 Log[q/(1 - q)] > 0, 
       x \[Distributed] NormalDistribution[n, s*n^(1/2)]]) + (1 - 
       q)*(Probability[x + b + B + 1/2 s^2 Log[q/(1 - q)] < 0, 
       x \[Distributed] NormalDistribution[-n, s*n^(1/2)]]));

g1[q_, n_?NumberQ, b_, B_, s_] := g[q, n, b, B, s]

argmaxfN[q_, n_?NumberQ, b_, b0_, b1_?NumberQ, t_, 
  s_] := (NArgMax[f[q, n, b, b0, b1, t, s], b] - b1)

So here goes.

AbsoluteTiming[
 res = Table[
    FindMinimum[argmaxfN[q, n, b, b0, b1, t, s]^2, {b1, -0.5}, 
     Method -> "Newton"], {n, 5, 25}];]

<a few warnings snipped>

(* Out[108]= {53.415487, Null} *)

ListPlot[b1 /. res[[All, 2]]]

enter image description here

As noted earlier, one can force usage of interior point code by adding a constraint.

AbsoluteTiming[
 res = Table[
    FindMinimum[{argmaxfN[q, n, b, b0, b1, t, s]^2, 
      b1 <= 0}, {b1, -0.5}], {n, 5, 25}];]

During evaluation of In[110]:= NArgMax::cvmit: Failed to converge to the requested accuracy or precision within 100 iterations. >>

During evaluation of In[110]:= NArgMax::cvmit: Failed to converge to the requested accuracy or precision within 100 iterations. >>

During evaluation of In[110]:= NArgMax::cvmit: Failed to converge to the requested accuracy or precision within 100 iterations. >>

During evaluation of In[110]:= General::stop: Further output of NArgMax::cvmit will be suppressed during this calculation. >>

(* Out[110]= {54.747887, Null} *)

The plot is pretty much the same as before, so I omit it.

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