Bio/Map/PositionHandler.pm

   1 #
   2 # BioPerl module for Bio::Map::PositionHandler
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Sendu Bala <bix@sendu.me.uk>
   7 #
   8 # Copyright Sendu Bala
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::Map::PositionHandler - A Position Handler Implementation
  17
  18 =head1 SYNOPSIS
  19
  20     # This is used by modules when they want to implement being a
  21     # Position or being something that has Positions (when they are
  22     # a L<Bio::Map::EntityI>)
  23
  24     # Make a PositionHandler that knows about you
  25     my $ph = Bio::Map::PositionHandler->new($self);
  26
  27     # Register with it so that it handles your Position-related needs
  28     $ph->register;
  29
  30     # If you are a position, get/set the map you are on and the marker you are
  31     # for
  32     $ph->map($map);
  33     $ph->element($marker);
  34     my $map = $ph->map;
  35     my $marker = $ph->element;
  36
  37     # If you are a marker, add a new position to yourself
  38     $ph->add_positions($pos);
  39
  40     # And then get all your positions on a particular map
  41     foreach my $pos ($ph->get_positions($map)) {
  42         # do something with this Bio::Map::PositionI
  43     }
  44
  45     # Or find out what maps you exist on
  46     my @maps = $ph->get_other_entities;
  47
  48     # The same applies if you were a map
  49
  50 =head1 DESCRIPTION
  51
  52 A Position Handler copes with the coordination of different Bio::Map::EntityI
  53 objects, adding and removing them from each other and knowning who belongs to
  54 who. These relationships between objects are based around shared Positions,
  55 hence PositionHandler.
  56
  57 This PositionHandler is able to cope with Bio::Map::PositionI objects,
  58 Bio::Map::MappableI objects and Bio::Map::MapI objects.
  59
  60 =head1 FEEDBACK
  61
  62 =head2 Mailing Lists
  63
  64 User feedback is an integral part of the evolution of this and other
  65 Bioperl modules. Send your comments and suggestions preferably to
  66 the Bioperl mailing list.  Your participation is much appreciated.
  67
  68   bioperl-l@bioperl.org                  - General discussion
  69   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  70
  71 =head2 Support
  72
  73 Please direct usage questions or support issues to the mailing list:
  74
  75 I<bioperl-l@bioperl.org>
  76
  77 rather than to the module maintainer directly. Many experienced and
  78 reponsive experts will be able look at the problem and quickly
  79 address it. Please include a thorough description of the problem
  80 with code and data examples if at all possible.
  81
  82 =head2 Reporting Bugs
  83
  84 Report bugs to the Bioperl bug tracking system to help us keep track
  85 of the bugs and their resolution. Bug reports can be submitted via the
  86 web:
  87
  88   https://github.com/bioperl/bioperl-live/issues
  89
  90 =head1 AUTHOR - Sendu Bala
  91
  92 Email bix@sendu.me.uk
  93
  94 =head1 APPENDIX
  95
  96 The rest of the documentation details each of the object methods.
  97 Internal methods are usually preceded with a _
  98
  99 =cut
 100
 101 # Let the code begin...
 102
 103 package Bio::Map::PositionHandler;
 104 use strict;
 105
 106 use base qw(Bio::Root::Root Bio::Map::PositionHandlerI);
 107
 108 # globally accessible hash, via private instance methods
 109 my $RELATIONS = {};
 110
 111 =head2 General methods
 112
 113 =cut
 114
 115 =head2 new
 116
 117  Title   : new
 118  Usage   : my $position_handler = Bio::Map::PositionHandler->new(-self => $self);
 119  Function: Get a Bio::Map::PositionHandler that knows who you are.
 120  Returns : Bio::Map::PositionHandler object
 121  Args    : -self => Bio::Map::EntityI that is you
 122
 123 =cut
 124
 125 sub new {
 126     my ($class, @args) = @_;
 127     my $self = $class->SUPER::new(@args);
 128
 129     my ($you) = $self->_rearrange([qw(SELF)], @args);
 130
 131     $self->throw('Must supply -self') unless $you;
 132     $self->throw('-self must be a reference (object)') unless ref($you);
 133     $self->throw('This is [$you], not a Bio::Map::EntityI object') unless $you->isa('Bio::Map::EntityI');
 134     $self->{_who} = $you;
 135     $self->{_rel} = $RELATIONS;
 136     return $self;
 137 }
 138
 139 =head2 register
 140
 141  Title   : register
 142  Usage   : $position_handler->register();
 143  Function: Ask this Position Handler to look after your entity relationships.
 144  Returns : n/a
 145  Args    : none
 146
 147 =cut
 148
 149 sub register {
 150     my $self = shift;
 151     my $you = $self->{_who};
 152
 153     $self->throw("Trying to re-register [$you], which could be bad") if $you->get_position_handler->index;
 154
 155     $self->{_index} = ++$self->{_rel}->{assigned_indices};
 156     $self->{_rel}->{registered}->{$self->{_index}} = $you;
 157 }
 158
 159 =head2 index
 160
 161  Title   : index
 162  Usage   : my $index = $position_handler->index();
 163  Function: Get the unique registry index for yourself, generated during the
 164            resistration process.
 165  Returns : int
 166  Args    : none
 167
 168 =cut
 169
 170 sub index {
 171     my $self = shift;
 172     return $self->{_index};
 173 }
 174
 175 =head2 get_entity
 176
 177  Title   : get_entity
 178  Usage   : my $entity = $position_handler->get_entity($index);
 179  Function: Get the entity that corresponds to the supplied registry index.
 180  Returns : Bio::Map::EntityI object
 181  Args    : int
 182
 183 =cut
 184
 185 sub get_entity {
 186     my ($self, $index) = @_;
 187     return $self->{_rel}->{registered}->{$index} || $self->throw("Requested registy index '$index' but that index isn't in the registry");
 188 }
 189
 190 =head2 Methods for Bio::Map::PositionI objects
 191
 192 =cut
 193
 194 =head2 map
 195
 196  Title   : map
 197  Usage   : my $map = $position_handler->map();
 198            $position_handler->map($map);
 199  Function: Get/Set the map you are on. You must be a Position.
 200  Returns : L<Bio::Map::MapI>
 201  Args    : none to get, OR
 202            new L<Bio::Map::MapI> to set
 203
 204 =cut
 205
 206 sub map {
 207     my ($self, $entity) = @_;
 208     return $self->_pos_get_set($entity, 'position_maps', 'Bio::Map::MapI');
 209 }
 210
 211 =head2 element
 212
 213  Title   : element
 214  Usage   : my $element = $position_handler->element();
 215            $position_handler->element($element);
 216  Function: Get/Set the map element you are for. You must be a Position.
 217  Returns : L<Bio::Map::MappableI>
 218  Args    : none to get, OR
 219            new L<Bio::Map::MappableI> to set
 220
 221 =cut
 222
 223 sub element {
 224     my ($self, $entity) = @_;
 225     return $self->_pos_get_set($entity, 'position_elements', 'Bio::Map::MappableI');
 226 }
 227
 228 =head2 Methods for all other Bio::Map::EntityI objects
 229
 230 =cut
 231
 232 =head2 add_positions
 233
 234  Title   : add_positions
 235  Usage   : $position_handler->add_positions($pos1, $pos2, ...);
 236  Function: Add some positions to yourself. You can't be a position.
 237  Returns : n/a
 238  Args    : Array of Bio::Map::PositionI objects
 239
 240 =cut
 241
 242 sub add_positions {
 243     my $self = shift;
 244     $self->throw('Must supply at least one Bio::Map::EntityI') unless @_ > 0;
 245     my $you_index = $self->_get_you_index(0);
 246     my $kind = $self->_get_kind;
 247
 248     foreach my $pos (@_) {
 249         $self->_check_object($pos, 'Bio::Map::PositionI');
 250         my $pos_index = $self->_get_other_index($pos);
 251
 252         $self->_pos_set($pos_index, $you_index, $kind);
 253     }
 254 }
 255
 256 =head2 get_positions
 257
 258  Title   : get_positions
 259  Usage   : my @positions = $position_handler->get_positions();
 260  Function: Get all your positions. You can't be a Position.
 261  Returns : Array of Bio::Map::PositionI objects
 262  Args    : none for all, OR
 263            Bio::Map::EntityI object to limit the Positions to those that
 264            are shared by you and this other entity.
 265
 266 =cut
 267
 268 sub get_positions {
 269     my ($self, $entity) = @_;
 270     my $you_index = $self->_get_you_index(0);
 271
 272     my @positions = keys %{$self->{_rel}->{has}->{$you_index}};
 273
 274     if ($entity) {
 275         my $entity_index = $self->_get_other_index($entity);
 276         my $pos_ref = $self->{_rel}->{has}->{$entity_index};
 277         @positions = grep { $pos_ref->{$_} } @positions;
 278     }
 279
 280     return map { $self->get_entity($_) } @positions;
 281 }
 282
 283 =head2 purge_positions
 284
 285  Title   : purge_positions
 286  Usage   : $position_handler->purge_positions();
 287  Function: Remove all positions from yourself. You can't be a Position.
 288  Returns : n/a
 289  Args    : none to remove all, OR
 290            Bio::Map::PositionI object to remove only that entity, OR
 291            Bio::Map::EntityI object to limit the removal to those Positions that
 292            are shared by you and this other entity.
 293
 294 =cut
 295
 296 sub purge_positions {
 297     my ($self, $thing) = @_;
 298     my $you_index = $self->_get_you_index(0);
 299     my $kind = $self->_get_kind;
 300
 301     my @pos_indices;
 302     if ($thing) {
 303         $self->throw("Must supply an object") unless ref($thing);
 304         if ($thing->isa("Bio::Map::PositionI")) {
 305             @pos_indices = ($self->_get_other_index($thing));
 306         }
 307         else {
 308             my $entity_index = $self->_get_other_index($thing);
 309             my $pos_ref = $self->{_rel}->{has}->{$entity_index};
 310             @pos_indices = grep { $pos_ref->{$_} } keys %{$self->{_rel}->{has}->{$you_index}};
 311         }
 312     }
 313     else {
 314         @pos_indices = keys %{$self->{_rel}->{has}->{$you_index}};
 315     }
 316
 317     foreach my $pos_index (@pos_indices) {
 318         $self->_purge_pos_entity($pos_index, $you_index, $kind);
 319     }
 320 }
 321
 322 =head2 get_other_entities
 323
 324  Title   : get_other_entities
 325  Usage   : my @entities = $position_handler->get_other_entities();
 326  Function: Get all the entities that share your Positions. You can't be a
 327            Position.
 328  Returns : Array of Bio::Map::EntityI objects
 329  Args    : none
 330
 331 =cut
 332
 333 sub get_other_entities {
 334     my $self = shift;
 335     my $you_index = $self->_get_you_index(0);
 336     my $kind = $self->_get_kind;
 337     my $want = $kind eq 'position_elements' ? 'position_maps' : 'position_elements';
 338
 339     my %entities;
 340     while (my ($pos_index) = each %{$self->{_rel}->{has}->{$you_index}}) {
 341         my $entity_index = $self->{_rel}->{$want}->{$pos_index};
 342         $entities{$entity_index} = 1 if $entity_index;
 343     }
 344
 345     return map { $self->get_entity($_) } keys %entities;
 346 }
 347
 348 # do basic check on an object, make sure it is the right type
 349 sub _check_object {
 350     my ($self, $object, $interface) = @_;
 351     $self->throw("Must supply an arguement") unless $object;
 352     $self->throw("This is [$object], not an object") unless ref($object);
 353     $self->throw("This is [$object], not a $interface") unless $object->isa($interface);
 354 }
 355
 356 # get the object we are the handler of, its index, and throw depending on if
 357 # we're a Position
 358 sub _get_you_index {
 359     my ($self, $should_be_pos) = @_;
 360     my $you = $self->{_who};
 361     if ($should_be_pos) {
 362         $self->throw("This is not a Position, method invalid") unless $you->isa('Bio::Map::PositionI');
 363     }
 364     else {
 365         $self->throw("This is a Position, method invalid") if $you->isa('Bio::Map::PositionI');
 366     }
 367     return $self->index;
 368 }
 369
 370 # check an entity is registered and get its index
 371 sub _get_other_index {
 372     my ($self, $entity) = @_;
 373     $self->throw("Must supply an object") unless ref($entity);
 374     my $index = $entity->get_position_handler->index;
 375     $self->throw("Entity doesn't seem like it's been registered") unless $index;
 376     $self->throw("Entity may have been registered with a different PositionHandler, can't deal with it") unless $entity eq $self->get_entity($index);
 377     return $index;
 378 }
 379
 380 # which of the position hashes should we be recorded under?
 381 sub _get_kind {
 382     my $self = shift;
 383     my $you = $self->{_who};
 384     return $you->isa('Bio::Map::MapI') ? 'position_maps' : $you->isa('Bio::Map::MappableI') ? 'position_elements' : $self->throw("This is [$you] which is an unsupported kind of entity");
 385 }
 386
 387 # get/set position entity
 388 sub _pos_get_set {
 389     my ($self, $entity, $kind, $interface) = @_;
 390     my $you_index = $self->_get_you_index(1);
 391
 392     my $entity_index;
 393     if ($entity) {
 394         $self->_check_object($entity, $interface);
 395         my $new_entity_index = $self->_get_other_index($entity);
 396         $entity_index = $self->_pos_set($you_index, $new_entity_index, $kind);
 397     }
 398
 399     $entity_index ||= $self->{_rel}->{$kind}->{$you_index} || 0;
 400     if ($entity_index) {
 401         return $self->get_entity($entity_index);
 402     }
 403     return;
 404 }
 405
 406 # set position entity
 407 sub _pos_set {
 408     my ($self, $pos_index, $new_entity_index, $kind) = @_;
 409     my $current_entity_index = $self->{_rel}->{$kind}->{$pos_index} || 0;
 410
 411     if ($current_entity_index) {
 412         if ($current_entity_index == $new_entity_index) {
 413             return $current_entity_index;
 414         }
 415
 416         $self->_purge_pos_entity($pos_index, $current_entity_index, $kind);
 417     }
 418
 419     $self->{_rel}->{has}->{$new_entity_index}->{$pos_index} = 1;
 420     $self->{_rel}->{$kind}->{$pos_index} = $new_entity_index;
 421     return $new_entity_index;
 422 }
 423
 424 # disassociate position from one of its current entities
 425 sub _purge_pos_entity {
 426     my ($self, $pos_index, $entity_index, $kind) = @_;
 427     delete $self->{_rel}->{has}->{$entity_index}->{$pos_index};
 428     delete $self->{_rel}->{$kind}->{$pos_index};
 429 }
 430
 431 1;