1#
2# BioPerl module for Bio::Tools::Run::EMBOSSacd
3#
4#
5# Please direct questions and support issues to <bioperl-l@bioperl.org>
6#
7# Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org>
8#
9# Copyright Heikki Lehvaslaiho
10#
11# You may distribute this module under the same terms as perl itself
12
13# POD documentation - main docs before the code
14
15=head1 NAME
16
17Bio::Tools::Run::EMBOSSacd - class for EMBOSS Application qualifiers
18
19=head1 SYNOPSIS
20
21  # Get an EMBOSS factory
22  use Bio::Factory::EMBOSS;
23  $f = Bio::Factory::EMBOSS -> new();
24  # Get an EMBOSS application  object from the factory
25  $water = $f->program('water') || die "Program not found!\n";
26
27  # Here is an example of running the application - water can
28  # compare 1 sequence against 1 or more sequences using Smith-Waterman.
29  # Pass a Sequence object and a reference to an array of objects.
30
31  my $wateroutfile = 'out.water';
32  $water->run({-asequence => $seq_object,
33               -bsequence => \@seq_objects,
34               -gapopen   => '10.0',
35               -gapextend => '0.5',
36               -outfile   => $wateroutfile});
37
38  # Now you might want to get the alignment
39  use Bio::AlignIO;
40  my $alnin = Bio::AlignIO->new(-format => 'emboss',
41                                -file   => $wateroutfile);
42
43  while ( my $aln = $alnin->next_aln ) {
44      # process the alignment -- these will be Bio::SimpleAlign objects
45  }
46
47=head1 DESCRIPTION
48
49The EMBOSSacd represents all the possible command line arguments that
50can be given to an EMBOSS application.
51
52Do not create this object directly. It will be created and attached to
53its corresponding Bio::Tools::Run::EMBOSSApplication if you set
54
55  $application->verbose > 0
56
57Call
58
59  $application->acd
60
61to retrive the Bio::Tools::Run::EMBOSSApplication::EMBOSSacd object.
62
63See also L<Bio::Tools::Run::EMBOSSApplication> and L<Bio::Factory::EMBOSS>.
64
65=head1 FEEDBACK
66
67=head2 Mailing Lists
68
69User feedback is an integral part of the evolution of this and other
70Bioperl modules. Send your comments and suggestions preferably to the
71Bioperl mailing lists  Your participation is much appreciated.
72
73  bioperl-l@bioperl.org                  - General discussion
74  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
75
76=head2 Support
77
78Please direct usage questions or support issues to the mailing list:
79
80I<bioperl-l@bioperl.org>
81
82rather than to the module maintainer directly. Many experienced and
83reponsive experts will be able look at the problem and quickly
84address it. Please include a thorough description of the problem
85with code and data examples if at all possible.
86
87=head2 Reporting Bugs
88
89report bugs to the Bioperl bug tracking system to help us keep track
90the bugs and their resolution.  Bug reports can be submitted via the
91web:
92
93  http://redmine.open-bio.org/projects/bioperl/
94
95=head1 AUTHOR - Heikki Lehvaslaiho
96
97Email:  heikki-at-bioperl-dot-org
98Address:
99
100     EMBL Outstation, European Bioinformatics Institute
101     Wellcome Trust Genome Campus, Hinxton
102     Cambs. CB10 1SD, United Kingdom
103
104=head1 APPENDIX
105
106The rest of the documentation details each of the object
107methods. Internal methods are usually preceded with a _
108
109=cut
110
111# Let the code begin...
112
113package Bio::Tools::Run::EMBOSSacd;
114use vars qw(@ISA %QUALIFIER_CATEGORIES $QUAL %OPT);
115
116use strict;
117use Data::Dumper;
118use Bio::Root::Root;
119
120@ISA = qw(Bio::Root::Root);
121
122BEGIN {
123
124    %QUALIFIER_CATEGORIES =
125	(
126	 'Mandatory qualifiers'            => 'mandatory',
127	 'Standard (Mandatory) qualifiers' => 'mandatory',
128	 'Optional qualifiers'             => 'optional',
129	 'Additional (Optional) qualifiers'=> 'optional',
130	 'Advanced qualifiers'             => 'advanced',
131	 'Advanced (Unprompted) qualifiers'=> 'advanced',
132	 'Associated qualifiers'           => 'associated',
133	 'General qualifiers'              => 'general',
134	);
135    $QUAL;			# qualifier category
136
137}
138
139
140=head2 new
141
142 Title   : new
143 Usage   : $emboss_prog->acd($prog_name);
144 Function: Constructor for the class.
145           Calls EMBOSS program 'acdc', converts the
146           HTML output into XML and uses XML::Twig XML
147           parser to write out a hash of qualifiers which is
148           then blessed.
149 Throws  : without program name
150 Returns : new object
151 Args    : EMBOSS program name
152
153=cut
154
155
156sub new {
157    my($class, $prog) = @_;
158
159    eval {require XML::Twig;};
160    Bio::Root::Root->warn("You need XML::Twig for EMBOSS ACD parsing")
161	    and return undef if $@;
162
163    Bio::Root::Root->throw("Need EMBOSSprogram name as an argument")
164	     unless $prog;
165    # reset global hash
166    %OPT = ();
167
168    my $version = `embossversion -auto`;
169    my $file;
170    if ($version lt "2.8.0") {
171	# reading from EMBOSS program acdc stdout (prior to version 2.8.0)
172	$file = `acdc $prog -help -verbose -acdtable 2>&1`;
173    } else {
174	# reading from EMBOSS program acdtable stdout (version 2.8.0 or greater)
175	$file = `acdtable $prog -help -verbose 2>&1`;
176    }
177
178    # converting HTML -> XHTML for XML parsing
179    $file =~ s/border/border="1"/;
180    $file =~ s/=(\d+)/="$1"/g;
181    $file =~ s/<br>/<br><\/br>/g;
182    $file =~ s/&nbsp;//g;
183
184    my $t = XML::Twig->new( TwigHandlers =>
185			   {
186			       '/table/tr' => \&_row  }
187			   );
188
189    $t->safe_parse( $file);
190
191    #Bio::Root::Root->throw("XML parsing error: $@");
192
193    my %acd = %OPT; # copy to a private hash
194    $acd{'_name'} = $prog;
195    bless \%acd, $class;
196}
197
198sub _row {
199    my ($t, $row)= @_;
200
201    return if $row->text eq "(none)"; #  no qualifiers in this category
202
203    my $name = $row->first_child; # qualifier name
204
205    my $namet = $name->text;
206    if ($namet =~ /qualifiers$/) { # set category
207	$QUAL = $QUALIFIER_CATEGORIES{$namet};
208	if( ! defined $QUAL ) {
209	    warn("-- namet is $namet\n");
210	}
211	return;
212    }
213    my $unnamed = 0;
214    if ($namet =~ /\(Parameter (\d+)\)/) { # unnamed parameter
215	$unnamed = $1;
216	$namet =~ s/\(Parameter (\d+)\)//;
217	$namet =~ s/[\[\]]//g ; # name is in brackets
218    }
219
220    my $desc = $name->next_sibling;
221    my $values = $desc->next_sibling;
222    my $default = $values->next_sibling;
223
224    $OPT{$namet}{'unnamed'} = $unnamed;
225    $OPT{$namet}{'category'} = $QUAL;
226    $OPT{$namet}{'descr'} = $desc->text;
227    $OPT{$namet}{'values'} = $values->text;
228    $OPT{$namet}{'default'} = $default->text;
229
230    $t->purge;			# to reduce memory requirements
231}
232
233=head2 name
234
235 Title   : name
236 Usage   : $embossacd->name
237 Function: sets/gets the name of the EMBOSS program
238           Setting is done by the EMBOSSApplication object,
239           you should only get it.
240 Throws  :
241 Returns : name string
242 Args    : None
243
244=cut
245
246sub name {
247    my ($self,$value) = @_;
248    if (defined $value) {
249	$self->{'_name'} = $value;
250    }
251    return $self->{'_name'};
252}
253
254
255=head2 print
256
257 Title   : print
258 Usage   : $embossacd->print; $embossacd->print('-word');
259 Function: Print out the qualifiers.
260           Uses Data::Dumper to print the qualifiers into STDOUT.
261           A valid qualifier name given as an argment limits the output.
262 Throws  :
263 Returns : print string
264 Args    : optional qualifier name
265
266=cut
267
268sub print {
269    my ($self, $value) = @_;
270    if ($value and $self->{$value}) {
271	print Dumper $self->{$value};
272    } else {
273	print Dumper $self;
274    }
275}
276
277=head2 mandatory
278
279 Title   : mandatory
280 Usage   : $acd->mandatory
281 Function: gets a  mandatory subset of qualifiers
282 Throws  :
283 Returns : Bio::Tools::Run::EMBOSSacd object
284 Args    : none
285
286=cut
287
288sub mandatory {
289    my ($self) = @_;
290    my %mand;
291    foreach my $key (keys %{$self}) {
292	next unless $key =~ /^-/; #ignore other attributes
293
294	$mand{$key} = $self->{$key}
295	if $self->{$key}{category} eq 'mandatory';
296    }
297    bless \%mand;
298}
299
300=head2 Qualifier queries
301
302These methods can be used test qualifier names and read values.
303
304=cut
305
306=head2 qualifier
307
308 Title   : qualifier
309 Usage   : $acd->qualifier($string)
310 Function: tests for the existence of the qualifier
311 Throws  :
312 Returns : boolean
313 Args    : string, name of the qualifier
314
315=cut
316
317sub qualifier {
318    my ($self, $value) = @_;
319
320    $self->throw("Qualifier has to start with '-'")
321	unless $value =~ /^-/;
322    $self->{$value} ? 1 : 0
323}
324
325=head2 category
326
327 Title   : category
328 Usage   : $acd->category($qual_name)
329 Function: Return the category of the qualifier
330 Throws  :
331 Returns : 'mandatory' or 'optional' or 'advanced' or
332            'associated' or 'general'
333 Args    : string, name of the qualifier
334
335=cut
336
337sub category {
338    my ($self, $value) = @_;
339
340    $self->throw("Not a valid qualifier name [$value]")
341	unless $self->qualifier($value);
342    $self->{$value}->{'category'};
343}
344
345=head2 values
346
347 Title   : values
348 Usage   : $acd->values($qual_name)
349 Function: Return the possible values for the qualifier
350 Throws  :
351 Returns : string
352 Args    : string, name of the qualifier
353
354=cut
355
356sub values {
357    my ($self, $value) = @_;
358
359    $self->throw("Not a valid qualifier name [$value]")
360	unless $self->qualifier($value);
361    $self->{$value}->{'values'};
362
363}
364
365=head2 descr
366
367 Title   : descr
368 Usage   : $acd->descr($qual_name)
369 Function: Return the description of the qualifier
370 Throws  :
371 Returns : boolean
372 Args    : string, name of the qualifier
373
374=cut
375
376sub descr {
377    my ($self, $value) = @_;
378
379    $self->throw("Not a valid qualifier name [$value]")
380	unless $self->qualifier($value);
381    $self->{$value}->{'descr'};
382
383}
384
385=head2 unnamed
386
387 Title   : unnamed
388 Usage   : $acd->unnamed($qual_name)
389 Function: Find if the qualifier can be left unnamed
390 Throws  :
391 Returns : 0 if needs to be named, order number otherwise
392 Args    : string, name of the qualifier
393
394=cut
395
396sub unnamed {
397    my ($self, $value) = @_;
398
399    $self->throw("Not a valid qualifier name [$value]")
400	unless $self->qualifier($value);
401    $self->{$value}->{'unnamed'};
402
403}
404
405=head2 default
406
407 Title   : default
408 Usage   : $acd->default($qual_name)
409 Function: Return the default value for the qualifier
410 Throws  :
411 Returns : scalar
412 Args    : string, name of the qualifier
413
414=cut
415
416sub default {
417    my ($self, $value) = @_;
418
419    $self->throw("Not a valid qualifier name [$value]")
420	unless $self->qualifier($value);
421    $self->{$value}->{'default'};
422}
423
424
4251;
426