1
$\begingroup$

I'm trying to write this Mathematica function to find the optimal price for a model, given some model parameters. This is a stylized example of what I'm trying to do, and I'm wondering what's a better way to do it. The code below takes a while to run (at least on my computer).

U[x_?NumericQ, p_?NumericQ, a_?NumericQ] := 
 RegionMeasure[ImplicitRegion[ 
   (a*v - p - x >= 0 && 0 <= v <= 1 ) , {v}]]
q[p_?NumericQ, 
  a_?NumericQ] := (x /. 
   FindRoot[x - U[x, p, a] == 0, {x, 0.00001, 0, 1}])
Purchase[p_, a_] := RegionMeasure[ImplicitRegion[ 
   {(a*v - p - x >= 0  && 0 <= v <= 1) /. {x -> q[p, a]}} // 
    Evaluate , {v}]]
bestPrice[a_] := 
 p /. Last[NMaximize[{p*Purchase[p, a], 0 <= p <= a}, p]] 

bestPrice[2]

Is there a faster optimization function for this problem then NMaximize? The Purchase[] function measures the total demand for the model, and the bestPrice[] function figures out the optimal price to maximize the profit, given the model parameter 'a'. In the full model I have, there is more than one model parameter and several conditions within the Purchase[] function and U[] function, so I'm wondering how I can make this simple example go faster. If you have any ideas, please let me know. Thanks in advacnce!

$\endgroup$
1
  • 1
    $\begingroup$ Could you write out the optimization problem more explicitly in LaTeX or give a diagram? There might be a linear programming solution. $\endgroup$
    – flinty
    Jul 3 at 10:55
2
$\begingroup$

I think nothing will beat

 bestPrice[a_] := a/2;

Why do I believe that this is true? Well, first I observed that

U[x_, p_, a_] := 1 - Clip[(x + p)/a, {0, 1}]

Now

Simplify[Solve[x - U[x, p, a] == 0, x], {a >= p >= 0}]

returns

{{x -> Undefined}, {x -> Undefined}, {x -> ConditionalExpression[(a - p)/(1 + a), a > p && p > 0]}}

wich makes me believe that

q[p_, a_] := (a - p)/(1 + a)

Substituted, we deduce that

Purchase[p_, a_] := 1 - Clip[(1 + p)/(1 + a), {0, 1}];

and because of 0 <= p <= a, (1 + p)/(1 + a) is always between 0 and 1, hence

Purchase[p_, a_] := 1 - (1 + p)/(1 + a);

So the objective is actually the function

f[p_] := p (1 - (1 + p)/(1 + a))

and

Solve[f'[p] == 0, p]

yields

{{p -> a/2}}

Moreover, f''[p] equals -(2/(1 + a)) which must be negative. So f is a downward pointing parabola and its unique critical point $a/2$ lies in the interior of the interval $[0,a]$. Hence it must be the maximum.

$\endgroup$
1
  • $\begingroup$ Thanks, but I wanted to figure this out numerically. This is a 'toy example' meant to illustrate the problem as simply as possible. In this case, it's possible to figure out the optimal solution quickly, but the actual problem involves many different sub-regions, conditions, cases, etc. $\endgroup$ Jul 3 at 18:38
1
$\begingroup$

We can reduce time by 6.66 times (on my computer) using Module instead of functions with ?NumericQ

price[a_] := 
 Module[{x, v, p}, 
  u = RegionMeasure[
    ImplicitRegion[(a*v - p - x >= 0 && 0 <= v <= 1), {v}]];
  Q = (x /. FindRoot[x - u == 0, {x, 0.00001, 0, 1}]);
  purchase = 
   RegionMeasure[
    ImplicitRegion[{(a*v - p - x >= 0 && 0 <= v <= 1) /. {x -> Q}} // 
      Evaluate, {v}]];
  bp = p /. Last[NMaximize[{p*purchase, 0 <= p <= a}, p]]; bp]

price[2] // AbsoluteTiming

Out[]= {7.50122, 1.}
$\endgroup$
1
  • $\begingroup$ Ah, thanks! That speeds it up quite a bit. $\endgroup$ Jul 3 at 15:58

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.