[Bio] / FigKernelPackages / P2Pupdate.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/P2Pupdate.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.49 - (view) (download) (as text)

1 : efrank 1.1 package P2Pupdate;
2 :    
3 : olson 1.33 use strict;
4 :    
5 : olson 1.41 use Safe;
6 : efrank 1.1 use FIG_Config;
7 :     use FIG;
8 :     use Carp;
9 :     use Data::Dumper;
10 :     use Cwd;
11 :    
12 :     =pod
13 :    
14 :     =head1 updating code
15 :    
16 :     This routine packages what is needed to upgrade an older system to the
17 :     current code. Code releases are numered
18 :    
19 :     p1n1.p2n2.p3n3...
20 :    
21 :     where "." is added at the point the code moved to another branch of
22 :     the tree. FIG, who provided the initial release of the SEED, will
23 :     number all of their code releases as
24 :    
25 :     FIGn
26 :    
27 :     where n is an integer. Suppose that between releases 13 and 14 a
28 :     second group (which we will term "Idiots" for convenience) took
29 :     release 13 and wished to branch the code tree. At that point, they
30 :     would name their first release as
31 :    
32 :     FIG13.Idiots1
33 :    
34 :     We are, of course, being both cavalier and nasty when we make such a
35 :     reference. We do, however, wish to express the view that it will
36 :     benefit everyone to attempt to reconcile differences and maintain a
37 :     single code progression as long as possible. There are often good
38 :     reasons to part ways, but we urge people to think carefully before
39 :     taking such a step.
40 :    
41 :     Two code releases
42 :    
43 :     i1.i2.i3...in
44 :     and j1.j2.j3...jm with m <= n
45 :    
46 :     are compatible iff
47 :    
48 :     ip == jp for p < m, and
49 :     jm and im have the same "source" and
50 :     jm <= im
51 :    
52 :     A new code release must have the property that it can bring any
53 :     "older" compatible release up to its release.
54 :    
55 :     Note that there is an issue relating to the code to build/install packages.
56 :     Since a system may be radically restructured between releases of code, the
57 :     code to build a "package" and the code to "install" a package are radically
58 :     separated. For example, the code in P2Pupdate.pm for building an assignment
59 :     package and the code for installing an assignment package both apply to the
60 :     release of code current on the system containing P2Pupdate.pm. In fact, the
61 :     code releases may be quite different on two synchronizing systems.
62 :    
63 :     To make things work the following rules must be observed:
64 :    
65 :     1. a code release is a tar file containing VERSION, Packages,
66 :     bin/ToolTemplates, and CGI/ToolTemplates. The installing system needs
67 :     to place these at the appropriate spots, and then run bring_system_up_to_date,
68 :     which is supposed to do any required restructuring.
69 :    
70 :     2. an assignments package is a tar file containing a single directory. The directory
71 :     contains subdirectories -- one per genome. Each genome subdirectory contains zero
72 :     or more files. The name of the file is the "user" and the contents will be the
73 :     assignments made by that user.
74 :    
75 :     3. an annotations package is a tar file containing a single directory. The files in
76 :     the directory are named by genome. They contain the annotations for the genome.
77 :    
78 :     =cut
79 :    
80 :     =pod
81 :    
82 :     =head1 what_code_do_I_have
83 :    
84 :     usage: &what_code_do_I_have($fig_base)
85 :    
86 :     This just returns the current version of the code.
87 :    
88 :     =cut
89 :    
90 :     sub what_code_do_I_have {
91 :     my($fig_base) = @_;
92 :    
93 : olson 1.34 my $version = &FIG::file_read("$fig_base/VERSION");
94 :     chomp $version;
95 : efrank 1.1 return $version;
96 :     }
97 :    
98 :     =pod
99 :    
100 :     =head1 updatable_code
101 :    
102 :     usage: &updatable_code_code($v1,$v2)
103 :    
104 :     This just returns true iff the two versions of code are compatible and $v1
105 :     is "more recent".
106 :    
107 :     =cut
108 :    
109 :     sub updatable_code {
110 :     my($v1,$v2) = @_;
111 :     my($i,$v1p,$v1n,$v2p,$v2n);
112 :    
113 :     my @v1 = split(/\./,$v1);
114 :     my @v2 = split(/\./,$v2);
115 :     if (@v1 < @v2) { return 0 }
116 :    
117 :     for ($i=0; ($i < $#v2) && ($v1[$i] eq $v2[$i]); $i++) {}
118 :     if ($i == $#v2)
119 :     {
120 :     $v1[$i] =~ /^(.*[^\d])(\d+)$/;
121 :     $v1p = $1;
122 :     $v1n = $2;
123 :    
124 :     $v2[$i] =~ /^(.*[^\d])(\d+)$/;
125 :     $v2p = $1;
126 :     $v2n = $2;
127 :    
128 :     return (($v2p eq $v1p) && ($v2n < $v1n));
129 :     }
130 :     return 0;
131 :     }
132 :    
133 :     =pod
134 :    
135 :     =head1 package_code
136 :    
137 :     usage: &package_code($fig_disk,$file)
138 :    
139 :     $fig_base must be an absolute filename (begins with "/") giving the FIG from which
140 :     the updated code release will be taken.
141 :    
142 :     $file must be an absolute filename where the "code package" will be built.
143 :    
144 :     =cut
145 :    
146 :     sub package_code {
147 :     my($fig_disk,$file) = @_;
148 :    
149 :     &force_absolute($fig_disk);
150 :     &force_absolute($file);
151 : olson 1.34 my @tmp = &FIG::file_head("$fig_disk/CURRENT_RELEASE", 1);
152 : overbeek 1.2 my $current_release = $tmp[0];
153 : olson 1.34 chomp $current_release;
154 : overbeek 1.2
155 :     &FIG::run("cd $fig_disk/dist/releases; tar czf $file $current_release");
156 : efrank 1.1 }
157 :    
158 :     sub force_absolute {
159 :     my($file) = @_;
160 :    
161 :     if (substr($file,0,1) ne "/")
162 :     {
163 : overbeek 1.2 print "Error: Please use absolute file names (i.e., /Users/fig/... or /home/fig/...)\n";
164 :     exit;
165 : efrank 1.1 }
166 :     }
167 :    
168 :     =pod
169 :    
170 :     =head1 install_code
171 :    
172 :     usage: &install_code($fig_disk,$package)
173 :    
174 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
175 :    
176 :     $package must be an absolute filename where the "code package" from which to make
177 :     the update exists.
178 :    
179 :     Note that this routine does not check that the updated code is compatible, or even less
180 :     current. It is assumed that upper level logic is doing that.
181 :    
182 :     =cut
183 :    
184 :     sub install_code {
185 :     my($fig_disk,$package) = @_;
186 :     my $fig_base = "$fig_disk/FIG";
187 :     &force_absolute($fig_base);
188 :     &force_absolute($package);
189 :    
190 :     if (getcwd() !~ /FIGdisk$/) { print die "Sorry, you must run this while in $FIG_Config::fig_disk" }
191 :    
192 :    
193 :     (! -d "$fig_disk/BackupCode") || &FIG::run("rm -rf $fig_disk/BackupCode");
194 :     mkdir("$fig_disk/BackupCode",0777) || die "Could not make the BackupCode directory";
195 :     (! -d "$fig_disk/BackupEnv") || &FIG::run("rm -rf $fig_disk/BackupEnv");
196 :     mkdir("$fig_disk/BackupEnv",0777) || die "Could not make the BackupEnv directory";
197 :    
198 :     my $version = &what_code_do_I_have($fig_base);
199 :     &FIG::run("cd $fig_disk; mv README install lib man env src $fig_disk/BackupEnv");
200 :     &FIG::run("cd $fig_base; mv VERSION Packages CGI $fig_disk/BackupCode");
201 :     print STDERR "made backups\n";
202 :    
203 :     &FIG::run("cd $fig_disk; tar xzf $package");
204 :     print STDERR "untarred new code\n";
205 :    
206 :     &fix_config("$fig_base/Packages/FIG_Config.pm","$fig_disk/BackupCode/Packages/FIG_Config.pm");
207 :     &FIG::run("cd $fig_base/bin; touch ToolTemplates/*/*; make all");
208 :     &FIG::run("cd $fig_base/CGI; touch ToolTemplates/*/*; make all");
209 :     print STDERR "installed new bin and CGI\n";
210 :    
211 :     &FIG::run("bring_system_up_to_date $version");
212 :     }
213 :    
214 :     =pod
215 :    
216 :     =head1 package_lightweight_code
217 :    
218 :     usage: &package_lightweight_code($fig_disk,$file)
219 :    
220 :     $fig_base must be an absolute filename (begins with "/") giving the FIG from which
221 :     the updated code release will be taken.
222 :    
223 :     $file must be an absolute filename where the "code package" will be built.
224 :    
225 :     =cut
226 :    
227 :     sub package_lightweight_code {
228 :     my($fig_disk,$file) = @_;
229 :    
230 :     &force_absolute($fig_disk);
231 :     &force_absolute($file);
232 : olson 1.34 my @tmp = &FIG::file_head("$fig_disk/CURRENT_RELEASE", 1);
233 : overbeek 1.2 my $current_release = $tmp[0];
234 : olson 1.34 chomp $current_release;
235 : overbeek 1.2
236 :     &FIG::run("cd $fig_disk/dist/releases; tar czf $file $current_release");
237 : efrank 1.1 }
238 :    
239 :     =pod
240 :    
241 :     =head1 install_lightweight_code
242 :    
243 :     usage: &install_lightweight_code($fig_disk,$package)
244 :    
245 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
246 :    
247 :     $package must be an absolute filename where the "code package" from which to make
248 :     the update exists.
249 :    
250 :     Note that this routine does not check that the updated code is compatible, or even less
251 :     current. It is assumed that upper level logic is doing that.
252 :    
253 :     =cut
254 :    
255 :     sub install_lightweight_code {
256 :     my($fig_disk,$package) = @_;
257 :     my $fig_base = "$fig_disk/FIG";
258 :     &force_absolute($fig_base);
259 :     &force_absolute($package);
260 :    
261 : overbeek 1.2 if (! mkdir("$fig_disk/Tmp$$",0777))
262 :     {
263 :     print "Error: could not make $fig_disk/Tmp$$\n";
264 :     exit;
265 :     }
266 : efrank 1.1
267 : overbeek 1.2 &FIG::run("cd $fig_disk/Tmp$$; tar xzf $package");
268 :     if (! opendir(TMP,"$fig_disk/Tmp$$"))
269 :     {
270 :     print "Error: could not open $fig_disk/Tmp$$\n";
271 :     exit;
272 :     }
273 : efrank 1.1
274 : overbeek 1.2 my @rels = grep { $_ !~ /^\./ } readdir(TMP);
275 :     closedir(TMP);
276 :     if (@rels != 1)
277 :     {
278 :     print "Error: Bad code package: $package\n";
279 :     exit;
280 :     }
281 : efrank 1.1
282 : overbeek 1.2 my $new_release = $rels[0];
283 :     if (-d "$fig_disk/dist/releases/$new_release")
284 :     {
285 :     print "Error: $new_release already exists; we are doing nothing\n";
286 :     exit;
287 :     }
288 : efrank 1.1
289 : efrank 1.3 &FIG::run("mv $fig_disk/Tmp$$/$new_release $fig_disk/dist/releases");
290 :     &FIG::run("rm -rf $fig_disk/Tmp$$");
291 : olson 1.22
292 :     #
293 :     # Ugh. For now, find the arch in the fig config file $fig_disk/config/fig-user-env.sh"
294 :     #
295 :    
296 :     my $arch;
297 :     open(FH, "<$fig_disk/config/fig-user-env.sh");
298 :     while (<FH>)
299 :     {
300 :     if (/RTARCH="(.*)"/)
301 :     {
302 :     $arch = $1;
303 :     last;
304 :     }
305 :     }
306 :     close(FH);
307 :    
308 :     if ($arch eq "")
309 :     {
310 :     die "Couldn't determine SEED install architecture, not switching to release.";
311 :     }
312 :    
313 :     $ENV{RTARCH} = $arch;
314 : olson 1.32
315 :     #
316 :     # Need to put the ext_bin in the path.
317 :     #
318 :    
319 :     $ENV{PATH} .= ":$FIG_Config::ext_bin";
320 : olson 1.22
321 : efrank 1.9 &FIG::run("$FIG_Config::bin/switch_to_release $new_release");
322 : efrank 1.1 }
323 :    
324 :    
325 :     sub fix_config {
326 :     my($new,$old) = @_;
327 :     my($line,$i);
328 :    
329 : olson 1.34 my @new = &FIG::file_read($new);
330 :     foreach $line (&FIG::file_read($old))
331 : efrank 1.1 {
332 :     if ($line =~ /^(\S+)\s+\=/)
333 :     {
334 : olson 1.33 my $var = $1;
335 :     my $varQ = quotemeta $var;
336 : efrank 1.1
337 :     for ($i=0; ($i < $#new) && ($new[$i] !~ /^$varQ\s+\=/); $i++) {}
338 :     if ($i == $#new)
339 :     {
340 :     splice(@new,$i,0,$line);
341 :     }
342 :     else
343 :     {
344 :     splice(@new,$i,1,$line);
345 :     }
346 :     }
347 :     }
348 :     open(NEW,">$new") || confess "could not overwrite $new";
349 :     foreach $line (@new)
350 :     {
351 :     print NEW $line;
352 :     }
353 :     close(NEW);
354 :     }
355 :    
356 :     =pod
357 :    
358 :     =head1 what_genomes_will_I_sync
359 :    
360 :     usage: &what_genomes_will_I_sync($fig_base,$who)
361 :    
362 :     This routine returns the list of genome IDs that you are willing to sync with $who.
363 :    
364 :     =cut
365 :    
366 :     sub what_genomes_will_I_sync {
367 :     my($fig_base,$who) = @_;
368 :    
369 :     # This is the promiscuous version - it will sync all genomes with anyone.
370 :    
371 :     opendir(GENOMES,"$fig_base/Data/Organisms") || die "could not open $fig_base/Data/Organisms";
372 :     my @genomes = grep { $_ =~ /^\d+\.\d+$/ } readdir(GENOMES);
373 :     closedir(GENOMES);
374 :     return @genomes;
375 :     }
376 :    
377 :     =pod
378 :    
379 :     =head1 package_annotations
380 :    
381 : overbeek 1.29 usage: &package_annotations($fig,$genomes,$file)
382 : efrank 1.1
383 :     $genomes is a pointer to a list of genome IDs that will be exchanged.
384 :    
385 :     $file must be an absolute filename where the "annotation package" will be built.
386 :    
387 :     =cut
388 :    
389 :     sub package_annotations {
390 : overbeek 1.29 my($fig,$who,$date,$genomes,$file) = @_;
391 :     my $fig_base = "$FIG_Config::fig_disk/FIG";
392 : efrank 1.1
393 : overbeek 1.29 if (open(ANNOTATIONS,">$file"))
394 : efrank 1.1 {
395 : overbeek 1.29 my @annotations = sort { $a->[0] cmp $b->[0] } $fig->annotations_made($genomes,$who,$date);
396 : olson 1.33 foreach my $x (@annotations)
397 : efrank 1.1 {
398 : overbeek 1.45 my $ann = join("\n",@$x);
399 :     if (($ann =~ /^fig\|\d+\.\d+\.peg\.\d+\n\d+\n/s) && ($ann !~ /\n\/\/\n/s))
400 :     {
401 :     print ANNOTATIONS join("\n",@$x),"\n///\n";
402 :     }
403 : efrank 1.1 }
404 : overbeek 1.29 print ANNOTATIONS "//\n";
405 : efrank 1.15
406 : olson 1.33 foreach my $x (@annotations)
407 : efrank 1.15 {
408 : olson 1.33 my $peg = $x->[0];
409 : overbeek 1.30 my @aliases = grep { $_ =~ /^(sp\||gi\||pirnr\||kegg\||N[PGZ]_)/ } $fig->feature_aliases($peg);
410 :     print ANNOTATIONS join("\t",($peg,join(",",@aliases),$fig->genus_species($fig->genome_of($peg)),scalar $fig->function_of($peg))) . "\n";
411 : efrank 1.15 }
412 : overbeek 1.29 print ANNOTATIONS "//\n";
413 :    
414 : olson 1.33 foreach my $x (@annotations)
415 : efrank 1.15 {
416 : olson 1.33 my $peg;
417 : overbeek 1.29 ($peg,undef) = @$x;
418 : overbeek 1.30 my $seq = $fig->get_translation($peg);
419 : overbeek 1.29 &FIG::display_id_and_seq($peg,\$seq,\*ANNOTATIONS);
420 : efrank 1.15 }
421 : overbeek 1.29 close(ANNOTATIONS);
422 : efrank 1.15 }
423 : efrank 1.1 }
424 :    
425 : overbeek 1.29
426 : efrank 1.1 =pod
427 :    
428 :     =head1 install_annotations
429 :    
430 :     usage: &install_annotations($fig_disk,$package)
431 :    
432 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
433 :    
434 :     $package must be an absolute filename where the "annotations package" from which to make
435 :     the update exists.
436 :    
437 :     =cut
438 :    
439 :     sub install_annotations {
440 : overbeek 1.29 my($fig,$package) = @_;
441 :     my($user,$who,$date,$userR,@assignments,$peg,$aliases,$org,$func);
442 :     my(%pegs,%seq_of,@seq,$peg_to,$trans_pegs,$seq,$line,@ann,$ann);
443 : efrank 1.1 my($genome);
444 :    
445 : overbeek 1.29 my $fig_disk = $FIG_Config::fig_disk;
446 :     open(IN,"<$package") || die "could not open $package";
447 :     $/ = "\n//\n";
448 :     if (defined($line = <IN>))
449 :     {
450 : olson 1.33 my(@annotations);
451 :    
452 : overbeek 1.29 $line =~ s/\n\/\/\n/\n/s;
453 :     @ann = split(/\n\/\/\/\n/,$line);
454 :     foreach $ann (@ann)
455 :     {
456 :     if ($ann =~ /^(fig\|\d+\.\d+\.peg\.\d+)\n(\d+)\n(\S+)\n(.*)/s)
457 :     {
458 :     push(@annotations,[$1,$2,$3,$4]);
459 :     }
460 :     }
461 :     $/ = "\n";
462 :     while ($line && defined($line = <IN>) && ($line !~ /^\/\//))
463 :     {
464 : olson 1.34 chomp $line;
465 : overbeek 1.29 ($peg,$aliases,$org,$func) = split(/\t/,$line);
466 :     $pegs{$peg} = [$aliases,$org,$func];
467 :     }
468 :    
469 :     if ($line) { $line = <IN> }
470 :     while (defined($line) && ($line !~ /^\/\//))
471 :     {
472 :     if ($line =~ /^>(\S+)/)
473 :     {
474 :     $peg = $1;
475 :     @seq = ();
476 : overbeek 1.44 $line = <IN>;
477 :     while ($line && ($line !~ /^[>\/]/) && ($line !~ /^\/\//))
478 : overbeek 1.29 {
479 :     push(@seq,$line);
480 :     $line = <IN>;
481 :     }
482 :     $seq = join("",@seq);
483 :     $seq =~ s/[ \n\t]//gs;
484 :     $seq_of{$peg} = uc $seq;
485 :     }
486 : overbeek 1.46 else
487 :     {
488 :     $line = <IN>;
489 :     }
490 : overbeek 1.29 }
491 :     close(IN);
492 :     $trans_pegs = $fig->translate_pegs(\%pegs,\%seq_of);
493 :     @annotations = sort { ($a->[0] cmp $b->[0]) or ($a->[1] <=> $b->[1]) }
494 :     map { ($peg = $trans_pegs->{$_->[0]}) ? [$peg,$_->[1],$_->[2],$_->[3]] : () }
495 :     @annotations;
496 :    
497 :     if (-d "$fig_disk/BackupAnnotations") { system "rm -rf $fig_disk/BackupAnnotations" }
498 :     mkdir("$fig_disk/BackupAnnotations",0777);
499 :     mkdir("$fig_disk/BackupAnnotations/New",0777);
500 : olson 1.33 my $i;
501 :     for ($i=0; ($i < @annotations); $i++)
502 : overbeek 1.29 {
503 :     if (($i == 0) || ($fig->genome_of($annotations[$i]->[0]) ne $fig->genome_of($annotations[$i-1]->[0])))
504 :     {
505 :     if ($i != 0)
506 :     {
507 :     close(OUT);
508 :     }
509 :     $genome = $fig->genome_of($annotations[$i]->[0]);
510 :     open(OUT,">$fig_disk/BackupAnnotations/New/$genome")
511 :     || die "could not open $fig_disk/BackupAnnotations/New/$genome";
512 :     }
513 :     print OUT join("\n",@{$annotations[$i]}),"\n//\n";
514 :     }
515 :     if ($i > 0) { close(OUT) }
516 :     }
517 : efrank 1.15
518 : efrank 1.1 opendir(TMP,"$fig_disk/BackupAnnotations/New") || die "could not open $fig_disk/BackupAnnotations/New";
519 :     my @genomes = grep { $_ =~ /^\d+\.\d+$/ } readdir(TMP);
520 :     closedir(TMP);
521 :     foreach $genome (@genomes)
522 :     {
523 : overbeek 1.43 next if (! -d "$fig_disk/FIG/Data/Organisms/$genome");
524 : efrank 1.13
525 : efrank 1.1 print STDERR "installing $fig_disk/FIG/Data/Organisms/$genome/annotations\n";
526 :     if (-s "$fig_disk/FIG/Data/Organisms/$genome/annotations")
527 :     {
528 :     &FIG::run("cp -p $fig_disk/FIG/Data/Organisms/$genome/annotations $fig_disk/BackupAnnotations/$genome");
529 : efrank 1.9 &FIG::run("$FIG_Config::bin/merge_annotations $fig_disk/BackupAnnotations/$genome $fig_disk/BackupAnnotations/New/$genome > $fig_disk/FIG/Data/Organisms/$genome/annotations");
530 : efrank 1.1 }
531 :     else
532 :     {
533 :     &FIG::run("cp $fig_disk/BackupAnnotations/New/$genome $fig_disk/FIG/Data/Organisms/$genome/annotations");
534 :     }
535 : olson 1.37 chmod 0777,"$fig_disk/FIG/Data/Organisms/$genome/annotations";
536 : efrank 1.1 }
537 : efrank 1.9 &FIG::run("$FIG_Config::bin/index_annotations");
538 : efrank 1.1 }
539 : olson 1.47
540 :    
541 :     =pod
542 :    
543 :     =head1 install_annotations_gff
544 :    
545 :     Install a set of annotations contained in a GFF3 file package.
546 :    
547 :     We parse using the FigGFF::GFFParser GFF parser. This returns a GFFFile object
548 :     that contains the parsed contents of the file.
549 :    
550 :     =cut
551 :    
552 :     sub install_annotations_gff
553 :     {
554 :     my($fig, $gff_file) = @_;
555 :    
556 :     my $db = $fig->db_handle;
557 :    
558 :     my $parser = new GFFParser($fig);
559 :    
560 :     my $fobj = $parser->parse($gff_file);
561 :    
562 :     #
563 :     # We assume that we only have one genome per GFF file, but we
564 :     # get the list of genomes and checksums via a general accessor anyway.
565 :     #
566 :    
567 :     for my $ent (@{$fobj->genome_checksums()})
568 :     {
569 :     my($genome, $checksum) = @$ent;
570 :    
571 :     #
572 :     # Determine if we have the same version of this genome.
573 :     #
574 :    
575 :     my $local_genome = $fig->genome_with_md5sum($checksum);
576 :     print "Local genome=$local_genome cksum=$checksum\n";
577 :    
578 :     #
579 :     # Walk the features, looking for matching features in the local SEED,
580 :     # and install the annotations if possible.
581 :     #
582 :    
583 :     my @annos;
584 :    
585 :     print "Walking $genome\n";
586 :     for my $feature (@{$fobj->features_for_genome($genome)})
587 :     {
588 :     my($local_id);
589 :    
590 :     my @local_ids = $feature->find_local_feature($local_genome);
591 :    
592 :     print "Mapped to @local_ids\n";
593 :     }
594 :     }
595 :     }
596 :    
597 : efrank 1.1
598 :     =pod
599 :    
600 :     =head1 restore_annotations
601 :    
602 :     usage: &restore_annotations($fig_disk);
603 :    
604 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
605 :    
606 :     =cut
607 :    
608 :     sub restore_annotations {
609 :     my($fig_disk) = @_;
610 :    
611 :     &force_absolute($fig_disk);
612 :     (-d "$fig_disk/BackupAnnotations") || die "could not find an active backup";
613 :     opendir(TMP,"$fig_disk/BackupAnnotations") || die "could not open $fig_disk/BackupAnnotations";
614 :     my @genomes = grep { $_ =~ /^\d+\.\d+$/ } readdir(TMP);
615 :     closedir(TMP);
616 : olson 1.33 foreach my $genome (@genomes)
617 : efrank 1.1 {
618 :     unlink("$fig_disk/FIG/Data/Organisms/$genome/annotations");
619 :     &FIG::run("cp $fig_disk/BackupAnnotations/$genome $fig_disk/FIG/Data/Organisms/$genome/annotations");
620 : olson 1.37 system "chmod 777 $fig_disk/FIG/Data/Organisms/$genome/annotations";
621 : efrank 1.1 }
622 : efrank 1.9 &FIG::run("$FIG_Config::bin/index_annotations");
623 : efrank 1.1 }
624 :    
625 :     =pod
626 :    
627 :     =head1 package_aassignments
628 :    
629 : overbeek 1.20 usage: package_assignments($fig,$user,$who,$date,$genomes,$file)
630 : efrank 1.1
631 : overbeek 1.20 $user designates the user wishing to get the assignments
632 : efrank 1.1
633 : overbeek 1.5 $who designates whose assignments you want (defaults to "master")
634 :    
635 :     $date if given indicates a point in time (get assignments after that point)
636 :    
637 : efrank 1.1 $genomes is a pointer to a list of genome IDs that will be exchanged.
638 :    
639 :     $file must be an absolute filename where the "assignment package" will be built.
640 :    
641 :     =cut
642 :    
643 :     sub package_assignments {
644 : overbeek 1.20 my($fig,$user,$who,$date,$genomes,$file) = @_;
645 : overbeek 1.27 my($genome,$x,$org,$curr,$peg);
646 : overbeek 1.4 $who = $who ? $who : "master";
647 : overbeek 1.7 $date = $date ? $date : 0;
648 : overbeek 1.27
649 : overbeek 1.20 if (open(ASSIGNMENTS,">$file"))
650 : efrank 1.1 {
651 : overbeek 1.20 print ASSIGNMENTS "$user\t$who\t$date\n";
652 : olson 1.33 my @assignments = sort { $a->[0] cmp $b->[0] } $fig->assignments_made_full($genomes,$who,$date);
653 : overbeek 1.36 my @curr_assignments = ();
654 : overbeek 1.27 foreach $x (@assignments)
655 : efrank 1.1 {
656 : overbeek 1.36 my($peg, $function, undef, undef) = @$x;
657 :     if ($function eq $fig->function_of($peg,$who))
658 :     {
659 :     print ASSIGNMENTS join("\t", $peg, $function),"\n";
660 :     push(@curr_assignments,$x);
661 :     }
662 : overbeek 1.4 }
663 : overbeek 1.27 print ASSIGNMENTS "//\n";
664 :    
665 : overbeek 1.36 foreach $x (@curr_assignments)
666 : overbeek 1.27 {
667 :     ($peg,undef) = @$x;
668 : overbeek 1.30 my @aliases = grep { $_ =~ /^(sp\||gi\||pirnr\||kegg\||N[PGZ]_)/ } $fig->feature_aliases($peg);
669 : olson 1.33
670 :     my $alias_txt = join(",",@aliases);
671 :     my $gs_txt = $fig->genus_species($fig->genome_of($peg));
672 :     my $func_txt = scalar $fig->function_of($peg);
673 :    
674 :     print ASSIGNMENTS join("\t",($peg,
675 :     $alias_txt,
676 :     $gs_txt,
677 :     $func_txt)) . "\n";
678 : overbeek 1.28 }
679 :     print ASSIGNMENTS "//\n";
680 :    
681 : overbeek 1.36 foreach $x (@curr_assignments)
682 : overbeek 1.28 {
683 :     ($peg,undef) = @$x;
684 : overbeek 1.30 my $seq = $fig->get_translation($peg);
685 : overbeek 1.27 &FIG::display_id_and_seq($peg,\$seq,\*ASSIGNMENTS);
686 :     }
687 :     close(ASSIGNMENTS);
688 : efrank 1.1 }
689 :     }
690 :    
691 :     =pod
692 :    
693 :     =head1 install_assignments
694 :    
695 : overbeek 1.20 usage: &install_assignments($package)
696 : efrank 1.1
697 : overbeek 1.20 $package must be a filename where the "assignments package" from which to make
698 :     the assignment set exists
699 : efrank 1.1
700 :     =cut
701 :    
702 :     sub install_assignments {
703 : overbeek 1.35 my($fig,$package,$make_assignments) = @_;
704 : overbeek 1.29 my($user,$who,$date,$userR,@assignments,$peg,$aliases,$org,$func);
705 :     my(%pegs,%seq_of,@seq,$peg_to,$trans_pegs,$seq);
706 : efrank 1.1
707 : overbeek 1.20 open(IN,"<$package") || die "could not open $package";
708 :     my $line = <IN>;
709 : olson 1.34 chomp $line;
710 : overbeek 1.20 ($user,$who,$date) = split(/\t/,$line);
711 : olson 1.26 $userR = $user;
712 :     $userR =~ s/^master://;
713 : overbeek 1.29
714 : overbeek 1.30 while (defined($line = <IN>) && ($line !~ /^\/\//))
715 : overbeek 1.29 {
716 :     if ($line =~ /^(fig\|\d+\.\d+\.peg\.\d+)\t(\S.*\S)/)
717 :     {
718 :     push(@assignments,[$1,$2]);
719 :     }
720 :     }
721 :     while ($line && defined($line = <IN>) && ($line !~ /^\/\//))
722 :     {
723 : olson 1.34 chomp $line;
724 : overbeek 1.29 ($peg,$aliases,$org,$func) = split(/\t/,$line);
725 :     $pegs{$peg} = [$aliases,$org,$func];
726 :     }
727 :    
728 :     if ($line) { $line = <IN> }
729 :     while (defined($line) && ($line !~ /^\/\//))
730 :     {
731 :     if ($line =~ /^>(\S+)/)
732 :     {
733 :     $peg = $1;
734 :     @seq = ();
735 : overbeek 1.44 $line = <IN>;
736 :     while ($line && ($line !~ /^[>\/]/) && ($line !~ /^\/\//))
737 : overbeek 1.29 {
738 :     push(@seq,$line);
739 :     $line = <IN>;
740 :     }
741 :     $seq = join("",@seq);
742 :     $seq =~ s/[ \n\t]//gs;
743 :     $seq_of{$peg} = uc $seq;
744 :     }
745 : overbeek 1.46 else
746 :     {
747 :     $line = <IN>;
748 : olson 1.47 }
749 : overbeek 1.29 }
750 :     close(IN);
751 :     $trans_pegs = $fig->translate_pegs(\%pegs,\%seq_of);
752 :    
753 : olson 1.26 &FIG::verify_dir("$FIG_Config::data/Assignments/$userR");
754 : overbeek 1.29 my $file = &FIG::epoch_to_readable($date) . ":$who:imported";
755 : overbeek 1.20 $file =~ s/\//-/g;
756 : overbeek 1.35
757 :     if (! $make_assignments)
758 :     {
759 :     open(OUT,">$FIG_Config::data/Assignments/$userR/$file")
760 :     || die "could not open $FIG_Config::data/Assignments/$userR/$file";
761 :     }
762 : overbeek 1.29
763 :     foreach $peg (keys(%$trans_pegs))
764 : overbeek 1.20 {
765 : overbeek 1.29 $peg_to = $trans_pegs->{$peg};
766 :     $func = $pegs{$peg}->[2];
767 :     if ($fig->function_of($peg_to) ne $func)
768 :     {
769 : overbeek 1.35 if ($make_assignments)
770 :     {
771 :     if ($user =~ /master:(.*)/)
772 :     {
773 :     $userR = $1;
774 :     $fig->assign_function($peg_to,"master",$func,"");
775 :     if ($userR ne "none")
776 :     {
777 :     $fig->add_annotation($peg_to,$userR,"Set master function to\n$func\n");
778 :     }
779 :     }
780 :     else
781 :     {
782 :     $fig->assign_function($peg_to,$user,$func,"");
783 :     if ($user ne "none")
784 :     {
785 :     $fig->add_annotation($peg_to,$user,"Set function to\n$func\n");
786 :     }
787 :     }
788 :     }
789 :     else
790 :     {
791 :     print OUT "$peg_to\t$func\n";
792 :     }
793 : overbeek 1.29 }
794 : overbeek 1.20 }
795 : overbeek 1.35 if (! $make_assignments)
796 :     {
797 :     close(OUT);
798 :     if (! -s "$FIG_Config::data/Assignments/$userR/$file") { unlink("$FIG_Config::data/Assignments/$userR/$file") }
799 :     }
800 : efrank 1.1 }
801 :    
802 :     =pod
803 :    
804 :     =head1 package_translation_rules
805 :    
806 :     usage: &package_translation_rules($fig_base,$file)
807 :    
808 :     $fig_base must be an absolute filename (begins with "/") giving the FIG from which
809 :     the updated code release will be taken.
810 :    
811 :     $file must be an absolute filename where the "translation_rules package" will be built.
812 :    
813 :     =cut
814 :    
815 :     sub package_translation_rules {
816 :     my($fig_base,$file) = @_;
817 :    
818 :     &FIG::run("cp $fig_base/Data/Global/function.synonyms $file");
819 :     }
820 :    
821 :     =pod
822 :    
823 :     =head1 install_translation_rules
824 :    
825 : efrank 1.10 usage: &install_translation_rules($fig_disk,$from,$package)
826 : efrank 1.1
827 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
828 :    
829 :     $package must be an absolute filename where the "translation_rules package" from which to make
830 :     the update exists.
831 :    
832 :     =cut
833 :    
834 :     sub install_translation_rules {
835 : efrank 1.10 my($fig_disk,$from,$package) = @_;
836 : efrank 1.1
837 :     my $file = "$fig_disk/FIG/Data/Global/function.synonyms";
838 :     &force_absolute($fig_disk);
839 :     if (-d "$fig_disk/BackupTranslation_Rules") { system "rm -rf $fig_disk/BackupTranslation_Rules" }
840 :     mkdir("$fig_disk/BackupTranslation_Rules",0777);
841 : disz 1.31 chmod 02777,"$fig_disk/BackupTranslation_Rules";
842 : efrank 1.1 if (-s $file)
843 :     {
844 :     &FIG::run("cp $file $fig_disk/BackupTranslation_Rules");
845 :     }
846 : efrank 1.10 &FIG::run("$FIG_Config::bin/merge_translation_rules $fig_disk/BackupTranslation_Rules/function.synonyms $package $from > $file");
847 : disz 1.31 chmod 02777,$file;
848 : efrank 1.1 }
849 :    
850 :     =pod
851 :    
852 :     =head1 restore_translation_rules
853 :    
854 :     usage: &restore_translation_rules($fig_disk);
855 :    
856 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
857 :    
858 :     =cut
859 :    
860 :     sub restore_translation_rules {
861 :     my($fig_disk) = @_;
862 :    
863 :     &force_absolute($fig_disk);
864 :    
865 :     my $file = "$fig_disk/FIG/Data/Global/function.synonyms";
866 :     (-s "$fig_disk/BackupTranslation_Rules/function.synonyms") || die "could not find an active backup";
867 :     if (-s "$fig_disk/BackupTranslation_Rules/function.synonyms")
868 :     {
869 :     &FIG::run("cp $fig_disk/BackupTranslation_Rules/function.synonyms $file");
870 : olson 1.37 chmod 0777, $file;
871 : efrank 1.1 }
872 :     }
873 :    
874 : overbeek 1.23 sub package_subsystems {
875 : overbeek 1.30 my($fig,$file,$just_exchangable) = @_;
876 : overbeek 1.23 my($ssa);
877 :    
878 : overbeek 1.27 $just_exchangable = defined($just_exchangable) ? $just_exchangable : 1;
879 :     my @exchangable = grep { (! $just_exchangable) || $fig->is_exchangable_subsystem($_) }
880 :     $fig->all_subsystems;
881 :    
882 : overbeek 1.23 my $fig = new FIG;
883 : overbeek 1.24 if ((@exchangable > 0) && open(SUB,">$file"))
884 : overbeek 1.23 {
885 : overbeek 1.24 foreach $ssa (@exchangable)
886 : overbeek 1.23 {
887 : overbeek 1.25 # print STDERR "writing $ssa to $file\n";
888 :     my($spreadsheet,$notes) = $fig->exportable_subsystem($ssa);
889 : overbeek 1.23 print SUB join("",@$spreadsheet),join("",@$notes),"########################\n";
890 :     }
891 :     close(SUB);
892 :     }
893 : overbeek 1.25 else
894 :     {
895 :     # print STDERR &Dumper(\@exchangable,$file);
896 :     }
897 : overbeek 1.23 }
898 :    
899 : overbeek 1.30 sub install_subsystems {
900 :     my($fig,$package) = @_;
901 :    
902 : disz 1.31 &FIG::run("$FIG_Config::bin/import_subsystems master last_release < $package");
903 : overbeek 1.30 }
904 :    
905 : olson 1.37
906 :     =pod
907 :    
908 :     =head2 unpack_packaged_subsystem
909 :    
910 :     Unpack a packaged subsystem (from the clearinghouse or a p2p transfer)
911 :     into a directory; this will create a directory named as the subsystem
912 :     and formatted like the standard subsystem directories, as well as a
913 :     file of assignments and a file of sequences in fasta format.
914 :    
915 :     Returns the name of the subsystem.
916 :    
917 :     =cut
918 :    
919 :     sub unpack_packaged_subsystem
920 :     {
921 :     my($fig, $file, $target_dir) = @_;
922 :    
923 :     my $user = $fig->get_user();
924 :    
925 :     &FIG::verify_dir($target_dir);
926 :    
927 :     my $fh;
928 :    
929 :     if (!open($fh, "<$file"))
930 :     {
931 :     warn "unpack_packaged_subsystem: cannot open $file: $!";
932 :     return undef;
933 :     }
934 :    
935 :     #
936 :     # We scan the file, breaking it up into sections and writing
937 :     # to the appropriate places.
938 :     #
939 :     # First the header.
940 :     #
941 :    
942 :     local $/ = "\n//\n";
943 :    
944 :     my $header = <$fh>;
945 :     chomp $header;
946 :    
947 :     my ($name, $version, $exchangable, $curation) = split(/\n/, $header);
948 :    
949 :     print "Importing name=$name version=$version exch=$exchangable curation='$curation'\n";
950 :    
951 :     #
952 :     # Pull in roles, subsets, and spreadsheet. These will be written to the new
953 :     # spreadsheet file.
954 :     #
955 :    
956 :     my $roles = <$fh>;
957 :     chomp $roles;
958 :    
959 :     my $subsets = <$fh>;
960 :     chomp $subsets;
961 :    
962 :     my $spreadsheet = <$fh>;
963 :     chomp $spreadsheet;
964 :    
965 :    
966 :     #
967 :     # Pull the assignments and sequences. These go to their own files.
968 :     #
969 :    
970 :     my $assignments = <$fh>;
971 :     chomp $assignments;
972 :    
973 :     my $sequences = <$fh>;
974 :     chomp $sequences;
975 :    
976 :     #
977 :     # And the notes; these will be written to the subsystem dir.
978 :     #
979 :    
980 :     my $notes = <$fh>;
981 :     chomp $notes;
982 :    
983 :     close($fh);
984 :    
985 :     #
986 :     # Everything is read. Now to write it all back out again.
987 :     #
988 :    
989 :     #
990 :     # First the subsystem.
991 :     #
992 :    
993 :     my $ss_path = "$target_dir/subsystem";
994 :     &FIG::verify_dir($ss_path);
995 :    
996 :     open($fh, ">$ss_path/EXCHANGABLE");
997 :     print $fh "$exchangable\n";
998 :     close($fh);
999 :    
1000 :     open($fh, ">$ss_path/VERSION");
1001 :     print $fh "$version\n";
1002 :     close($fh);
1003 :    
1004 :     open($fh, ">$ss_path/curation.log");
1005 :     print $fh "$curation\n";
1006 :     my $now = time;
1007 :     print $fh "$now\t$user\timported\n";
1008 :     close($fh);
1009 :    
1010 :     open($fh, ">$ss_path/notes");
1011 :     print $fh "$notes\n";
1012 :     close($fh);
1013 :    
1014 :     open($fh, ">$ss_path/spreadsheet");
1015 :     print $fh "$roles\n";
1016 :     print $fh "//\n";
1017 :     print $fh "$subsets\n";
1018 :     print $fh "//\n";
1019 :     print $fh "$spreadsheet\n";
1020 :     close($fh);
1021 :    
1022 :     open($fh, ">$target_dir/subsystem_name");
1023 :     print $fh "$name\n";
1024 :     close($fh);
1025 :    
1026 :     open($fh, ">$target_dir/assignments");
1027 :     print $fh "$assignments\n";
1028 :     close($fh);
1029 :    
1030 :     open($fh, ">$target_dir/seqs.fasta");
1031 :     print $fh "$sequences\n";
1032 :     close($fh);
1033 :    
1034 :     return $name;
1035 :     }
1036 :    
1037 : olson 1.33 package SubsystemFile;
1038 :    
1039 :     use Data::Dumper;
1040 :     use strict;
1041 :    
1042 :     sub new
1043 :     {
1044 :     my($class, $qdir, $file, $fig) = @_;
1045 :     my(@info);
1046 :    
1047 :     @info = FIG::file_head($file, 4);
1048 :     if (!@info)
1049 :     {
1050 :     warn "Cannot open $file\n";
1051 :     return undef;
1052 :     }
1053 :    
1054 :     chomp(@info);
1055 :    
1056 :     my $name = $info[0];
1057 :     my $version = $info[1];
1058 :     my $exc = $info[2];
1059 :    
1060 :     my @c = split(/\t/, $info[3]);
1061 :    
1062 :     my $curator = $c[1];
1063 :    
1064 :     my $self = {
1065 :     qdir => $qdir,
1066 :     file => $file,
1067 :     name => $name,
1068 :     version => $version,
1069 :     exchangable => $exc,
1070 :     curator => $curator,
1071 : olson 1.39 curation_log => $info[3],
1072 : olson 1.33 fig => $fig,
1073 :     };
1074 :    
1075 :     return bless($self, $class);
1076 :    
1077 :     }
1078 :    
1079 :     #
1080 :     # Load the export file into internal data structures.
1081 :     #
1082 :     # It's structured as
1083 :     #
1084 :     # name
1085 :     # version
1086 :     # exchangable
1087 :     # creation date <tab> curator <tab> "started"
1088 :     # //
1089 :     # roles
1090 :     # //
1091 :     # subsets
1092 :     # //
1093 :     # spreadsheet
1094 :     # //
1095 :     # assignments
1096 :     # //
1097 :     # sequences
1098 :     # //
1099 :     # notes
1100 :     # //
1101 : olson 1.49 # reactions
1102 : olson 1.33 #
1103 :     # Subsections:
1104 :     #
1105 :     # roles:
1106 :     #
1107 :     # abbr <tab> role-name
1108 :     #
1109 :     # subsets has meaning to the acutal subsystems, but we'll use it as a string.
1110 :     #
1111 :     # spreadsheet:
1112 :     #
1113 :     # genome <tab> variant <tab> items
1114 :     #
1115 :     # Where items is tab-separated columns, each of which is comma-separated peg number in the genome
1116 :     #
1117 :     # assignments:
1118 :     #
1119 :     # fid <tab> aliases <tab> organism <tab> function
1120 :     #
1121 :     # sequences:
1122 :     #
1123 :     # list of fasta's
1124 :     #
1125 :     # notes:
1126 :     #
1127 :     # plain text
1128 :     #
1129 :     sub load
1130 :     {
1131 :     my($self) = @_;
1132 :    
1133 :     my $fig = $self->{fig};
1134 :    
1135 :     my($fh);
1136 :    
1137 :     open($fh, "<$self->{file}") or die "Cannot open $self->{file}: $!\n";
1138 :    
1139 :     #
1140 : olson 1.39 # Skip intro section - we already read this information in the constructor.
1141 : olson 1.33 #
1142 :    
1143 :     while (<$fh>)
1144 :     {
1145 :     chomp;
1146 :     last if m,^//,;
1147 :     }
1148 :    
1149 :     #
1150 :     # Read the roles.
1151 :     #
1152 :    
1153 :    
1154 :     my $nroles;
1155 :    
1156 :     while (<$fh>)
1157 :     {
1158 :     last if m,^//,;
1159 :    
1160 :     $self->{role_text} .= $_;
1161 :     chomp $_;
1162 :    
1163 :     my($abbr, $role) = split(/\t/);
1164 :    
1165 :     warn "Have role $role\n";
1166 :    
1167 :     push(@{$self->{roles}}, $role);
1168 :     push(@{$self->{abbrs}}, $abbr);
1169 :    
1170 :     $nroles++;
1171 :     }
1172 :    
1173 :     #
1174 :     # Read in subsets as a string.
1175 :     #
1176 :    
1177 :     while (<$fh>)
1178 :     {
1179 :     last if m,^//,;
1180 :    
1181 :     $self->{subsets_text} .= $_;
1182 :     }
1183 :    
1184 :     #
1185 :     # Read the spreadsheet.
1186 :     #
1187 :    
1188 :     while (<$fh>)
1189 :     {
1190 :     last if m,^//,;
1191 :    
1192 :     $self->{spreadsheet_text} .= $_;
1193 :    
1194 :     chomp;
1195 :    
1196 :     my($genome, $variant, @items) = split(/\t/, $_, $nroles + 2);
1197 :    
1198 :     push(@{$self->{genomes}}, $genome);
1199 :    
1200 :     my $gobj = GenomeObj->new($self, $fig, $genome, $variant, [@items]);
1201 :    
1202 :     $self->{genome_objs}->{$genome} = $gobj;
1203 :     }
1204 :    
1205 :     #
1206 :     # Read PEG info
1207 :     #
1208 :    
1209 :     while (<$fh>)
1210 :     {
1211 :     last if m,^//,;
1212 :    
1213 :     chomp;
1214 :    
1215 :     my ($peg, $aliases, $org, $func) = split(/\t/);
1216 :    
1217 :     push(@{$self->{pegs}}, [$peg, $aliases, $org, $func]);
1218 :     }
1219 :    
1220 :     #
1221 :     # Read sequence info
1222 :     #
1223 :    
1224 :     my($cur, $cur_peg);
1225 :    
1226 :     while (<$fh>)
1227 :     {
1228 :     if (/^>(fig\|\d+\.\d+\.peg\.\d+)/)
1229 :     {
1230 :     if ($cur)
1231 :     {
1232 :     $cur =~ s/\s+//gs;
1233 :     $self->{peg_seq}->{$cur_peg} = $cur;
1234 :     }
1235 :     $cur_peg = $1;
1236 :     $cur = '';
1237 :     }
1238 :     elsif (m,^//,)
1239 :     {
1240 :     $cur =~ s/\s+//gs;
1241 :     $self->{peg_seq}->{$cur_peg} = $cur;
1242 :     last;
1243 :     }
1244 :     else
1245 :     {
1246 :     $cur .= $_;
1247 :     }
1248 :     }
1249 :    
1250 :     #
1251 :     # Read notes as a string
1252 :     #
1253 :    
1254 :     while (<$fh>)
1255 :     {
1256 :     last if m,^//,;
1257 :    
1258 :     $self->{notes_txt} .= $_;
1259 :     }
1260 : olson 1.49
1261 :     #
1262 :     # Anything left here is reaction data.
1263 :     #
1264 :    
1265 :     my $reactions;
1266 :    
1267 :     while (<$fh>)
1268 :     {
1269 :     last if m,^//,;
1270 :    
1271 :     if (/^([^\t]+)\t([^\t]+)/)
1272 :     {
1273 :     $reactions .= $_;
1274 :     }
1275 :     }
1276 :    
1277 :     $self->{reactions} = $reactions if $reactions ne "";
1278 :    
1279 : olson 1.33
1280 :     }
1281 :    
1282 :     #
1283 : olson 1.39 # Compute or load from cache the PEG translations for this subsystem.
1284 :     #
1285 :     sub ensure_peg_translations
1286 :     {
1287 :     my($self) = @_;
1288 :    
1289 :     #
1290 :     # First we map the PEGs in this subsystem to PEGs in the
1291 :     # local SEED.
1292 :     #
1293 :     # translate_pegs requires a hash of peg->[aliases] as the first argument,
1294 :     # and a hash of peg->sequence as the second argument.
1295 :     #
1296 :    
1297 :     my $fig = $self->{fig};
1298 :    
1299 :     my %pegs;
1300 :     my %seqs_of;
1301 :    
1302 :     for my $pegent (@{$self->{pegs}})
1303 :     {
1304 :     my($peg, $aliases, $org, $func) = @$pegent;
1305 :     $pegs{$peg} = [$aliases, $org, $func];
1306 :     $seqs_of{$peg} = $self->{peg_seq}->{$peg};
1307 :     }
1308 :    
1309 :     sub show_cb
1310 :     {
1311 :     print "$_[0]<p>\n";
1312 :     }
1313 :    
1314 :     my $cached_translation_file = "$self->{qdir}/peg_translation";
1315 :    
1316 :     my $tran_peg;
1317 :    
1318 :     if (-f $cached_translation_file and -s $cached_translation_file > 0)
1319 :     {
1320 :     #
1321 :     # Read the cached translations.
1322 :     #
1323 :    
1324 :     if (open(my $fh, "<$cached_translation_file"))
1325 :     {
1326 :     warn "Reading cached peg translations\n";
1327 :     $tran_peg = {};
1328 :     while (<$fh>)
1329 :     {
1330 :     chomp;
1331 :     my($k, $v) = split(/\t/);
1332 :     $tran_peg->{$k} = $v;
1333 :     }
1334 :     close($fh);
1335 :     }
1336 :     }
1337 :    
1338 :     if (!$tran_peg)
1339 :     {
1340 :     $tran_peg = $fig->translate_pegs(\%pegs, \%seqs_of, \&show_cb);
1341 :    
1342 :     #
1343 :     # tran_peg is now a hash from subsystem_peg->local_peg
1344 :     #
1345 :    
1346 :     #
1347 :     # Write the translations out to a file in the queue directory
1348 :     # for use during installation.
1349 :     #
1350 :    
1351 :     if (open(my $fh, ">$self->{qdir}/peg_translation"))
1352 :     {
1353 :     for my $p (keys(%$tran_peg))
1354 :     {
1355 :     my $tp = $tran_peg->{$p};
1356 :     print $fh "$p\t$tp\n";
1357 :     }
1358 :     close($fh);
1359 :     }
1360 :     }
1361 :     $self->{tran_peg} = $tran_peg;
1362 :     return $tran_peg;
1363 :     }
1364 :    
1365 :     #
1366 : olson 1.33 # Analyze this subsystem for compatibility with this SEED install.
1367 :     #
1368 :     # Returns three lists:
1369 :     #
1370 :     # A major conflict list, consisting of tuples
1371 :     # [$ss_peg, $ss_func, $loc_peg, $loc_func, $subs] where $ss_peg
1372 :     # is the peg in the subsystem being analyzied, and $ss_func is
1373 :     # its assigned function in that subsystem. $loc_peg is the peg
1374 :     # in the local SEED, and $loc_func its local assignment. $subs is
1375 :     # the list of pairs [$subsystem_name, $role] denoting the subsystem(s)
1376 :     # that $loc_peg particpates in.
1377 :     #
1378 :     # A conflict is flagged if the local function is different than
1379 :     # the one being imported, and if the local peg is in a subsystem.
1380 :     #
1381 :     # A minor conflict list, consisting of tuples [$ss_peg, $ss_func, $loc_peg, $loc_func].
1382 :     #
1383 :     #
1384 :     # The second list is a list of subsystem pegs that do not have
1385 :     # a local equivalent. Each entry is a triple
1386 :     # [peg, orgname, function].
1387 :     #
1388 :    
1389 :     sub analyze
1390 :     {
1391 :     my($self) = @_;
1392 :     my $fig = $self->{fig};
1393 :    
1394 : olson 1.39 my $tran_peg = $self->ensure_peg_translations();
1395 :    
1396 :     #
1397 :     # Now we walk the PEGs, determining a) which are missing
1398 :     # in the local SEED, and b) which have a conflicting assignment.
1399 :     #
1400 : olson 1.33 #
1401 : olson 1.39 # We also need to determine if this assignment will cause
1402 :     # pegs to be filled into subsystem roles that were not
1403 :     # otherwise going to be added.
1404 : olson 1.33 #
1405 : olson 1.39 # To enable this, we determine from the subsystem index
1406 :     # the list all roles that are present in subsystems on
1407 :     # this SEED.
1408 : olson 1.33 #
1409 :    
1410 : olson 1.39 my $sub_name = $self->name();
1411 :     my $subsystem_roles = $fig->subsystem_roles();
1412 :    
1413 :     my(@conflict, $minor_conflict, $missing);
1414 :    
1415 : olson 1.40 #
1416 :     # Hashes for accumulating aggregate counts of conflicts.
1417 :     #
1418 :    
1419 :     my(%subs_in, %subs_out, %roles_in, %roles_out);
1420 :    
1421 : olson 1.39 $missing = [];
1422 :    
1423 :     print "Determining conflicts...<p>\n";
1424 : olson 1.33
1425 :     for my $pegent (@{$self->{pegs}})
1426 :     {
1427 : olson 1.39 my($ss_peg, undef, $ss_org, $ss_func) = @$pegent;
1428 :    
1429 :     #
1430 :     # If this peg has a local translation, determine if
1431 :     # the associated assignment conflicts with a local assignment.
1432 :     #
1433 :     # One type of conflict occurs when the new assignment would cause
1434 :     # the peg to be removed from a subsystem. This occurs when the
1435 :     # new functional assignment is different from the current
1436 :     # assignment, and the peg is already in a subsystem.
1437 :     #
1438 :     # Another type of conflict occurs when the new assignment
1439 :     # for a peg matches a role that exists in a locally-installed
1440 :     # subsystem. This will cause the peg to be added to a
1441 :     # subsystem upon refill of that subsystem.
1442 :     #
1443 :     # It is possible for both the above conditions to hold,
1444 :     # in which case a peg would be moved out of one
1445 :     # subsystem into another.
1446 :     #
1447 :     # We denote these cases in the generated conflict list by
1448 :     # annotating the entry with the list of subsystems from which
1449 :     # the peg would be removed if the assignment were to be
1450 :     # accepted, and the list of subsystems to which the
1451 :     # peg would be added.
1452 :     #
1453 :    
1454 :     if (my $loc_peg = $tran_peg->{$ss_peg})
1455 :     {
1456 :     my $subs_removed = [];
1457 :     my $subs_added = [];
1458 :    
1459 :     #
1460 :     # Determine what our locally-assigned function is, and what
1461 :     # subsystem this peg appears in.
1462 :     #
1463 :    
1464 :     my $loc_func = $fig->function_of($loc_peg);
1465 :    
1466 :     #
1467 :     # If the functions don't match, it's a conflict.
1468 :     # If the local function is in a subsystem, it's a major
1469 :     # conflict. If it's not, it's a minor conflict.
1470 :     #
1471 :     # We actually let the major/minor determination be done by
1472 :     # the analysis display code, since the difference is only in whether
1473 :     # there are subsystems.
1474 :     #
1475 :    
1476 :     if ($loc_func ne $ss_func)
1477 :     {
1478 :    
1479 :     #
1480 :     # If the function defined in the new subsystem is different than
1481 :     # the current function, we mark a conflict. Along with the conflict
1482 :     # we include a list of the subsystems in which the local peg
1483 :     # is included.
1484 :     #
1485 :     # We use the subsystems_for_peg method to determine local subsystems
1486 :     # associated with a peg. It returns a list of pairs [subsystem, rolename].
1487 :     #
1488 :    
1489 :     #
1490 :     # What if we are loading a new version of an existing subsystem, and
1491 :     # a role name has changed?
1492 :     #
1493 :     # In this case, $loc_func ne $ss_func, $loc_peg will appear in the local copy of
1494 :     # the subsystem we are loading, and hence as a candidate for removal from that subsystem.
1495 :     # This may be thought of as a spurious message, and leads me to want to remove
1496 :     # such warnings (if I'm updating a subsystem, I can expect that the pegs in that
1497 :     # subsystem will change).
1498 :     #
1499 : olson 1.40 # subsystems_for_peg returns a list of pairs [subsystem, role].
1500 :     #
1501 :     # There might be somethign of a discrepancy here. This only
1502 :     # measures the subsystems the peg is actually currently part of, not
1503 :     # the number of subsystems that have a role corresponding to the peg's
1504 :     # current assignment.
1505 :     #
1506 : olson 1.39
1507 :     my @removed = $fig->subsystems_for_peg($loc_peg);
1508 : olson 1.40
1509 :     for my $r (@removed)
1510 :     {
1511 :     my($rsub, $rrole) = @$r;
1512 :    
1513 :     #
1514 :     # Skip the numbers for an existing subsystem.
1515 :     #
1516 :     next if $rsub eq $sub_name;
1517 :    
1518 :     $roles_out{$rrole}++;
1519 :     $subs_out{$rsub}++;
1520 :    
1521 :     push(@$subs_removed, $r);
1522 :     }
1523 : olson 1.39
1524 :     #
1525 :     # We also check to see if the new function is present
1526 :     # as a role in any local subsystem. If it is, then when that subsystem
1527 :     # is refilled, this peg will appear in it.
1528 :     #
1529 : olson 1.41 # $subsystem_roles is a hash keyed on role name with each value
1530 : olson 1.40 # a list of subsystem names.
1531 : olson 1.39 #
1532 :    
1533 :     if (my $loc_ss = $subsystem_roles->{$ss_func})
1534 :     {
1535 : olson 1.40 #
1536 :     # $loc_ss is the set of subsystems that have the new
1537 :     # function assignment as a role name.
1538 :     #
1539 : olson 1.41 my @subs = grep { $_ ne $sub_name} @$loc_ss;
1540 : olson 1.40
1541 : olson 1.41 if (@subs)
1542 :     {
1543 :     push(@$subs_added, @subs);
1544 :    
1545 :     map { $subs_in{$_}++ } @subs;
1546 :     $roles_in{$ss_func}++;
1547 :     }
1548 : olson 1.39 }
1549 :    
1550 :     push(@conflict, [$ss_peg, $ss_func, $loc_peg, $loc_func, $subs_removed, $subs_added]);
1551 :     }
1552 :    
1553 :     }
1554 :     else
1555 :     {
1556 :     push(@$missing, [$ss_peg, $ss_org, $ss_func]);
1557 :     }
1558 :     }
1559 :    
1560 :     my $conflict = [sort { @{$b->[4]} + @{$b->[5]} <=> @{$a->[4]} + @{$a->[5]} } @conflict];
1561 :    
1562 : olson 1.40 my $aggreg = {
1563 :     roles_in => [keys(%roles_in)],
1564 :     roles_out => [keys(%roles_out)],
1565 :     subs_in => [keys(%subs_in)],
1566 :     subs_out => [keys(%subs_out)],
1567 :     };
1568 :    
1569 :     return ($conflict, $missing, $aggreg);
1570 : olson 1.39 }
1571 :    
1572 :     sub read_cached_analysis
1573 :     {
1574 :     my($self) = @_;
1575 :    
1576 :     my $cfile = "$self->{qdir}/conflicts";
1577 :     my $mfile = "$self->{qdir}/missing";
1578 :    
1579 :     my($conflict, $missing);
1580 :     $conflict = [];
1581 :     $missing = [];
1582 :    
1583 :     if (open(my $fh, "<$cfile"))
1584 :     {
1585 :    
1586 :     while (<$fh>)
1587 :     {
1588 :     chomp;
1589 :    
1590 :     my($ss_peg, $ss_func, $loc_peg, $loc_func) = split(/\t/);
1591 :    
1592 :     my $subs_removed = <$fh>;
1593 :     my $subs_added = <$fh>;
1594 :    
1595 :     chomp($subs_removed);
1596 :     chomp($subs_added);
1597 :    
1598 :     my @subs_removed_raw = split(/\t/, $subs_removed);
1599 :     my $subs_added_list = [split(/\t/, $subs_added)];
1600 :    
1601 :     my $subs_removed_list = [];
1602 :    
1603 :     while (@subs_removed_raw)
1604 :     {
1605 :     my($v1, $v2, @rest) = @subs_removed_raw;
1606 :     @subs_removed_raw = @rest;
1607 :     push(@$subs_removed_list, [$v1, $v2]);
1608 :     }
1609 :    
1610 :     push(@$conflict, [$ss_peg, $ss_func, $loc_peg, $loc_func, $subs_removed_list, $subs_added_list]);
1611 :     }
1612 :     }
1613 :    
1614 :     if (open(my $fh, "<$mfile"))
1615 :     {
1616 :    
1617 :     while (<$fh>)
1618 :     {
1619 :     chomp;
1620 :    
1621 :     my(@a) = split(/\t/);
1622 :     push(@$missing, [@a]);
1623 :     }
1624 :     }
1625 :    
1626 :     return($conflict, $missing);
1627 :     }
1628 :    
1629 :     #
1630 :     # Install this subsystem.
1631 :     #
1632 : olson 1.42 # $dont_assign is a list of subsytem PEGs that should not have their assignments overwritten.
1633 : olson 1.39 #
1634 :     # We return a list of for-the-installer messages that will be presented when the install completes.
1635 :     #
1636 :     sub install
1637 :     {
1638 :     my($self, $dont_assign) = @_;
1639 :    
1640 :     my @messages;
1641 :    
1642 :     my $fig = $self->{fig};
1643 :     my $subsystems_dir = "$FIG_Config::data/Subsystems";
1644 :    
1645 :     my $sub_name = $self->name();
1646 :     $sub_name =~ s/ /_/g;
1647 :     my $sub_dir = "$subsystems_dir/$sub_name";
1648 :     my $ver = $self->version();
1649 :    
1650 :     #
1651 :     # First check to see if we already have this subsystem installed.
1652 :     #
1653 :    
1654 :     if (-d $sub_dir and (my $cur_ver = $fig->subsystem_version($sub_name)) >= $ver)
1655 :     {
1656 :     warn "Not importing $sub_name: current version $cur_ver >= imported version $ver";
1657 :     }
1658 :    
1659 :     warn "Importing $sub_name version $ver\n";
1660 :     push(@messages, "Importing $sub_name version $ver\n");
1661 :    
1662 :     if (! -d $sub_dir)
1663 :     {
1664 :     mkdir($sub_dir, 0777) or die "Cannot mkdir $sub_dir: $!";
1665 : olson 1.33 }
1666 :    
1667 : olson 1.39 #
1668 :     # Write the header/meta information.
1669 :     #
1670 :    
1671 :     my $fh;
1672 :     my $imported_from = "???";
1673 :    
1674 :     open($fh, ">$sub_dir/VERSION") or die "Cannot open $sub_dir/VERSION for writing: $!";
1675 :     print $fh "$ver\n";
1676 :     close($fh);
1677 :     chmod(0666, "$sub_dir/VERSION");
1678 :    
1679 :     open($fh, ">$sub_dir/EXCHANGABLE") or die "Cannot open $sub_dir/EXCHANGABLE for writing: $!";
1680 :     print $fh $self->exchangable() . "\n";
1681 :     close($fh);
1682 :     chmod(0666, "$sub_dir/EXCHANGABLE");
1683 :    
1684 :     open($fh, ">$sub_dir/curation.log") or die "Cannot open $sub_dir/curation.logt for writing: $!";
1685 :     print $fh "$self->{curation_log}\n";
1686 :     my $time = time;
1687 :     print $fh "$time\t$imported_from\timported_from\n";
1688 :     close($fh);
1689 :     chmod(0666, "$sub_dir/curation.log");
1690 :    
1691 :     open($fh, ">$sub_dir/notes") or die "Cannot open $sub_dir/notes for writing: $!";
1692 :     print $fh $self->{notes_txt} . "\n";
1693 :     close($fh);
1694 :     chmod(0666, "$sub_dir/notes");
1695 : olson 1.49
1696 :     if ($self->{reactions})
1697 :     {
1698 :     open($fh, ">$sub_dir/reactions") or die "Cannot open $sub_dir/reactions for writing: $!";
1699 :     print $fh $self->{reactions} . "\n";
1700 :     close($fh);
1701 :     chmod(0666, "$sub_dir/reactions");
1702 :     }
1703 : olson 1.39
1704 :     my $tran_peg = $self->ensure_peg_translations();
1705 : olson 1.33
1706 :     #
1707 : olson 1.39 # We can start writing the spreadsheet.
1708 : olson 1.33 #
1709 :    
1710 : olson 1.39 my $ssa_fh;
1711 :     open($ssa_fh, ">$sub_dir/spreadsheet") or die "Cannot open $sub_dir/spreadsheet for writing: $!";
1712 :    
1713 : olson 1.33 #
1714 : olson 1.39 # Start with the roles and subsets.
1715 : olson 1.33 #
1716 : olson 1.39
1717 :     print $ssa_fh $self->{role_text};
1718 :     print $ssa_fh "//\n";
1719 :    
1720 :     print $ssa_fh $self->{subsets_text};
1721 :     print $ssa_fh "//\n";
1722 : olson 1.33
1723 : olson 1.39 for my $g (@{$self->{genomes}})
1724 : olson 1.33 {
1725 : olson 1.39 my $gobj = $self->{genome_objs}->{$g};
1726 :     my ($trans_genome, @row) = $gobj->translate($tran_peg);
1727 :    
1728 :     if ($trans_genome)
1729 : olson 1.33 {
1730 : olson 1.39 print $ssa_fh join("\t", $trans_genome, $gobj->{variant}, @row), "\n";
1731 : olson 1.33 }
1732 :     }
1733 : olson 1.39
1734 :     close($ssa_fh);
1735 :    
1736 :     #
1737 :     # The subsystem itself is now in place.
1738 : olson 1.33 #
1739 : olson 1.39 # Enter the new assignments, saving the old assignments in the spool dir.
1740 : olson 1.33 #
1741 :    
1742 : olson 1.39 my $now = time;
1743 :    
1744 :     my $old_funcs_fh;
1745 :     open($old_funcs_fh, ">>$self->{qdir}/old_assignments.$now");
1746 :    
1747 :     my $curator = $self->curator();
1748 : olson 1.33
1749 : olson 1.42 my %dont_assign;
1750 :    
1751 :     map { $dont_assign{$_}++ } @$dont_assign;
1752 :    
1753 : olson 1.33 for my $pegent (@{$self->{pegs}})
1754 :     {
1755 : olson 1.39 my($peg, $aliases, $org, $func) = @$pegent;
1756 :     my $tpeg = $tran_peg->{$peg};
1757 :    
1758 :     if (!$tpeg)
1759 :     {
1760 :     warn "Couldn't translate $peg (from $org)\n";
1761 :     push(@messages, "Couldn't translate $peg (from $org)");
1762 :     next;
1763 :     }
1764 :    
1765 : olson 1.42 if ($dont_assign{$peg})
1766 :     {
1767 :     warn "Skipping assignment of $peg ($tpeg locally)\n";
1768 :     next;
1769 :     }
1770 :    
1771 : olson 1.39 my $old = $fig->function_of($tpeg);
1772 :    
1773 :     if ($old ne $func)
1774 : olson 1.33 {
1775 : olson 1.39 print $old_funcs_fh "$tpeg\t$old\t$curator\t$func\n";
1776 :     $fig->add_annotation($tpeg, $curator,
1777 :     "Assigning function $func based on installation of subsystem $self->{name}");
1778 : olson 1.33
1779 : olson 1.39 if ($curator =~ /master:(.*)/)
1780 :     {
1781 :     my $user = $1;
1782 :     $fig->assign_function($tpeg, "master", $func, "");
1783 : olson 1.48 $fig->add_annotation($tpeg, $user, "Set master function to\n$func\n");
1784 : olson 1.39 }
1785 :     else
1786 : olson 1.33 {
1787 : olson 1.39 $fig->assign_function($tpeg, $curator, $func, "");
1788 : olson 1.48 $fig->add_annotation($tpeg, $curator, "Set function to\n$func\n");
1789 : olson 1.33 }
1790 :     }
1791 :     else
1792 :     {
1793 : olson 1.39 # print "$tpeg already has assignment $func\n";
1794 : olson 1.33 }
1795 :     }
1796 : olson 1.39 close($old_funcs_fh);
1797 :     return @messages;
1798 : olson 1.33 }
1799 :    
1800 : olson 1.41 #
1801 :     # Read the aggregate analysis results.
1802 :     #
1803 :    
1804 :     sub aggregate_analysis
1805 :     {
1806 :     my($self) = @_;
1807 :    
1808 :     if (open(my $fh, "<$self->{qdir}/aggregate"))
1809 :     {
1810 :     local($/);
1811 :     my $txt = <$fh>;
1812 :     close($fh);
1813 :    
1814 :     my $VAR1; # For the Dumper'd data.
1815 :    
1816 :     my $compartment = new Safe;
1817 :     my $aggr = $compartment->reval($txt);
1818 :     if ($@)
1819 :     {
1820 :     warn "aggregate_analysis: error parsing saved data: $@";
1821 :     return undef;
1822 :     }
1823 :     return $aggr;
1824 :     }
1825 :     else
1826 :     {
1827 :     return undef;
1828 :     }
1829 :     }
1830 :    
1831 : olson 1.33 sub name
1832 :     {
1833 :     my($self) = @_;
1834 :     return $self->{name};
1835 :     }
1836 :    
1837 :    
1838 :     sub version
1839 :     {
1840 :     my($self) = @_;
1841 :     return $self->{version};
1842 :     }
1843 :    
1844 :     sub exchangable
1845 :     {
1846 :     my($self) = @_;
1847 :     return $self->{exchangable};
1848 :     }
1849 :    
1850 :     sub curator
1851 :     {
1852 :     my($self) = @_;
1853 :     return $self->{curator};
1854 :     }
1855 :    
1856 : olson 1.39 sub analysis_complete
1857 :     {
1858 :     my($self) = @_;
1859 :    
1860 :     return -f "$self->{qdir}/analysis_complete";
1861 :     }
1862 :    
1863 :     sub analysis_jobid
1864 :     {
1865 :     my($self) = @_;
1866 :    
1867 :     my $jid_file = "$self->{qdir}/analysis_jobid";
1868 :    
1869 :     return &FIG::file_head($jid_file, 1);
1870 :     }
1871 :    
1872 : olson 1.33 package GenomeObj;
1873 :    
1874 : olson 1.39 use strict;
1875 :     use Data::Dumper;
1876 :    
1877 :     #
1878 :     # A genomeobj is a small datatype that holds the data in a row of a
1879 :     # spreadsheet file.
1880 :     #
1881 :    
1882 : olson 1.33 sub new
1883 :     {
1884 :     my($class, $subfile, $fig, $genome, $variant, $items) = @_;
1885 :    
1886 :     my $self = {
1887 :     fig => $fig,
1888 :     subfile => $subfile,
1889 :     genome => $genome,
1890 :     variant => $variant,
1891 :     items => $items,
1892 :     };
1893 :     return bless($self, $class);
1894 :    
1895 :     }
1896 :    
1897 : olson 1.39 #
1898 :     # Translate this row to a new context.
1899 :     #
1900 :     # $trans_peg is a hash mapping from spreadsheet PEG to local PEG
1901 :     #
1902 :     sub translate
1903 :     {
1904 :     my($self, $trans_peg) = @_;
1905 :     my $fig = $self->{fig};
1906 :    
1907 :     my $genome = $self->{genome};
1908 :    
1909 :     my $parsed_items = [];
1910 :     $self->{parsed_items} = $parsed_items;
1911 :     my $trans_items = [];
1912 :     $self->{trans_items} = $trans_items;
1913 :    
1914 :     #
1915 :     # Hash of genomes seen in this row.
1916 :     my %genomes;
1917 :    
1918 :     for my $item (@{$self->{items}})
1919 :     {
1920 :     my $l = [ map { $_ eq '' ? undef : "fig|$genome.peg.$_" } split(/,/, $item) ];
1921 :     my $t = [ map { $trans_peg->{$_} } @$l ];
1922 :    
1923 :     push(@$parsed_items, $l);
1924 :     push(@$trans_items, $t);
1925 :    
1926 :     #
1927 :     # Count the genomes that are seen in the translated pegs.
1928 :     #
1929 :    
1930 :     for my $tpeg (@$t)
1931 :     {
1932 :     my $tg = $fig->genome_of($tpeg);
1933 :     $genomes{$tg}++ if $tg ne "";
1934 :     }
1935 :    
1936 :     }
1937 :    
1938 :     #
1939 :     # Now determine the dominant organism for this translated row.
1940 :     #
1941 :    
1942 :     my @orgs = sort { $genomes{$b} <=> $genomes{$a} } keys(%genomes);
1943 :    
1944 :     # print "@{$self->{items}}\n";
1945 :     # print join(" ", map { "$_: $genomes{$_} " } @orgs ), "\n";
1946 :    
1947 :     unless (@orgs == 1 # Single organism
1948 :     or
1949 :     (@orgs > 1 and $genomes{$orgs[0]} > (2 * $genomes{$orgs[1]})) # First org has > 2x the second org
1950 :     )
1951 :     {
1952 :     warn "Could not determine translation for $genome\n";
1953 :     return undef;
1954 :     }
1955 :    
1956 :     #
1957 :     # The dominant organism is the first in the list.
1958 :     #
1959 :    
1960 :     my $dom = $orgs[0];
1961 :    
1962 :     #
1963 :     # Run through the translated pegs, and remove the ones that are
1964 :     # not in the dominant organism.
1965 :     #
1966 :    
1967 :     my @res;
1968 :     for my $i (0..@$trans_items - 1)
1969 :     {
1970 :     my $t = $trans_items->[$i];
1971 :    
1972 :     my @nt;
1973 :     for my $peg (@$t)
1974 :     {
1975 :     if ($peg =~ /^fig\|(\d+\.\d+)\.peg\.(\d+)$/)
1976 :     {
1977 :     if ($1 eq $dom)
1978 :     {
1979 :     push(@nt, $2);
1980 :     }
1981 :     }
1982 :     }
1983 :     push(@res, join(",", @nt));
1984 :     }
1985 :     return $dom, @res;
1986 :     }
1987 : efrank 1.1 1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3