1package Viz;
2
3use strict;
4use warnings;
5no warnings 'redefine';
6
7use Class::Struct;
8use Visualization::NetworkGraph;
9use Visualization::GML;
10
11
12struct ProcessGraph =>
13{
14	'Processes'	=> '@',
15	'Edges' => '@',
16	'ReacProds' => '%', # to be deprecated
17	'Names' => '%',
18	'Embed' => '%',
19};
20
21struct ProcessGraph2 =>
22{
23	'Nodes'=> '@',
24	'Edges'=> '@',
25	'Embed'=> '@',
26	'Names'=> '@',
27
28};
29sub initializeProcessGraph
30{
31	my $pg = ProcessGraph2->new();
32	$pg->{'Nodes'} = shift @_;
33	$pg->{'Edges'} = shift @_;
34	if(@_) { $pg->{'Embed'} = shift @_; }
35	if(@_) { $pg->{'Names'} = shift @_; }
36	#else {my @x = @{$pg->{'Nodes'}}; $pg->{'Names'} = \@x;}
37	#print @{$pg->{'Names'}};
38	return $pg;
39}
40sub printProcessGraph
41{
42	my $pg = shift @_;
43	my $str = ();
44	$str .= "Processes:\n";
45	$str .= join "\n", map { $_.":".$pg->{'Names'}->{$_} } @{$pg->{'Processes'}};
46	$str .= "\n";
47	$str .= "Influences:\n";
48	$str .= join "\n", @{$pg->{'Edges'}};
49	return $str;
50
51}
52
53sub makeProcessGraph
54{
55	print "Building process graph for whole model.\n";
56	my $bpg = shift @_;
57
58	my $mergepairs = @_ ? shift @_ : 0;
59	my $embed = @_ ? shift @_ : 0;
60
61	my @edges = @{$bpg->{'EdgeList'}};
62	my @edges2;
63
64	my @processes = grep {$bpg->{'NodeType'}->{$_} =~ /Rule/} @{$bpg->{'NodeList'}};
65	my @wcs = uniq(map {$_ =~ /^(.*):.*:.*/; $1; } grep { $_ =~ /Wildcard/ } @edges);
66
67	my %reacprod;
68	my %context;
69	my %reac;
70	my %prod;
71	map { my @x = (); $reacprod{$_} = \@x; } @processes;
72	map { my @x = (); $context{$_} = \@x; } @processes;
73
74	foreach my $proc(@processes)
75	{
76		my $r = quotemeta $proc;
77		my @rps = 	uniq( map { $_ =~ /.*:(.*):.*/;  $1; }
78					grep { $_ =~ /Reactant|Product/ }
79					grep {$_ =~ /^$r:/ } @edges );
80		if(@wcs) { push @rps, getWCs(\@rps,\@wcs,\@edges); }
81		$reacprod{$proc} = \@rps;
82
83		my @cont = 	uniq( map { $_ =~ /.*:(.*):.*/;  $1; }
84					grep { $_ =~ /Context/ }
85					grep {$_ =~ /^$r:/ } @edges );
86		$context{$proc} = \@cont;
87	}
88	foreach my $r1(@processes)
89	{
90		foreach my $r2(@processes)
91		{
92			if(has_overlap($reacprod{$r1},$context{$r2}))
93			{
94				push @edges2, join(" ",($r1,$r2));
95			}
96		}
97	}
98	my %namesarr;
99	my %bpgs;
100	foreach my $proc(@processes)
101	{
102	my $r = quotemeta $proc;
103	my @reacs = 	sort {$a cmp $b}
104					uniq( map { $_ =~ /.*:(.*):.*/;  $1; }
105					grep { $_ =~ /Reactant/ }
106					grep {$_ =~ /^$r:/ } @edges );
107	$reac{$proc} = \@reacs;
108
109	my @prods = 	sort {$a cmp $b}
110					uniq( map { $_ =~ /.*:(.*):.*/;  $1; }
111					grep { $_ =~ /Product/ }
112					grep {$_ =~ /^$r:/ } @edges );
113	$prod{$proc} = \@prods;
114
115	my $namearr = [[$proc],\@reacs,\@prods];
116	#my $name = $proc."\n:".join("+",@reacs)."->".join("+",@prods)." }";
117	#my $name = make_name($namearr);
118	$namesarr{$proc} = $namearr;
119
120	# building embed graph here
121	if($embed)
122		{
123			my @embed_edges = grep { $_ =~ /Reactant|Product/ }
124							  grep {$_ =~ /^$r:/ } @edges ;
125			my @embed_nodes = uniq( map { $_ =~ /.*:(.*):.*/;  $1; } @embed_edges);
126			push @embed_nodes,$proc;
127			my %embed_nodetype;
128			my %nodetype = %{$bpg->{'NodeType'}};
129			@embed_nodetype { @embed_nodes } = @nodetype {@embed_nodes};
130			my $bpg2 = makeRuleNetworkGraph_simple(\@embed_nodes,\@embed_edges,\%embed_nodetype,$proc);
131			$bpgs{$proc} = $bpg2;
132		}
133	}
134
135	my %names;
136	map {$names{$_} = make_name($namesarr{$_});} @processes;
137
138	my $pg = ProcessGraph->new();
139	if($mergepairs==0)
140	{
141		$pg->{'Processes'} = \@processes;
142		#$pg->{'ReacProds'} = \%reacprod;
143		$pg->{'Names'} = \%names;
144		$pg->{'Edges'} = \@edges2;
145		if($embed) {$pg->{'Embed'} = \%bpgs;}
146		return $pg;
147	}
148
149	# mergepairs needs to be done correctly!
150	my @procs = @processes;
151	my @pairs;
152	my @unpaired;
153	if($mergepairs==1)
154	{
155		# build pairs;
156		# get a process from the stack
157		my @stack = @processes;
158
159		while(@stack)
160		{
161			my $proc1 = shift @stack;
162			my @stack2 = @stack;
163			my @stack3;
164			while(@stack2)
165				{
166				my $proc2 = shift @stack2;
167				if(is_reverse_of($reac{$proc1},$prod{$proc1},$reac{$proc2},$prod{$proc2}))
168					{
169					push @pairs, $proc1." ".$proc2;
170					#$pairs{$proc1} = $proc2;
171					last;
172					}
173				else
174					{
175					push @stack3,$proc2;
176					}
177				if(not @stack2) { push @unpaired,$proc1;}
178				}
179			@stack = (@stack2,@stack3);
180		}
181	}
182
183	my @procs_p;
184	my @edges_p;
185	my %names_p;
186	my %embed_p;
187	my %remaphash;
188	my %bpgs_p;
189	foreach my $pair(@pairs)
190	{
191		my ($dom,$sub) = split(" ",$pair);
192		my $proc = join(",",($dom,$sub));
193		push @procs_p, $proc;
194		$remaphash{$dom} = $proc;
195		$remaphash{$sub} = $proc;
196
197		my @name_arr = @{$namesarr{$dom}};
198		push2ref($name_arr[0],$sub);
199		my $name = make_name(\@name_arr);
200		$names_p{$proc} = $name;
201		if($embed)
202		{
203			my @bpgs2 = map {$bpgs{$_} } ($dom,$sub);
204			my $bpg = mergeNetworkGraphs(@bpgs2);
205			$bpgs_p{$proc} = $bpg;
206		}
207	}
208	foreach my $proc(@unpaired)
209	{
210		push @procs_p, $proc;
211		$remaphash{$proc} = $proc;
212		my $name = make_name($namesarr{$proc});
213		$names_p{$proc} = $name;
214		if($embed)
215		{
216			$bpgs_p{$proc} = $bpgs{$proc};
217		}
218	}
219	@edges_p =uniq( map
220	{
221		my @x = split(" ",$_);
222		join(" ",map {$remaphash{$_}} @x);
223	} @edges2);
224
225
226	$pg->{'Processes'} = \@procs_p;
227	#$pg->{'ReacProds'} = \%reacprod;
228	$pg->{'Names'} = \%names_p;
229	$pg->{'Edges'} = \@edges_p;
230	if($embed) {$pg->{'Embed'} = \%bpgs_p;}
231	return $pg;
232
233}
234
235sub reprocessWildcards
236{
237	my @edgelist = @{shift @_};
238	my @wc_edges = grep {$_ =~ /.*:.*:Wildcard$/ } @edgelist ;
239	my @wcs = uniq (map {$_ =~ /^(.*):.*:.*/; $1; } @wc_edges);
240	my @other_edges = grep { not has(\@wc_edges,$_) } @edgelist;
241
242	my @edges2;
243	foreach my $edge(@other_edges)
244	{
245		$edge =~ /^(.*):(.*):(.*)$/;
246		my ($rule,$pat,$rel) = ($1,$2,$3);
247		if($rel ne 'Context') { push @edges2,$edge; next;}
248		if(not has(\@wcs,$pat)) { push @edges2,$edge; next;}
249
250		my @matches = uniq( map {$_ =~ /^.*:(.*):.*$/; $1;} grep {$_ =~ /^(.*):.*:.*$/; $1 eq $pat} @wc_edges);
251		foreach my $pat2(@matches) { push @edges2, join(":",($rule,$pat2,$rel)); }
252	}
253	return uniq(@edges2);
254}
255
256sub makeProcessGraph2
257{
258	my $bpg = shift @_;
259	my %nodetype = %{$bpg->{'NodeType'}};
260	my @allnodes = @{$bpg->{'NodeList'}};
261	my @alledges = reprocessWildcards($bpg->{'EdgeList'});
262
263
264	my %args = %{shift @_};
265	my @processgrps = ();
266	my $pg;
267
268	if($args{'groups'}==0)
269	{
270		if($args{'mergepairs'}==0)
271			{
272				my @rules = grep { $nodetype{$_} eq 'Rule' } @allnodes;
273				my @reacprods = map [getRelationships(\@alledges,$_,['Reactant','Product'])],  @rules;
274				my @contexts = map [getRelationship(\@alledges,$_,'Context')],  @rules;
275
276				my @processes = @rules;
277				my @relations = ();
278				foreach my $i(0..@processes-1)
279				{
280					foreach my $j($i..@processes-1)
281						{
282							if( has_overlap($reacprods[$i],$contexts[$j]) )
283								{ push @relations, join(" ",($i,$j));}
284							next if($i == $j);
285							if( has_overlap($reacprods[$j],$contexts[$i]) )
286								{ push @relations, join(" ",($j,$i));}
287
288						}
289				}
290				@relations = uniq(@relations);
291				my @names = ($args{'embed'}==0) ? @processes : () x @processes;
292				$pg = initializeProcessGraph(\@processes,\@relations,[],\@names);
293			}
294		else
295			{
296				my @rules = grep { $nodetype{$_} eq 'Rule' } @allnodes;
297				# group rules and their reverses
298				my %revmap;
299				foreach my $rule(@rules)
300					{
301					# stupid naming conventions!
302					if($rule =~ /^(Rule[0-9]{.*})r$/)
303						{
304						my $pair = $1;
305						if(has(\@rules,$pair)) {$revmap{$rule} = $pair;}
306						}
307					elsif($rule =~ /^(.*)\(reverse\)$/)
308						{
309						my $pair = $1;
310						if(has(\@rules,$pair)) {$revmap{$rule} = $pair;}
311						}
312					}
313				my @paired =  (keys %revmap,values %revmap);
314				my @stack = ();
315				foreach my $rule(@rules)
316				{
317					if(not has(\@paired,$rule)) { my @x = ($rule); push @stack, \@x;}
318					if(has([keys %revmap],$rule)) { push @stack, [$revmap{$rule},$rule]; }
319				}
320
321				my @processes = @stack;
322				my @reacprods = map {
323									my @x = @$_;
324									my @y = map getRelationships(\@alledges,$_,['Reactant','Product']),@x;
325									\@y;
326									} @processes;
327				my @contexts = map {
328									my @x = @$_;
329									my @y = map getRelationship(\@alledges,$_,'Context'),@x;
330									\@y;
331									} @processes;
332
333				my @relations = ();
334				foreach my $i(0..@processes-1)
335				{
336					foreach my $j($i..@processes-1)
337						{
338							if( has_overlap($reacprods[$i],$contexts[$j]) )
339								{ push @relations, join(" ",($i,$j));}
340							next if($i == $j);
341							if( has_overlap($reacprods[$j],$contexts[$i]) )
342								{ push @relations, join(" ",($j,$i));}
343						}
344				}
345				@relations = uniq(@relations);
346
347				my @pr1 = map join(",",@$_), @processes;
348				my @names = ($args{'embed'}==0) ? @pr1 : () x @pr1;
349				$pg = initializeProcessGraph(\@processes,\@relations,[],\@names);
350			}
351	}
352
353	if($args{'groups'}==1)
354	{
355		my @rules = grep { $nodetype{$_} eq 'Rule' } @allnodes;
356		my %nodeclass = %{$bpg->{'NodeClass'}};
357		my %extended;
358		foreach my $node(@allnodes)
359		{
360			if(has([keys %nodeclass],$node)) { $extended{$node} = $nodeclass{$node}; }
361			else { $extended{$node} = $node; }
362		}
363		my @processes = uniq( map $extended{$_}, @rules);
364		my @reacprods = map {
365							my $p = $_;
366							my @x = grep {$extended{$_} eq $p} @rules;
367							my @y = map getRelationships(\@alledges,$_,['Reactant','Product']),@x;
368							my @z = uniq( map {$extended{$_}} @y );
369							\@z;
370							} @processes;
371		my @contexts = map {
372							my $p = $_;
373							my @x = grep {$extended{$_} eq $p} @rules;
374							my @y = map getRelationship(\@alledges,$_,'Context'),@x;
375							my @z = uniq( map {$extended{$_}} @y );
376							\@z;
377							} @processes;
378
379		if($args{'mergepairs'}==0)
380			{
381				my @relations = ();
382				foreach my $i(0..@processes-1)
383				{
384					foreach my $j($i..@processes-1)
385						{
386							if( has_overlap($reacprods[$i],$contexts[$j]) )
387								{ push @relations, join(" ",($i,$j));}
388							next if($i == $j);
389							if( has_overlap($reacprods[$j],$contexts[$i]) )
390								{ push @relations, join(" ",($j,$i));}
391						}
392				}
393				@relations = uniq(@relations);
394
395				#my @names = @processes;
396				my @names = ($args{'embed'}==0) ? @processes : () x @processes;
397				$pg = initializeProcessGraph(\@processes,\@relations,[],\@names);
398			}
399		else
400			{
401				my @procs2;
402				my @reacprods2;
403				my @contexts2;
404				my %merged;
405				@merged { 0..@processes-1 } = (0) x @processes;
406				foreach my $i(0..@processes-1)
407				{
408					next if ($merged{$i}==1);
409					my @rp1 = sort {$a cmp $b} uniq(@{$reacprods[$i]});
410					foreach my $j(($i+1)..@processes-1)
411						{
412							my @rp2 = sort {$a cmp $b} uniq(@{$reacprods[$j]});
413							if( arrayEquals(\@rp1,\@rp2) )
414							{
415								push @procs2, [$processes[$i],$processes[$j]];
416								push @reacprods2, \@rp1;
417								my @x = (@{$contexts[$i]},@{$contexts[$j]});
418								push @contexts2,\@x;
419								$merged{$i} = 1;
420								$merged{$j} = 1;
421							}
422						}
423					if($merged{$i} == 0)
424						{
425							push @procs2, [$processes[$i]];
426							push @reacprods2, \@rp1;
427							push @contexts2,[uniq(@{$contexts[$i]})];
428						}
429				}
430				my @relations = ();
431				foreach my $i(0..@procs2-1)
432				{
433					foreach my $j($i..@procs2-1)
434						{
435							if( has_overlap($reacprods2[$i],$contexts2[$j]) )
436								{ push @relations, join(" ",($i,$j));}
437							next if($i == $j);
438							if( has_overlap($reacprods2[$j],$contexts2[$i]) )
439								{ push @relations, join(" ",($j,$i));}
440						}
441				}
442				@relations = uniq(@relations);
443				my @pr1 = map join(",",@$_), @procs2;
444				my @names = ($args{'embed'}==0) ? @pr1 : () x @pr1;
445				$pg = initializeProcessGraph(\@procs2,\@relations,[],\@names);
446			}
447	}
448	return $pg;
449}
450
451sub embedProcessGraph
452{
453	my $pg = shift @_;
454	my $gr = shift @_;
455	my %args = %{shift @_};
456	my $bpg = $gr->{'RuleNetworkCurrent'};
457	my $bpg2;
458	#my $bpg2 = collapseNetworkGraph($bpg);
459
460	my @nodes = @{$pg->{'Nodes'}};
461	my @names = @{$pg->{'Names'}};
462	my @embed = () x @nodes;
463	my $mergepairs = $args{'mergepairs'};
464	my $groups = $args{'groups'};
465	if($groups) {$bpg2 = collapseNetworkGraph($bpg);}
466	else {$bpg2 = $bpg;}
467
468	my @reacprods = grep {$_ =~ /^.*:.*:(.*)/; has(['Reactant','Product'],$1);}
469					@{$bpg2->{'EdgeList'}};
470	my @rsgs = map {@$_;} flat($gr->{'RuleStructureGraphs'});
471	my @rnames = map {@$_;} flat($gr->{'RuleNames'});
472	foreach my $i(0..@nodes-1)
473	{
474		my $node = $nodes[$i];
475		my @arr = ($mergepairs==1) ? @$node : ($node);
476		if($groups==1)
477		{
478			my @edges = map {
479							my $x = $_;
480							grep {$_ =~ /^(.*):.*:.*/; $1 eq $x}
481							@reacprods
482							} @arr;
483			@edges = uniq(@edges);
484			$embed[$i] = makeRuleNetworkGraphFromEdges(\@edges,$bpg2->{'NodeType'},$names[$i]);
485		}
486		else
487		{
488			my @rsgs1 = map {
489							my $x = $_;
490							map {$rsgs[$_]}
491							grep {$rnames[$_] eq $x} 0..@rnames-1;
492							} @arr;
493			$embed[$i] = combine2(\@rsgs1);
494		}
495	}
496	$pg->{'Embed'} = \@embed;
497	return;
498}
499sub getRelationship
500{
501	my @edgelist = @{shift @_};
502	my $node = shift @_;
503	my $reltype = shift @_;
504
505	my @edges = grep { $_ =~ /.*:.*:(.*)$/; $1 eq $reltype} @edgelist;
506	my @arr1 = map { $_ =~ /^(.*):.*:.*$/; $1;} grep { $_ =~ /.*:(.*):.*$/; $1 eq $node} @edges;
507	my @arr2 = map { $_ =~ /.*:(.*):.*$/; $1;} grep { $_ =~ /^(.*):.*:.*$/; $1 eq $node} @edges;
508	return (@arr1,@arr2);
509}
510
511sub getRelationships
512{
513	my $edgelist = shift @_;
514	my $node = shift @_;
515	my @reltypes = @{shift @_};
516	my @arr = map {getRelationship($edgelist,$node,$_)} @reltypes;
517	return @arr;
518}
519sub is_reverse_of
520{
521	my @proc1_reac = sort {$a cmp $b} @{shift @_};
522	my @proc1_prod = sort {$a cmp $b} @{shift @_};
523	my @proc2_reac = sort {$a cmp $b} @{shift @_};
524	my @proc2_prod = sort {$a cmp $b} @{shift @_};
525	my $ret = 0;
526	$ret = 1 if(scalar @proc1_reac and arrayEquals(\@proc1_reac,\@proc2_prod));
527	$ret = 1 if(scalar @proc1_prod and arrayEquals(\@proc1_prod,\@proc2_reac));
528	return $ret;
529}
530
531sub has_overlap
532{
533	my @x = @{shift @_};
534	my @y = @{shift @_};
535	my @z = grep {has(\@y,$_) } @x;
536	return (scalar(@z) > 0) ? 1: 0;
537}
538sub getWCs
539{
540	my @aps = @{shift @_};
541	my @wcs = @{shift @_};
542	my @edges = @{shift @_};
543	my @rets = ();
544	foreach my $ap(@aps)
545	{
546		foreach my $wc(@wcs)
547		{
548			my $str = join(":",($wc,$ap,'Wildcard'));
549			my @matches = grep {$_ eq $str} @edges;
550			if(@matches) { push @rets,map {$_ =~ /^(.*):.*:.*/; $1; } @matches; }
551		}
552	}
553	return uniq(@rets);
554}
555
556sub make_name
557{
558	my ($x,$y,$z) = @{shift @_};
559	my @procs = @$x;
560	my @reac = sort {$a cmp $b} @$y;
561	my @prod = sort {$a cmp $b} @$z;
562
563	my $str1 = join(",",@procs);
564	my $str2 = join("+",@reac);
565	my $str3 = join("+",@prod);
566
567	my $arrow = (scalar @procs > 1) ? "<->" : "->";
568	#return $str1."\n".$str2.$arrow.$str3;
569	return $str2.$arrow.$str3;
570}
571
572sub arrayEquals
573{
574	my @arr1 = sort {$a cmp $b} @{shift @_};
575	my @arr2 = sort {$a cmp $b} @{shift @_};
576
577	return 0 if (scalar @arr1 != scalar @arr2);
578	foreach my $i(0..@arr1-1)
579		{
580			return 0 if ($arr1[$i] ne $arr2[$i]);
581		}
582	return 1;
583}
5841;
585