1
$\begingroup$

In the following MWE, NArgMax finds the correct argmax (br1) as a function of the parameter p2 for most values of p2, but not close to zero. Instead, a vertical line is plotted. NArgMax gives a constant value to br1 for p2 close to 0.

To confirm the wrongness of the solution, in the 3D plot, the objective function to maximize is smooth and its max at different p2 reaches the origin. Thus the argmax and the maximized value should reach the origin, which can be proved theoretically as well.

No breakpoints of the Piecewise part of the objective function are where NArgMax kinks into the wrong solution. Trace shows a correct derivation until the last step. After that a value of p1 is selected that makes the objective zero, but a positive objective is attainable at small positive p1, which should be the max.

Clear[d1, q1, pi1, p1, p2, γ, br1, pi1opt, plot1, plot3]
$Assumptions = 
  0 < q1 < q2 && 0 <= p1 < p2 && 
   0 <= p2 < q2 && (p2 - p1)*q1 >= p1*(q2 - q1) && p1 < q1 && 
   0 < γ < 1;
cdf[v_] = 
  Piecewise[{{0, v < 0}, {v^2/γ, 
         0 <= v < γ}, {1 - (1 - v)^2/(1 - γ), γ <= 
  v <= 1}, {1, v > 1}}];
d1[p1_, p2_, q1_, q2_] = Max[0, cdf[(p2 - p1)/(q2 - q1)] - cdf[p1/q1]];
pi1[p1_, p2_, q1_, q2_] = p1*d1[p1, p2, q1, q2];
γ = 0.1; q1 = 1; q2 = 1.2;
br1[p2_] = br1[p2_?NumericQ] := NArgMax[pi1[p1, p2, q1, q2], p1]
{br1[0.001], br1[0.01], br1[0.1]}
pi1opt[p2_] = 
 pi1opt[p2_?NumericQ] := NMaxValue[pi1[p1, p2, q1, q2], p1]
plot1 = Plot3D[{pi1[p1, p2, q1, q2]}, {p1, 0, q1}, {p2, 0, q2}, 
RegionFunction -> Function[{p1, p2, z}, p1 < p2], 
AxesLabel -> {Subscript[P, 1], Subscript[P, 2]}, 
PlotStyle -> Opacity[0.5]];
plot3 = ParametricPlot3D[{br1[p2], p2, pi1opt[p2]}, {p2, 0, q2}, 
AxesLabel -> {Subscript[P, 1], Subscript[P, 2], Subscript[π, 
 1]}, PlotStyle -> {Thick, Orange, Dashed}];
Show[plot1, plot3]
Plot[br1[p2], {p2, 0, q2}, AxesOrigin -> {0, 0}]

How to make NArgMax find the correct maximum at all points?

Using ArgMax instead of NArgMax with the same numerical parameters, the Plot is empty and the Plot3D is missing the dotted line denoting the maximum.

$\endgroup$
  • $\begingroup$ Your code doesn't run - I get Plot3D::plln: Limiting value c1 in {p1,c1,1} is not a machine-sized real number. $\endgroup$ – flinty May 28 at 10:36
  • $\begingroup$ Corrected it, thank you for pointing it out! $\endgroup$ – Sander Heinsalu May 28 at 11:21
1
$\begingroup$

Adding constraints to rule out the wrong answer of NArgMax fixes the problem. Now NArgMax finds the correct solution. Code below. The cause of the problem is still unknown.

Clear[d1, d2, q1, q2, pi1, pi2, p1br, p2br, df, c1, c2, p1, p2, \
α, β, γ, br1, br2, pi1opt, pi2opt, plot1, plot2, \
plot3, plot4, plot5, refl4, constraints]
constraints = 
  0 < q1 < q2 && 0 <= c1 <= c2 && c1 <= p1 < p2 && 
   c2 <= p2 < β*q2 && (p2 - p1)*q1 >= p1*(q2 - q1) && 
   p1 < q1*β && 0 <= α < γ < β;
$Assumptions = constraints;
cdf[v_] = 
  Piecewise[{{0, 
 v < α}, {(v - α)^2/((β - α)*(γ \
- α)), α <= 
      v < γ}, {1 - (β - 
          v)^2/((β - α)*(β - γ)), γ \
<= v <= β}, {1, v > β}}];
d1[p1_, p2_, q1_, q2_] = Max[0, cdf[(p2 - p1)/(q2 - q1)] - cdf[p1/q1]];
d2[p1_, p2_, q1_, q2_] = 1 - cdf[Max[p2/q2, (p2 - p1)/(q2 - q1)]];
pi1[p1_, p2_, q1_, q2_] = (p1 - c1)*d1[p1, p2, q1, q2];
pi2[p1_, p2_, q1_, q2_] = (p2 - c2)*d2[p1, p2, q1, q2];
(*Parameter values specified numerically. Use 1., 0., etc to force \
floating point numbers instead of symbolic. *)
α = 0.; β \
= 1.; γ = 0.8; q1 = 1.; q2 = 1.2; c1 = 0.; c2 = 0.;
br1[p2_] = 
 br1[p2_?NumericQ] := NArgMax[{pi1[p1, p2, q1, q2], constraints}, p1]
br2[p1_] = 
 br2[p1_?NumericQ] := NArgMax[{pi2[p1, p2, q1, q2], constraints}, p2]
pi1opt[p2_] = 
 pi1opt[p2_?NumericQ] := 
  NMaxValue[{pi1[p1, p2, q1, q2], constraints}, p1]
pi2opt[p1_] = 
 pi2opt[p1_?NumericQ] := 
  NMaxValue[{pi2[p1, p2, q1, q2], constraints}, p2]
(*{br1[0.01],pi1opt[0.01]}*)(*Test whether br1 exists at low p1. *)

plot1 = Plot3D[{pi1[p1, p2, q1, q2], pi2[p1, p2, q1, q2]}, {p1, 
    c1, β*q1}, {p2, c2, β*q2}, 
   RegionFunction -> Function[{p1, p2, z}, p1 < p2], 
   AxesLabel -> {Subscript[P, 1], Subscript[P, 2]}, 
   PlotStyle -> Opacity[0.5]];
plot2 = ParametricPlot3D[{p1, br2[p1], pi2opt[p1]}, {p1, 
    c1, β*q1}
   , AxesLabel -> {Subscript[P, 1], Subscript[P, 2], Subscript[π, 
     2]}, PlotStyle -> {Thick, Blue, Dashed}];
plot3 = ParametricPlot3D[{br1[p2], p2, pi1opt[p2]}, {p2, 
  c2, β*q2}, 
  AxesLabel -> {Subscript[P, 1], Subscript[P, 2], Subscript[π, 
  1]}, PlotStyle -> {Thick, Orange, Dashed}];
Show[plot1, plot2, plot3]
plot4 = Plot[br1[p2], {p2, c2, β*q2}, AxesOrigin -> {0, 0}];
plot5 = Plot[br2[p1], {p1, c1, β*q1}, PlotStyle -> Blue, 
   AxesLabel -> {Subscript[P, 1], Subscript[P, 2]}, 
   AxesOrigin -> {0, 0}];
refl4 = plot4 /. 
   line_Line :> {Orange, 
     GeometricTransformation[line, ReflectionTransform[{-1, 1}]]};
Show[plot5, refl4, PlotRange -> All, ImageSize -> 300]
| improve this answer | |
$\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.