1
$\begingroup$

I have this code that generates an Edgeworth both with two optimum points. The optimal points change as I move the slider. I would like to plot/trace the change in the optimal so that at the end I can see in a graph how the optimum moved with the change in slider's value. Anyone can help please? Here is my code:

sigma = 1.5;
a11 = 0.4;
a21 = 0.6;
a12 = 0.4;
a22 = 0.6;
t12 = 1;
t21 = 1;
u1 = Function[{xa1, 
    xa2}, (a11^(1/sigma)*xa1^((sigma - 1)/sigma) + 
      a21^(1/sigma)*xa2^((sigma - 1)/sigma))^(sigma/(sigma - 1))];
u2 = Function[{xb1, 
    xb2}, (a12^(1/sigma)*xb1^((sigma - 1)/sigma) + 
      a22^(1/sigma)*xb2^((sigma - 1)/sigma))^(sigma/(sigma - 1))];
SetOptions[ContourPlot, 
 ContourShading -> None]; SetOptions[RegionPlot, PlotStyle -> None, 
 Mesh -> Full, BoundaryStyle -> Directive[Black, Thick]];
ICmap = Show[
   ContourPlot[{u1[xa1, xa2]}, {xa1, 0, 1}, {xa2, 0, 1}, 
    ContourStyle -> Table[Directive[Red, Opacity[i/10]], {i, 10}]], 
   ContourPlot[{u2[1 - xa1, 1 - xa2]}, {xa1, 0, 1}, {xa2, 0, 1}, 
    ContourStyle -> Table[Directive[Blue, Opacity[i/10]], {i, 10}]], 
   Graphics[{Dashed, Opacity[.2], Line[{{0, 0}, {1, 1}}]}]];
InvTicks = Table[{.2 (i - 1), 1 - .2 (i - 1)}, {i, 6}];

Manipulate[
 uMax = {ArgMax[{u1[xa1, xa2], 
     And[xa1 + \[Rho]*t21*xa2 == e[[1]] + \[Rho]*e[[2]], 
      0 <= xa1 <= 1, 0 <= xa2 <= 1]}, {xa1, xa2}], 
   ArgMax[{u2[1 - xa1, 1 - xa2], 
     And[t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) == 
       1 - e[[1]] + \[Rho]*(1 - e[[2]]), 0 <= xa1 <= 1, 
      0 <= xa2 <= 1]}, {xa1, xa2}]};

 BudgetSets1 = {RegionPlot[
    xa1 + \[Rho]*t21*xa2 <= e[[1]] + \[Rho]*e[[2]], {xa1, 0, 1}, {xa2,
      0, 1}, MeshStyle -> Directive[Opacity[.07], Red]], 
   RegionPlot[
    xa1 + \[Rho]*t21*xa2 > e[[1]] + \[Rho]*e[[2]], {xa1, 0, 1}, {xa2, 
     0, 1}, MeshStyle -> Directive[Opacity[.05], Blue]]};

 BudgetSets2 = {RegionPlot[
    t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) <= 
     1 - e[[1]] + \[Rho]*(1 - e[[2]]), {xa1, 0, 1}, {xa2, 0, 1}, 
    MeshStyle -> Directive[Opacity[.07], Green]], 
   RegionPlot[
    t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) > 
     1 - e[[1]] + \[Rho]*(1 - e[[2]]), {xa1, 0, 1}, {xa2, 0, 1}, 
    MeshStyle -> Directive[Opacity[.05], Yellow]]};

 tangentICs = 
  ContourPlot[{u1[xa1, xa2] == u1 @@ uMax[[1]], 
    u2[1 - xa1, 1 - xa2] == u2 @@ (1 - uMax[[2]])}, {xa1, 0, 1}, {xa2,
     0, 1}, ContourStyle -> {Directive[Red, Thickness[.01], 
      Opacity[.7]], Directive[Blue, Thickness[.01], Opacity[.6]]}];

 optPoints = 
  Graphics[{PointSize[.025], {Red, (Point[uMax[[1]]])}, {Blue, (Point[
       uMax[[2]]])}}];
Show @@ {BudgetSets1, BudgetSets2, tangentICs, optPoints, 
   FrameTicks -> {{Automatic, InvTicks}, {Automatic, 
      InvTicks}}, \[CapitalDelta] = uMax[[2, 1]] - uMax[[1, 1]]; 
   FrameLabel -> 
    Which[\[CapitalDelta] < 
      0, {{None, "excess supply of y"}, {"excess demand for x", 
       None}}, \[CapitalDelta] > 
      0, {{None, "excess demand for y"}, {"excess supply of x", 
       None}}, \[CapitalDelta] == 
      0, {{None, "market clears"}, {"market clears", 
       None}}]}, {{\[Rho], 1}, 1/2, 2}, {{e, {3/4, 1/4}}, Locator}, 
 ContinuousAction -> False, ControlType -> VerticalSlider, 
 ControlPlacement -> Left]
$\endgroup$
2
$\begingroup$

Here's a quick implementation; not terribly elegant but gets the job done. I've added two checkboxes which allow the user to add a point to a trace line and then clear that line if desired. The revised code:

sigma = 1.5;
a11 = 0.4;
a21 = 0.6;
a12 = 0.4;
a22 = 0.6;
t12 = 1;
t21 = 1;
u1 = Function[{xa1, 
    xa2}, (a11^(1/sigma)*xa1^((sigma - 1)/sigma) + 
      a21^(1/sigma)*xa2^((sigma - 1)/sigma))^(sigma/(sigma - 1))];
u2 = Function[{xb1, 
    xb2}, (a12^(1/sigma)*xb1^((sigma - 1)/sigma) + 
      a22^(1/sigma)*xb2^((sigma - 1)/sigma))^(sigma/(sigma - 1))];
SetOptions[ContourPlot, 
 ContourShading -> None]; SetOptions[RegionPlot, PlotStyle -> None, 
 Mesh -> Full, BoundaryStyle -> Directive[Black, Thick]];
ICmap = Show[
   ContourPlot[{u1[xa1, xa2]}, {xa1, 0, 1}, {xa2, 0, 1}, 
    ContourStyle -> Table[Directive[Red, Opacity[i/10]], {i, 10}]], 
   ContourPlot[{u2[1 - xa1, 1 - xa2]}, {xa1, 0, 1}, {xa2, 0, 1}, 
    ContourStyle -> Table[Directive[Blue, Opacity[i/10]], {i, 10}]], 
   Graphics[{Dashed, Opacity[.2], Line[{{0, 0}, {1, 1}}]}]];
InvTicks = Table[{.2 (i - 1), 1 - .2 (i - 1)}, {i, 6}];

Manipulate[
 If[cleartrace == True, (cleartrace = False; trace = {};)];
 uMax = {ArgMax[{u1[xa1, xa2], 
     And[xa1 + \[Rho]*t21*xa2 == e[[1]] + \[Rho]*e[[2]], 
      0 <= xa1 <= 1, 0 <= xa2 <= 1]}, {xa1, xa2}], 
   ArgMax[{u2[1 - xa1, 1 - xa2], 
     And[t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) == 
       1 - e[[1]] + \[Rho]*(1 - e[[2]]), 0 <= xa1 <= 1, 
      0 <= xa2 <= 1]}, {xa1, xa2}]};
 (* Added here *)
 If[addpt == True, (addpt = False; AppendTo[trace, uMax[[1]]])];
 (* End add *)
 BudgetSets1 = {RegionPlot[
    xa1 + \[Rho]*t21*xa2 <= e[[1]] + \[Rho]*e[[2]], {xa1, 0, 1}, {xa2,
      0, 1}, MeshStyle -> Directive[Opacity[.07], Red]], 
   RegionPlot[
    xa1 + \[Rho]*t21*xa2 > e[[1]] + \[Rho]*e[[2]], {xa1, 0, 1}, {xa2, 
     0, 1}, MeshStyle -> Directive[Opacity[.05], Blue]]};
 BudgetSets2 = {RegionPlot[
    t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) <= 
     1 - e[[1]] + \[Rho]*(1 - e[[2]]), {xa1, 0, 1}, {xa2, 0, 1}, 
    MeshStyle -> Directive[Opacity[.07], Green]], 
   RegionPlot[
    t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) > 
     1 - e[[1]] + \[Rho]*(1 - e[[2]]), {xa1, 0, 1}, {xa2, 0, 1}, 
    MeshStyle -> Directive[Opacity[.05], Yellow]]};
 tangentICs = 
  ContourPlot[{u1[xa1, xa2] == u1 @@ uMax[[1]], 
    u2[1 - xa1, 1 - xa2] == u2 @@ (1 - uMax[[2]])}, {xa1, 0, 1}, {xa2,
     0, 1}, ContourStyle -> {Directive[Red, Thickness[.01], 
      Opacity[.7]], Directive[Blue, Thickness[.01], Opacity[.6]]}];
 optPoints = 
  Graphics[{PointSize[.025], {Red, (Point[uMax[[1]]])}, {Blue, (Point[
       uMax[[2]]])},(* Added here *) {Black, Dashed, Line@trace}}];
 Show @@ {BudgetSets1, BudgetSets2, tangentICs, optPoints, 
   FrameTicks -> {{Automatic, InvTicks}, {Automatic, 
      InvTicks}}, \[CapitalDelta] = uMax[[2, 1]] - uMax[[1, 1]];
   FrameLabel -> 
    Which[\[CapitalDelta] < 
      0, {{None, "excess supply of y"}, {"excess demand for x", 
       None}}, \[CapitalDelta] > 
      0, {{None, "excess demand for y"}, {"excess supply of x", 
       None}}, \[CapitalDelta] == 
      0, {{None, "market clears"}, {"market clears", 
       None}}]}, {{\[Rho], 1}, 1/2, 2}, {{e, {3/4, 1/4}}, 
  Locator}, {addpt, {True, False}, 
  ControlType -> Checkbox}, {{cleartrace, False}, {True, False}, 
  ControlType -> Checkbox}, ContinuousAction -> False, 
 ControlType -> VerticalSlider, ControlPlacement -> Left,
 (* Added here *) Initialization :> (trace = {};)]

...and sample output

enter image description here

| improve this answer | |
$\endgroup$
2
$\begingroup$

Here's my go. I use global variables, which is not quite the best way, but it works. If you change e then I erase the memory. I also took the liberty of taking all your definitions outside of the Manipulate block, because I find it more elegant.

sigma = 1.5;
a11 = 0.4;
a21 = 0.6;
a12 = 0.4;
a22 = 0.6;
t12 = 1;
t21 = 1;
u1 = Function[{xa1, 
    xa2}, (a11^(1/sigma)*xa1^((sigma - 1)/sigma) + 
      a21^(1/sigma)*xa2^((sigma - 1)/sigma))^(sigma/(sigma - 1))];
u2 = Function[{xb1, 
    xb2}, (a12^(1/sigma)*xb1^((sigma - 1)/sigma) + 
      a22^(1/sigma)*xb2^((sigma - 1)/sigma))^(sigma/(sigma - 1))];
SetOptions[ContourPlot, 
 ContourShading -> None]; SetOptions[RegionPlot, PlotStyle -> None, 
 Mesh -> Full, BoundaryStyle -> Directive[Black, Thick]];
ICmap = Show[
   ContourPlot[{u1[xa1, xa2]}, {xa1, 0, 1}, {xa2, 0, 1}, 
    ContourStyle -> Table[Directive[Red, Opacity[i/10]], {i, 10}]], 
   ContourPlot[{u2[1 - xa1, 1 - xa2]}, {xa1, 0, 1}, {xa2, 0, 1}, 
    ContourStyle -> Table[Directive[Blue, Opacity[i/10]], {i, 10}]], 
   Graphics[{Dashed, Opacity[.2], Line[{{0, 0}, {1, 1}}]}]];
InvTicks = Table[{.2 (i - 1), 1 - .2 (i - 1)}, {i, 6}];
\[Rho]List = {};
uList = {};
globale = {3/4, 1/4};
uMax[e_, \[Rho]_] := uMax[e, \[Rho]] = Module[{result},
    If[Thread[e != globale], \[Rho]List = {}; uList = {}; globale = e];
    result = {ArgMax[{u1[xa1, xa2], 
        And[xa1 + \[Rho]*t21*xa2 == e[[1]] + \[Rho]*e[[2]], 
         0 <= xa1 <= 1, 0 <= xa2 <= 1]}, {xa1, xa2}], 
      ArgMax[{u2[1 - xa1, 1 - xa2], 
        And[t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) == 
          1 - e[[1]] + \[Rho]*(1 - e[[2]]), 0 <= xa1 <= 1, 
         0 <= xa2 <= 1]}, {xa1, xa2}]};
    AppendTo[\[Rho]List, \[Rho]];
    AppendTo[uList, result];
    result
    ];
BudgetSets1[
   e_, \[Rho]_] := {RegionPlot[
    xa1 + \[Rho]*t21*xa2 <= e[[1]] + \[Rho]*e[[2]], {xa1, 0, 1}, {xa2,
      0, 1}, MeshStyle -> Directive[Opacity[.07], Red]], 
   RegionPlot[
    xa1 + \[Rho]*t21*xa2 > e[[1]] + \[Rho]*e[[2]], {xa1, 0, 1}, {xa2, 
     0, 1}, MeshStyle -> Directive[Opacity[.05], Blue]]};
BudgetSets2[
   e_, \[Rho]_] := {RegionPlot[
    t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) <= 
     1 - e[[1]] + \[Rho]*(1 - e[[2]]), {xa1, 0, 1}, {xa2, 0, 1}, 
    MeshStyle -> Directive[Opacity[.07], Green]], 
   RegionPlot[
    t12 (1 - xa1) + \[Rho]*t12*(1 - xa2) > 
     1 - e[[1]] + \[Rho]*(1 - e[[2]]), {xa1, 0, 1}, {xa2, 0, 1}, 
    MeshStyle -> Directive[Opacity[.05], Yellow]]};
tangentICs[e_, \[Rho]_] := 
  ContourPlot[{u1[xa1, xa2] == u1 @@ uMax[e, \[Rho]][[1]], 
    u2[1 - xa1, 1 - xa2] == u2 @@ (1 - uMax[e, \[Rho]][[2]])}, {xa1, 
    0, 1}, {xa2, 0, 1}, 
   ContourStyle -> {Directive[Red, Thickness[.01], Opacity[.7]], 
     Directive[Blue, Thickness[.01], Opacity[.6]]}];
optPoints[e_, \[Rho]_] := 
  Graphics[{PointSize[.025], {Red, (Point[
       uMax[e, \[Rho]][[1]]])}, {Blue, (Point[
       uMax[e, \[Rho]][[2]]])}}];
label[e_, \[Rho]_] := 
 With[{\[CapitalDelta] = 
    uMax[e, \[Rho]][[2, 1]] - uMax[e, \[Rho]][[1, 1]]},
  Which[\[CapitalDelta] < 
    0, {{None, "excess supply of y"}, {"excess demand for x", 
     None}}, \[CapitalDelta] > 
    0, {{None, "excess demand for y"}, {"excess supply of x", 
     None}}, \[CapitalDelta] == 
    0, {{None, "market clears"}, {"market clears", None}}]
  ]
line := Module[{perm},
  If[Length[\[Rho]List] == 0, Graphics[],
   perm = Ordering[\[Rho]List];
   Graphics[{Red, Line[uList[[perm, 1]]], Blue, 
     Line[uList[[perm, 2]]]}]
   ]
  ]
Manipulate[
 Show[BudgetSets1[e, \[Rho]], BudgetSets2[e, \[Rho]], 
  tangentICs[e, \[Rho]], optPoints[e, \[Rho]], line, 
  FrameTicks -> {{Automatic, InvTicks}, {Automatic, InvTicks}},
  FrameLabel -> label[e, \[Rho]]],
 {{\[Rho], 1}, 1/2, 2}, {{e, {3/4, 1/4}}, Locator}, 
 ContinuousAction -> False, ControlType -> VerticalSlider, 
 ControlPlacement -> Left]

Result:

enter image description here

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