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

Diff of /FigKernelPackages/FFserver.pm

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

revision 1.1, Tue Apr 28 21:03:25 2009 UTC revision 1.5, Mon May 11 20:55:05 2009 UTC
# Line 2  Line 2 
2  package FFserver;  package FFserver;
3    
4  use LWP::UserAgent;  use LWP::UserAgent;
 use FIG_Config;  
5  use Data::Dumper;  use Data::Dumper;
6    use YAML;
7    
8  use strict;  use strict;
9    
# Line 11  Line 11 
11  {  {
12      my($class, $server_url) = @_;      my($class, $server_url) = @_;
13    
14      $server_url = $FIG_Config::FFserver_url unless $server_url;      $server_url = "http://servers.nmpdr.org/figfam/server.cgi" unless $server_url;
     $server_url = "http://bio-macpro-1.mcs.anl.gov/~disz/FIG/figfam_server.cgi" unless $server_url;  
15    
16    
17      my $self = {      my $self = {
# Line 23  Line 22 
22      return bless $self, $class;      return bless $self, $class;
23  }  }
24    
25    sub members_of_families
26    {
27        my($self, @ids) = @_;
28        return $self->run_query('members_of_families', @ids);
29    }
30    
31    sub should_be_member
32    {
33        my($self, @id_seq_pairs) = @_;
34        return $self->run_query('should_be_member', @id_seq_pairs);
35    }
36    
37    sub all_families
38    {
39        my($self) = @_;
40        return $self->run_query('all_families');
41    }
42    
43    sub run_query
44    {
45        my($self, $function, @args ) = @_;
46        my $form = [function  => $function,
47                    args => YAML::Dump(@args),
48                    ];
49        return $self->run_query_form($form);
50    }
51    
52    sub run_query_form
53    {
54        my($self, $form) = @_;
55    
56        my $res = $self->{ua}->post($self->{server_url}, $form);
57    
58        if ($res->is_success)
59        {
60            return Load($res->content);
61        }
62        else
63        {
64            die "error on post " . $res->content;
65        }
66    }
67    
68  sub assign_function_to_prot  sub assign_function_to_prot
69  {  {
70      my($self, $input) = @_;      my($self, $input) = @_;
71    
72      my $handle;      my $wq;
73    
74      if (ref($input) eq 'ARRAY')      if (ref($input) eq 'ARRAY')
75      {      {
76          $handle = ListInputHandle->new($input, sub { $self->assign_function_to_prot_one(@_); });          $wq = SequenceListWorkQueue->new($input);
77      }      }
78      elsif (ref($input))      else
79      {      {
80          $handle = FileInputHandle->new($input, sub { $self->assign_function_to_prot_one(@_); });          $wq = FastaWorkQueue->new($input);
81        }
82    
83        return ResultHandler->new($wq, $self->{server_url}, 'assign_function_to_prot', \&id_seq_pair_bundler, \&tab_delimited_output_parser);
84    }
85    
86    sub assign_functions_to_dna
87    {
88        my($self, $input, $min_hits, $max_gap) = @_;
89    
90        my $wq;
91    
92        if (ref($input) eq 'ARRAY')
93        {
94            $wq = SequenceListWorkQueue->new($input);
95      }      }
96      else      else
97      {      {
98          $handle = FileInputHandle->new($input, sub { $self->assign_function_to_prot_one(@_); });          $wq = FastaWorkQueue->new($input);
99      }      }
100    
101        return ResultHandler->new($wq, $self->{server_url}, 'assign_functions_to_DNA', \&id_seq_pair_bundler, \&tab_delimited_output_parser, [min_hits => $min_hits, max_gap => $max_gap]);
102  }  }
103    
104  sub assign_function_to_prot_one  sub id_seq_pair_bundler
105  {  {
106      my($self, $dat) = @_;      my($item) = @_;
107        my($id, $seq) = @$item[0,2];
108        return "id_seq", join(",", $id, (ref($seq) eq 'SCALAR' ? $$seq : $seq));
109    }
110    
111    sub tab_delimited_output_parser
112    {
113        my($line) = @_;
114        chomp $line;
115        my @cols = split(/\t/, $line);
116        return \@cols;
117    }
118    
119    
120    sub tab_delimited_dna_data_output_parser
121    {
122        my($line) = @_;
123        chomp $line;
124        my ($id, $idbe, $fam) = split(/\t/, $line);
125        my ($beg, $end) = $idbe =~ /_(\d+)_(\d+)$/;
126        return [$id, $beg, $end, $fam];
127    }
128    
129      my($id, undef, $seq) = @$dat;  package ResultHandler;
130    use strict;
131    use Data::Dumper;
132    
133      my $form = [function => 'assign_function_to_prot',  sub new
134                  id_seq => "$id,$seq"];  {
135        my($class, $work_queue, $server_url, $function, $input_bundler, $output_parser, $form_vars) = @_;
136    
137      print Dumper($self->{server_url}, $form);      my $self = {
138            work_queue => $work_queue,
139            server_url => $server_url,
140            function => $function,
141            input_bundler => $input_bundler,
142            output_parser => $output_parser,
143            ua => LWP::UserAgent->new(),
144            cur_result => undef,
145            form_vars => $form_vars ? $form_vars : [],
146        };
147        return bless $self, $class;
148    }
149    
150    sub get_next
151    {
152        my($self) = @_;
153    
154        if ($self->{cur_result})
155        {
156            return $self->get_next_from_result();
157        }
158        else
159        {
160            my @inp = $self->{work_queue}->get_next_n_bytes(16000);
161            if (@inp)
162            {
163                my $form = [@{$self->{form_vars}}];
164                push(@$form, function => $self->{function},
165                             map { &{$self->{input_bundler}}($_) } @inp);
166                print "Invoke " .Dumper($form);
167    
168      my $res = $self->{ua}->post($self->{server_url}, $form);      my $res = $self->{ua}->post($self->{server_url}, $form);
169      if ($res->is_success)      if ($res->is_success)
170      {      {
171          my $txt = $res->content;                  $self->{cur_result} = $res->content;
172          return $txt;                  #print "res: $self->{cur_result}\n";
173                    return $self->get_next_from_result();
174      }      }
175      else      else
176      {      {
177          die "error on post " . $res->content;                  die "error " . $res->status_line . " on post " . $res->content;
178                }
179            }
180            else
181            {
182                return;
183            }
184        }
185      }      }
186    
187    sub get_next_from_result
188    {
189        my($self) = @_;
190        if ($self->{cur_result} =~ s/^([^\n]*)\n//)
191        {
192            return &{$self->{output_parser}}($1);
193        }
194  }  }
195    
196  package ListInputHandle;  package SequenceWorkQueue;
197  use strict;  use strict;
198    
199  sub new  sub new
200  {  {
201      my($class, $list, $handler) = @_;      my($class) = @_;
202      my $self = {  
203          list => $list,      my $self = {};
204          handler => $handler,  
     };  
205      return bless $self, $class;      return bless $self, $class;
206  }  }
207    
208  sub get_next  sub get_next_n
209  {  {
210      my($self) = @_;      my($self, $n) = @_;
211        my @out;
212    
213        for (my $i = 0;$i < $n; $i++)
214        {
215            my($id, $com, $seqp) = $self->get_next();
216            if (defined($id))
217            {
218                push(@out, [$id, $com, $seqp]);
219            }
220            else
221            {
222                last;
223            }
224        }
225        return @out;
226    }
227    
228      my $l = $self->{list};  sub get_next_n_bytes
229    {
230        my($self, $n) = @_;
231        my @out;
232    
233      if (@$l)      my $size = 0;
234        while ($size < $n)
235      {      {
236          my $ent = shift @$l;          my($id, $com, $seqp) = $self->get_next();
237          my $res = &{$self->{handler}}($ent);          if (defined($id))
238          my($id, $val) = split(/\t/, $res);          {
239          chomp $val;              push(@out, [$id, $com, $seqp]);
240          return $val;              $size += (ref($seqp) eq 'SCALAR') ? length($$seqp) : length($seqp);
241      }      }
242      else      else
243      {      {
244          return undef;              last;
245            }
246      }      }
247        return @out;
248  }  }
249    
250  package FileInputHandle;  package FastaWorkQueue;
251  use strict;  use strict;
252    use base 'SequenceWorkQueue';
253  use FileHandle;  use FileHandle;
254  use FIG;  use FIG;
255    
256  sub new  sub new
257  {  {
258      my($class, $input, $handler) = @_;      my($class, $input) = @_;
259    
260      my $fh;      my $fh;
261      if (ref($input))      if (ref($input))
# Line 118  Line 267 
267          $fh = new FileHandle("<$input");          $fh = new FileHandle("<$input");
268      }      }
269    
270      my $self = {      my $self = $class->SUPER::new();
271          fh => $fh,  
272          handler => $handler,      $self->{fh} = $fh;
273      };  
274      return bless $self, $class;      return bless $self, $class;
275  }  }
276    
# Line 129  Line 278 
278  {  {
279      my($self) = @_;      my($self) = @_;
280    
281      my($id, $seqp) = &FIG::read_fasta_record($self->{fh});      my($id, $seqp, $com) = &FIG::read_fasta_record($self->{fh});
282        return defined($id) ? ($id, $com, $seqp) : ();
283    }
284    
285    package SequenceListWorkQueue;
286    use strict;
287    use base 'SequenceWorkQueue';
288    
289      if ($id)  sub new
290      {      {
291          my $ent = [$id, undef, $$seqp];      my($class, $input) = @_;
292          my $res = &{$self->{handler}}($ent);  
293          my($id, $val) = split(/\t/, $res);      my $fh;
294          chomp $val;      if (ref($input) ne 'ARRAY')
         return $val;  
     }  
     else  
295      {      {
296          close($self->{fh});          die "SequenceWorkQueue requires a list as input";
         return undef;  
297      }      }
298    
299        my $self = $class->SUPER::new();
300    
301        $self->{list} = $input;
302    
303        return bless $self, $class;
304  }  }
305    
306    sub get_next
307    {
308        my($self) = @_;
309    
310        my $top = shift @{$self->{list}};
311    
312        return defined($top) ? @$top : ();
313    }
314    
315    
316  1;  1;
317    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.5

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3