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

Annotation of /FigKernelPackages/P2Pupdate.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : efrank 1.1 package P2Pupdate;
2 :    
3 :     use FIG_Config;
4 :     use FIG;
5 :     use Carp;
6 :     use Data::Dumper;
7 :     use Cwd;
8 :    
9 :     =pod
10 :    
11 :     =head1 updating code
12 :    
13 :     This routine packages what is needed to upgrade an older system to the
14 :     current code. Code releases are numered
15 :    
16 :     p1n1.p2n2.p3n3...
17 :    
18 :     where "." is added at the point the code moved to another branch of
19 :     the tree. FIG, who provided the initial release of the SEED, will
20 :     number all of their code releases as
21 :    
22 :     FIGn
23 :    
24 :     where n is an integer. Suppose that between releases 13 and 14 a
25 :     second group (which we will term "Idiots" for convenience) took
26 :     release 13 and wished to branch the code tree. At that point, they
27 :     would name their first release as
28 :    
29 :     FIG13.Idiots1
30 :    
31 :     We are, of course, being both cavalier and nasty when we make such a
32 :     reference. We do, however, wish to express the view that it will
33 :     benefit everyone to attempt to reconcile differences and maintain a
34 :     single code progression as long as possible. There are often good
35 :     reasons to part ways, but we urge people to think carefully before
36 :     taking such a step.
37 :    
38 :     Two code releases
39 :    
40 :     i1.i2.i3...in
41 :     and j1.j2.j3...jm with m <= n
42 :    
43 :     are compatible iff
44 :    
45 :     ip == jp for p < m, and
46 :     jm and im have the same "source" and
47 :     jm <= im
48 :    
49 :     A new code release must have the property that it can bring any
50 :     "older" compatible release up to its release.
51 :    
52 :     Note that there is an issue relating to the code to build/install packages.
53 :     Since a system may be radically restructured between releases of code, the
54 :     code to build a "package" and the code to "install" a package are radically
55 :     separated. For example, the code in P2Pupdate.pm for building an assignment
56 :     package and the code for installing an assignment package both apply to the
57 :     release of code current on the system containing P2Pupdate.pm. In fact, the
58 :     code releases may be quite different on two synchronizing systems.
59 :    
60 :     To make things work the following rules must be observed:
61 :    
62 :     1. a code release is a tar file containing VERSION, Packages,
63 :     bin/ToolTemplates, and CGI/ToolTemplates. The installing system needs
64 :     to place these at the appropriate spots, and then run bring_system_up_to_date,
65 :     which is supposed to do any required restructuring.
66 :    
67 :     2. an assignments package is a tar file containing a single directory. The directory
68 :     contains subdirectories -- one per genome. Each genome subdirectory contains zero
69 :     or more files. The name of the file is the "user" and the contents will be the
70 :     assignments made by that user.
71 :    
72 :     3. an annotations package is a tar file containing a single directory. The files in
73 :     the directory are named by genome. They contain the annotations for the genome.
74 :    
75 :     =cut
76 :    
77 :     =pod
78 :    
79 :     =head1 what_code_do_I_have
80 :    
81 :     usage: &what_code_do_I_have($fig_base)
82 :    
83 :     This just returns the current version of the code.
84 :    
85 :     =cut
86 :    
87 :     sub what_code_do_I_have {
88 :     my($fig_base) = @_;
89 :    
90 :     my $version = `cat $fig_base/VERSION`;
91 :     chop $version;
92 :     return $version;
93 :     }
94 :    
95 :     =pod
96 :    
97 :     =head1 updatable_code
98 :    
99 :     usage: &updatable_code_code($v1,$v2)
100 :    
101 :     This just returns true iff the two versions of code are compatible and $v1
102 :     is "more recent".
103 :    
104 :     =cut
105 :    
106 :     sub updatable_code {
107 :     my($v1,$v2) = @_;
108 :     my($i,$v1p,$v1n,$v2p,$v2n);
109 :    
110 :     my @v1 = split(/\./,$v1);
111 :     my @v2 = split(/\./,$v2);
112 :     if (@v1 < @v2) { return 0 }
113 :    
114 :     for ($i=0; ($i < $#v2) && ($v1[$i] eq $v2[$i]); $i++) {}
115 :     if ($i == $#v2)
116 :     {
117 :     $v1[$i] =~ /^(.*[^\d])(\d+)$/;
118 :     $v1p = $1;
119 :     $v1n = $2;
120 :    
121 :     $v2[$i] =~ /^(.*[^\d])(\d+)$/;
122 :     $v2p = $1;
123 :     $v2n = $2;
124 :    
125 :     return (($v2p eq $v1p) && ($v2n < $v1n));
126 :     }
127 :     return 0;
128 :     }
129 :    
130 :     =pod
131 :    
132 :     =head1 package_code
133 :    
134 :     usage: &package_code($fig_disk,$file)
135 :    
136 :     $fig_base must be an absolute filename (begins with "/") giving the FIG from which
137 :     the updated code release will be taken.
138 :    
139 :     $file must be an absolute filename where the "code package" will be built.
140 :    
141 :     =cut
142 :    
143 :     sub package_code {
144 :     my($fig_disk,$file) = @_;
145 :    
146 :     &force_absolute($fig_disk);
147 :     &force_absolute($file);
148 : overbeek 1.2 my @tmp = `cat $fig_disk/CURRENT_RELEASE`;
149 :     my $current_release = $tmp[0];
150 :     chop $current_release;
151 :    
152 :     &FIG::run("cd $fig_disk/dist/releases; tar czf $file $current_release");
153 : efrank 1.1 }
154 :    
155 :     sub force_absolute {
156 :     my($file) = @_;
157 :    
158 :     if (substr($file,0,1) ne "/")
159 :     {
160 : overbeek 1.2 print "Error: Please use absolute file names (i.e., /Users/fig/... or /home/fig/...)\n";
161 :     exit;
162 : efrank 1.1 }
163 :     }
164 :    
165 :     =pod
166 :    
167 :     =head1 install_code
168 :    
169 :     usage: &install_code($fig_disk,$package)
170 :    
171 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
172 :    
173 :     $package must be an absolute filename where the "code package" from which to make
174 :     the update exists.
175 :    
176 :     Note that this routine does not check that the updated code is compatible, or even less
177 :     current. It is assumed that upper level logic is doing that.
178 :    
179 :     =cut
180 :    
181 :     sub install_code {
182 :     my($fig_disk,$package) = @_;
183 :     my $fig_base = "$fig_disk/FIG";
184 :     &force_absolute($fig_base);
185 :     &force_absolute($package);
186 :    
187 :     if (getcwd() !~ /FIGdisk$/) { print die "Sorry, you must run this while in $FIG_Config::fig_disk" }
188 :    
189 :    
190 :     (! -d "$fig_disk/BackupCode") || &FIG::run("rm -rf $fig_disk/BackupCode");
191 :     mkdir("$fig_disk/BackupCode",0777) || die "Could not make the BackupCode directory";
192 :     (! -d "$fig_disk/BackupEnv") || &FIG::run("rm -rf $fig_disk/BackupEnv");
193 :     mkdir("$fig_disk/BackupEnv",0777) || die "Could not make the BackupEnv directory";
194 :    
195 :     my $version = &what_code_do_I_have($fig_base);
196 :     &FIG::run("cd $fig_disk; mv README install lib man env src $fig_disk/BackupEnv");
197 :     &FIG::run("cd $fig_base; mv VERSION Packages CGI $fig_disk/BackupCode");
198 :     print STDERR "made backups\n";
199 :    
200 :     &FIG::run("cd $fig_disk; tar xzf $package");
201 :     print STDERR "untarred new code\n";
202 :    
203 :     &fix_config("$fig_base/Packages/FIG_Config.pm","$fig_disk/BackupCode/Packages/FIG_Config.pm");
204 :     &FIG::run("cd $fig_base/bin; touch ToolTemplates/*/*; make all");
205 :     &FIG::run("cd $fig_base/CGI; touch ToolTemplates/*/*; make all");
206 :     print STDERR "installed new bin and CGI\n";
207 :    
208 :     &FIG::run("bring_system_up_to_date $version");
209 :     }
210 :    
211 :     =pod
212 :    
213 :     =head1 package_lightweight_code
214 :    
215 :     usage: &package_lightweight_code($fig_disk,$file)
216 :    
217 :     $fig_base must be an absolute filename (begins with "/") giving the FIG from which
218 :     the updated code release will be taken.
219 :    
220 :     $file must be an absolute filename where the "code package" will be built.
221 :    
222 :     =cut
223 :    
224 :     sub package_lightweight_code {
225 :     my($fig_disk,$file) = @_;
226 :    
227 :     &force_absolute($fig_disk);
228 :     &force_absolute($file);
229 : overbeek 1.2 my @tmp = `cat $fig_disk/CURRENT_RELEASE`;
230 :     my $current_release = $tmp[0];
231 :     chop $current_release;
232 :    
233 :     &FIG::run("cd $fig_disk/dist/releases; tar czf $file $current_release");
234 : efrank 1.1 }
235 :    
236 :     =pod
237 :    
238 :     =head1 install_lightweight_code
239 :    
240 :     usage: &install_lightweight_code($fig_disk,$package)
241 :    
242 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
243 :    
244 :     $package must be an absolute filename where the "code package" from which to make
245 :     the update exists.
246 :    
247 :     Note that this routine does not check that the updated code is compatible, or even less
248 :     current. It is assumed that upper level logic is doing that.
249 :    
250 :     =cut
251 :    
252 :     sub install_lightweight_code {
253 :     my($fig_disk,$package) = @_;
254 :     my $fig_base = "$fig_disk/FIG";
255 :     &force_absolute($fig_base);
256 :     &force_absolute($package);
257 :    
258 : overbeek 1.2 if (! mkdir("$fig_disk/Tmp$$",0777))
259 :     {
260 :     print "Error: could not make $fig_disk/Tmp$$\n";
261 :     exit;
262 :     }
263 : efrank 1.1
264 : overbeek 1.2 &FIG::run("cd $fig_disk/Tmp$$; tar xzf $package");
265 :     if (! opendir(TMP,"$fig_disk/Tmp$$"))
266 :     {
267 :     print "Error: could not open $fig_disk/Tmp$$\n";
268 :     exit;
269 :     }
270 : efrank 1.1
271 : overbeek 1.2 my @rels = grep { $_ !~ /^\./ } readdir(TMP);
272 :     closedir(TMP);
273 :     if (@rels != 1)
274 :     {
275 :     print "Error: Bad code package: $package\n";
276 :     exit;
277 :     }
278 : efrank 1.1
279 : overbeek 1.2 my $new_release = $rels[0];
280 :     if (-d "$fig_disk/dist/releases/$new_release")
281 :     {
282 :     print "Error: $new_release already exists; we are doing nothing\n";
283 :     exit;
284 :     }
285 : efrank 1.1
286 : efrank 1.3 &FIG::run("mv $fig_disk/Tmp$$/$new_release $fig_disk/dist/releases");
287 :     &FIG::run("rm -rf $fig_disk/Tmp$$");
288 : olson 1.22
289 :     #
290 :     # Ugh. For now, find the arch in the fig config file $fig_disk/config/fig-user-env.sh"
291 :     #
292 :    
293 :     my $arch;
294 :     open(FH, "<$fig_disk/config/fig-user-env.sh");
295 :     while (<FH>)
296 :     {
297 :     if (/RTARCH="(.*)"/)
298 :     {
299 :     $arch = $1;
300 :     last;
301 :     }
302 :     }
303 :     close(FH);
304 :    
305 :     if ($arch eq "")
306 :     {
307 :     die "Couldn't determine SEED install architecture, not switching to release.";
308 :     }
309 :    
310 :     $ENV{RTARCH} = $arch;
311 : olson 1.32
312 :     #
313 :     # Need to put the ext_bin in the path.
314 :     #
315 :    
316 :     $ENV{PATH} .= ":$FIG_Config::ext_bin";
317 : olson 1.22
318 : efrank 1.9 &FIG::run("$FIG_Config::bin/switch_to_release $new_release");
319 : efrank 1.1 }
320 :    
321 :    
322 :     sub fix_config {
323 :     my($new,$old) = @_;
324 :     my($line,$i);
325 :    
326 :     my @new = `cat $new`;
327 :     foreach $line (`cat $old`)
328 :     {
329 :     if ($line =~ /^(\S+)\s+\=/)
330 :     {
331 :     $var = $1;
332 :     $varQ = quotemeta $var;
333 :    
334 :     for ($i=0; ($i < $#new) && ($new[$i] !~ /^$varQ\s+\=/); $i++) {}
335 :     if ($i == $#new)
336 :     {
337 :     splice(@new,$i,0,$line);
338 :     }
339 :     else
340 :     {
341 :     splice(@new,$i,1,$line);
342 :     }
343 :     }
344 :     }
345 :     open(NEW,">$new") || confess "could not overwrite $new";
346 :     foreach $line (@new)
347 :     {
348 :     print NEW $line;
349 :     }
350 :     close(NEW);
351 :     }
352 :    
353 :     =pod
354 :    
355 :     =head1 what_genomes_will_I_sync
356 :    
357 :     usage: &what_genomes_will_I_sync($fig_base,$who)
358 :    
359 :     This routine returns the list of genome IDs that you are willing to sync with $who.
360 :    
361 :     =cut
362 :    
363 :     sub what_genomes_will_I_sync {
364 :     my($fig_base,$who) = @_;
365 :    
366 :     # This is the promiscuous version - it will sync all genomes with anyone.
367 :    
368 :     opendir(GENOMES,"$fig_base/Data/Organisms") || die "could not open $fig_base/Data/Organisms";
369 :     my @genomes = grep { $_ =~ /^\d+\.\d+$/ } readdir(GENOMES);
370 :     closedir(GENOMES);
371 :     return @genomes;
372 :     }
373 :    
374 :     =pod
375 :    
376 :     =head1 package_annotations
377 :    
378 : overbeek 1.29 usage: &package_annotations($fig,$genomes,$file)
379 : efrank 1.1
380 :     $genomes is a pointer to a list of genome IDs that will be exchanged.
381 :    
382 :     $file must be an absolute filename where the "annotation package" will be built.
383 :    
384 :     =cut
385 :    
386 :     sub package_annotations {
387 : overbeek 1.29 my($fig,$who,$date,$genomes,$file) = @_;
388 :     my $fig_base = "$FIG_Config::fig_disk/FIG";
389 : efrank 1.1
390 : overbeek 1.29 if (open(ANNOTATIONS,">$file"))
391 : efrank 1.1 {
392 : overbeek 1.29 my @annotations = sort { $a->[0] cmp $b->[0] } $fig->annotations_made($genomes,$who,$date);
393 :     foreach $x (@annotations)
394 : efrank 1.1 {
395 : overbeek 1.29 print ANNOTATIONS join("\n",@$x),"\n///\n";
396 : efrank 1.1 }
397 : overbeek 1.29 print ANNOTATIONS "//\n";
398 : efrank 1.15
399 : overbeek 1.29 foreach $x (@annotations)
400 : efrank 1.15 {
401 : overbeek 1.29 $peg = $x->[0];
402 : overbeek 1.30 my @aliases = grep { $_ =~ /^(sp\||gi\||pirnr\||kegg\||N[PGZ]_)/ } $fig->feature_aliases($peg);
403 :     print ANNOTATIONS join("\t",($peg,join(",",@aliases),$fig->genus_species($fig->genome_of($peg)),scalar $fig->function_of($peg))) . "\n";
404 : efrank 1.15 }
405 : overbeek 1.29 print ANNOTATIONS "//\n";
406 :    
407 :     foreach $x (@annotations)
408 : efrank 1.15 {
409 : overbeek 1.29 ($peg,undef) = @$x;
410 : overbeek 1.30 my $seq = $fig->get_translation($peg);
411 : overbeek 1.29 &FIG::display_id_and_seq($peg,\$seq,\*ANNOTATIONS);
412 : efrank 1.15 }
413 : overbeek 1.29 close(ANNOTATIONS);
414 : efrank 1.15 }
415 : efrank 1.1 }
416 :    
417 : overbeek 1.29
418 : efrank 1.1 =pod
419 :    
420 :     =head1 install_annotations
421 :    
422 :     usage: &install_annotations($fig_disk,$package)
423 :    
424 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
425 :    
426 :     $package must be an absolute filename where the "annotations package" from which to make
427 :     the update exists.
428 :    
429 :     =cut
430 :    
431 :     sub install_annotations {
432 : overbeek 1.29 my($fig,$package) = @_;
433 :     my($user,$who,$date,$userR,@assignments,$peg,$aliases,$org,$func);
434 :     my(%pegs,%seq_of,@seq,$peg_to,$trans_pegs,$seq,$line,@ann,$ann);
435 : efrank 1.1 my($genome);
436 :    
437 : overbeek 1.29 my $fig_disk = $FIG_Config::fig_disk;
438 :     open(IN,"<$package") || die "could not open $package";
439 :     $/ = "\n//\n";
440 :     if (defined($line = <IN>))
441 :     {
442 :     $line =~ s/\n\/\/\n/\n/s;
443 :     $line =~ s/\n\/\/\/\n//s;
444 :     @ann = split(/\n\/\/\/\n/,$line);
445 :     foreach $ann (@ann)
446 :     {
447 :     if ($ann =~ /^(fig\|\d+\.\d+\.peg\.\d+)\n(\d+)\n(\S+)\n(.*)/s)
448 :     {
449 :     push(@annotations,[$1,$2,$3,$4]);
450 :     }
451 :     }
452 :     $/ = "\n";
453 :     while ($line && defined($line = <IN>) && ($line !~ /^\/\//))
454 :     {
455 :     chop $line;
456 :     ($peg,$aliases,$org,$func) = split(/\t/,$line);
457 :     $pegs{$peg} = [$aliases,$org,$func];
458 :     }
459 :    
460 :     if ($line) { $line = <IN> }
461 :     while (defined($line) && ($line !~ /^\/\//))
462 :     {
463 :     if ($line =~ /^>(\S+)/)
464 :     {
465 :     $peg = $1;
466 :     @seq = ();
467 :     while (defined($line = <IN>) && ($line !~ /^[>\/]/) && ($line !~ /^\/\//))
468 :     {
469 :     push(@seq,$line);
470 :     $line = <IN>;
471 :     }
472 :     $seq = join("",@seq);
473 :     $seq =~ s/[ \n\t]//gs;
474 :     $seq_of{$peg} = uc $seq;
475 :     }
476 :     }
477 :     close(IN);
478 :     $trans_pegs = $fig->translate_pegs(\%pegs,\%seq_of);
479 :     @annotations = sort { ($a->[0] cmp $b->[0]) or ($a->[1] <=> $b->[1]) }
480 :     map { ($peg = $trans_pegs->{$_->[0]}) ? [$peg,$_->[1],$_->[2],$_->[3]] : () }
481 :     @annotations;
482 :    
483 :     if (-d "$fig_disk/BackupAnnotations") { system "rm -rf $fig_disk/BackupAnnotations" }
484 :     mkdir("$fig_disk/BackupAnnotations",0777);
485 :     mkdir("$fig_disk/BackupAnnotations/New",0777);
486 :     for ($i=0; ($i < @annotation); $i++)
487 :     {
488 :     if (($i == 0) || ($fig->genome_of($annotations[$i]->[0]) ne $fig->genome_of($annotations[$i-1]->[0])))
489 :     {
490 :     if ($i != 0)
491 :     {
492 :     close(OUT);
493 :     }
494 :     $genome = $fig->genome_of($annotations[$i]->[0]);
495 :     open(OUT,">$fig_disk/BackupAnnotations/New/$genome")
496 :     || die "could not open $fig_disk/BackupAnnotations/New/$genome";
497 :     }
498 :     print OUT join("\n",@{$annotations[$i]}),"\n//\n";
499 :     }
500 :     if ($i > 0) { close(OUT) }
501 :     }
502 : efrank 1.15
503 : efrank 1.1 opendir(TMP,"$fig_disk/BackupAnnotations/New") || die "could not open $fig_disk/BackupAnnotations/New";
504 :     my @genomes = grep { $_ =~ /^\d+\.\d+$/ } readdir(TMP);
505 :     closedir(TMP);
506 :     foreach $genome (@genomes)
507 :     {
508 : efrank 1.14 next if (! -d "$fig_disk/FIG/Data/organisms/$genome");
509 : efrank 1.13
510 : efrank 1.1 print STDERR "installing $fig_disk/FIG/Data/Organisms/$genome/annotations\n";
511 :     if (-s "$fig_disk/FIG/Data/Organisms/$genome/annotations")
512 :     {
513 :     &FIG::run("cp -p $fig_disk/FIG/Data/Organisms/$genome/annotations $fig_disk/BackupAnnotations/$genome");
514 : 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");
515 : efrank 1.1 }
516 :     else
517 :     {
518 :     &FIG::run("cp $fig_disk/BackupAnnotations/New/$genome $fig_disk/FIG/Data/Organisms/$genome/annotations");
519 :     }
520 : disz 1.31 chmod 02777,"$fig_disk/FIG/Data/Organisms/$genome/annotations";
521 : efrank 1.1 }
522 : efrank 1.9 &FIG::run("$FIG_Config::bin/index_annotations");
523 : efrank 1.1 }
524 :    
525 :     =pod
526 :    
527 :     =head1 restore_annotations
528 :    
529 :     usage: &restore_annotations($fig_disk);
530 :    
531 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
532 :    
533 :     =cut
534 :    
535 :     sub restore_annotations {
536 :     my($fig_disk) = @_;
537 :    
538 :     &force_absolute($fig_disk);
539 :     (-d "$fig_disk/BackupAnnotations") || die "could not find an active backup";
540 :     opendir(TMP,"$fig_disk/BackupAnnotations") || die "could not open $fig_disk/BackupAnnotations";
541 :     my @genomes = grep { $_ =~ /^\d+\.\d+$/ } readdir(TMP);
542 :     closedir(TMP);
543 :     foreach $genome (@genomes)
544 :     {
545 :     unlink("$fig_disk/FIG/Data/Organisms/$genome/annotations");
546 :     &FIG::run("cp $fig_disk/BackupAnnotations/$genome $fig_disk/FIG/Data/Organisms/$genome/annotations");
547 : disz 1.31 system "chmod 2777 $fig_disk/FIG/Data/Organisms/$genome/annotations";
548 : efrank 1.1 }
549 : efrank 1.9 &FIG::run("$FIG_Config::bin/index_annotations");
550 : efrank 1.1 }
551 :    
552 :     =pod
553 :    
554 :     =head1 package_aassignments
555 :    
556 : overbeek 1.20 usage: package_assignments($fig,$user,$who,$date,$genomes,$file)
557 : efrank 1.1
558 : overbeek 1.20 $user designates the user wishing to get the assignments
559 : efrank 1.1
560 : overbeek 1.5 $who designates whose assignments you want (defaults to "master")
561 :    
562 :     $date if given indicates a point in time (get assignments after that point)
563 :    
564 : efrank 1.1 $genomes is a pointer to a list of genome IDs that will be exchanged.
565 :    
566 :     $file must be an absolute filename where the "assignment package" will be built.
567 :    
568 :     =cut
569 :    
570 :     sub package_assignments {
571 : overbeek 1.20 my($fig,$user,$who,$date,$genomes,$file) = @_;
572 : overbeek 1.27 my($genome,$x,$org,$curr,$peg);
573 : overbeek 1.4 $who = $who ? $who : "master";
574 : overbeek 1.7 $date = $date ? $date : 0;
575 : overbeek 1.27
576 : overbeek 1.20 if (open(ASSIGNMENTS,">$file"))
577 : efrank 1.1 {
578 : overbeek 1.20 print ASSIGNMENTS "$user\t$who\t$date\n";
579 : overbeek 1.27 my @assignments = sort { $a->[0] cmp $b->[0] } $fig->assignments_made($genomes,$who,$date);
580 :     foreach $x (@assignments)
581 : efrank 1.1 {
582 : overbeek 1.20 print ASSIGNMENTS join("\t",@$x),"\n";
583 : overbeek 1.4 }
584 : overbeek 1.27 print ASSIGNMENTS "//\n";
585 :    
586 :     foreach $x (@assignments)
587 :     {
588 :     ($peg,undef) = @$x;
589 : overbeek 1.30 my @aliases = grep { $_ =~ /^(sp\||gi\||pirnr\||kegg\||N[PGZ]_)/ } $fig->feature_aliases($peg);
590 :     print ASSIGNMENTS join("\t",($peg,join(",",@aliases),$fig->genus_species($fig->genome_of($peg)),scalar $fig->function_of($peg))) . "\n";
591 : overbeek 1.28 }
592 :     print ASSIGNMENTS "//\n";
593 :    
594 :     foreach $x (@assignments)
595 :     {
596 :     ($peg,undef) = @$x;
597 : overbeek 1.30 my $seq = $fig->get_translation($peg);
598 : overbeek 1.27 &FIG::display_id_and_seq($peg,\$seq,\*ASSIGNMENTS);
599 :     }
600 :     close(ASSIGNMENTS);
601 : efrank 1.1 }
602 :     }
603 :    
604 :     =pod
605 :    
606 :     =head1 install_assignments
607 :    
608 : overbeek 1.20 usage: &install_assignments($package)
609 : efrank 1.1
610 : overbeek 1.20 $package must be a filename where the "assignments package" from which to make
611 :     the assignment set exists
612 : efrank 1.1
613 :     =cut
614 :    
615 :     sub install_assignments {
616 : overbeek 1.29 my($fig,$package) = @_;
617 :     my($user,$who,$date,$userR,@assignments,$peg,$aliases,$org,$func);
618 :     my(%pegs,%seq_of,@seq,$peg_to,$trans_pegs,$seq);
619 : efrank 1.1
620 : overbeek 1.20 open(IN,"<$package") || die "could not open $package";
621 :     my $line = <IN>;
622 :     chop $line;
623 :     ($user,$who,$date) = split(/\t/,$line);
624 : olson 1.26 $userR = $user;
625 :     $userR =~ s/^master://;
626 : overbeek 1.29
627 : overbeek 1.30 while (defined($line = <IN>) && ($line !~ /^\/\//))
628 : overbeek 1.29 {
629 :     if ($line =~ /^(fig\|\d+\.\d+\.peg\.\d+)\t(\S.*\S)/)
630 :     {
631 :     push(@assignments,[$1,$2]);
632 :     }
633 :     }
634 :     while ($line && defined($line = <IN>) && ($line !~ /^\/\//))
635 :     {
636 :     chop $line;
637 :     ($peg,$aliases,$org,$func) = split(/\t/,$line);
638 :     $pegs{$peg} = [$aliases,$org,$func];
639 :     }
640 :    
641 :     if ($line) { $line = <IN> }
642 :     while (defined($line) && ($line !~ /^\/\//))
643 :     {
644 :     if ($line =~ /^>(\S+)/)
645 :     {
646 :     $peg = $1;
647 :     @seq = ();
648 :     while (defined($line = <IN>) && ($line !~ /^[>\/]/) && ($line !~ /^\/\//))
649 :     {
650 :     push(@seq,$line);
651 :     $line = <IN>;
652 :     }
653 :     $seq = join("",@seq);
654 :     $seq =~ s/[ \n\t]//gs;
655 :     $seq_of{$peg} = uc $seq;
656 :     }
657 :     }
658 :     close(IN);
659 :     $trans_pegs = $fig->translate_pegs(\%pegs,\%seq_of);
660 :    
661 : olson 1.26 &FIG::verify_dir("$FIG_Config::data/Assignments/$userR");
662 : overbeek 1.29 my $file = &FIG::epoch_to_readable($date) . ":$who:imported";
663 : overbeek 1.20 $file =~ s/\//-/g;
664 : olson 1.26 open(OUT,">$FIG_Config::data/Assignments/$userR/$file")
665 :     || die "could not open $FIG_Config::data/Assignments/$userR/$file";
666 : overbeek 1.29
667 :     foreach $peg (keys(%$trans_pegs))
668 : overbeek 1.20 {
669 : overbeek 1.29 $peg_to = $trans_pegs->{$peg};
670 :     $func = $pegs{$peg}->[2];
671 :     if ($fig->function_of($peg_to) ne $func)
672 :     {
673 :     print OUT "$peg_to\t$func\n";
674 :     }
675 : overbeek 1.20 }
676 : overbeek 1.29
677 : overbeek 1.20 close(OUT);
678 : olson 1.26 if (! -s "$FIG_Config::data/Assignments/$userR/$file") { unlink("$FIG_Config::data/Assignments/$userR/$file") }
679 : efrank 1.1 }
680 :    
681 :     =pod
682 :    
683 :     =head1 package_translation_rules
684 :    
685 :     usage: &package_translation_rules($fig_base,$file)
686 :    
687 :     $fig_base must be an absolute filename (begins with "/") giving the FIG from which
688 :     the updated code release will be taken.
689 :    
690 :     $file must be an absolute filename where the "translation_rules package" will be built.
691 :    
692 :     =cut
693 :    
694 :     sub package_translation_rules {
695 :     my($fig_base,$file) = @_;
696 :    
697 :     &FIG::run("cp $fig_base/Data/Global/function.synonyms $file");
698 :     }
699 :    
700 :     =pod
701 :    
702 :     =head1 install_translation_rules
703 :    
704 : efrank 1.10 usage: &install_translation_rules($fig_disk,$from,$package)
705 : efrank 1.1
706 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
707 :    
708 :     $package must be an absolute filename where the "translation_rules package" from which to make
709 :     the update exists.
710 :    
711 :     =cut
712 :    
713 :     sub install_translation_rules {
714 : efrank 1.10 my($fig_disk,$from,$package) = @_;
715 : efrank 1.1
716 :     my $file = "$fig_disk/FIG/Data/Global/function.synonyms";
717 :     &force_absolute($fig_disk);
718 :     if (-d "$fig_disk/BackupTranslation_Rules") { system "rm -rf $fig_disk/BackupTranslation_Rules" }
719 :     mkdir("$fig_disk/BackupTranslation_Rules",0777);
720 : disz 1.31 chmod 02777,"$fig_disk/BackupTranslation_Rules";
721 : efrank 1.1 if (-s $file)
722 :     {
723 :     &FIG::run("cp $file $fig_disk/BackupTranslation_Rules");
724 :     }
725 : efrank 1.10 &FIG::run("$FIG_Config::bin/merge_translation_rules $fig_disk/BackupTranslation_Rules/function.synonyms $package $from > $file");
726 : disz 1.31 chmod 02777,$file;
727 : efrank 1.1 }
728 :    
729 :     =pod
730 :    
731 :     =head1 restore_translation_rules
732 :    
733 :     usage: &restore_translation_rules($fig_disk);
734 :    
735 :     $fig_disk must be an absolute filename (begins with "/") giving the FIG to be updated.
736 :    
737 :     =cut
738 :    
739 :     sub restore_translation_rules {
740 :     my($fig_disk) = @_;
741 :    
742 :     &force_absolute($fig_disk);
743 :    
744 :     my $file = "$fig_disk/FIG/Data/Global/function.synonyms";
745 :     (-s "$fig_disk/BackupTranslation_Rules/function.synonyms") || die "could not find an active backup";
746 :     if (-s "$fig_disk/BackupTranslation_Rules/function.synonyms")
747 :     {
748 :     &FIG::run("cp $fig_disk/BackupTranslation_Rules/function.synonyms $file");
749 : disz 1.31 chmod 02777, $file;
750 : efrank 1.1 }
751 :     }
752 :    
753 : overbeek 1.23 sub package_subsystems {
754 : overbeek 1.30 my($fig,$file,$just_exchangable) = @_;
755 : overbeek 1.23 my($ssa);
756 :    
757 : overbeek 1.27 $just_exchangable = defined($just_exchangable) ? $just_exchangable : 1;
758 :     my @exchangable = grep { (! $just_exchangable) || $fig->is_exchangable_subsystem($_) }
759 :     $fig->all_subsystems;
760 :    
761 : overbeek 1.23 my $fig = new FIG;
762 : overbeek 1.24 if ((@exchangable > 0) && open(SUB,">$file"))
763 : overbeek 1.23 {
764 : overbeek 1.24 foreach $ssa (@exchangable)
765 : overbeek 1.23 {
766 : overbeek 1.25 # print STDERR "writing $ssa to $file\n";
767 :     my($spreadsheet,$notes) = $fig->exportable_subsystem($ssa);
768 : overbeek 1.23 print SUB join("",@$spreadsheet),join("",@$notes),"########################\n";
769 :     }
770 :     close(SUB);
771 :     }
772 : overbeek 1.25 else
773 :     {
774 :     # print STDERR &Dumper(\@exchangable,$file);
775 :     }
776 : overbeek 1.23 }
777 :    
778 : overbeek 1.30 sub install_subsystems {
779 :     my($fig,$package) = @_;
780 :    
781 : disz 1.31 &FIG::run("$FIG_Config::bin/import_subsystems master last_release < $package");
782 : overbeek 1.30 }
783 :    
784 : efrank 1.1 1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3