/lib/CXGN/Marker/Location.pm
Perl | 452 lines | 413 code | 37 blank | 2 comment | 27 complexity | d6a494c23fc1d1db0eac4220a7db31b7 MD5 | raw file
- =head1 NAME
- CXGN::Marker::Location;
- =head1 AUTHOR
- John Binns <zombieite@gmail.com>
- =head1 DESCRIPTION
- Location object. It's a very simple match to the marker_location table in the database, but it has a little bit of intelligence too.
- =cut
- package CXGN::Marker::Location;
- use strict;
- use CXGN::Marker::Tools;
- use CXGN::DB::Connection;
- use CXGN::Tools::Text;
- use Carp;
- =head2 new
- my $location=CXGN::Marker::Location->new($dbh,$location_id);
- Takes a dbh and a location_id and returns an object representing little more than a row in the marker_location table.
- my $location=CXGN::Marker::Location->new($dbh);
- Takes a dbh and returns an empty object which can perform an insert into the marker_location table.
- =cut
- sub new
- {
- my $class=shift;
- my($dbh,$id)=@_;
- unless(CXGN::DB::Connection::is_valid_dbh($dbh))
- {
- croak"Invalid DBH";
- }
- my $self=bless({},$class);
- $self->{dbh}=$dbh;
- if($id)
- {
- my $q=$dbh->prepare
- ('
- select
- marker_id,
- location_id,
- lg_id,
- lg_name,
- marker_location.map_version_id,
- position,
- confidence_id,
- confidence_name as confidence,
- subscript
- from
- marker_experiment
- inner join marker_location using (location_id)
- inner join linkage_group using (lg_id)
- inner join marker_confidence using (confidence_id)
- where
- location_id=?
- ');
- $q->execute($id);
- my $hr=$q->fetchrow_hashref();
- while(my($key,$value)=each %$hr)
- {
- $self->{$key}=$value;
- }
- }
- return $self;
- }
- =head2 location_id
- my $id=$location->location_id();
- Gets location ID. Cannot set it since it is either retrieved from the database or sent in to the constructor.
- =cut
- #this is not a setter, since these ids are assigned by the database
- sub location_id
- {
- my $self=shift;
- return $self->{location_id};
- }
- =head2 marker_id, lg_name, map_version_id, position, confidence, subscript
- Getters/setters.
- =cut
- sub marker_id
- {
- my $self=shift;
- my($value)=@_;
- if($value) {
- unless($value=~/^\d+$/) {
- croak"Marker ID must be a number, not '$value'";
- }
- unless(CXGN::Marker::Tools::is_valid_marker_id($self->{dbh},$value)) {
- croak"Marker ID '$value' does not exist in the database";
- }
- $self->{marker_id}=$value;
- }
- return $self->{marker_id};
- }
- sub lg_name {
- my $self=shift;
- my($lg_name)=@_;
- if($lg_name) {
- unless($self->{map_version_id}) {
- croak"You must set this object's map_version_id before throwing around lg_names like that, else how can it know what map_version those lg_names are on?";
- }
- my $lg_id=CXGN::Marker::Tools::get_lg_id($self->{dbh},$lg_name,$self->{map_version_id});
- unless($lg_id)
- {
- croak"Linkage group '$lg_name' does not exist on map_version_id '$self->{map_version_id}'";
- }
- $self->{lg_id}=$lg_id;
- $self->{lg_name}=$lg_name;
- }
- return $self->{lg_name};
- }
- sub lg_id {
- my $self = shift;
- my $lg_id = shift;
- if ($lg_id) {
- unless ($self->{map_version_id}) {
- croak "You must set map_version_id before trying to set lg_id. Thanks!\n";
- }
- $self->{lg_id}=$lg_id;
- }
- return $self->{lg_id};
- }
- sub map_version_id
- {
- my $self=shift;
- my($map_version_id)=@_;
- if($map_version_id)
- {
- unless($map_version_id=~/^\d+$/)
- {
- croak"Map version ID must be an integer, not '$map_version_id'";
- }
- $self->{map_version_id}=$map_version_id;
- }
- return $self->{map_version_id};
- }
- sub position {
- my $self=shift;
- my($position)=@_;
- if ($self->{position} =~ /\-/) { # if position describes a range, such as a QTL
- print STDERR "RANGE DETECTED ($self->{position})\n";
- ($self->{position_north}, $self->{position_south}) = split "-", $self->{position};
- $self->{position} = ($self->{position_south} + $self->{position_north})/2;
- }
-
- if(defined($position)) {
- unless(CXGN::Tools::Text::is_number($position)) {
- print STDERR "Position must be a floating-point number, not '$position'";
- }
- $self->{position}=$position;
- }
- return $self->{position};
- }
- sub confidence {
- my $self=shift;
- my($confidence)=@_;
- if($confidence)
- {
- my $confidence_id;
- $confidence_id=CXGN::Marker::Tools::get_marker_confidence_id($self->{dbh},$confidence);
- unless(defined($confidence_id))
- {
- croak"Confidence ID not found for confidence '$confidence'";
- }
- $self->{confidence_id}=$confidence_id;
- $self->{confidence}=$confidence;
- }
- return $self->{confidence};
- }
- sub subscript
- {
- my $self=shift;
- my($subscript)=@_;
- if($subscript)
- {
- $subscript=uc($subscript);
- unless($subscript=~/^[ABC]$/)
- {
- croak"Subscript must be a 'A', 'B', or 'C', not '$subscript'";
- }
- $self->{subscript}=$subscript;
- }
- return $self->{subscript};
- }
- =head2 equals
- if($location1->equals($location2)){print"Location 1 and 2 are the same.";}
- Takes another location object and tells you if it is equivalent to the first location object.
- =cut
- sub equals
- {
- my $self=shift;
- my($other)=@_;
- if
- (
- $self->{marker_id}==$other->{marker_id}
- and $self->{lg_id}==$other->{lg_id}
- and $self->{map_version_id}==$other->{map_version_id}
- and $self->{position}==$other->{position}
- and $self->{confidence} eq $other->{confidence}
- and $self->{subscript} eq $other->{subscript}
- )
- {
- return 1;
- }
- return 0;
- }
- =head2 exists
- if($location->exists()){print"Location exists in database.";}
- Returns its location_id if location is already in the database, or undef if not. Mainly used by store_unless_exists.
- =cut
- sub exists
- {
- my $self=shift;
- unless($self->{marker_id})
- {
- croak"Cannot test for a location's existence without knowing which marker it goes with--store marker and set experiment's marker ID before storing locations";
- }
- unless($self->{lg_id})
- {
- croak"You really should have an lg_id set before testing for a location's existence";
- }
- unless($self->{map_version_id})
- {
- croak"You really should have a map_version_id set before testing for a location's existence";
- }
- unless(defined($self->{position}))
- {
- croak"You really should have a position set before testing for a location's existence";
- }
- unless(defined($self->{confidence_id}))
- {
- croak"You really should have a confidence_id set before testing for a location's existence";
- }
- if($self->{location_id})
- {
- #warn"I think it's pretty obvious that this location exists, since it seems to have been loaded from the database, or recently stored to the database--it already has an id of $self->{location_id}";
- return $self->{location_id};
- }
- my $dbh=$self->{dbh};
- my $q;
- $q=$dbh->prepare
- ('
- select
- distinct location_id
- from
- marker_location
- inner join marker_experiment using (location_id)
- where
- marker_id=?
- and lg_id=?
- and marker_location.map_version_id=?
- and position=?
- and confidence_id=?
- and not(subscript is distinct from ?)
- ');
- $q->execute($self->{marker_id},$self->{lg_id},$self->{map_version_id},$self->{position},$self->{confidence_id},$self->{subscript});
- my %found_location_ids;#a place to keep all location IDs that match for this marker, for use in error checking in a moment
- my($location_id)=$q->fetchrow_array();
- if($location_id)#if we found some matching locations for this marker
- {
- $self->{location_id}=$location_id;#get the ID of the existing row in the database so we know we've already been stored
- $found_location_ids{$location_id}=1;#make a note of the location ID found
- while(my($other_location_id)=$q->fetchrow_array())#grab all other location IDs
- {
- $found_location_ids{$other_location_id}=1;
- }
- if(keys(%found_location_ids)>1)#if we found more than one matching location ID, then the database data is not how we expect it to be
- {
- die"Multiple locations found like\n".$self->as_string()."Locations found: ".CXGN::Tools::Text::list_to_string(keys(%found_location_ids));
- }
- return $self->{location_id};
- }
- return;
- }
- =head2 exists_with_any_confidence
- Checks to see if a location exists, but not knowing its confidence. Used by CAPS loading scripts which know which location
- the PCR experiment maps to, but they do not know the confidence.
- $loc->exists_with_any_confidence() or die"Could not find location:\n".$loc->as_string()."in database--load locations first, before running this script";
- =cut
- sub exists_with_any_confidence
- {
- my $self=shift;
- unless($self->{marker_id})
- {
- croak"Cannot test for a location's existence without knowing which marker it goes with--store marker and set experiment's marker ID before storing locations";
- }
- unless($self->{lg_id})
- {
- croak"You really should have an lg_id set before testing for a location's existence";
- }
- unless($self->{map_version_id})
- {
- croak"You really should have a map_version_id set before testing for a location's existence";
- }
- unless(defined($self->{position}))
- {
- croak"You really should have a position set before testing for a location's existence";
- }
- if(defined($self->{confidence_id}))
- {
- croak"You have a confidence_id set--why not just use the 'exists' function instead?";
- }
- if($self->{location_id})
- {
- #warn"I think it's pretty obvious that this location exists, since it seems to have been loaded from the database, or recently stored to the database--it already has an id of $self->{location_id}";
- return $self->{location_id};
- }
- my $dbh=$self->{dbh};
- my $q;
- $q=$dbh->prepare
- ('
- select
- distinct location_id
- from
- marker_location
- inner join marker_experiment using (location_id)
- where
- marker_id=?
- and lg_id=?
- and map_version_id=?
- and position=?
- and not(subscript is distinct from ?)
- ');
- $q->execute($self->{marker_id},$self->{lg_id},$self->{map_version_id},$self->{position},$self->{subscript});
- my %found_location_ids;#a place to keep all location IDs that match for this marker, for use in error checking in a moment
- my($location_id)=$q->fetchrow_array();
- if($location_id)#if we found some matching locations for this marker
- {
- $self->{location_id}=$location_id;#get the ID of the existing row in the database so we know we've already been stored
- $found_location_ids{$location_id}=1;#make a note of the location ID found
- while(my($other_location_id)=$q->fetchrow_array())#grab all other location IDs
- {
- $found_location_ids{$other_location_id}=1;
- }
- if(keys(%found_location_ids)>1)#if we found more than one matching location ID, then the database data is not how we expect it to be
- {
- die"Multiple locations found like\n".$self->as_string()."Locations found: ".CXGN::Tools::Text::list_to_string(keys(%found_location_ids));
- }
- return $self->{location_id};
- }
- return;
- }
- =head2 store_unless_exists
- my $location_id,$existing_location_id,$new_location_id;
- $location_id=$new_location_id=$location->store_unless_exists();
- unless($location_id)
- {
- $location_id=$existing_location_id=$location->location_id();
- }
- Makes a database insert unless a similar row exists. Returns a location_id ONLY if a new insert was made. If a matching entry was found, location_id is now set, but not returned.
- =cut
- sub store_unless_exists
- {
- my $self=shift;
- if($self->exists()){return;}
- unless($self->{lg_id})
- {
- croak"No lg_id set";
- }
- unless($self->{map_version_id})
- {
- croak"No map_version_id set";
- }
- unless(defined($self->{position}))
- {
- croak"No position set";
- }
- unless(defined($self->{confidence_id}))
- {
- croak"No confidence set";
- }
- my $dbh=$self->{dbh};
- my $statement='insert into sgn.marker_location (lg_id,map_version_id,position,confidence_id,subscript, position_north, position_south) values (?,?,?,?,?,?,?)';
- my @values=($self->{lg_id},$self->{map_version_id},$self->{position},$self->{confidence_id},$self->{subscript}, $self->{position_north}, $self->{position_south});
- my $q=$dbh->prepare($statement);
- #print STDERR "$statement; (@values)\n";
- $q->execute(@values);
- $self->{location_id}=$dbh->last_insert_id('marker_location') or croak"Can't find last insert id for location ".$self->as_string();
- return($self->{location_id});
- }
- =head2 as_string
- print $location->as_string();
- Prints a location string for debugging.
- =cut
- sub as_string
- {
- my $self=shift;
- my $string="<location>\n";
- $string.="\tmarker_id: '$self->{marker_id}'\tsubscript: '$self->{subscript}'\n";
- $string.="\tlg_name: '$self->{lg_name}'\tlg_id: '$self->{lg_id}'\tposition: '$self->{position}'\n";
- $string.="\tlocation_id: '$self->{location_id}'\tmap_version_id: '$self->{map_version_id}'\n";
- $string.="\tconfidence: '$self->{confidence}'\tconfidence_id: '$self->{confidence_id}'\n";
- $string.="</location>\n";
- return $string;
- }
- 1;