How to plot a coalition game?

Question

Consider a game of a function $v$ which has

\begin{align} v(1) & \geq 1\\ v(2) & \geq 0\\ v(3) & \geq 1\\ v(1,2) &\geq 4\\ v(1,3) &\geq 3\\ v(2,3) &\geq 5\\ v(1,2,3) &=8 \end{align}

How can I plot such a function in Mathematica (preferably in 2D). Should one use RegionPlotor Graphics?

Answer 1

I do not have a good command of the techniques needed to achieve the final transformations but I do understand the problem and can at least get part of the way there. Hopefully one of the whizzes will carry it the rest of the way :)

A coalition game is a model in game theory where one evaluates how well teams of players do. Each player must decide: compete or cooperate. Since there are three players here, each player has multiple choices. This model is less concerned with individual payouts, and more with understanding what configurations are possible assuming the players maximize their positions rationally. A team could be any of these:

players = {x1, x2, x3};
Subsets[players]

{{}, {x1}, {x2}, {x3}, {x1, x2}, {x1, x3}, {x2, x3}, {x1, x2, x3}}

(The empty team is sometimes formally relevant.) Everyone must play, which means that at the end of the game each player receives a payout. (The payout could be nothing.) The purpose of this chart is to describe the space of payouts ("imputations") to {x1, x2, x3}. This task is defined by the characteristic function v, which establishes the parameters of the game in the form of "guarantees". So, v( {1} ) >= 1 means that if x1 plays by himself, he is ensured to receive at least one unit of value, say 1. We see the same constructs for the other two players, and we also see other guarantees: v( {1, 2} ) >= 4 means that x1 and x2 are guaranteed to receive 4 between them if they cooperate, and so forth. The v( {1, 2, 3} ) = 8 means a total of $8 is available if everyone holds hands and joins the "grand coalition". So the possible configurations are:

configurations = 
 DeleteCases[
  ReplaceList[players, {a___, b___, c___} -> {{a}, {b}, {c}}], {}, 2]

{{{x1, x2, x3}}, {{x1}, {x2, x3}}, {{x1, x2}, {x3}}, {{x1, x2, x3}}, {{x1}, {x2, x3}}, {{x1}, {x2}, {x3}}, {{x1}, {x2, x3}}, {{x1, x2}, {x3}}, {{x1, x2}, {x3}}, {{x1, x2, x3}}}

And our characteristic function is:

v = {{x1} -> 1, {x2} -> 0, {x3} -> 1, {x1, x2} -> 4, {x1, x3} -> 
3, {x2, x3} -> 5, {x1, x2, x3} -> 8};

Meaning the configurations imply these guaranteed payouts:

MapThread[Rule, {configurations, configurations /. v}]

{{{x1, x2, x3}} -> {8}, {{x1}, {x2, x3}} -> {1, 5}, {{x1, x2}, {x3}} -> {4, 1}, {{x1, x2, x3}} -> {8}, {{x1}, {x2, x3}} -> {1, 5}, {{x1}, {x2}, {x3}} -> {1, 0, 1}, {{x1}, {x2, x3}} -> {1, 5}, {{x1, x2}, {x3}} -> {4, 1}, {{x1, x2}, {x3}} -> {4, 1}, {{x1, x2, x3}} -> {8}}

Everything else is up in the air, but we can anticipate some of the participants' decisions. By eliminating parts of the payout space that are "unstable" we are left with the "core", the set of "stable" imputations. Instability "through" a coalition means that, if a particular imputation were to be proposed, there would be an incentive for some players to reject it and instead form the coalition in question, which would upset the bargaining power and destroy that proposal. The set of all imputations is:

imputations =
  Solve[
    And[
     x1 + x2 + x3 == 8,
     x1 >= 1,
     x2 >= 0,
     x3 >= 1],
    {x1, x2, x3},
    Integers][[All, All, 2]];

This is indeed a plane:

Point@imputations // Graphics3D

The unstable imputations are:

unstableThrough = Map[
   Select[imputations, #] &,
   unstableRules = {#[[1]] + #[[2]] < 4 &,
     #[[1]] + #[[3]] < 3 &,
     #[[2]] + #[[3]] < 5 &}];
unstableThrough // Column

{{{1, 0, 7}, {1, 1, 6}, {1, 2, 5}, {2, 0, 6}, {2, 1, 5}, {3, 0, 5}},

{{1, 6, 1}},

{{4, 0, 4}, {4, 1, 3}, {4, 2, 2}, {4, 3, 1}, {5, 0, 3}, {5, 1, 2}, {5, 2, 1}, {6, 0, 2}, {6, 1, 1}, {7, 0, 1}}}

dimensions--

colored = {PointSize@Large, Map[Point, unstableThrough, {2}], Red, 
   Point@(stable = 
      Complement[imputations, Flatten[unstableThrough, 1]])};
colored /. l : {__Integer} :> Take[l, 2] // Graphics

So we can now do whatever we want stylistically with the unstable sections:

stable2d = stable[[All, ;; 2]];
stablech = (ch = Part[#, ConvexHull@#] &)@stable2d
unstablech = 
  ch /@ MapThread[
     Join, {unstableThrough, 
      Select[stable, #] & /@ (unstableRules /. Less -> Equal)}][[All, 
     All, ;; 2]];
imputationsch = ch@imputations[[All, ;; 2]];
(*rt=RotationTransform[Pi/2]; I couldn't manage to get all of this to \
rotate in one piece *)
Graphics[{
  Black,
  imputationsch // Polygon,
  Red,
  stablech // Polygon,
  Inner[
   List,
   {Orange, Blue, Green},
   Polygon /@ unstablech,
   List]
  }]

These points just need to be rotated by Pi/2 and transformed into an equilateral triangle but I can't seem to get that working. Then you can pretty it up.

Let's try Invoke[@MrWizard].

Answer 2

For this particular setup and aiming to produce ternary plot that represents game:

tp[c_, a_, b_] := {b + c/2, Sqrt[3] c/2}/(a + b + c)
h1 = Table[Line[{tp[j, 0, 8 - j], tp[j, 8 - j, 0]}], {j, 0, 7}];
h2 = Table[
   Line[{tp[j, k, 8 - j - k], tp[8 - j - k, k, j]}], {j, 0, 7}, {k, 0,
     6 - j}];
h3 = Table[
   Line[{tp[j, 8 - j - k, k], tp[8 - j - k, j, k]}], {j, 0, 7}, {k, 0,
     6 - j}];
gra = Graphics[{LightGray, h1, h2, h3}];
cand = Cases[
   Join @@ Permutations /@ 
     PadRight[IntegerPartitions[8, 3]], {_?(# > 0 &), _, _?(# > 0 &)}];
dc = {{1, 2}, {1, 3}, {2, 3}};
uns[p_, {a_, b_}] := 
  Plus @@ p[[{a, b}]] < ({a, 
      b} /. {{1, 2} -> 4, {1, 3} -> 3, {2, 3} -> 5});
unstable = Map[Function[x, x -> Select[uns[#, x] &][cand]], dc];
stable = Complement[cand, Join @@ (unstable[[All, 2]])];
core = MeshPrimitives[ConvexHullMesh[tp @@@ stable], 2] /. 
   Polygon[x__] :> {Green, Thick, Line[x~Join~{x[[1]]}]};
tpp[x__] := Tooltip[Point[tp@x], {x}];
res = Show[gra, 
   Graphics[{Purple, PointSize[0.02], tpp @@@ ({1, 2} /. unstable), 
     Red, tpp @@@ ({1, 3} /. unstable), Black, 
     tpp @@@ ({2, 3} /. unstable), Green, tpp @@@ stable, core}]];
Framed[Legended[res, 
  PointLegend[{Purple, Red, Black, Green}, 
   Join[unstable, {"stable"}]]]]

Answer 3

I recommend to use my Mathematica Package TuGames Version 2.3 that can plot the core for 3- as well as for 4-person coalitional games. The package for Mathematica Version 8 and higher can be found here

http://library.wolfram.com/infocenter/MathSource/5709/

Assuming that everything is installed properly (cddmathlink is required), we start while loading some sub-packages, all of them ship with the above package (See the archive file tugames-v2.3.7z)

Needs["coop`CooperativeGames`"];
Needs["TuGames`"];
Needs["VertexEnum`"];
<<IOTuGamesV6`

In the next step we define the above TU-game by

In[6]:= cval={0,1,0,1,4,3,5,8};
In[7]:= T={1,2,3}
Out[7]= {1, 2, 3}
ExpGame06 = DefineGame[T,cval];

Then we check that everything works properly

In[9]:= ConvexQ[ExpGame06]
Out[9]= False

In[10]:= CoreQ[ExpGame06]
Out[10]= True

Finally, plotting the core is accomplished by invoking the command

fig01=FilledCoreV6[ExpGame06]

For a four person TU-game, we change the coalitional values and the player set to

vals={0,0,0,0,0.54839,0,0,15.67188,0,13.54167,11.55263,0,40.75862,36.47619,32.63158,96.29412};
T={1,2,3,4};

and redefining the game through

ExpGame11 = DefineGame[T,vals];
ConvexQ[ExpGame11]
ker=Kernel[ExpGame11]
shv=ShapleyValue[ExpGame11]
mnuc=ModifiedNucleolus[ExpGame11]

To plot the core for this four person game, we execute

gr1=PlotCore3dV6[ExpGame11,ViewKernelSol -> False, KernelCoord -> {}, ViewShapleySol -> False, ShapleyCoord -> {},ViewNucleolusSol -> False, NucleolusCoord->{}] 

gr3=PlotCore3dV6[ExpGame11,ViewKernelSol -> True, KernelCoord -> ker, ViewShapleySol -> True, ShapleyCoord -> shv,ViewNucleolusSol -> False, NucleolusCoord->{}]

The last command should give the following graphic

This graphic shows the imputation set (triangle), the core (in yellow), the Shapley value (enlarged blue dot), and the nucleolus/kernel (enlarged red dot).

A more sophisticated graphic can be found here

http://members.wolfram.com/jeffb/visualization/gametheory.shtml

See also the following documentation (based on Mathematica 5)

http://library.wolfram.com/infocenter/MathSource/5709/TuGamesView3D.pdf

as well as the example notebooks that ship with the package.