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

Diff of /FigKernelPackages/P2P.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.24, Mon Jan 10 13:15:00 2005 UTC revision 1.29, Wed Feb 23 22:07:14 2005 UTC
# Line 46  Line 46 
46    
47  =pod  =pod
48    
49  =head1 perform_update($peer)  =head1 perform_update($peer, $last_update, $skip_tough_search, $update_thru, $log_file, $html_file, $assignment_policy))
50    
51  Perform a peer-to-peer update with the given peer. $peer is an instance of  Perform a peer-to-peer update with the given peer. $peer is an instance of
52  P2P::Requestor which can connect to the peer. It is expected that the  P2P::Requestor which can connect to the peer. It is expected that the
# Line 56  Line 56 
56  This code executes the high-level protocol, maintaining state between  This code executes the high-level protocol, maintaining state between
57  calls to the peer to exchange the actual information.  calls to the peer to exchange the actual information.
58    
59        $last_update: Search for updates since this time.
60        $skip_tough_search: Do not use the time-consuming $fig->tough_search method as a last resort for peg mapping.
61        $update_thru: Search for updates until this time. Undef means to search for all since $last_update.
62        $log_file: Write logging information to this file.
63        $html_file: Write a HTML summary to this file.
64        $assignment_policy: If a list reference, contains the list of users from which we will accept assignments. If a code ref, a predicate that is passed ($peg, $timestamp, $author, $function) and returns true if the assignment should be made.
65    
66  =cut  =cut
67    
68  sub perform_update  sub perform_update
69  {  {
70      my($fig, $peer, $last_update, $skip_tough_search, $update_thru, $log_file, $html_file) = @_;      my($fig, $peer, $last_update, $skip_tough_search, $update_thru, $log_file, $html_file,
71           $assignment_policy) = @_;
72    
73        my $allow_assignment;
74    
75      $log_file = "/dev/null" unless $log_file ne "";      $log_file = "/dev/null" unless $log_file ne "";
76      open($log_fh, ">>$log_file") or die "Cannot open logfile $log_file: $!\n";      open($log_fh, ">>$log_file") or die "Cannot open logfile $log_file: $!\n";
# Line 70  Line 80 
80      open($html_fh, ">$html_file") or die "Cannot open htmlfile $html_file: $!\n";      open($html_fh, ">$html_file") or die "Cannot open htmlfile $html_file: $!\n";
81      $html_fh->autoflush(1);      $html_fh->autoflush(1);
82    
83        if (!defined($assignment_policy))
84        {
85            $allow_assignment = sub { 1;};
86        }
87        elsif (ref($assignment_policy) eq "CODE")
88        {
89            $allow_assignment = $assignment_policy;
90        }
91        elsif (ref($assignment_policy) eq "ARRAY")
92        {
93            my $ahash = {};
94            map { $ahash->{$_}++; } @$assignment_policy;
95            $allow_assignment = sub {
96                return $ahash->{$_[2]};
97            };
98        }
99        elsif (ref($assignment_policy) eq "HASH")
100        {
101            $allow_assignment = sub {
102                return $assignment_policy->{$_[2]};
103            };
104        }
105        else
106        {
107            print $log_fh "Invalid assignment policy $assignment_policy\n";
108            die "Invalid assignment policy $assignment_policy\n";
109        }
110    
111      my $now = localtime();      my $now = localtime();
112      my $last_str = localtime($last_update);      my $last_str = localtime($last_update);
113      print $html_fh <<END;      print $html_fh <<END;
# Line 290  Line 328 
328    
329                  if ($peg =~ /^fig\|/ and $ts =~ /^\d+$/)                  if ($peg =~ /^fig\|/ and $ts =~ /^\d+$/)
330                  {                  {
331                      my $ent = [$peg, $ts, $author, $anno];                      #
332                        # The last field marks this as an "old" annotation (that is,
333                        # already in place in this system), so we don't
334                        # log its installation later.
335                        #
336                        my $ent = [$peg, $ts, $author, $anno, 1];
337                      push(@annos, $ent);                      push(@annos, $ent);
338    
339                      if (defined($assignments->{$peg}))                      if (defined($assignments->{$peg}))
# Line 313  Line 356 
356    
357          my $cgi_url = &FIG::cgi_url();          my $cgi_url = &FIG::cgi_url();
358          print $html_fh "<h2>Assignments made</h2>\n";          print $html_fh "<h2>Assignments made</h2>\n";
359          print $html_fh "<table>\n";          print $html_fh "<table border=\"1\">\n";
360          print $html_fh "<tr><th>PEG</th><th>Old assignment</th><th>New assignment</th><tr>\n";          print $html_fh "<tr><th>PEG</th><th>Old assignment</th><th>New assignment</th><tr>\n";
361    
362          for my $peg (keys %$assignments)          for my $peg (keys %$assignments)
# Line 323  Line 366 
366              #              #
367              # Sort the existing annotations for this peg by date.              # Sort the existing annotations for this peg by date.
368              #              #
369              # Recall that this list has entries [$peg, $timestamp, $author, $anno]              # Recall that this list has entries [$peg, $timestamp, $author, $anno, $old_flag]
370              #              #
371    
372              my @eannos;              my @eannos;
# Line 371  Line 414 
414    
415                  my $old = $fig->function_of($peg, 'master');                  my $old = $fig->function_of($peg, 'master');
416    
417                  if ($old ne $func)                  if ($old ne $func and &$allow_assignment($peg, $ts, $author, $func))
418                  {                  {
419                      my $l = "$cgi_url/protein.cgi?prot=$peg";                      my $l = "$cgi_url/protein.cgi?prot=$peg";
420                      print $html_fh "<tr><td><a href=\"$l\">$peg</a></td><td>$old</td><td>$func</td></tr>\n";                      print $html_fh "<tr><td><a href=\"$l\">$peg</a></td><td>$old</td><td>$func</td></tr>\n";
# Line 388  Line 431 
431          print $html_fh "</table>\n";          print $html_fh "</table>\n";
432    
433          print $html_fh "<h2>Annotations added</h2>\n";          print $html_fh "<h2>Annotations added</h2>\n";
434          print $html_fh "<table>\n";          print $html_fh "<table border=\"1\">\n";
435          print $html_fh "<tr><th>PEG</th><th>Time</th><th>Author</th><th>Annotation</th></tr>\n";          print $html_fh "<tr><th>PEG</th><th>Time</th><th>Author</th><th>Annotation</th></tr>\n";
436    
437          open(my $outfh, ">$anno_file") or die "Cannot open new annotation file $anno_file: $!\n";          open(my $outfh, ">$anno_file") or die "Cannot open new annotation file $anno_file: $!\n";
# Line 399  Line 442 
442          my $dup = 0;          my $dup = 0;
443          foreach my $ann (@sorted)          foreach my $ann (@sorted)
444          {          {
445              my $txt = join("\n", @$ann);              my $txt = join("\n", @$ann[0..3]);
446              #              #
447              # Drop the trailing \n if there is one; we  will add it back when we print and              # Drop the trailing \n if there is one; we  will add it back when we print and
448              # want to ensure the file format remains sane.              # want to ensure the file format remains sane.
# Line 409  Line 452 
452              {              {
453                  my $peg = $ann->[0];                  my $peg = $ann->[0];
454                  my $l = "$cgi_url/protein.cgi?prot=$peg";                  my $l = "$cgi_url/protein.cgi?prot=$peg";
455                    if (!$ann->[4])
456                    {
457                  print $html_fh "<tr>" . join("\n", map { "<td>$_</td>" }                  print $html_fh "<tr>" . join("\n", map { "<td>$_</td>" }
458                                               "<a href=\"$l\">$peg</a>",                                               "<a href=\"$l\">$peg</a>",
459                                               scalar(localtime($ann->[1])), $ann->[2], $ann->[3])                                               scalar(localtime($ann->[1])), $ann->[2], $ann->[3])
460                      . "</tr>\n";                      . "</tr>\n";
461                    }
462    
463                  print $outfh "$txt\n//\n";                  print $outfh "$txt\n//\n";
464                  $last = $txt;                  $last = $txt;
# Line 723  Line 769 
769                      # the feature is on, we want to look at either minloc or maxloc.                      # the feature is on, we want to look at either minloc or maxloc.
770                      #                      #
771    
772                      my $whichloc = $strand eq '-' ? "minloc" : "maxloc";                      my($start_loc, $end_loc);
773    
774                      my $res = $dbh->SQL(qq!SELECT id from features                      if ($strand eq '-')
775                                             WHERE $whichloc = $end and genome = '$my_genome' and                      {
776                            $start_loc = 'maxloc';
777                            $end_loc = 'minloc';
778                        }
779                        else
780                        {
781                            $start_loc = 'minloc';
782                            $end_loc = 'maxloc';
783                        }
784    
785                        my $res = $dbh->SQL(qq!SELECT id, $start_loc from features
786                                               WHERE $end_loc = $end and genome = '$my_genome' and
787                                             contig = '$local_contig'                                             contig = '$local_contig'
788                                          !);                                          !);
789    
790                      if ($res and @$res > 0)                      if ($res and @$res > 0)
791                      {                      {
792                          my(@ids) = map { $_->[0] } @$res;                          my $id;
793                          my $id = $ids[0];                          if (@$res == 1)
794                            {
795                                #
796                                # Found a unique mapping.
797                                #
798                                $id = $res->[0]->[0];
799                            }
800                            else
801                            {
802                                #
803                                # Multiple mappings found. See if one matches the
804                                # start location. If it doesn't, pick the one that
805                                # is closest in length.
806                                #
807    
808                                my @lens;
809    
810                                for my $res_ent (@$res)
811                                {
812                                    my($rid, $rloc) = @$res_ent;
813    
814                                    push(@lens, [$rid, abs($rloc - $end - ($start - $end))]);
815                                    warn "Matching $rid $rloc to $start\n";
816                                    if ($rloc == $start)
817                                    {
818                                        $id = $rid;
819                                        warn "Matched $rid\n";
820                                        last;
821                                    }
822                                }
823    
824                                if (!$id)
825                                {
826                                    my @slens = sort { $a->[1] <=> $b->[1]} @lens;
827                                    my $len;
828                                    ($id, $len) = @{$slens[0]};
829                                    warn "No unique match found, picking closest match $id (len=$len)\n";
830                                }
831                            }
832    
833                          $peg_mapping->{$peg} = $id;                          $peg_mapping->{$peg} = $id;
834                          $peg_cache->{$peg} = $id;                          $peg_cache->{$peg} = $id;
835                          print "Mapped $peg to $id via contigs\n";                          print "Mapped $peg to $id via contigs\n";
                         if (@$res > 1)  
                         {  
                             warn "Multiple mappings found for $peg: @ids\n";  
                             print $log_fh "Multiple mappings found for $peg: @ids\n";  
                         }  
836                      }                      }
837                      else                      else
838                      {                      {
# Line 814  Line 905 
905  {  {
906      my($class, $url) = @_;      my($class, $url) = @_;
907    
908      my $creds = ['seed-linux-2.uchicago.edu:80',      my $creds = [];
                  'SEED User',  
                  annotator => 'anno4all'];  
909    
910      my $proxy = SOAP::Lite->uri($P2P::ns_relay)->proxy([$url,      my $proxy = SOAP::Lite->uri($P2P::ns_relay)->proxy([$url,
911                                                          credentials => $creds]);                                                          credentials => $creds]);
# Line 957  Line 1046 
1046    
1047      $credentials = [] unless ref($credentials);      $credentials = [] unless ref($credentials);
1048    
1049      my $proxy = SOAP::Lite->uri($ns_p2p)->proxy($url, timeout => 3600,      my $proxy = SOAP::Lite->uri($ns_p2p)->proxy($url, timeout => 3600);
1050                                                  credentials => $credentials);  
1051        for my $cred (@$credentials)
1052        {
1053            $proxy->transport->credentials(@$cred);
1054        }
1055    
1056      my $self = {      my $self = {
1057          fig => $fig,          fig => $fig,
# Line 1162  Line 1255 
1255      my $assign_fh;      my $assign_fh;
1256      open($assign_fh, ">$spool_dir/assignments");      open($assign_fh, ">$spool_dir/assignments");
1257    
1258        #
1259        # We originally used a query to get the PEGs that needed to have annotations
1260        # sent. Unfortunately, this performed very poorly due to all of the resultant
1261        # seeking around in the annotations files.
1262        #
1263        # The code below just runs through all of the anno files looking for annos.
1264        #
1265        # A better way to do this would be to do a query to retrieve the genome id's for
1266        # genomes that have updates. The problem here is that the annotation_seeks
1267        # table doesn't have an explicit genome field.
1268        #
1269        # Surprisingly, to me anyway, the following query appers to run quickly, in both
1270        # postgres and mysql:
1271        #
1272        # SELECT distinct(substring(fid from 5 for position('.peg.' in fid) - 5))
1273        # FROM annotation_seeks
1274        # WHERE dateof > some-date.
1275        #
1276        # The output of that can be parsed to get the genome id and just those
1277        # annotations files searched.
1278        #
1279    
1280      for my $genome (@$all_genomes)      for my $genome (@$all_genomes)
1281      {      {
1282          my $num_annos_for_genome = 0;          my $num_annos_for_genome = 0;

Legend:
Removed from v.1.24  
changed lines
  Added in v.1.29

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3