forked from RubensZimbres/Repo-2016
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathMathematica - Social Network Surveillance
77 lines (56 loc) · 11.8 KB
/
Mathematica - Social Network Surveillance
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Clear["Global`*"]
SetDirectory[$UserDocumentsDirectory];
gr=Import["Social_Network.Data.xlsx"][[1]];
g77=Flatten[Drop[gr[[#]],-1]&/@Table[p,{p,1,349,1}]];
z={-39,29,41,-35,59,16,-11,-57,-101,-96,-88,-58,-10,55,172,10,32,10,32,18,14,-33,-11,-9,-25,-139,55,-35,85,100,20,14,-44,9,11,34,65,-41,8,-23,39,-16,-23,-37,-123,-8,-47,-28,31,58,-20,-32,4,-22,-26,9,-81,-9,-22,11,0,2,-41,18,25,-134,35,76,-15,10,-29,35,-62,15,7,26,52,23,-16,21,14,26,-37,10,21,-16,29,1,3,9,38,24,24,-10,-13,13,-13,-40,-3,25,27,57,15,4,16,4,-6,-10,15,-9,28,-102,1,2,16,15,17,16,65,24,91,-50,-22,-3,-37,-4,-10,31,37,37,-26,4,8,25,-5,11,65,2,37,18,-2,12,-5,-12,46,36,-25,30,-95,-30,91,-120,-160,22,20,21,90,17,11,63,-21,21,-4,13,9,51,27,-13,27,-2,-6,60,131,-3,5,7,21,47,39,-19,-41,18,-20,7,13,15,-22,-9,35,20,30,24,-47,-8,10,33,19,20,36,-21,-25,45,31,56,-38,-11,14,70,-53,19,-23,19,12,-21,12,-1,-3,43,38,37,-15,-27,-22,37,17,-1,16,35,6,-15,29,43,47,14,-42,60,32,52,26,23,38,60,27,28,-72,31,-27,-8,-8,23,22,70,23,36,44,43,9,12,140,10,48,13,44,46,18,-30,-13,37,-24,13,68,25,-18,37,20,-143,47,-162,5,80,-48,8,87,38,-12,15,-43,-72,22,22,76,43,47,-113,51,55,-2,-27,69,9,-105,-114,-123,24,-8,9,-16,-147,30,-38,-64,-46,16,13,-22,-5,-50,8,-20,-30,65,23,45,40,-20,7,-4,7,30,10,21,21,69,-27,18,37,28,14,37,-121,21,16,-30,-30,2,73,-36,106,-30};
tre=IntegerDigits[z,5];
amounteach=15;lattice=200;initial=0;state1=40;state2=59;state3=197;state4=234;left=-1;right=1;ciclosSet=15;country="BRA";goal=260;
If[country=="BRA",If[initial==0,monthstart=9;daystart=15;year=2015,If[initial==1,year=2015;monthstart=7;daystart=1]],If[initial==0,year=2016;monthstart=1;daystart=15,If[initial==1,year=2015;monthstart=9;daystart=11]]];
Partition[Table[RandomInteger[{1,lattice-10}],{amounteach}],1];
position1={{76},{20},{21},{42},{38},{15},{62},{20},{47},{9},{72},{47},{7},{34},{22}};
position2={{61},{80},{71},{49},{36},{5},{62},{70},{22},{62},{76},{13},{37},{33},{35}};
position3={{58},{61},{13},{47},{44},{74},{6},{58},{14},{34},{37},{41},{74},{40},{48}};
position4={{59},{36},{21},{59},{61},{24},{58},{30},{67},{58},{72},{28},{75},{19},{32}};
suspects={1};
Condinit11=Table[Table[RandomInteger[{0,4}],{lattice}],{7}];
Condnow22=Table[Table[RandomInteger[{0,4}],{Dimensions[Condinit11][[2]]}],{7}];
Condinit=Flatten[Insert[Insert[Insert[Insert[Condinit11[[#]],IntegerDigits[z[[state1]],5],position1],IntegerDigits[z[[state2]],5],position2],IntegerDigits[z[[state3]],5],position3],IntegerDigits[z[[state4]],5],position4]]&/@Table[g,{g,1,7,1}];
zh=5;
ah=Dimensions[CellularAutomaton[{2159062512564987644819455219116893945895958528152021228705752563807962227809675103689306,5,{{-1},{0},{1}}},Condinit[[1]],2]];
aput=Table[{{RandomInteger[{-ah[[2]],-1}]},{0},{RandomInteger[{1,ah[[2]]}]}},{ah[[2]]}];
cycle=ciclos=0;While[(cycle=ciclos=ciclos+1)<=ciclosSet,Print[
ppp=CellularAutomaton[{2159062512564987644819455219116893945895958528152021228705752563807962227809675103689306,5,aput[[#]]},Condinit[[zh]],cycle]&/@Table[i,{i,1,ah[[2]],1}];tew[tg_]:=ppp[[tg]][[#]][[tg]]&/@Table[po,{po,1,cycle+1,1}];asw=tew/@Table[po,{po,1,Dimensions[ppp][[1]],1}];l[v_]:=asw[[#]][[v]]&/@Table[pot,{pot,1,Dimensions[asw][[1]],1}];rr=l/@Table[pu,{pu,1,Dimensions[asw][[2]],1}];Condnow=rr;
CirclePoints[n_]:=Table[{Cos[x],Sin[x]},{x,0,2Pi-2Pi/n,2Pi/n}];pessoas[foww_]:=Condnow[[#]][[foww]]&/@Table[gt,{gt,1,cycle+1,1}];kgf=pessoas/@Table[gt,{gt,1,Dimensions[Condnow][[2]],1}];prt=N[EuclideanDistance[{kgf[[1]]},{kgf[[#]]}]&/@Table[gt,{gt,1,Dimensions[Condnow][[2]],1}]+1];pcp=N[prt[[#]]/Max[prt]&/@Table[gt,{gt,1,Dimensions[Condnow][[2]],1}]];cp8=N[Times[pcp,CirclePoints[Dimensions[Condnow][[2]]]]];
tyu=Table[pp,{pp,1,Dimensions[Condnow][[2]],1}];asj=rr[[cycle+1]];aput2=Partition[Flatten[aput],3];zee=Drop[aput2[[#]],{2}]&/@tyu;listaconjunta7=Insert[zee[[#]],#,2]&/@tyu;lista=Dimensions[Condinit][[2]]+1+listaconjunta7[[#]][[1]]&/@tyu;tuu=Drop[listaconjunta7[[#]],1]&/@tyu;tg[tau_]:=Insert[tuu[[#]],tau,1]&/@tyu;see=tg/@lista;Dimensions[see];listaconjunta=see[[#]][[#]]&/@tyu;zeros=Flatten[Position[asj,0]];If[zeros=={},0,Dimensions[zeros];zeros1=Tuples[zeros,2];zeros2=Partition[zeros1,Dimensions[zeros][[1]]]];zeros3=zeros2[[#]][[RandomInteger[{1,Dimensions[zeros][[1]]}]]]&/@Table[o,{o,1,Dimensions[zeros][[1]],1}];zeros4=Flatten[Drop[zeros3[[#]],1]&/@Table[o,{o,1,Dimensions[zeros][[1]],1}]];zeros5=listaconjunta[[#]]&/@zeros;zeros6=Drop[zeros5[[#]],-1]&/@Table[j,{j,1,Dimensions[zeros][[1]],1}];zeros7=Insert[zeros6[[#]],zeros4[[#]],3]&/@Table[j,{j,1,Dimensions[zeros][[1]],1}];ones=Flatten[Position[asj,1]];If[ones=={},0,Dimensions[ones];ones1=Tuples[ones,2];ones2=Partition[ones1,Dimensions[ones][[1]]]];ones3=ones2[[#]][[RandomInteger[{1,Dimensions[ones][[1]]}]]]&/@Table[o,{o,1,Dimensions[ones][[1]],1}];ones4=Flatten[Drop[ones3[[#]],1]&/@Table[o,{o,1,Dimensions[ones][[1]],1}]];ones5=listaconjunta[[#]]&/@ones;ones6=Drop[ones5[[#]],-1]&/@Table[j,{j,1,Dimensions[ones][[1]],1}];ones7=Insert[ones6[[#]],ones4[[#]],3]&/@Table[j,{j,1,Dimensions[ones][[1]],1}];twos=Flatten[Position[asj,2]];If[twos=={},0,Dimensions[twos];twos1=Tuples[twos,2];twos2=Partition[twos1,Dimensions[twos][[1]]]];twos3=twos2[[#]][[RandomInteger[{1,Dimensions[twos][[1]]}]]]&/@Table[o,{o,1,Dimensions[twos][[1]],1}];twos4=Flatten[Drop[twos3[[#]],1]&/@Table[o,{o,1,Dimensions[twos][[1]],1}]];twos5=listaconjunta[[#]]&/@twos;twos6=Drop[twos5[[#]],-1]&/@Table[j,{j,1,Dimensions[twos][[1]],1}];twos7=Insert[twos6[[#]],twos4[[#]],3]&/@Table[j,{j,1,Dimensions[twos][[1]],1}];threes=Flatten[Position[asj,3]];If[threes=={},0,Dimensions[threes];threes1=Tuples[threes,2];threes2=Partition[threes1,Dimensions[threes][[1]]]];threes3=threes2[[#]][[RandomInteger[{1,Dimensions[threes][[1]]}]]]&/@Table[o,{o,1,Dimensions[threes][[1]],1}];threes4=Flatten[Drop[threes3[[#]],1]&/@Table[o,{o,1,Dimensions[threes][[1]],1}]];threes5=listaconjunta[[#]]&/@threes;threes6=Drop[threes5[[#]],-1]&/@Table[j,{j,1,Dimensions[threes][[1]],1}];threes7=Insert[threes6[[#]],threes4[[#]],3]&/@Table[j,{j,1,Dimensions[threes][[1]],1}];fours=Flatten[Position[asj,4]];If[fours=={},0,Dimensions[fours];fours1=Tuples[fours,2];fours2=Partition[fours1,Dimensions[fours][[1]]]];fours3=fours2[[#]][[RandomInteger[{1,Dimensions[fours][[1]]}]]]&/@Table[o,{o,1,Dimensions[fours][[1]],1}];fours4=Flatten[Drop[fours3[[#]],1]&/@Table[o,{o,1,Dimensions[fours][[1]],1}]];fours5=listaconjunta[[#]]&/@fours;fours6=Drop[fours5[[#]],-1]&/@Table[j,{j,1,Dimensions[fours][[1]],1}];fours7=Insert[fours6[[#]],fours4[[#]],3]&/@Table[j,{j,1,Dimensions[fours][[1]],1}];peep=Sort[Flatten[{zeros,ones,twos,threes,fours}]];aw=Partition[peep,1];Delete[listaconjunta,aw];neigh=Partition[Flatten[{zeros7,ones7,twos7,threes7,fours7}],3];aff=Partition[neigh[[#]][[3]]&/@tyu,1];afu=Insert[aff[[#]],0,1]&/@tyu;afu=Insert[afu[[#]],RandomInteger[{-Dimensions[Condinit][[2]],-1}],1]&/@tyu;aput2=Partition[Partition[Flatten[afu],1],3];
listaconjunta=Partition[Flatten[{If[Dimensions[Condinit][[2]]-Abs[aput2[[#]][[1]][[1]]]+1==0,1,Dimensions[Condinit][[2]]-Abs[aput2[[#]][[1]][[1]]]+1]
,#,If[aput2[[#]][[3]][[1]]==0,1,aput2[[#]][[3]][[1]]]}&/@tyu],3];asus=Table[ki,{ki,1,ah[[2]],1}];asus2=Table[ki,{ki,1,ah[[2]],1}];pop=asus[[#]]->asus2[[#]]&/@asus;pfp=asus2;ppt=asus2;listacjnames=listaconjunta;tb=N[(Count[Flatten[listaconjunta],#]/70)]&/@Table[pz,{pz,1,ah[[2]],1}];listacv=Flatten[{Table[listacjnames[[i]][[2]]->listacjnames[[i]][[3]],{i,1,ah[[2]],1}],Table[listacjnames[[i]][[2]]->listacjnames[[i]][[1]],{i,1,ah[[2]],1}]}];x=Sort[listacv,#1[[1]]&];listacz=Flatten[{x[[#]],x[[#+ah[[2]]-1]]}&/@Table[gt,{gt,1,Dimensions[ppt][[1]],1}]];pew=rr[[cycle+1]];abh=Total[kgf[[#]]]&/@tyu;
ft=Flatten[If[Count[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]>0,If[listacz[[#]][[1]]==Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]][[1]][[1]],{listacz[[#]][[1]], listacz[[#]][[2]]},If[listacz[[#]][[2]]==Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]][[1]][[1]],{listacz[[#]][[1]], listacz[[#]][[2]]},{}]]&/@Table[t,{t,1,Dimensions[listacz][[1]],1}],{}]];
wd[wf_]:=If[listacz[[#]][[1]]==suspects[[wf]],{listacz[[#]][[1]],listacz[[#]][[2]]},
If[listacz[[#]][[2]]==suspects[[wf]],{listacz[[#]][[1]],listacz[[#]][[2]]},{}],{}]&/@Table[r,{r,1,Dimensions[listacz][[1]],1}];
u6[ii6_]:=If[Count[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]>0,Flatten[If[listacz[[#]][[1]]==Flatten[{Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]}][[ii6]],{listacz[[#]][[1]], listacz[[#]][[2]]},If[listacz[[#]][[2]]==Flatten[{Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]}][[ii6]],{listacz[[#]][[1]], listacz[[#]][[2]]},{}]]&/@Table[t,{t,1,Dimensions[listacz][[1]],1}]],{}];fj=u6/@Table[r,{r,1,Dimensions[Flatten[Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]]][[1]],1}];dh1=Partition[Flatten[wd/@Table[j,{j,1,Dimensions[suspects][[1]],1}]],2];dh=Partition[Flatten[Append[dh1,fj]],2];dj={cp8[[dh[[#]][[1]]]],cp8[[dh[[#]][[2]]]]}&/@Table[j,{j,1,Dimensions[dh][[1]],1}];
{GraphPlot[listacz,
VertexCoordinateRules->cp8,VertexRenderingFunction->({
Black
,FontSize->14,Text[#2,cp8[[#2]]],Hue[If[pew[[Position[cp8,#][[1]][[1]]]]==4,0.01,If[pew[[Position[cp8,#][[1]][[1]]]]==3,0.09,If[pew[[Position[cp8,#][[1]][[1]]]]==2,0.126,If[pew[[Position[cp8,#][[1]][[1]]]]==1,0.159,If[pew[[Position[cp8,#][[1]][[1]]]]==0,0.28,9]]]]]],EdgeForm[Black],
,{u[q_]:=If[#2==suspects[[q]],
If[Count[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]!=0,#2==Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[ciclos]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]][[1]];
{fh[rt_]:={Thickness[0.17 tb[[Position[pop,rt][[1]][[1]]]]],Blue,Circle[cp8[[rt]]
,1.1 tb[[Position[pop,rt][[1]][[1]]]]]};fh/@Flatten[Partition[Flatten[Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[#]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]&/@Table[ju,{ju,1,ciclos,1}]],1]],
{Thickness[0.09 tb[[Position[pop,#2][[1]][[1]]]]],Black,Circle[cp8[[suspects[[q]]]],0.8 tb[[Position[pop,#2][[1]][[1]]]]]}
},{Thickness[0.09 tb[[Position[pop,#2][[1]][[1]]]]],Black,Circle[cp8[[suspects[[q]]]],0.8tb[[Position[pop,#2][[1]][[1]]]]]}],
{}];u/@Table[e,{e,1,Dimensions[suspects][[1]],1}]}
,Opacity[0.37],Disk[#,tb[[Position[pop,#2][[1]][[1]]]]]
}&),EdgeRenderingFunction->({Gray,Arrowheads[0.015],Arrow[#1,0.04]}&),ImageSize->900],
tyy=Partition[Flatten[rr],Dimensions[rr][[2]]];zip=Partition[tyy[[#]],Dimensions[IntegerDigits[z[[goal]],5]]]&/@Table[p,{p,1,Dimensions[tyy][[1]],1}];ao={#,Position[zip[[#]],tre[[goal]]]}&/@Table[p,{p,1,ciclos,1}]/.{}->{};DayPlus[{2015,monthstart,daystart},Times[ciclos,7]],
Text[Style[g77[[goal]],Bold,Large]],Text[Style["=",Bold,Large]],
Text[Style[Dimensions[Partition[Flatten[Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[#]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]&/@Table[ju,{ju,1,ciclos,1}]],1]][[1]],Bold,Large]],
Text[Style["TOTAL=",Bold,Large]],
Text[Style[100 N[Dimensions[Partition[Flatten[Dimensions[tre[[goal]]][[1]] Position[Partition[rr[[#]],Dimensions[tre[[goal]]][[1]]],tre[[goal]]]&/@Table[ju,{ju,1,ciclos,1}]],1]][[1]]/Dimensions[Condinit][[2]],2],Bold,Large]],
Text[Style["%"\.1c,Bold,Large]],
Text[Style["Mood=",Bold,Large]],Text[Style[Times[5,1/N[Total[rr[[cycle+1]]]/ah[[2]]]],Bold,Large]],Text[Style["Deaths=",Bold,Large]],Text[Style[
ge4[f4_]:=rr[[#]][[f4]]&/@Table[pre4,{pre4,1,Dimensions[rr][[1]]}];asp4=ge4/@Table[pre24,{pre24,1,Dimensions[rr][[2]]}];asr4=Count[asp4[[#]],0]&/@Table[pre2,{pre2,1,Dimensions[rr][[2]]}];Count[If[asr4[[#]]>8,"Death","None"]&/@Table[pre24,{pre24,1,Dimensions[rr][[2]]}],"Death"],Bold,Large]],
Text[Style["Density=",Bold,Large]],Text[Style[N[100 Mean[Variance[cp8]],2],Bold,Large]],
ArrayPlot[rr,ColorRules->{0->RGBColor[0,1,0],1->RGBColor[1,0.77,0],2->RGBColor[0,0,1],3->RGBColor[1,1,1],4->RGBColor[1,0,0]},ImageSize->1000,Mesh->True],
ciclos
}
]]