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$
2
  • $\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 '20 at 10:36
  • $\begingroup$ Corrected it, thank you for pointing it out! $\endgroup$ May 28 '20 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]
$\endgroup$

This site is temporarily in read only mode and not accepting new answers.

Not the answer you're looking for? Browse other questions tagged .