0
$\begingroup$

I'm trying to solve the first part of a Quantal Response Equilibrium (QRE).

I'm the situation of needing analytical solutions to a large system of equations (Logit-type). Solution will be up to a single parameter: I have, say, $n$ variables and $n-1$ equations.

Variables are in the form a[h]a[q], for example a1a3, plus the parameter d.

Each equation of the system of equations to be solved is in the following form:

a1a3 == Exp[d*pay[1, 3]]/Sum[Exp[d*pay[1, s]], {s, 0, qmax[1]}]

where pay[h, q] and qmax[h] are functions that I have previously defined.

My code appears to work up to the last line, where I receive an error message:

Solve::ivar: {a1a0,a1a1,a1a2....} is not a valid variable. >>

Here the code.

qmax[h_] := Floor[8 Sqrt[2] Sqrt[h]]
pay[h_, q_] := 
  (32 - q^2/(4h))*(1/10)*
     Sum[Sum[Symbol["a" <> ToString[t] <> "a" <> ToString[s]], {s, 0, (q-1)}]+ 
     0.5*Symbol["a"<>ToString[t]<>"a" <>ToString[q]], {t, 1, 10}]
equations = 
  Table[
    Table[
       Symbol["a" <> ToString[h] <> "a" <> ToString[q]] == 
         Exp[d*pay[h, q]]/Sum[Exp[d*pay[h, s]], {s, 0, qmax[h]}], 
       {q, 0, qmax[h]}],
    {h, 1, 10}]
vars = 
  Table[Symbol["a" <> ToString[h] <> "a" <> ToString[q]], {h, 1, 10}, {q, 0,qmax[h]}]

Solve[{equations}, vars]

Edit

Setting a value for d and using FindRoot is perfectly fine for me, but I'm still not able to solve the problem.

$\endgroup$
5
  • 1
    $\begingroup$ Your first problem is that the vars list generate by your Table is nested, whereas Solve wants a flat list of variables. That's an easy fix: vars = Flatten @ Table[... rest of your code ...]. You might have the same problem with your equations too. More in general, your problem seems like a challenge for Solve to generate analytical solutions. Do you know that analytical solutions must exist for your equations? $\endgroup$
    – MarcoB
    Jun 26, 2018 at 13:55
  • $\begingroup$ Thanks, the "is not a valid variable" error has disappeared. Unfortunately, there is a new error: "[equations].. is not a quantified system of equations and inequalities". EDIT: the variables a1a3 ecc.. are probabilities; with d that goes to zero, then all probabilities goes to 0 except one; with d that goes to infinite, all probabilities become equal. For positive values of d a solution should exist. $\endgroup$
    – Rosangela
    Jun 26, 2018 at 14:05
  • 1
    $\begingroup$ 1) I think the equations problem is what I meant when I said "You might have the same problem with your equations too" previously. Try out a much smaller example to start, and inspect your equations variable to see that it is correct and shaped as you expect; now it is a nested list, which you nest further by wrapping it in {} within Solve, which I don't think you need. 2) A solution might exist, but it may not be possible to express it analytically, i.e. with a formula or equation, in which case you should use numerical solvers (e.g. FindRoot) to get its value. $\endgroup$
    – MarcoB
    Jun 26, 2018 at 14:22
  • $\begingroup$ Thanks, I will try. Findroot is fine for me. At the end of the day, I will generate many solutions (for many d) and - via maximum likelihood - I will find the "d" that best fit my observed data. $\endgroup$
    – Rosangela
    Jun 26, 2018 at 14:34
  • $\begingroup$ I still receive an error message. I have add vars = Flatten[ Table[{Symbol["a" <> ToString[[Theta]] <> "a" <> ToString[q]], 0.01}, {[Theta], 1, 2}, {q, 0, qmax[[Theta]]}], 1] and FindRoot[equations, vars] $\endgroup$
    – Rosangela
    Jun 26, 2018 at 14:59

2 Answers 2

1
$\begingroup$

You appear to have 103 more variables than show up in your vars list.

See if this will help you make any progress

qmax[h_] := Floor[8 Sqrt[2] Sqrt[h]];
varpay[h_, q_] := Table[{
  Table[Symbol["a" <> ToString[t] <> "a" <> ToString[s]], {s, 0, (q - 1)}], 
  Symbol["a" <> ToString[t] <> "a" <> ToString[q]]}, {t, 1, 10}];
vars = Union[Flatten[Table[
  Table[{Symbol["a" <> ToString[h] <> "a" <> ToString[q]], 
    Table[{d, varpay[h, s]}, {s, 0, qmax[h]}], {d, varpay[h, q]}},
    {q, 0, qmax[h]}], {h, 1, 10}]]];
pay[h_, q_] := (32 - q^2/(4 h))*(1/10)*
  Sum[Sum[Symbol["a" <> ToString[t] <> "a" <> ToString[s]], {s, 0, (q - 1)}] + 
  0.5*Symbol["a" <> ToString[t] <> "a" <> ToString[q]], {t, 1, 10}];
equations = Total[Flatten[Table[Table[
  Norm[Symbol["a" <> ToString[h] <> "a" <> ToString[q]]*
    Sum[Exp[d*pay[h, s]], {s, 0, qmax[h]}] - 
    Exp[d*pay[h, q]]], {q, 0, qmax[h]}], {h, 1, 10}]]];
NMinimize[equations, vars]

I used a modified version of your equations to generate the vars list.

I multiplied both sides of your equations by your denominator and you should verify that does not give you an incorrect result.

I used Norm[lhs-rhs] and added all the equations together so that NMinimize could look for a solution.

$\endgroup$
0
$\begingroup$

I solved my problem. There were three problems with my code: 1) What I was asking was too challenging for Solve; I used FindRoot and a numeric value for "d". 2) Add Flatten 3) There was an error in the way the function "pay" was defined. As a result, the function created additional (and non-defined) variables.

The code works, but it requires 11 minutes to run. I will ask, in a separate question, if there is a way to make my code more efficient. Reasons because more efficiency is required: 1) The code need to run for 100 (at least) values of the parameter "d" 2) I have a different "pay" function which will generate much more equations to be solved (around 10.000).

Marco, thank you very much. Flatten was the key!

Bill, I do not entirely understand your solution strategy. Maybe it's more efficient?

Here the code. I also changed some notation.

 ClearAll["Global`*"];
qmax[h_] := Floor[8 Sqrt[2] Sqrt[h]];
qmax2[h_, q_] := Min[qmax[h], (q - 1)];
pay[h_, q_] := (32 - q^2/(4 h))*(1/10)*Sum[
Sum[
  Symbol["t" <> ToString[t] <> "q" <> ToString[s]], {s, 0, 
   qmax2[t, q]}] + 
  If[q <= qmax[t], 
  0.5*Symbol["t" <> ToString[t] <> "q" <> ToString[q]], 0], {t, 1,
  10}];
equations = Flatten@Table[
   Table[
   Symbol[
   "t" <> ToString[h] <> "q" <> ToString[q]] == 
  Exp[d*pay[h, q]]/Sum[Exp[d*pay[h, s]], {s, 0, qmax[h]}],
  {q, 0, qmax[h]}],
  {h, 1, 10}];
vars = Flatten[
 Table[{Symbol["t" <> ToString[h] <> "q" <> ToString[q]], 0.01}, {h,
  1, 10}, {q, 0, qmax[h]}], 1];
d = 1;
FindRoot[equations, vars]

And here the link for the follow-up question: FindRoot, large system of equations. Improving Efficiency, loop around many parameter and exporting results

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