I am trying to generate a version of Watts' model of cascading shocks to a network following the discussion on p. 20-25 of this article.
The basic premise is to use the RandomGraph
function to generate a graph, then create a table of characteristics on from VertexList
. The values in the table (x
) are the vertex number, the 'persuadability' of the vertex, and the current state (0,1). Everyone is at 0 to start, and we put in an initial shock of 5 vertices going from 0 to 1. Then if the ratio of neighbours who are 1s is above the 'persuadability' number, that neighbour changes its state from 0 to 1.
UPDATE 2
The code below does what I want, in that it iterates the cascade and records each step, and also does it for different initial system shocks.
The code does most of what I originally asked about -
Ultimately I would like to be able to do the following:
Use the code to store a table of
x
tables at each iteration. This could be used to animate the graph later (usingHighlightGraph[SubGraph[...]]
).Use the code to simulate various random shocks on the same graph by iterating until the table
x
does not change.Maybe a nice
Manipulate
interface at some point.
However, the evaluation takes about 20 minutes, and it also iterates a fixed number of times iter
instead of sufficient for convergence. So I have some specific questions.
- Why is the assignment
record[[l]]=x
necessary in theTable
loop? - How can I get the
Table
to iterate tillrecord[[l]]==record[[l-1]]
? (Mike suggestsFixedPointList
, but I can't seem to get the syntax to work) - How can I write the
Do
loop with theIf
statement so I can useParallelDo
or similar? (much like the answer here, but with conditions from two lists) - What are some other ways to speed this up generally?
UPDATE 3
This part of the code takes about half a second (which seems slow, since it is called every iteration, or 750 times)
nextn = Table[
Drop[VertexList[NeighborhoodGraph[y, neighbourVL[[i]]]], 1], {i,
1, Length[neighbourVL]}];
This generates a table with each row a list of neighbours of the vertexes in the list neighbourVL. Is there a way to get this list with a faster method?
Thanks everyone.
(* Note 20min evaluation time *)
y = RandomGraph[{100, 150}];
edges = EdgeList[y];
nodes = Partition[
Flatten[Riffle[VertexList[y], Table[{RandomReal[0.7], 0}, {100}]]],
3];
iter = 15;
record = Table[0, {iter}];
output = Table[
shock = Transpose[{RandomSample[Range[100], 5], Table[3, {5}]}];
x = ReplacePart[nodes, shock -> 1];
Table[
converted = Cases[x, {_, _, 1}];
neighbourVL =
Flatten[Table[
Drop[VertexList[NeighborhoodGraph[y, converted[[i, 1]], 1]],
1], {i, 1, Length[converted]}]];
(* Vertex list of neighbours' first neighbours to be evaluated
with If function *)
nextn = Table[
Drop[VertexList[NeighborhoodGraph[y, neighbourVL[[i]]]], 1], {i,
1, Length[neighbourVL]}];
(* Number of neighbours of vertex 1's first neighbour who are 1s *)
neighbourcount =
Table[Table[
Count[x, {Take[nextn[[i, j]]], _, 1}], {j, 1,
Length[nextn[[i, All]]]}], {i, 1, Length[nextn]}];
threshold =
N[Total[neighbourcount, {2}]/
Table[Length[nextn[[i, All]]], {i, 1, Length[nextn]}]];
Do[
If[threshold[[i]] > x[[neighbourVL[[i]], 2]],
x = ReplacePart[x, {neighbourVL[[i]], 3} -> 1]];, {i,
Length[nextn]}];
record[[l]] = x
, {l, 1, iter}]
, {50}];
Histogram[Total[output[[All, -1, All, -1]], {2}]]
Manipulate[
Table[HighlightGraph[y,
Subgraph[y, Cases[output[[j, i]], {_, _, 1}][[All, 1]]]]
, {j, 1, 6}], {i, 1, iter, 1}]
With
. Sorry for the confusion. $\endgroup$ – kglr Oct 23 '12 at 10:01