|
0
|
1 #-----------------------------------------------------------------------------
|
|
|
2 # PACKAGE : Bio::Root::Vector.pm
|
|
|
3 # AUTHOR : Steve Chervitz (sac@bioperl.org)
|
|
|
4 # CREATED : 15 April 1997
|
|
|
5 # REVISION: $Id: Vector.pm,v 1.10 2002/10/22 07:38:37 lapp Exp $
|
|
|
6 # STATUS : Alpha
|
|
|
7 #
|
|
|
8 # WARNING: This is considered an experimental module.
|
|
|
9 #
|
|
|
10 # For documentation, run this module through pod2html
|
|
|
11 # (preferably from Perl v5.004 or better).
|
|
|
12 #
|
|
|
13 # MODIFIED:
|
|
|
14 # sac --- Fri Nov 6 14:24:48 1998
|
|
|
15 # * Added destroy() method (experimental).
|
|
|
16 # 0.023, 20 Jul 1998, sac:
|
|
|
17 # * Improved memory management (_destroy_master()).
|
|
|
18 #
|
|
|
19 # Copyright (c) 1997 Steve Chervitz. All Rights Reserved.
|
|
|
20 # This module is free software; you can redistribute it and/or
|
|
|
21 # modify it under the same terms as Perl itself.
|
|
|
22 #-----------------------------------------------------------------------------
|
|
|
23
|
|
|
24 package Bio::Root::Vector;
|
|
|
25
|
|
|
26 use Bio::Root::Global qw(:devel);
|
|
|
27 use Bio::Root::Object ();
|
|
|
28
|
|
|
29 # @ISA = qw(Bio::Root::Object); # Eventually perhaps...
|
|
|
30
|
|
|
31 use vars qw($ID $VERSION);
|
|
|
32 $ID = 'Bio::Root::Vector';
|
|
|
33 $VERSION = 0.04;
|
|
|
34
|
|
|
35 use strict;
|
|
|
36 my @SORT_BY = ('rank','name');
|
|
|
37
|
|
|
38 ## POD Documentation:
|
|
|
39
|
|
|
40 =head1 NAME
|
|
|
41
|
|
|
42 Bio::Root::Vector - Interface for managing linked lists of Perl5 objects.
|
|
|
43
|
|
|
44 =head1 SYNOPSIS
|
|
|
45
|
|
|
46 =head2 Object Creation
|
|
|
47
|
|
|
48 B<At present, Vector objects cannot be instantiated.> This
|
|
|
49 package is currently designed to be inherited along with another class
|
|
|
50 that provides a constructor (e.g., B<Bio::Root::Object.pm>).
|
|
|
51 The Vector provides a set of methods that can then be used for managing
|
|
|
52 sets of objects.
|
|
|
53
|
|
|
54 See L<the USAGE section | USAGE>.
|
|
|
55
|
|
|
56 =head1 INSTALLATION
|
|
|
57
|
|
|
58 This module is included with the central Bioperl distribution:
|
|
|
59
|
|
|
60 http://bio.perl.org/Core/Latest
|
|
|
61 ftp://bio.perl.org/pub/DIST
|
|
|
62
|
|
|
63 Follow the installation instructions included in the README file.
|
|
|
64
|
|
|
65
|
|
|
66 =head1 DESCRIPTION
|
|
|
67
|
|
|
68 Bio::Root::Vector.pm provides an interface for creating and manipulating
|
|
|
69 dynamic sets (linked lists) of Perl5 objects. This is an abstract class (ie.,
|
|
|
70 there is no constructor) and as such is expected to be inherited along with
|
|
|
71 some other class (see note above).
|
|
|
72
|
|
|
73 Vectors are handy when, for example, an object may contain one or more
|
|
|
74 other objects of a certain class. The container object knows only
|
|
|
75 that is has at least one such object; the multiplex nature of the contained
|
|
|
76 object is managed by the contained object via its Vector interface.
|
|
|
77 The methods for adding, removing, counting, listing, and sorting all objects
|
|
|
78 are bundled together in Vector.pm.
|
|
|
79
|
|
|
80 Thus, the current Bio::Root::Vector class is somewhat of a cross between an
|
|
|
81 interator and a composite design pattern. At present, a number of classes
|
|
|
82 utilize Bio::Root::Vector's composite-like behavior to implement a composite
|
|
|
83 pattern (Bio::SeqManager.pm, for example).
|
|
|
84 This is not necessarily ideal and is expected to change.
|
|
|
85
|
|
|
86 =head1 USAGE
|
|
|
87
|
|
|
88 For a usage demo of Bio::Root::Vector.pm see the scripts in the
|
|
|
89 examples/root_object/vector directory.
|
|
|
90
|
|
|
91
|
|
|
92 =head1 DEPENDENCIES
|
|
|
93
|
|
|
94 Bio::Root::Vector.pm does not directly inherit from B<Bio::Root::Object.pm> but
|
|
|
95 creates an manager object which does.
|
|
|
96
|
|
|
97 =head1 BUGS/FEATURES
|
|
|
98
|
|
|
99 By default, all Vectors are doubly-linked lists. This relieves one from
|
|
|
100 the burden of worrying about whether a given Vector is single- or doubly-linked.
|
|
|
101 However, when generating lots of Vectors or extremely large vectors, memory
|
|
|
102 becomes an issue. In particular, signaling the GC to free the memory for
|
|
|
103 an object when you want to remove it. B<Until this memory issue is resolved,
|
|
|
104 the use of Vector.pm is not recommended for large projects.>
|
|
|
105
|
|
|
106 Although it is not required, all objects within a vector are expected
|
|
|
107 to derive from the same class (package). Support for heterogeneous
|
|
|
108 Vectors has not been explicitly added (but they should work fine, as long
|
|
|
109 as you know what you're doing).
|
|
|
110
|
|
|
111 =head1 FEEDBACK
|
|
|
112
|
|
|
113 =head2 Mailing Lists
|
|
|
114
|
|
|
115 User feedback is an integral part of the evolution of this and other Bioperl modules.
|
|
|
116 Send your comments and suggestions preferably to one of the Bioperl mailing lists.
|
|
|
117 Your participation is much appreciated.
|
|
|
118
|
|
|
119 bioperl-l@bioperl.org - General discussion
|
|
|
120 http://bioperl.org/MailList.shtml - About the mailing lists
|
|
|
121
|
|
|
122 =head2 Reporting Bugs
|
|
|
123
|
|
|
124 Report bugs to the Bioperl bug tracking system to help us keep track the bugs and
|
|
|
125 their resolution. Bug reports can be submitted via email or the web:
|
|
|
126
|
|
|
127 bioperl-bugs@bio.perl.org
|
|
|
128 http://bugzilla.bioperl.org/
|
|
|
129
|
|
|
130 =head1 AUTHOR
|
|
|
131
|
|
|
132 Steve Chervitz E<lt>sac@bioperl.orgE<gt>
|
|
|
133
|
|
|
134 See L<the FEEDBACK section | FEEDBACK> for where to send bug reports and comments.
|
|
|
135
|
|
|
136 =head1 VERSION
|
|
|
137
|
|
|
138 Bio::Root::Vector.pm, 0.04
|
|
|
139
|
|
|
140 =head1 TODO
|
|
|
141
|
|
|
142 =over 4
|
|
|
143
|
|
|
144 =item * (Maybe) create an container class version of this module
|
|
|
145
|
|
|
146 to permit Vectors to be instantiated. Thus, instead of inherited
|
|
|
147 from both Object.pm and Vector.pm, you could create a Vector.pm object.
|
|
|
148
|
|
|
149 =item * Improve documentation.
|
|
|
150
|
|
|
151 =back
|
|
|
152
|
|
|
153 =head1 SEE ALSO
|
|
|
154
|
|
|
155 Bio::Root::Object.pm - Core object
|
|
|
156 Bio::Root::Err.pm - Error/Exception object
|
|
|
157 Bio::Root::Global.pm - Manages global variables/constants
|
|
|
158
|
|
|
159 http://bio.perl.org/Projects/modules.html - Online module documentation
|
|
|
160 http://bio.perl.org/ - Bioperl Project Homepage
|
|
|
161
|
|
|
162 =head1 ACKNOWLEDGEMENTS
|
|
|
163
|
|
|
164 This module was developed under the auspices of the Saccharomyces Genome
|
|
|
165 Database:
|
|
|
166 http://genome-www.stanford.edu/Saccharomyces
|
|
|
167
|
|
|
168 =head1 COPYRIGHT
|
|
|
169
|
|
|
170 Copyright (c) 1996-98 Steve Chervitz. All Rights Reserved.
|
|
|
171 This module is free software; you can redistribute it and/or
|
|
|
172 modify it under the same terms as Perl itself.
|
|
|
173
|
|
|
174 =cut
|
|
|
175
|
|
|
176
|
|
|
177 #'
|
|
|
178 ##
|
|
|
179 ###
|
|
|
180 #### END of main POD documentation.
|
|
|
181 ###
|
|
|
182 ##
|
|
|
183 #
|
|
|
184
|
|
|
185 =head1 APPENDIX
|
|
|
186
|
|
|
187 Methods beginning with a leading underscore are considered private
|
|
|
188 and are intended for internal use by this module. They are
|
|
|
189 B<not> considered part of the public interface and are described here
|
|
|
190 for documentation purposes only.
|
|
|
191
|
|
|
192 =cut
|
|
|
193
|
|
|
194 ########################################################
|
|
|
195 # CONSTRUCTOR #
|
|
|
196 ########################################################
|
|
|
197
|
|
|
198 ## No constructor. See _set_master() for construction of {Master} data member.
|
|
|
199
|
|
|
200 ## Destructor: Use remove_all() or remove().
|
|
|
201
|
|
|
202 # New Idea for destructor
|
|
|
203 #-------------
|
|
|
204 sub destroy {
|
|
|
205 #-------------
|
|
|
206 my $self = shift;
|
|
|
207 local($^W) = 0;
|
|
|
208 undef $self->{'_prev'};
|
|
|
209 undef $self->{'_next'};
|
|
|
210 undef $self->{'_rank'};
|
|
|
211 undef $self->{'_master'};
|
|
|
212 }
|
|
|
213
|
|
|
214 #####################################################################################
|
|
|
215 ## ACCESSORS ##
|
|
|
216 #####################################################################################
|
|
|
217
|
|
|
218
|
|
|
219 =head2 set_rank
|
|
|
220
|
|
|
221 Purpose : To set an object's rank to an arbitrary numeric
|
|
|
222 : value to be used for sorting the objects of the Vector.
|
|
|
223 Usage : $self->set_rank(-RANK =>numeric_ranking_data,
|
|
|
224 : -RANK_BY =>ranking_criterion_string);
|
|
|
225 : or without the named parameters as (rank, rank_by).
|
|
|
226 Throws : warning (if rank is set without also setting RANK_BY)
|
|
|
227 Comments : It is redundant for every object to store RANK_BY data.
|
|
|
228 : For this reason, the RANK_BY data is stored with the master
|
|
|
229 : object associated with the vector.
|
|
|
230
|
|
|
231 See Also : L<rank>(), L<rank_by>()
|
|
|
232
|
|
|
233 =cut
|
|
|
234
|
|
|
235 #-------------'
|
|
|
236 sub set_rank {
|
|
|
237 #-------------
|
|
|
238 my( $self, %param) = @_;
|
|
|
239
|
|
|
240 $self->_set_master($self) unless $self->{'_master'}->{'_set'};
|
|
|
241
|
|
|
242 my($rank, $rank_by) = $self->master->_rearrange([qw(RANK RANK_BY)], %param);
|
|
|
243
|
|
|
244 $DEBUG==1 and do{ print STDERR "$ID:set_rank() = $rank; Criteria: $rank_by."; <STDIN>; };
|
|
|
245
|
|
|
246 $self->{'_rank'} = ($rank || undef);
|
|
|
247 $self->{'_master'}->{'_rankBy'} = ($rank_by || undef);
|
|
|
248 if( defined $self->{'_rank'} and not defined $self->{'_master'}->{'_rankBy'} ) {
|
|
|
249 return $self->master->warn('Rank defined without ranking criteria.');
|
|
|
250 }
|
|
|
251 1;
|
|
|
252 }
|
|
|
253
|
|
|
254 sub _set_rank_by {
|
|
|
255 my( $self, $arg) = @_;
|
|
|
256 $self->{'_master'}->{'_rankBy'} = $arg || 'unknown';
|
|
|
257 }
|
|
|
258
|
|
|
259 sub _set_master {
|
|
|
260 ## A vector does not need a master object unless it needs to grow.
|
|
|
261 my($self,$obj) = @_;
|
|
|
262
|
|
|
263 # print "$ID: _set_master() new Master object for ${\$obj->name}."; <STDIN>;
|
|
|
264
|
|
|
265 require Bio::Root::Object;
|
|
|
266 my $master = {};
|
|
|
267 bless $master, 'Bio::Root::Object';
|
|
|
268
|
|
|
269 $master->{'_set'} = 1; ## Special member indicating that this method has been called.
|
|
|
270 ## Necessary since perl will generate an anonymous {Master}
|
|
|
271 ## hash ref on the fly. This ref will not be blessed however.
|
|
|
272 $master->{'_first'} = $obj;
|
|
|
273 $master->{'_last'} = $obj;
|
|
|
274 $master->{'_size'} = 1;
|
|
|
275 $master->{'_index'}->{$obj->name()} = $obj;
|
|
|
276 $self->{'_master'} = $master;
|
|
|
277
|
|
|
278 $self->{'_rank'} = 1;
|
|
|
279 $self->{'_prev'} = undef;
|
|
|
280 $self->{'_next'} = undef;
|
|
|
281 # $self->{'_master'}->{'_rankBy'} = undef; # Default rank is the order of addition to Vector.
|
|
|
282 }
|
|
|
283
|
|
|
284 sub _destroy_master {
|
|
|
285 # This is called when the last object in the vector is being remove()d
|
|
|
286 my $self = shift;
|
|
|
287
|
|
|
288 return if !$self->master or !$self->master->{'_set'};
|
|
|
289
|
|
|
290 my $master = $self->master;
|
|
|
291
|
|
|
292 ## Get rid of the Vector master object.
|
|
|
293 ref $master->{'_first'} and (%{$master->{'_first'}} = (), undef $master->{'_first'});
|
|
|
294 ref $master->{'_last'} and (%{$master->{'_last'}} = (), undef $master->{'_last'});
|
|
|
295 ref $master->{'_index'} and (%{$master->{'_index'}} = (), undef $master->{'_index'});
|
|
|
296 %{$master} = ();
|
|
|
297 undef $master;
|
|
|
298 }
|
|
|
299
|
|
|
300
|
|
|
301 =head2 clone_vector
|
|
|
302
|
|
|
303 Purpose : Call this method to clone the whole vector.
|
|
|
304 : NOT calling this method will extract the vector element.
|
|
|
305 Usage : $self->clone_vector();
|
|
|
306 Throws : Exception if argument is not an object reference.
|
|
|
307 Comments : This method is usually called from within a module's
|
|
|
308 : _set_clone() method for modules that inherit from
|
|
|
309 : Bio::Root::Vector.pm.
|
|
|
310
|
|
|
311 =cut
|
|
|
312
|
|
|
313 #-----------------'
|
|
|
314 sub clone_vector {
|
|
|
315 #-----------------
|
|
|
316 my($self, $obj) = @_;
|
|
|
317
|
|
|
318 ref($obj) || throw($self, "Can't clone $ID object: Not an object ref ($obj)");
|
|
|
319
|
|
|
320 $self->{'_prev'} = $obj->{'_prev'};
|
|
|
321 $self->{'_next'} = $obj->{'_next'};
|
|
|
322 $self->{'_rank'} = $obj->{'_rank'};
|
|
|
323 $self->{'_master'} = $obj->{'_master'};
|
|
|
324 }
|
|
|
325
|
|
|
326
|
|
|
327 =head2 prev
|
|
|
328
|
|
|
329 Purpose : Returns the previous object in the Vector or undef
|
|
|
330 : if on first object.
|
|
|
331 Usage : $self->prev
|
|
|
332
|
|
|
333 =cut
|
|
|
334
|
|
|
335 #--------
|
|
|
336 sub prev { my $self = shift; $self->{'_prev'}; }
|
|
|
337 #--------
|
|
|
338
|
|
|
339
|
|
|
340
|
|
|
341 =head2 next
|
|
|
342
|
|
|
343 Purpose : Returns the next object in the Vector or undef
|
|
|
344 : if on last object.
|
|
|
345 Usage : $self->next
|
|
|
346
|
|
|
347 =cut
|
|
|
348
|
|
|
349 #--------
|
|
|
350 sub next { my $self = shift; $self->{'_next'}; }
|
|
|
351 #--------
|
|
|
352
|
|
|
353
|
|
|
354
|
|
|
355 =head2 first
|
|
|
356
|
|
|
357 Purpose : Returns the first object in the Vector or $self
|
|
|
358 : if Vector size = 1.
|
|
|
359 Usage : $self->first
|
|
|
360
|
|
|
361 =cut
|
|
|
362
|
|
|
363 #----------
|
|
|
364 sub first {
|
|
|
365 #----------
|
|
|
366 my $self = shift;
|
|
|
367 defined $self->{'_master'} ? $self->{'_master'}->{'_first'} : $self;
|
|
|
368 }
|
|
|
369
|
|
|
370
|
|
|
371 =head2 last
|
|
|
372
|
|
|
373 Purpose : Returns the last object in the Vector or
|
|
|
374 : $self if Vector size = 1.
|
|
|
375 Usage : $self->last
|
|
|
376
|
|
|
377 =cut
|
|
|
378
|
|
|
379 #-------
|
|
|
380 sub last {
|
|
|
381 #-------
|
|
|
382 my $self = shift;
|
|
|
383 defined $self->{'_master'} ? $self->{'_master'}->{'_last'} : $self;
|
|
|
384 }
|
|
|
385
|
|
|
386
|
|
|
387
|
|
|
388 =head2 rank
|
|
|
389
|
|
|
390 Purpose : Returns the rank of the current object or 1
|
|
|
391 : if rank is not defined.
|
|
|
392 Usage : $self->rank
|
|
|
393
|
|
|
394 See Also : L<set_rank>()
|
|
|
395
|
|
|
396 =cut
|
|
|
397
|
|
|
398 #---------
|
|
|
399 sub rank { my $self = shift; $self->{'_rank'} || 1; }
|
|
|
400 #---------
|
|
|
401
|
|
|
402
|
|
|
403
|
|
|
404 =head2 rank_by
|
|
|
405
|
|
|
406 Purpose : Returns the ranking criterion or the string 'order of addition'
|
|
|
407 : if rankBy has not been explicitly set.
|
|
|
408 Usage : $self->rank_by
|
|
|
409
|
|
|
410 See Also : L<set_rank>()
|
|
|
411
|
|
|
412 =cut
|
|
|
413
|
|
|
414 #-----------
|
|
|
415 sub rank_by {
|
|
|
416 #-----------
|
|
|
417 my $self = shift;
|
|
|
418 defined $self->{'_master'} ? ($self->{'_master'}->{'_rankBy'}||'order of addition')
|
|
|
419 : 'unranked';
|
|
|
420 }
|
|
|
421
|
|
|
422
|
|
|
423
|
|
|
424 =head2 size
|
|
|
425
|
|
|
426 Purpose : Returns the number of objects currently in the Vector.
|
|
|
427 Usage : $self->size
|
|
|
428
|
|
|
429 =cut
|
|
|
430
|
|
|
431 #---------
|
|
|
432 sub size {
|
|
|
433 #---------
|
|
|
434 my $self = shift;
|
|
|
435 defined $self->{'_master'} ? $self->{'_master'}->{'_size'} : 1;
|
|
|
436 }
|
|
|
437
|
|
|
438
|
|
|
439 =head2 master
|
|
|
440
|
|
|
441 Purpose : Returns the master object associated with the Vector.
|
|
|
442 : (should probably be a private method).
|
|
|
443 Usage : $self->master
|
|
|
444
|
|
|
445 =cut
|
|
|
446
|
|
|
447 #-----------
|
|
|
448 sub master { my $self = shift; $self->{'_master'}; }
|
|
|
449 #-----------
|
|
|
450
|
|
|
451
|
|
|
452 ## Not sure what these potentially dangerous methods are used for.
|
|
|
453 ## Should be unnecessary and probably can be removed.
|
|
|
454 sub set_prev { my($self,$obj) = @_; $self->{'_prev'} = $obj; }
|
|
|
455 sub set_next { my($self,$obj) = @_; $self->{'_next'} = $obj; }
|
|
|
456
|
|
|
457 #############################################################################
|
|
|
458 # INSTANCE METHODS ##
|
|
|
459 #############################################################################
|
|
|
460
|
|
|
461
|
|
|
462 =head2 is_first
|
|
|
463
|
|
|
464 Purpose : Test whether the current object is the first in the Vector.
|
|
|
465 Usage : $self->is_first
|
|
|
466
|
|
|
467 =cut
|
|
|
468
|
|
|
469 #------------
|
|
|
470 sub is_first { my($self) = shift; return not defined $self->{'_prev'}; }
|
|
|
471 #------------
|
|
|
472
|
|
|
473
|
|
|
474 =head2 is_last
|
|
|
475
|
|
|
476 Purpose : Test whether the current object is the last in the Vector.
|
|
|
477 Usage : $self->is_last
|
|
|
478
|
|
|
479 =cut
|
|
|
480
|
|
|
481 #------------
|
|
|
482 sub is_last { my($self) = shift; return not defined $self->{'_next'}; }
|
|
|
483 #------------
|
|
|
484
|
|
|
485
|
|
|
486
|
|
|
487
|
|
|
488 =head2 get
|
|
|
489
|
|
|
490 Purpose : Retrives an object from the Vector given its name.
|
|
|
491 : Returns undef if the object cannot be found.
|
|
|
492 Usage : $self->get(object_name)
|
|
|
493 Examples : $self->get($obj->name)
|
|
|
494
|
|
|
495 See Also : L<list>()
|
|
|
496
|
|
|
497 =cut
|
|
|
498
|
|
|
499 #--------
|
|
|
500 sub get {
|
|
|
501 #--------
|
|
|
502 my($self,$name) = @_;
|
|
|
503
|
|
|
504 my ($obj);
|
|
|
505 # print "$ID get(): getting $name\n";
|
|
|
506
|
|
|
507 if($self->{'_master'}->{'_set'}) {
|
|
|
508 # my @names = keys %{$self->{'_master'}->{'_index'}};
|
|
|
509 # print "$ID: names in hash:\n@names";<STDIN>;
|
|
|
510 # print " returning $self->{'_master'}->{'_index'}->{$name}\n";
|
|
|
511 local($^W) = 0;
|
|
|
512 $obj = $self->{'_master'}->{'_index'}->{$name};
|
|
|
513 }
|
|
|
514
|
|
|
515 elsif($self->name =~ /$name/i) {
|
|
|
516 # print " returning self\n";
|
|
|
517 $obj = $self;
|
|
|
518 }
|
|
|
519
|
|
|
520 if(not ref $obj) {
|
|
|
521 $self->throw("Can't get object named \"$name\": object not set or name undefined.");
|
|
|
522 }
|
|
|
523 $obj;
|
|
|
524 }
|
|
|
525
|
|
|
526 ## Former strategy: hunt through the list for the object.
|
|
|
527 ## No longer needed since master indexes all objects.
|
|
|
528 # do{
|
|
|
529 # if($obj->name eq $name) { return $obj; }
|
|
|
530 #
|
|
|
531 # } while($obj = $current->prev());
|
|
|
532
|
|
|
533
|
|
|
534
|
|
|
535
|
|
|
536 =head2 add
|
|
|
537
|
|
|
538 Purpose : Add an object to the end of a Vector.
|
|
|
539 Usage : $self->add(object_reference)
|
|
|
540
|
|
|
541 See also : L<insert>(), L<remove>()
|
|
|
542
|
|
|
543 =cut
|
|
|
544
|
|
|
545 #--------
|
|
|
546 sub add {
|
|
|
547 #--------
|
|
|
548 my($self,$new,$index) = @_;
|
|
|
549
|
|
|
550 $self->_set_master($self) unless $self->{'_master'}->{'_set'};
|
|
|
551
|
|
|
552 # print "\n\nADDING TO VECTOR ${\ref $self} ${\$self->name}\nFOR PARENT: ${\ref $self->parent} ${\$self->parent->name}\n\n";
|
|
|
553
|
|
|
554 $self->{'_next'} = $new;
|
|
|
555 $new->{'_prev'} = $self;
|
|
|
556 $self->{'_master'}->{'_last'} = $new;
|
|
|
557 $self->{'_master'}->{'_size'}++;
|
|
|
558 $new->{'_master'} = $self->{'_master'};
|
|
|
559 $new->_incrementRank();
|
|
|
560 $new->Bio::Root::Vector::_index();
|
|
|
561
|
|
|
562 # printf "NEW CONTENTS: (n=%s)\n", $self->size;
|
|
|
563 # my $obj = $self->first;
|
|
|
564 # my $count=0;
|
|
|
565 # do { print "\n","Object #",++$count,"\n";
|
|
|
566 # $obj->display;
|
|
|
567 # } while($obj=$obj->next);
|
|
|
568 # <STDIN>;
|
|
|
569 }
|
|
|
570
|
|
|
571
|
|
|
572 sub _index {
|
|
|
573 my($self) = @_;
|
|
|
574 my $name = $self->name;
|
|
|
575
|
|
|
576 # Generate unique name, if necessary, for indexing purposes.
|
|
|
577 if( not $name or $name =~ /anonymous/) {
|
|
|
578 $name ||= '';
|
|
|
579 $name .= $self->size();
|
|
|
580 }
|
|
|
581 # print "$ID: _index() called for $name\n";
|
|
|
582
|
|
|
583 $self->{'_master'}->{'_index'}->{$name} = $self;
|
|
|
584 }
|
|
|
585
|
|
|
586 sub _incrementRank {
|
|
|
587 my $self = shift;
|
|
|
588 return if not defined $self->{'_prev'};
|
|
|
589 $self->{'_rank'} = $self->{'_prev'}->rank() + 1;
|
|
|
590 }
|
|
|
591
|
|
|
592
|
|
|
593 =head2 remove
|
|
|
594
|
|
|
595 Purpose : Remove the current object from the Vector.
|
|
|
596 Usage : $self->remove([-RET=>'first'|'last'|'next'|'prev'], [-UPDATE => 0|1])
|
|
|
597 Returns : The first, last, next, or previous object in the Vector
|
|
|
598 : depending on the value of the -RET parameter.
|
|
|
599 : Default = next.
|
|
|
600 Argument : Named parameters: (TAGS CAN BE ALL UPPER OR ALL LOWER CASE)
|
|
|
601 : -RET => string: 'first', 'last', 'prev' 'next'
|
|
|
602 : THis indicates the object to be returned.
|
|
|
603 : -UPDATE => boolean, if non-zero all objects in the vector
|
|
|
604 : will be re-ranked.
|
|
|
605 Comments : The -UPDATE parameter should be set to true to force a re-updating
|
|
|
606 : of the rank data for each object. (default = 0, no update).
|
|
|
607
|
|
|
608 See Also : L<add>(), L<insert>(), L<shift>(), L<chop>()
|
|
|
609
|
|
|
610 =cut
|
|
|
611
|
|
|
612 #-----------
|
|
|
613 sub remove {
|
|
|
614 #-----------
|
|
|
615 my($self,%param) = @_;
|
|
|
616 my $updateRank = $param{-UPDATE} || $param{'-update'} || 0;
|
|
|
617 my $ret = $param{-RET} || $param{'-ret'} || 'next';
|
|
|
618
|
|
|
619 $DEBUG==2 && do{ print STDERR "$ID: removing ${\$self->name}; ret = $ret";<STDIN>; };
|
|
|
620
|
|
|
621 ## This set of conditionals involves primarily pointer shuffling.
|
|
|
622 ## The special case of destroying a vector of size 1 is handled.
|
|
|
623
|
|
|
624 if($self->is_first()) {
|
|
|
625 $DEBUG==2 && print STDERR "---> removing first object: ${\$self->name()}.\n";
|
|
|
626 if($self->is_last) {
|
|
|
627 # print "Removing only object in vector: ${\$self->name}.\n";
|
|
|
628 $self->_destroy_master();
|
|
|
629 return $self->destroy;
|
|
|
630 } else {
|
|
|
631 undef ($self->{'_next'}->{'_prev'});
|
|
|
632 $self->_update_first($self->{'_next'});
|
|
|
633 }
|
|
|
634
|
|
|
635 } elsif($self->is_last()) {
|
|
|
636 $DEBUG==2 && print STDERR "---> removing last object: ${\$self->name()}.\n";
|
|
|
637 undef ($self->{'_prev'}->{'_next'});
|
|
|
638 $self->_update_last($self->{'_prev'});
|
|
|
639
|
|
|
640 } else {
|
|
|
641 $DEBUG==2 && print STDERR "---> removing internal object.\n";
|
|
|
642 $self->{'_prev'}->{'_next'} = $self->{'_next'};
|
|
|
643 $self->{'_next'}->{'_prev'} = $self->{'_prev'};
|
|
|
644 }
|
|
|
645
|
|
|
646 $updateRank && $self->_update_rank();
|
|
|
647 $self->{'_master'}->{'_size'}--;
|
|
|
648
|
|
|
649 # print "new vector size = ",$self->size,"\n"; <STDIN>;
|
|
|
650
|
|
|
651 my($retObj);
|
|
|
652
|
|
|
653 if( $self->size) {
|
|
|
654 if($ret eq 'first') { $retObj = $self->first(); }
|
|
|
655 elsif($ret eq 'last') { $retObj = $self->last(); }
|
|
|
656 elsif($ret eq 'next') { $retObj = $self->next(); }
|
|
|
657 elsif($ret eq 'prev') { $retObj = $self->prev(); }
|
|
|
658 }
|
|
|
659
|
|
|
660 ## Destroy the object.
|
|
|
661 # $self->destroy;
|
|
|
662
|
|
|
663 $DEBUG && do{ print STDERR "$ID: returning ${\$retObj->name}";<STDIN>; };
|
|
|
664
|
|
|
665 $retObj;
|
|
|
666 }
|
|
|
667
|
|
|
668 sub _update_first {
|
|
|
669 my($self,$first) = @_;
|
|
|
670 $DEBUG && print STDERR "Updating first.\n";
|
|
|
671 undef ($first->{'_prev'});
|
|
|
672 $self->{'_master'}->{'_first'} = $first;
|
|
|
673 }
|
|
|
674
|
|
|
675 sub _update_last {
|
|
|
676 my($self,$last) = @_;
|
|
|
677 $DEBUG && print STDERR "Updating last.\n";
|
|
|
678 undef ($last->{'_next'});
|
|
|
679 $self->{'_master'}->{'_last'} = $last;
|
|
|
680 }
|
|
|
681
|
|
|
682
|
|
|
683 =head2 remove_all
|
|
|
684
|
|
|
685 Purpose : Remove all objects currently in the Vector.
|
|
|
686 Usage : $self->remove_all
|
|
|
687
|
|
|
688 See Also : L<remove>(), L<shift>(), L<chop>()
|
|
|
689
|
|
|
690 =cut
|
|
|
691
|
|
|
692 #---------------
|
|
|
693 sub remove_all {
|
|
|
694 #---------------
|
|
|
695 my($self,%param) = @_;
|
|
|
696
|
|
|
697 $DEBUG==2 && print STDERR "DESTROYING VECTOR $self ${\$self->name}";
|
|
|
698
|
|
|
699 # print "$ID Removing all.";
|
|
|
700
|
|
|
701 $self = $self->first();
|
|
|
702
|
|
|
703 while(ref $self) {
|
|
|
704 # print "$ID: removing ${\$self->name}\n";
|
|
|
705 $self = $self->remove(-RET=>'next');
|
|
|
706 }
|
|
|
707 }
|
|
|
708
|
|
|
709
|
|
|
710 =head2 shift
|
|
|
711
|
|
|
712 Purpose : Remove the first object from the Vector.
|
|
|
713 : This is a wrapper for remove().
|
|
|
714 Usage : $self->shift([-RET=>'first'|'last'|'next'|'prev'])
|
|
|
715 Returns : The object returned by remove().
|
|
|
716
|
|
|
717 See Also : L<remove>(), L<chop>()
|
|
|
718
|
|
|
719 =cut
|
|
|
720
|
|
|
721 #---------
|
|
|
722 sub shift {
|
|
|
723 #---------
|
|
|
724 my($self,%param) = @_;
|
|
|
725 $self = $self->first();
|
|
|
726 $self = $self->remove(%param);
|
|
|
727 }
|
|
|
728
|
|
|
729
|
|
|
730 =head2 chop
|
|
|
731
|
|
|
732 Purpose : Remove the last object from the Vector.
|
|
|
733 : This is a wrapper for remove().
|
|
|
734 Usage : $self->chop([-RET=>'first'|'last'|'next'|'prev'])
|
|
|
735 Returns : The object returned by remove().
|
|
|
736
|
|
|
737 See Also : L<remove>(), L<shift>()
|
|
|
738
|
|
|
739 =cut
|
|
|
740
|
|
|
741 #----------
|
|
|
742 sub chop {
|
|
|
743 #----------
|
|
|
744 my($self,%param) = @_;
|
|
|
745 $self = $self->last();
|
|
|
746 $self = $self->remove(%param);
|
|
|
747 }
|
|
|
748
|
|
|
749
|
|
|
750
|
|
|
751 =head2 insert
|
|
|
752
|
|
|
753 Purpose : Insert a new object into the vector relative to the current object.
|
|
|
754 Usage : $self->insert(object_ref, ['before'|'after'])
|
|
|
755 Examples : $self->insert($obj) # Default insert after $self
|
|
|
756 : $self->insert($obj,'before')
|
|
|
757 Returns : The new number of objects in the vector (int).
|
|
|
758 Throws : exception if the first argument is not a reference.
|
|
|
759
|
|
|
760 See Also : L<add>(), L<remove>()
|
|
|
761
|
|
|
762 =cut
|
|
|
763
|
|
|
764 #-----------
|
|
|
765 sub insert {
|
|
|
766 #-----------
|
|
|
767 my($self,$object,$where) = @_;
|
|
|
768 my($first);
|
|
|
769 $where ||= 'after';
|
|
|
770
|
|
|
771 $self->_set_master($self) unless $self->{'_master'}->{'_set'};
|
|
|
772
|
|
|
773 ref($object) || return $self->master->throw("Can't insert. Not an object: $object");
|
|
|
774
|
|
|
775 if($where eq 'before') {
|
|
|
776 $object->{'_next'} = $self;
|
|
|
777 $object->{'_prev'} = $self->{'_prev'};
|
|
|
778 $object->{'_master'} = $self->{'_master'};
|
|
|
779 $self->{'_prev'}->{'_next'} = $object;
|
|
|
780 $self->{'_prev'} = $object;
|
|
|
781 } else {
|
|
|
782 $object->{'_prev'} = $self;
|
|
|
783 $object->{'_next'} = $self->{'_next'};
|
|
|
784 $object->{'_master'} = $self->{'_master'};
|
|
|
785 $self->{'_next'}->{'_prev'} = $object;
|
|
|
786 $self->{'_next'} = $object;
|
|
|
787 }
|
|
|
788 $self->{'_master'}->{'_size'}++;
|
|
|
789 $object->Bio::Root::Vector::_index(); ##Fully qualified to disambiguate a potentially common method name.
|
|
|
790 $self->_update_rank();
|
|
|
791 }
|
|
|
792
|
|
|
793 sub _update_rank {
|
|
|
794 my($self) = @_;
|
|
|
795 my $current = $self->first();
|
|
|
796 my $count = 0;
|
|
|
797 $DEBUG && print STDERR "$ID: Updating rank.\n";
|
|
|
798 do{
|
|
|
799 $count++;
|
|
|
800 $current->{'_rank'} = $count;
|
|
|
801
|
|
|
802 } while($current = $current->next());
|
|
|
803 }
|
|
|
804
|
|
|
805
|
|
|
806 =head2 list
|
|
|
807
|
|
|
808 Purpose : Returns objects in the Vector as an array or array slice.
|
|
|
809 Usage : $self->list([starting_object|'first'] [,ending_object|'last'])
|
|
|
810 Examples : $self->list
|
|
|
811 : $self->list('first',$self->prev)
|
|
|
812
|
|
|
813 See Also : L<get>()
|
|
|
814
|
|
|
815 =cut
|
|
|
816
|
|
|
817 #----------
|
|
|
818 sub list {
|
|
|
819 #----------
|
|
|
820 my($self,$start,$stop) = @_;
|
|
|
821 my(@list);
|
|
|
822
|
|
|
823 $start ||= 1;
|
|
|
824 $stop ||= 'last';
|
|
|
825
|
|
|
826 if( $start =~ /first|beg|start/i or $start <= 1 ) {
|
|
|
827 $start = $self->first();
|
|
|
828 }
|
|
|
829
|
|
|
830 if( $stop =~ /last|end|stop/i ) {
|
|
|
831 $stop = $self->last();
|
|
|
832 }
|
|
|
833
|
|
|
834 ref($start) || ($start = $self->first());
|
|
|
835 ref($stop) || ($stop = $self->last());
|
|
|
836
|
|
|
837 my $obj = $start;
|
|
|
838 my $fini = 0;
|
|
|
839 do{
|
|
|
840 push @list, $obj;
|
|
|
841 if($obj eq $stop) { $fini = 1; }
|
|
|
842 } while( $obj = $obj->next() and !$fini);
|
|
|
843
|
|
|
844 @list;
|
|
|
845 }
|
|
|
846
|
|
|
847
|
|
|
848 =head2 sort
|
|
|
849
|
|
|
850 Purpose : Sort the objects in the Vector.
|
|
|
851 Usage : $self->sort(['rank'|'name'], [reverse])
|
|
|
852 Returns : The last object of the sorted Vector.
|
|
|
853 Argument : First argument can be 'name' or 'rank' to sort on
|
|
|
854 : the object's name or rank data member, respectively.
|
|
|
855 : If reverse is non-zero, sort will be in reverse order.
|
|
|
856 Example : $self->sort() # Default sort by rank, not reverse.
|
|
|
857 : $self->sort('name','reverse')
|
|
|
858
|
|
|
859 =cut
|
|
|
860
|
|
|
861 #---------'
|
|
|
862 sub sort {
|
|
|
863 #---------
|
|
|
864 my ($self,$sortBy,$reverse) = @_;
|
|
|
865 my (@unsortedList,@sortedList);
|
|
|
866
|
|
|
867 $sortBy ||= 'rank';
|
|
|
868 my $rankBy = $self->rank_by;
|
|
|
869
|
|
|
870 ### Build the initial unsorted list.
|
|
|
871 my $obj = $self->first();
|
|
|
872 do{
|
|
|
873 push @unsortedList, $obj;
|
|
|
874 } while( $obj = $obj->next());
|
|
|
875
|
|
|
876 # print "UNSORTED LIST:\n";
|
|
|
877 # foreach(@unsortedList) {print $_->name().' '};<STDIN>;
|
|
|
878
|
|
|
879 ### Sort it.
|
|
|
880 if( $sortBy =~ /rank/i) {
|
|
|
881 # print "sorting by rank";
|
|
|
882 if($reverse) {
|
|
|
883 # print " (reverse).\n";
|
|
|
884 @sortedList = reverse sort _sort_by_rank @unsortedList;
|
|
|
885 } else {
|
|
|
886 @sortedList = sort _sort_by_rank @unsortedList;
|
|
|
887 }
|
|
|
888 } elsif( $sortBy =~ /name/i) {
|
|
|
889 # print "sorting by name";
|
|
|
890 if($reverse) {
|
|
|
891 # print "(reverse).\n";
|
|
|
892 @sortedList = reverse sort _sort_by_name @unsortedList;
|
|
|
893 } else {
|
|
|
894 @sortedList = sort _sort_by_name @unsortedList;
|
|
|
895 }
|
|
|
896 } else {
|
|
|
897 # print "unknown sort criteria: $sortBy\n";
|
|
|
898 $self->warn("Invalid sorting criteria: $sortBy.",
|
|
|
899 "Sorting by rank.");
|
|
|
900 @sortedList = sort _sort_by_rank @unsortedList;
|
|
|
901 }
|
|
|
902
|
|
|
903
|
|
|
904 # if($reverse) { @sortedList = reverse sort @sortedList; }
|
|
|
905
|
|
|
906 # print "SORTED LIST:\n";
|
|
|
907 # foreach(@sortedList) {print $_->name().' '};<STDIN>;
|
|
|
908
|
|
|
909 ### Re-load the Vector with the sorted list.
|
|
|
910 my $count=0;
|
|
|
911
|
|
|
912 $self = $sortedList[0];
|
|
|
913 $self->_set_master($self);
|
|
|
914 $self->_set_rank_by($rankBy);
|
|
|
915
|
|
|
916 my($i);
|
|
|
917 my $current = $self;
|
|
|
918 for($i=1; $i<@sortedList; $current=$sortedList[$i], $i++) {
|
|
|
919 $current->add($sortedList[$i]);
|
|
|
920 if($i==$#sortedList) { $sortedList[$i]->{'_next'} = undef;}
|
|
|
921 }
|
|
|
922
|
|
|
923 $self->last();
|
|
|
924 }
|
|
|
925
|
|
|
926 sub _sort_by_rank { my $aRank = $a->rank(); my $bRank = $b->rank(); $aRank <=> $bRank; }
|
|
|
927
|
|
|
928 sub _sort_by_name { my $aName = $a->name(); my $bName = $b->name(); $aName cmp $bName; }
|
|
|
929
|
|
|
930
|
|
|
931
|
|
|
932 =head2 valid_any
|
|
|
933
|
|
|
934 Purpose : Determine if at least one object in the Vector is valid.
|
|
|
935 Usage : $self->valid_any
|
|
|
936 Status : Deprecated.
|
|
|
937 Comments : A non-valid object should throw an exception that must be
|
|
|
938 : be caught an dealt with on the spot.
|
|
|
939
|
|
|
940 See Also : B<Bio::Root::Object::valid()>
|
|
|
941
|
|
|
942 =cut
|
|
|
943
|
|
|
944 #-------------
|
|
|
945 sub valid_any {
|
|
|
946 #-------------
|
|
|
947 my $self = &shift(@_);
|
|
|
948
|
|
|
949 my $obj = $self->first();
|
|
|
950 do{
|
|
|
951 return 1 if $obj->valid();
|
|
|
952 } while( $obj = $obj->next());
|
|
|
953
|
|
|
954 return undef;
|
|
|
955 }
|
|
|
956
|
|
|
957
|
|
|
958 =head2 valid_all
|
|
|
959
|
|
|
960 Purpose : Determine if all objects in the Vector are valid.
|
|
|
961 Usage : $self->valid_all
|
|
|
962 Comments : A non-valid object should throw an exception that must be
|
|
|
963 : be caught an dealt with on the spot.
|
|
|
964
|
|
|
965 See Also : B<Bio::Root::Object::valid()>
|
|
|
966
|
|
|
967 =cut
|
|
|
968
|
|
|
969 #--------------
|
|
|
970 sub valid_all {
|
|
|
971 #--------------
|
|
|
972 my $self = &shift(@_);
|
|
|
973
|
|
|
974 my $obj = $self->first();
|
|
|
975 do{
|
|
|
976 return unless $obj->valid();
|
|
|
977 } while( $obj = $obj->next());
|
|
|
978
|
|
|
979 return 1;
|
|
|
980 }
|
|
|
981
|
|
|
982 sub _display_stats {
|
|
|
983 # This could be fleshed out a bit...
|
|
|
984
|
|
|
985 my( $self, $OUT ) = @_;
|
|
|
986
|
|
|
987 printf ( $OUT "%-11s %s\n","RANK:", $self->rank());
|
|
|
988 printf ( $OUT "%-11s %s\n","RANK BY:", $self->rank_by());
|
|
|
989 }
|
|
|
990
|
|
|
991 1;
|
|
|
992 __END__
|
|
|
993
|
|
|
994 #####################################################################################
|
|
|
995 # END OF CLASS #
|
|
|
996 #####################################################################################
|
|
|
997
|
|
|
998 =head1 FOR DEVELOPERS ONLY
|
|
|
999
|
|
|
1000 =head2 Data Members
|
|
|
1001
|
|
|
1002 Information about the various data members of this module is provided for those
|
|
|
1003 wishing to modify or understand the code. Two things to bear in mind:
|
|
|
1004
|
|
|
1005 =over 4
|
|
|
1006
|
|
|
1007 =item 1 Do NOT rely on these in any code outside of this module.
|
|
|
1008
|
|
|
1009 All data members are prefixed with an underscore to signify that they are private.
|
|
|
1010 Always use accessor methods. If the accessor doesn't exist or is inadequate,
|
|
|
1011 create or modify an accessor (and let me know, too!).
|
|
|
1012
|
|
|
1013 =item 2 This documentation may be incomplete and out of date.
|
|
|
1014
|
|
|
1015 It is easy for this documentation to become obsolete as this module is still evolving.
|
|
|
1016 Always double check this info and search for members not described here.
|
|
|
1017
|
|
|
1018 =back
|
|
|
1019
|
|
|
1020 Bio::Root::Vector.pm objects currently cannot be instantiated. Vector.pm must be inherited
|
|
|
1021 along with Bio::Root::Object.pm (or an object that provides a constructor).
|
|
|
1022 Vector.pm defines the following fields:
|
|
|
1023
|
|
|
1024 FIELD VALUE
|
|
|
1025 ------------------------------------------------------------------------
|
|
|
1026 _prev Reference to the previous object in the Vector.
|
|
|
1027
|
|
|
1028 _next Reference to the next object in the Vector.
|
|
|
1029
|
|
|
1030 _rank Rank relative to other objects in the Vector.
|
|
|
1031 Default rank = chronological order of addition to the Vector.
|
|
|
1032
|
|
|
1033 _master A reference to an Bio::Root::Object that acts as a manager for
|
|
|
1034 the given Vector. There is only one master per Vector.
|
|
|
1035 A master object is only needed when the Vector size is >1.
|
|
|
1036 The master object manages the following Vector data:
|
|
|
1037
|
|
|
1038 _first - Reference to the first object in the Vector.
|
|
|
1039 _last - Reference to the last object in the Vector.
|
|
|
1040 _size - Total number of objects in the Vector.
|
|
|
1041 _rankBy - Criteria used to rank the object.
|
|
|
1042 Default: chronological order of addition.
|
|
|
1043 _index - Hash reference for quick access to any object
|
|
|
1044 based on its name.
|
|
|
1045 Bio::Root::Object{'_err'} - Holds any errors affecting the
|
|
|
1046 Vector as a whole.
|
|
|
1047
|
|
|
1048 =cut
|
|
|
1049
|
|
|
1050 1;
|
