1
$\begingroup$

Let $G=(V,E)$ be a directed graph with $n$ vertices, $V$, and a set of $m$ edges, $E$. Each edge is a function of two unknown parameters, $[t(i,j),a(i,j)]$ and a given value for $x(i)$. If the two parameters are known, then one can apply Mathematica's NetworkFlow[] to find the maximum flow between any two vertices $(s,t)$ because the edge weights of $G$ are real numbers. However, in my case, each edge weight is a function of the two unknown parameters, for example, the edge weight of a directed path from $i$ to $j$ is $[t(i,j) a(j,i) x(i)]$.

As an example, suppose that vertex 1 sends information to vertex 5. $t(1,5)$ denotes the transfer attention of vertex 1, which is allocated for sending information to vertex 5. On the other hand, vertex 5 allocates some of its attention, denoted by $a(5,1)$, to absorb the incoming information from vertex 1. Therefore, the edge weight for the flow from vertex 1 to 5 becomes equal to $[t(1,5)*a(5,1)*x(1)]$, where $x(1)$ stands for the total information stock of vertex 1, which is distributed across vertices with which vertex 1 has binary links. The entire network is constructed using this logic.

I want to find the optimal values of all the unknown parameters in the network. This problem boils down to the case that I have to run NetworkFlow[] $n(n-1)$ times in the worst case.

My formal question to the community is:

How can I automate the formulation of this network flow problem (like a linear programming problem) and find the optimal distribution of ${t[i,j],a(j,i)}$ for each pathway from $s$ to $t$ in the network? One may think of the pathway from $s$ to $t$ as a subgraph of $G$.

Here is a manually constructed maximization problem for s = 1 to t = 5. In larger digraphs of the above type, I cannot handle to prepare the max problems for each pathway from s to t. I want to formalize the following max problem using Mathematica functionality. Eventually, I should be able to get the optimal distribution of the parameters for each path.

Clear[nn, adjM, eCap, infoNet, wG];
nn = 5;  (* number of vertices *)
adjM = {{0, 1 , 1, 1, 0}, {0, 0, 0, 1, 1}, {0, 0, 0, 0, 1}, {0, 0, 0, 
    0, 1}, {0, 0, 0, 0, 0}};
eCap = Table[
   Subscript[t, i, j]*Subscript[a, j, i]*Subscript[x, i], {i, 1, 
    nn}, {j, 1, nn}];  (* edge capacity *)
infoNet = adjM*eCap; (* a matrix of info flow *)
infoNet // MatrixForm 
wG = WeightedAdjacencyGraph[infoNet /. {0 -> Infinity}, 
  DirectedEdges -> True, 
  VertexLabels -> "Name"]  (* a weighted digraph of "infoNet" *)

(* Find Maximum Flow between vertices 1 and 5 *) 
Clear[objFn, const];
objFn = Total[infoNet[[1]]] // Simplify;
const = {
   1 >= Subscript[t, 1, 2] > 0,
   1 >= Subscript[t, 1, 3] > 0,
   1 >= Subscript[t, 1, 4] > 0,
   1 >= Subscript[t, 2, 4] > 0,
   1 >= Subscript[t, 2, 5] > 0,
   1 >= Subscript[t, 3, 5] > 0,
   1 >= Subscript[t, 4, 5] > 0,
   1 >= Subscript[a, 2, 1] > 0,
   1 >= Subscript[a, 3, 1] > 0,
   1 >= Subscript[a, 4, 1] > 0,
   1 >= Subscript[a, 4, 2] > 0,
   1 >= Subscript[a, 5, 2] > 0,
   1 >= Subscript[a, 5, 3] > 0,
   1 >= Subscript[a, 5, 4] > 0,
   Subscript[TT, 1] == 
    Subscript[t, 1, 2] + Subscript[t, 1, 3] + Subscript[t, 1, 4],
   Subscript[TT, 2] == Subscript[t, 2, 4] + Subscript[t, 2, 5],
   Subscript[TT, 3] == Subscript[t, 3, 5],
   Subscript[TT, 4] == Subscript[t, 4, 5],
   Subscript[AA, 2] == Subscript[a, 2, 1],
   Subscript[AA, 3] == Subscript[a, 3, 1],
   Subscript[AA, 4] == Subscript[a, 4, 1] + Subscript[a, 4, 2],
   Subscript[AA, 5] == 
    Subscript[a, 5, 2] + Subscript[a, 5, 3] + Subscript[a, 5, 4],
   Subscript[t, 1, 2]*Subscript[a, 2, 1]*Subscript[x, 
      1] - (Subscript[t, 2, 5]*Subscript[a, 5, 2] + 
        Subscript[t, 2, 4]*Subscript[a, 4, 2])*Subscript[x, 2] == 0,
   Subscript[t, 1, 2]*Subscript[a, 2, 1]*Subscript[x, 1] <= Subscript[
    x, 2],
   Subscript[t, 1, 3]*Subscript[a, 3, 1]*Subscript[x, 1] - 
     Subscript[t, 3, 5]*Subscript[a, 5, 3]*Subscript[x, 3] == 0,
   Subscript[t, 1, 3]*Subscript[a, 3, 1]*Subscript[x, 1] <= Subscript[
    x, 3],
   Subscript[t, 1, 4]*Subscript[a, 4, 1]*Subscript[x, 1] + 
     Subscript[t, 2, 4]*Subscript[a, 4, 2]*Subscript[x, 2] - 
     Subscript[t, 4, 5]*Subscript[a, 5, 4]*Subscript[x, 4] == 0,
   Subscript[t, 1, 4]*Subscript[a, 4, 1]*Subscript[x, 1] + 
     Subscript[t, 2, 4]*Subscript[a, 4, 2]*Subscript[x, 2] <= 
    Subscript[x, 4]
   };

Choose Random numbers to numerically solve the above max-flow problem:

Clear[x, TT, AA];
SeedRandom[01];
Table[Subscript[x, i] = RandomInteger[{1, 5}], {i, 1, 
  nn}];  (* given info carrying capacity *)
Table[Subscript[TT, i] = RandomReal[], {i, 1, 
  nn}];  (* given total Transfer attention *)
Table[Subscript[AA, i] = RandomReal[], {i, 1, 
  nn}];  (* given total Absorption attention *)

Maximize[{objFn, const}, {Subscript[t, 1, 2], Subscript[t, 1, 3], 
  Subscript[t, 1, 4], Subscript[t, 2, 4], Subscript[t, 2, 5], 
  Subscript[t, 3, 5], Subscript[t, 4, 5], Subscript[a, 2, 1], 
  Subscript[a, 3, 1], Subscript[a, 4, 1], Subscript[a, 4, 2], 
  Subscript[a, 5, 2], Subscript[a, 5, 3], Subscript[a, 5, 4]}]

(* solution *)

{2.7306, {Subscript[t, 1, 2] -> 0.428477, 
  Subscript[t, 1, 3] -> 0.322034, 
  Subscript[t, 1, 4] -> 6.61845*10^-10, 
  Subscript[t, 2, 4] -> 3.02959*10^-9, Subscript[t, 2, 5] -> 0.98254, 
  Subscript[t, 3, 5] -> 0.502337, Subscript[t, 4, 5] -> 0.46809, 
  Subscript[a, 2, 1] -> 0.698087, Subscript[a, 3, 1] -> 0.767014, 
  Subscript[a, 4, 1] -> 0.513681, Subscript[a, 4, 2] -> 0.10456, 
  Subscript[a, 5, 2] -> 0.507382, Subscript[a, 5, 3] -> 0.491711, 
  Subscript[a, 5, 4] -> 5.42932*10^-9}}
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.