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

Annotation of /FigKernelPackages/P2P.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.1 #
2 :     # This module contains the code for the P2P update protocol.
3 :     #
4 :     # Package P2P contains the namespace declarations, and possibly toplevel utility
5 :     # routines. (get_relay ?)
6 :     #
7 :     # Package P2P::Relay contains methods for contacting the P2P relay service. The actual
8 :     # implementation of the relay service is not contained here - it is a standalone module
9 :     # that can be installed on a web server that does not have a full SEED installed.
10 :     #
11 :     # Package P2P::Requestor contains the requestor-side code for the update protocol.
12 :     #
13 :     # Package P2P::Service contains the web service implementation routines for the
14 :     # protocol.
15 :     #
16 :    
17 :     package P2P;
18 :    
19 :     use FIG_Config;
20 :    
21 :     use strict;
22 :     use Exporter;
23 :     use base qw(Exporter);
24 :    
25 :     use Data::Dumper;
26 :    
27 :     use vars qw(@EXPORT @EXPORT_OK);
28 :     @EXPORT = ();
29 :     @EXPORT_OK = qw($ns_p2p $ns_relay);
30 :    
31 :     our $ns_p2p = "http://thefig.info/schemas/p2p_update";
32 :     our $ns_relay = "http://thefig.info/schemas/p2p_relay";
33 :    
34 :     =pod
35 :    
36 :     =head1 perform_update($peer)
37 :    
38 :     Perform a peer-to-peer update with the given peer. $peer is an instance of
39 :     P2P::Requestor which can connect to the peer. It is expected that the
40 :     SEED infrastructure will create this requestor appropriately for the
41 :     particular circumstance (direct connection, thru relay, etc).
42 :    
43 :     This code executes the high-level protocol, maintaining state between
44 :     calls to the peer to exchange the actual information.
45 :    
46 :     =cut
47 :    
48 :     sub perform_update
49 :     {
50 :     my($fig, $peer, $last_update) = @_;
51 :    
52 :     my $ret = $peer->request_update($last_update);
53 :    
54 :     if (!$ret or ref($ret) ne "ARRAY")
55 :     {
56 :     die "perform_update: request_updated failed\n";
57 :     }
58 :    
59 :     my($session, $target_release, $num_annos, $num_pegs, $num_genomes,
60 :     $target_time, $compatible) = @$ret;
61 :    
62 :     print "perform_update: session=$session target=$target_release num_annos=$num_annos\n";
63 :     print " num_pegs=$num_pegs num_genomes=$num_genomes target_time=$target_time compat=$compatible\n";
64 :    
65 :     #
66 :     # We have the information now to begin the update process. Retrieve the pegs.
67 :     #
68 :    
69 :     $ret = $peer->get_pegs($session, 0, $num_pegs);
70 :    
71 :     if (!$ret or ref($ret) ne "ARRAY")
72 :     {
73 :     die "perform_update: get_pegs failed\n";
74 :     }
75 :    
76 :     my($peg_list, $genome_list) = @$ret;
77 :    
78 :     #
79 :     # Walk the peg-list to and generate @pegs_to_finalize.
80 :     #
81 :    
82 :     my(%peg_mapping, %genome_map );
83 :    
84 :     for my $peg_info (@$peg_list)
85 :     {
86 :     my($key, $peg, @rest) = @$peg_info;
87 :    
88 :     if ($key eq 'peg')
89 :     {
90 :     #
91 :     # Peg id is directly usable.
92 :     #
93 : olson 1.6 $peg_mapping{$peg} = $peg;
94 : olson 1.1 }
95 :     elsif ($key eq 'peg_info')
96 :     {
97 :     #
98 :     # Peg id not directly usable.
99 :     #
100 :    
101 :     my($alias_list, $genome_id) = @rest;
102 :    
103 :     for my $alias (@$alias_list)
104 :     {
105 :     my $mapped = $fig->by_alias($alias);
106 : olson 1.3 if ($mapped)
107 : olson 1.1 {
108 :     print "$peg maps to $mapped via $alias\n";
109 :     $peg_mapping{$peg}= $mapped;
110 :     last;
111 :     }
112 :     }
113 :    
114 :     #
115 :     # If we didn't succeed in mapping by alias,
116 :     # stash this in the list of pegs to be mapped by
117 :     # genome.
118 :     #
119 :    
120 :     if (!defined($peg_mapping{$peg}))
121 :     {
122 :     push(@{$genome_map{$genome_id}}, $peg);
123 : olson 1.4 print "$peg did not map\n";
124 : olson 1.1 }
125 :     }
126 :     }
127 :    
128 :     #
129 :     # finished first pass. Now go over the per-genome mappings that need to be made.
130 :     #
131 : olson 1.6 # $genome_map{$genome_id} is a list of pegs that reside on that genome.
132 :     # the pegs and genome id are both target-based identifiers.
133 :     #
134 :    
135 :     my @finalize_req = ();
136 : olson 1.7 my %local_genome;
137 : olson 1.1
138 :     for my $genome_info (@$genome_list)
139 :     {
140 :     my($genome, $n_contigs, $n_nucs, $cksum) = @$genome_info;
141 :    
142 : olson 1.5 next unless defined($genome_map{$genome});
143 : olson 1.1
144 : olson 1.6 #
145 :     # Determine if we have a local genome installed that matches precisely the
146 :     # genome on the target side.
147 :     #
148 : olson 1.1 my $my_genome = $fig->find_genome_by_content($genome, $n_contigs, $n_nucs, $cksum);
149 :    
150 : olson 1.6 my $pegs = $genome_map{$genome};
151 :    
152 : olson 1.1 if ($my_genome)
153 :     {
154 :     #
155 : olson 1.6 # We do have such a local genome. Generate a peg_genome request to
156 :     # get the location information from the target side.
157 : olson 1.1 #
158 : olson 1.7 # Also remember the local genome mapping for this peg.
159 :     #
160 :    
161 : olson 1.6 print "$genome mapped to $my_genome\n";
162 : olson 1.7 for my $peg (@$pegs)
163 :     {
164 :     push(@finalize_req, ['peg_genome', $peg]);
165 :     $local_genome{$peg} = $my_genome;
166 :     }
167 : olson 1.1
168 :     }
169 : olson 1.2 else
170 :     {
171 : olson 1.6 #
172 :     # We don't have such a genome. We need to retrieve the
173 :     # sequence data in order to finish mapping.
174 :     #
175 :     push(@finalize_req, map { ['peg_unknown', $_] } @$pegs);
176 :     }
177 :     }
178 :    
179 :     #
180 :     # If we need to finalize, make the call.
181 :     if (@finalize_req)
182 :     {
183 :     print Dumper(\@finalize_req);
184 :     $ret = $peer->finalize_pegs($session, \@finalize_req);
185 :    
186 :     if (!$ret or ref($ret) ne "ARRAY")
187 :     {
188 :     die "perform_update: finalize_pegs failed\n";
189 : olson 1.2 }
190 : olson 1.6
191 :     #
192 :     # The return is a list of either location entries or
193 : olson 1.7 # sequence data. Attempt to finish up the mapping.
194 : olson 1.6 #
195 :    
196 : olson 1.13 my(%sought, %sought_seqs);
197 :    
198 : olson 1.9
199 :     my $dbh = $fig->db_handle();
200 : olson 1.7 for my $entry (@$ret)
201 :     {
202 :     my($what, $peg, @rest) = @$entry;
203 :    
204 :     if ($what eq "peg_loc")
205 :     {
206 : olson 1.13 my($strand, $start, $end, $cksum, $seq) = @rest;
207 : olson 1.7
208 :     #
209 :     # We have a contig location. Try to find a matching contig
210 :     # here, and see if it maps to something.
211 :     #
212 :    
213 :     my $my_genome = $local_genome{$peg};
214 :     my $local_contig = $fig->find_contig_with_checksum($my_genome, $cksum);
215 :     if ($local_contig)
216 :     {
217 : olson 1.8 #
218 : olson 1.9 # Now look up the local peg. We match on the end location; depending on the strand
219 :     # the feature is on, we want to look at either minloc or maxloc.
220 : olson 1.8 #
221 : olson 1.9
222 :     my $whichloc = $strand eq '-' ? "minloc" : "maxloc";
223 :    
224 :     my $res = $dbh->SQL(qq!SELECT id from features
225 :     WHERE $whichloc = $end and genome = '$my_genome' and
226 :     contig = '$local_contig'
227 :     !);
228 :    
229 : olson 1.12 if ($res and @$res > 0)
230 : olson 1.9 {
231 : olson 1.12 my(@ids) = map { $_->[0] } @$res;
232 :     my $id = $ids[0];
233 : olson 1.9 $peg_mapping{$peg} = $id;
234 :     print "Mapped $peg to $id via contigs\n";
235 : olson 1.12 if (@$res > 1)
236 :     {
237 :     warn "Multiple mappings found for $peg: @ids\n";
238 :     }
239 : olson 1.9 }
240 :     else
241 :     {
242 : olson 1.11 print "failed: $peg $my_genome and contig $local_contig start=$start end=$end strand=$strand\n";
243 : olson 1.13 $sought{$peg}++;
244 :     $sought_seq{$peg} = $seq;
245 : olson 1.9 }
246 : olson 1.7 }
247 :     else
248 :     {
249 :     print "Mapping failed for $my_genome checksum $cksum\n";
250 : olson 1.13 $sought{$peg}++;
251 :     $sought_seq{$peg} = $seq;
252 : olson 1.7 }
253 :     }
254 : olson 1.13 elsif ($what eq "peg_seq")
255 :     {
256 :     my($seq) = @rest;
257 :    
258 :     $sought{$peg}++;
259 :     $sought_seq{$peg} = $seq;
260 :     }
261 :     }
262 :    
263 :     #
264 :     # Now see if we need to do a tough search.
265 :     #
266 :    
267 :     if (keys(%sought) > 0)
268 :     {
269 :     my %trans;
270 :    
271 :     print "Starting tough search\n";
272 :    
273 :     $fig->tough_search(undef, \%sought_seq, \%trans, \%sought);
274 :     print "Tough search translated: \n";
275 :     map { print "$_ -> $trans{$_}\n" } keys(%trans);
276 : olson 1.7 }
277 : olson 1.1 }
278 :     }
279 :    
280 :    
281 :     #############
282 :     #
283 :     # P2P Relay
284 :     #
285 :     #############
286 :    
287 :    
288 :     package P2P::Relay;
289 :     use strict;
290 :    
291 :     use Data::Dumper;
292 :     use SOAP::Lite;
293 :    
294 :     use P2P;
295 :    
296 :     sub new
297 :     {
298 :     my($class, $url) = @_;
299 :    
300 :     my $proxy = SOAP::Lite->uri($P2P::ns_relay)->proxy($url);
301 :    
302 :     my $self = {
303 :     url => $url,
304 :     proxy => $proxy,
305 :     };
306 :     return bless($self, $class);
307 :     }
308 :    
309 :     sub enumerate_annotation_systems
310 :     {
311 :     my($self) = @_;
312 :    
313 :     return $self->{proxy}->enumerate_annotation_systems()->result;
314 :     }
315 :    
316 :     sub fetch_queries
317 :     {
318 :     my($self, $id) = @_;
319 :    
320 :     my $reply = $self->{proxy}->fetch_queries($id);
321 :    
322 :     if ($reply->fault)
323 :     {
324 :     print "Failed to fetch queries: ", $reply->faultcode, " ", $reply->faultstring, "\n";
325 :     return undef;
326 :     }
327 :    
328 :     return $reply->result;
329 :     }
330 :    
331 :     sub deposit_answer
332 :     {
333 :     my($self, $id, $key, $answer) = @_;
334 :    
335 :     my $reply = $self->{proxy}->deposit_answer($id, $key,
336 :     SOAP::Data->type('base64')->value($answer));
337 :    
338 :     if ($reply->fault)
339 :     {
340 :     print "deposit_answer got fault: ", $reply->faultcode, " ", $reply->faultstring, "\n";
341 :     return undef;
342 :     }
343 :    
344 :     return $reply;
345 :     }
346 :    
347 :     =pod
348 :    
349 :     =head1 await_result
350 :    
351 :     Await the result from a possibly-asynchronous soap request.
352 :    
353 :     Look at the reply that we have. If it's a deferred reply, loop polling
354 :     the relay for the actual result.
355 :    
356 :     We determine if the reply is a deferred reply by examining the namespace
357 :     URI of the response. A response will be generated from the relay's namespace,
358 :     rather than that of the application itself.
359 :    
360 :     =cut
361 :    
362 :     sub await_result
363 :     {
364 :     my($self, $reply) = @_;
365 :    
366 :     while (1)
367 :     {
368 :     #
369 :     # Retrieve the namespace of the response, which is the first
370 :     # element in the body of the message.
371 :     #
372 :     my $ns = $reply->namespaceuriof('/Envelope/Body/[1]');
373 :     print "Reply ns=$ns want $P2P::ns_relay\n";
374 :    
375 :     if ($ns eq $P2P::ns_relay)
376 :     {
377 :     my $val = $reply->result;
378 :     print "got val=", Dumper($val);
379 :     if ($val->[0] eq 'deferred')
380 :     {
381 :     #
382 :     # Sleep a little, then try to retrieve the response.
383 :     #
384 :    
385 :     sleep(1);
386 :     my $id = $val->[1];
387 :    
388 :     print "Retrieving reply\n";
389 :     $reply = $self->{proxy}->call_completed($id);
390 :     }
391 :     else
392 :     {
393 :     #
394 :     # We're not sure what to do here..
395 :     #
396 :     return undef;
397 :     }
398 :     }
399 :     else
400 :     {
401 :     #
402 :     # We got an actual response. Return it.
403 :     #
404 :    
405 :     return $reply;
406 :     }
407 :     }
408 :     }
409 :    
410 :     #############
411 :     #
412 :     # P2P Requestor
413 :     #
414 :     #############
415 :    
416 :     package P2P::Requestor;
417 :     use strict;
418 :    
419 :     use Data::Dumper;
420 :    
421 :     use SOAP::Lite;
422 :     use P2P;
423 :    
424 :     #
425 :     # Create a new Requestor. It contains a reference to the FIG instance
426 :     # so that we can run the protocol completely from in here.
427 :     #
428 :    
429 :     sub new
430 :     {
431 :     my($class, $fig, $url, $peer_id, $relay) = @_;
432 :    
433 :     my $proxy = SOAP::Lite->uri($ns_p2p)->proxy($url);
434 :    
435 :     my $self = {
436 :     fig => $fig,
437 :     url => $url,
438 :     peer_id => $peer_id,
439 :     proxy => $proxy,
440 :     relay => $relay,
441 :     };
442 :     return bless($self, $class);
443 :     }
444 :    
445 :     #
446 :     # First step: Request an update.
447 :     #
448 :     # We need to determine some notion of what our release is, since we are not
449 :     # currently tagging them explicitly. Until we delve into this more,
450 :     # I am going to return a null release, which means the same-release
451 :     # optimization won't be able to kick in.
452 :     #
453 :     # We also need to determine the last time we got an update from this
454 :     # system.
455 :     #
456 :    
457 :     sub request_update
458 :     {
459 :     my($self, $last_update) = @_;
460 :    
461 :     my $rel = $self->{fig}->get_release_info();
462 :    
463 :     if (!defined($last_update))
464 :     {
465 :     $last_update = $self->{fig}->get_peer_last_update($self->{peer_id});
466 :     }
467 :    
468 :     my $reply = $self->{proxy}->request_update($rel, $last_update);
469 :    
470 :     if ($self->{relay})
471 :     {
472 :     $reply = $self->{relay}->await_result($reply);
473 :     }
474 :    
475 :     if ($reply->fault)
476 :     {
477 :     print "request_update triggered fault: ", $reply->faultcode, " ", $reply->faultstring, "\n";
478 :     return undef;
479 :     }
480 :    
481 :     return $reply->result;
482 :     }
483 :    
484 :     =pod
485 :    
486 :     =head1 get_pegs($session_id, $start, $length)
487 :    
488 :    
489 :     =cut
490 :    
491 :     sub get_pegs
492 :     {
493 :     my($self, $session_id, $start, $length) = @_;
494 :    
495 :     return $self->call("get_pegs", $session_id, $start, $length);
496 :     }
497 :    
498 : olson 1.6 sub finalize_pegs
499 :     {
500 :     my($self, $session_id, $request) = @_;
501 :    
502 :     return $self->call("finalize_pegs", $session_id, $request);
503 :     }
504 :    
505 : olson 1.1 sub call
506 :     {
507 :     my($self, $func, @args) = @_;
508 :    
509 :     my $reply = $self->{proxy}->$func(@args);
510 :    
511 :     if ($self->{relay})
512 :     {
513 :     $reply = $self->{relay}->await_result($reply);
514 :     }
515 :    
516 :     if ($reply->fault)
517 :     {
518 :     print "$func triggered fault: ", $reply->faultcode, " ", $reply->faultstring, "\n";
519 :     return undef;
520 :     }
521 :    
522 :     return $reply->result;
523 :     }
524 :    
525 :    
526 :     #############
527 :     #
528 :     # P2P Service
529 :     #
530 :     # Code in this module is invoked on the target on behalf of a requestor.
531 :     #
532 :     #############
533 :    
534 :     package P2P::Service;
535 :    
536 :     use Data::Dumper;
537 :    
538 :     use FIG;
539 :     use FIG_Config;
540 :     use strict;
541 :    
542 :     use File::Temp qw(tempdir);
543 :     use File::Basename;
544 :    
545 :     sub request_update
546 :     {
547 :     my($class, $his_release, $last_update)= @_;
548 :    
549 :     #
550 :     # Verify input.
551 :     #
552 :    
553 :     if ($last_update !~ /^\d+$/)
554 :     {
555 :     die "request_update: last_update must be a number (not '$last_update')\n";
556 :     }
557 :    
558 :     #
559 :     # Create a new session id and a spool directory to use for storage
560 :     # of information about it. This can go in the tempdir since it is
561 :     # not persistent.
562 :     #
563 :    
564 :     &FIG::verify_dir("$FIG_Config::temp/p2p_spool");
565 :     #my $spool_dir = tempdir(DIR => "$FIG_Config::temp/p2p_spool");
566 :    
567 :     my $spool_dir = "$FIG_Config::temp/p2p_spool/test";
568 :     &FIG::verify_dir($spool_dir);
569 :    
570 :     my $session_id = basename($spool_dir);
571 :     my $now = time;
572 :    
573 :     #
574 :     # Gather the list of pegs and annotations for the update.
575 :     #
576 :    
577 :     my $fig = new FIG;
578 :    
579 :     my $all_genomes = [$fig->genomes];
580 :    
581 :     my %all_genomes = map { $_ => 1 } @$all_genomes;
582 :    
583 :     my %pegs;
584 :    
585 :     my $num_annos = 0;
586 :     my $num_genomes = 0;
587 :     my $num_pegs = 0;
588 :    
589 :     my $anno_fh;
590 :     open($anno_fh, ">$spool_dir/annos");
591 :    
592 :     my $peg_fh;
593 :     open($peg_fh, ">$spool_dir/pegs");
594 :    
595 :     my $genome_fh;
596 :     open($genome_fh, ">$spool_dir/genomes");
597 :    
598 :     for my $genome (@$all_genomes)
599 :     {
600 :     my $num_annos_for_genome = 0;
601 :    
602 :     my $genome_dir = "$FIG_Config::organisms/$genome";
603 :     next unless -d $genome_dir;
604 :    
605 :     my $afh;
606 :     if (open($afh, "$genome_dir/annotations"))
607 :     {
608 :     my($fid, $anno_time, $who, $anno_text);
609 :     local($/);
610 :     $/ = "//\n";
611 :     while (my $ann = <$afh>)
612 :     {
613 :     chomp $ann;
614 :    
615 :     if ((($fid, $anno_time, $who, $anno_text) =
616 :     ($ann =~ /^(fig\|\d+\.\d+\.peg\.\d+)\n(\d+)\n(\S+)\n(.*\S)/s)) and
617 :     $anno_time > $last_update)
618 :    
619 :     {
620 :     #
621 :     # Look up aliases if we haven't seen this fid before.
622 :     #
623 :    
624 :     if (!defined($pegs{$fid}))
625 :     {
626 :     my @aliases = $fig->feature_aliases($fid);
627 :    
628 :     print $peg_fh join("\t", $fid, $genome, @aliases), "\n";
629 :     $num_pegs++;
630 :     }
631 :    
632 :     print $anno_fh "$ann//\n";
633 :    
634 :     $pegs{$fid}++;
635 :    
636 :     $num_annos_for_genome++;
637 :     $num_annos++;
638 :     }
639 :     }
640 :     close($afh);
641 :     }
642 :    
643 :     #
644 :     # Determine genome information if we have annotations for this one.
645 :     #
646 :    
647 :     if ($num_annos_for_genome > 0)
648 :     {
649 :     $num_genomes++;
650 :     if (open(my $cfh, "<$genome_dir/COUNTS"))
651 :     {
652 :     if ($_ = <$cfh>)
653 :     {
654 :     chomp;
655 :     my($cgenome, $n_contigs, $total_nucs, $cksum) = split(/\t/, $_);
656 :     if ($cgenome ne $genome)
657 :     {
658 :     warn "Hm, $genome has a COUNTS file with genome=$cgenome that does not match\n";
659 :     }
660 :     else
661 :     {
662 :     print $genome_fh join("\t",
663 :     $genome, $num_annos_for_genome, $n_contigs,
664 :     $total_nucs, $cksum), "\n";
665 :     }
666 :     }
667 :     }
668 :     }
669 :    
670 :     }
671 :     close($anno_fh);
672 :     close($peg_fh);
673 :     close($genome_fh);
674 :    
675 :     print "Pegs: $num_pegs\n";
676 :     print "Genomes: $num_genomes\n";
677 :     print "Annos: $num_annos\n";
678 :    
679 :     #
680 :     # Check compatibility.
681 :     #
682 :    
683 :     my $my_release = $fig->get_release_info();
684 :     my $compatible = (defined($my_release) && ($my_release == $his_release)) ? 1 : 0;
685 :    
686 :     open(my $fh, ">$spool_dir/INFO");
687 :     print $fh "requestor_release\t$his_release\n";
688 :     print $fh "last_update\t$last_update\n";
689 :     print $fh "cur_update\t$now\n";
690 :     print $fh "target_release\t$my_release\n";
691 :     print $fh "compatible\t$compatible\n";
692 :     print $fh "num_pegs\t$num_pegs\n";
693 :     print $fh "num_genomes\t$num_genomes\n";
694 :     print $fh "num_annos\t$num_annos\n";
695 :     close($fh);
696 :    
697 :     return [$session_id, $my_release, $num_annos, $num_pegs, $num_genomes, $now, $compatible];
698 :     }
699 :    
700 :    
701 :     sub get_pegs
702 :     {
703 :     my($self, $session_id, $start, $len) = @_;
704 :     my(%session_info);
705 :    
706 :     my $spool_dir = "$FIG_Config::temp/p2p_spool/$session_id";
707 :    
708 :     -d $spool_dir or die "Invalid session id $session_id";
709 :    
710 :     #
711 :     # Read in the cached information for this session.
712 :     #
713 :    
714 :     open(my $info_fh, "<$spool_dir/INFO") or die "Cannot open INFO file: $!";
715 :     while (<$info_fh>)
716 :     {
717 :     chomp;
718 :     my($var, $val) = split(/\t/, $_, 2);
719 :     $session_info{$var} = $val;
720 :     }
721 :     close($info_fh);
722 :    
723 :     #
724 :     # Sanity check start and length.
725 :     #
726 :    
727 :     if ($start < 0 or $start >= $session_info{num_pegs})
728 :     {
729 :     die "Invalid start position $start";
730 :     }
731 :    
732 :     if ($len < 0 or ($start + $len - 1) >= $session_info{num_pegs})
733 :     {
734 :     die "Invalid length $len";
735 :     }
736 :    
737 :     #
738 :     # Open file, spin to the starting line, then start reading.
739 :     #
740 :    
741 :     open(my $peg_fh, "<$spool_dir/pegs") or die "Cannot open pegs file: $!";
742 :    
743 :     my $peg_output = [];
744 :     my $genome_output = [];
745 :    
746 :     my $peg_num = 0;
747 :     my $genomes_to_show = [];
748 :     my %genomes_to_show;
749 :    
750 :     my($fid, $genome, @aliases);
751 :    
752 :     while (<$peg_fh>)
753 :     {
754 :     next if ($peg_num < $start);
755 :    
756 :     last if ($peg_num > ($start + $len));
757 :    
758 :     chomp;
759 :    
760 :     #
761 :     # OK, this is a peg to process.
762 :     # It's easy if we're compatible.
763 :     #
764 :    
765 :     ($fid, $genome, @aliases) = split(/\t/, $_);
766 :    
767 :     if ($session_info{compatible})
768 :     {
769 :     push(@$peg_output, ['peg', $fid]);
770 :     }
771 :     else
772 :     {
773 :     if (!$genomes_to_show{$genome})
774 :     {
775 :     push(@$genomes_to_show, $genome);
776 :     $genomes_to_show{$genome}++;
777 :     }
778 :     push(@$peg_output, ['peg_info', $fid, [@aliases], $genome]);
779 :     }
780 :     }
781 :     continue
782 :     {
783 :     $peg_num++;
784 :     }
785 :    
786 :     #
787 :     # Read the genomes file, returning information about genomes referenced
788 :     # in the pegs returned.
789 :     #
790 :    
791 :     my $n_left = @$genomes_to_show;
792 :    
793 :     open(my $gfh, "<$spool_dir/genomes") or die "Cannot open genomes file: $!";
794 :     while ($n_left > 0 and $_ = <$gfh>)
795 :     {
796 :     chomp;
797 :    
798 :     my($genome, $n_annos, $n_contigs, $n_nucs, $cksum) = split(/\t/);
799 :    
800 :     if ($genomes_to_show{$genome})
801 :     {
802 :     push(@$genome_output, [$genome, $n_contigs, $n_nucs, $cksum]);
803 :     $n_left--;
804 :     }
805 :     }
806 :     close($gfh);
807 :    
808 :     return [$peg_output, $genome_output];
809 :     }
810 : olson 1.6
811 :     sub finalize_pegs
812 :     {
813 :     my($self, $session, $request) = @_;
814 :     my($out);
815 :    
816 :     my $fig = new FIG;
817 :    
818 :     #
819 :     # Walk the request handling appropriately. This is fairly easy, as it
820 :     # is just a matter of pulling either sequence or location/contig data.
821 :     #
822 :    
823 :     for my $item (@$request)
824 :     {
825 :     my($what, $peg) = @$item;
826 :    
827 :     if ($what eq "peg_genome")
828 :     {
829 :     #
830 :     # Return the location and contig checksum for this peg.
831 :     #
832 : olson 1.13 # We also include the sequence in case the contig mapping doesn't work.
833 :     #
834 : olson 1.6
835 :     my $loc = $fig->feature_location($peg);
836 :     my $contig = $fig->contig_of($loc);
837 : olson 1.7 my $cksum = $fig->contig_checksum($fig->genome_of($peg), $contig);
838 : olson 1.13 my $seq = $fig->get_translation($peg);
839 : olson 1.6
840 :     push(@$out, ['peg_loc', $peg,
841 : olson 1.13 $fig->strand_of($peg),
842 : olson 1.6 $fig->beg_of($loc), $fig->end_of($loc),
843 : olson 1.13 $cksum, $seq]);
844 : olson 1.6
845 :     }
846 : olson 1.7 elsif ($what eq "peg_unknown")
847 : olson 1.6 {
848 :     my $seq = $fig->get_translation($peg);
849 :     push(@$out, ['peg_seq', $peg, $seq]);
850 :     }
851 :     }
852 :     return $out;
853 :     }
854 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3