Bio/DB/Map/SQL/MarkerAdaptor.pm

   1
   2 #
   3 # BioPerl module for Bio::DB::Map::SQL::MarkerAdaptor
   4 #
   5 # Cared for by Jason Stajich <jason@chg.mc.duke.edu>
   6 #
   7 # Copyright Jason Stajich
   8 #
   9 # You may distribute this module under the same terms as perl itself
  10
  11 # POD documentation - main docs before the code
  12
  13 =head1 NAME
  14
  15 Bio::DB::Map::SQL::MarkerAdaptor - Adaptor Object for Markers
  16
  17 =head1 SYNOPSIS
  18
  19 Give standard usage here
  20
  21 =head1 DESCRIPTION
  22
  23 Describe the object here
  24
  25 =head1 FEEDBACK
  26
  27 =head2 Mailing Lists
  28
  29 User feedback is an integral part of the evolution of this and other
  30 Bioperl modules. Send your comments and suggestions preferably to the
  31 Bioperl mailing list.  Your participation is much appreciated.
  32
  33   bioperl-l@bioperl.org             - General discussion
  34   http://bioperl.org/MailList.shtml - About the mailing lists
  35
  36 =head2 Reporting Bugs
  37
  38 Report bugs to the Bioperl bug tracking system to help us keep track
  39  the bugs and their resolution.
  40  Bug reports can be submitted via email or the web:
  41
  42   bioperl-bugs@bioperl.org
  43   http://bioperl.org/bioperl-bugs/
  44
  45 =head1 AUTHOR - Jason Stajich
  46
  47 Email jason@chg.mc.duke.edu
  48
  49 Describe contact details here
  50
  51 =head1 APPENDIX
  52
  53 The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _
  54
  55 =cut
  56
  57
  58 # Let the code begin...
  59
  60
  61 package Bio::DB::Map::SQL::MarkerAdaptor;
  62 use vars qw(@ISA);
  63 use strict;
  64
  65 use Bio::DB::SQL::BaseAdaptor;
  66 use Bio::DB::Map::Marker;
  67
  68 @ISA = qw(Bio::DB::SQL::BaseAdaptor);
  69
  70 sub new {
  71     my($class,@args) = @_;
  72     my $self = $class->SUPER::new(@args);
  73     return $self;
  74 }
  75
  76
  77 =head2 get
  78
  79  Title   : get
  80  Usage   : my @markers = $markeradaptor->get(-ids => \@ids );
  81  Function: gets a list of Bio::DB::Map::Marker objects based on
  82            the list of queries
  83  Returns : list of Bio::DB::Map::Marker objects
  84  Args    : -id   => markerid
  85            -ids  => array ref of marker ids
  86            -name => marker name
  87            -names=> array ref of marker names
  88            -pcrprimers => array ref of pcrprimers to use to search for marker
  89 =cut
  90
  91 sub get {
  92     my ($self, @args) = @_;
  93     my ($id, $ids, $name, $names,
  94         $pcrprimers ) = $self->_rearrange( [qw(ID IDS NAME NAMES
  95                                                PCRPRIMERS )],
  96                                                      @args );
  97
  98     my (@n, @i);
  99
 100
 101     # for now we will ignore bad users who specify > 1 argument
 102     # by just handling input in a precedence order.
 103
 104     if( defined $pcrprimers ) {
 105         # pcr primers trump all for now
 106         if( ref($pcrprimers) !~ /array/i ||
 107             scalar @$pcrprimers != 2 ) {
 108             $self->warn("Did not supply a 2-entry array ref or paramer -pcrprimers");
 109             return undef;
 110         }
 111         return $self->_get_marker_by_primers(@$pcrprimers);
 112     }
 113
 114
 115     if( defined $names ) {
 116         if( ref($names) !~ /array/i ) {
 117             $self->warn("Must specify an array ref for the parameter -names");
 118             return undef;
 119         }
 120         @n = @$names;
 121     } elsif( defined $name ) {
 122         @n = ($name);
 123     }
 124
 125     if( defined $ids ) {
 126         if( ref($ids ) !~ /array/i ) {
 127             $self->warn("Must specify an array ref for the parameter - ids");
 128             return undef;
 129         }
 130         @i = @$ids;
 131     } elsif( defined $id ) {
 132         @i = ($id);
 133     }
 134     if( ! @i && ! @n ) {
 135         $self->warn("did not pass in appropriate arguments to get!");
 136         return ();
 137     }
 138     # should we try and be sure that the lists produce a unique list?
 139     return ( $self->_get_markers_by_ids(@i),
 140              $self->_get_markers_by_names(@n) );
 141 }
 142
 143 =head2 write
 144
 145  Title   : write
 146  Usage   : $marker_adaptor->write($marker);
 147  Function: Store a new Marker or update an existing one
 148  Returns : Bio::DB::Map::MarkerI object (id updated if necessary)
 149            or undef if not properly updated
 150  Args    : Bio::DB::Map::MarkerI object
 151
 152 =cut
 153
 154 # this is not atomic and we don't have transactions so it is hard to
 155 # rollback this stuff.  Right now if a marker has a map which is not in
 156 # the db we don't find out until we get to that part of the data a
 157 # better check should probably be done here to handle this properly
 158
 159 sub write {
 160     my ($self,$marker) = @_;
 161
 162     if( !ref($marker) || ! $marker->isa('Bio::DB::Map::MarkerI') ) {
 163         $self->throw("Must specify a Bio::DB::Map::MarkerI object not '".ref($marker)."' for MarkerAdaptor::write");
 164     }
 165
 166     my $mapadaptor = $self->db->get_MapAdaptor();
 167     my %maphash = $mapadaptor->get_mapids_hash();
 168     my $sth;
 169     if( $marker->id ) {
 170         # this is an update since marker already has an id
 171         my $rc = 0;
 172         my $UPDATESQL = 'UPDATE marker SET %s WHERE markerid = ? ';
 173         # let's get the original and compare for
 174         # the sake of comparing aliases and map positions
 175         my ($markercopy) = $self->get('-id' => $marker->id );
 176         if( ! $markercopy ) {
 177             $self->warn("Marker ". join(' ', ($marker->id, $marker->locus,
 178                                               $marker->probe)). "DNE \n");
 179             return;
 180         }
 181         my ( @updatefields, @updatevalues );
 182
 183         foreach my $field ( qw(locus probe chrom type length) ) {
 184             next if( !defined $marker->{$field} );
 185             if( !defined $markercopy->{$field} ||
 186                 ($markercopy->{$field} ne $marker->{$field}) ) {
 187                 push (@updatefields,"$field=?");
 188                 push (@updatevalues, $marker->{$field});
 189             }
 190         }
 191
 192         if( $markercopy->pcrfwd ne $marker->pcrfwd ){
 193             push (@updatefields,"fwdprimer=?");
 194             push (@updatevalues, $marker->pcrfwd);
 195         }
 196         if( $markercopy->pcrrev ne $marker->pcrrev ){
 197             push (@updatefields,"revprimer=?");
 198             push (@updatevalues, $marker->pcrrev);
 199         }
 200         eval {
 201             if( @updatefields ) {
 202                 my $sql = sprintf($UPDATESQL,
 203                                   join(', ', @updatefields));
 204                 $sth = $self->prepare($sql);
 205                 $sth->execute(@updatevalues,$marker->id);
 206                 $sth->finish();
 207             }
 208         };
 209         if( $@ ) {
 210             $self->warn($@);
 211             $marker = undef;
 212             return $marker;
 213         }
 214         # update aliases, in the current implementation we'll never
 215         # remove aliases unless a marker is completely removed
 216         $sth = $self->prepare(q(INSERT INTO marker_alias
 217                                 ( alias, markerid, source )
 218                                 VALUES ( ?, ?, ?)
 219                                 ));
 220         my $sthupdate = $self->prepare(q(UPDATE marker_alias
 221                                          SET source = ?
 222                                          WHERE markerid = ?
 223                                          AND alias = ?));
 224         foreach my $alias ( $marker->each_alias ) {
 225             my $src = $marker->get_source_for_alias($alias);
 226             eval {
 227                 if( ! $markercopy->is_alias($alias) ) {
 228                     $sth->execute($alias,$marker->id, $src);
 229                 } elsif( $markercopy->get_source_for_alias($alias) ne
 230                          $src ) {
 231                     $sthupdate->execute($src, $marker->id, $alias);
 232                 }
 233             };
 234             if( $@) {
 235                 if ( $@ =~ /Duplicate entry/ ) {
 236                     $self->warn($@) if( $self->verbose >= 1);
 237                 } else {
 238                     $rc = -1;
 239                     $self->warn($@);
 240                 }
 241             }
 242         }
 243         $sth->finish();
 244         $sthupdate->finish();
 245
 246         # update positions
 247         $sth = undef;
 248
 249         my $updatesth = $self->prepare(q(UPDATE map_position
 250                                          SET position = ?
 251                                          WHERE markerid = ?
 252                                          AND mapid = ?));
 253
 254         my $insertsth = $self->prepare(q(INSERT INTO map_position
 255                                          (position, markerid, mapid)
 256                                          VALUES ( ?, ?, ?) ));
 257
 258         foreach my $position ( $marker->each_position ) {
 259             my $mapid = $maphash{$position->{'map'}};
 260             if( ! $mapid ) {
 261                 $self->warn(sprintf("Trying to add positions for map '%s', which does not exist in this database yet, please add it first",
 262                                     $position->{'map'}));
 263             }
 264             if( !defined $markercopy->get_position($position->{'map'})) {
 265                 $sth = $insertsth;
 266             } elsif( $markercopy->get_position($position->{'map'}) !=
 267                      $position->{'position'} ) {
 268                 $sth = $updatesth;
 269             } else {  next; }
 270             eval {
 271                 $sth->execute($position->{'position'}, $marker->id,$mapid);
 272             };
 273             if( $@) {
 274                 $self->warn($@);
 275                 $rc = -1;
 276             }
 277         }
 278         $sth->finish() if( $sth);
 279         $updatesth->finish();
 280         $insertsth->finish();
 281         $marker = undef unless( $rc == 0);
 282     } else {
 283         # this is a new insert
 284         eval {
 285             $sth = $self->prepare(q(INSERT INTO marker
 286                                         (locus,probe,type,chrom,
 287                                          fwdprimer,revprimer,length)
 288                                         VALUES ( ?, ?, ?, ?, ?, ?, ?)));
 289             my (undef,$chrom) = ( $marker->chrom =~ /(chr)?(X|Y|UL|\d+)/ );
 290
 291             $sth->execute($marker->locus,$marker->probe,$marker->type,
 292                           $chrom, $marker->pcrfwd,$marker->pcrrev,
 293                           $marker->length);
 294             # for db cross-platform, even though I could just call
 295             # $sth->{'mysql_insertid'};
 296             # $self->get_last_id();
 297             $marker->id($sth->{'mysql_insertid'});
 298             $sth->finish();
 299         };
 300         if( $@ ) {
 301             if( $@ =~ /Duplicate entry/ ) {
 302                 $self->warn($@) if( $self->verbose >= 1);
 303                 return undef;
 304             }
 305             $self->warn($@);
 306             $self->warn("Working on marker \n" . $marker->to_string());
 307             $marker = undef;
 308             return $marker;
 309         }
 310         # let's insert aliases
 311         $sth = $self->prepare(q(INSERT INTO marker_alias
 312                                         ( markerid, alias, source)
 313                                         VALUES ( ?, ?, ?)));
 314             foreach my $alias ( $marker->each_alias ) {
 315                 eval {
 316                     $sth->execute($marker->id, $alias,
 317                                   $marker->get_source_for_alias($alias));
 318                 };
 319                 if ($@) {
 320                     $self->{'_dblasterr'} = $@;
 321                     $self->warn($@) unless ( $@ =~ /Duplicate entry/ &&
 322                                              $self->verbose < 1 );
 323                 }
 324             }
 325             $sth->finish();
 326         eval {
 327             # let's insert map positions
 328             $sth = $self->prepare(q(INSERT INTO map_position
 329                                         (markerid, position, mapid)
 330                                         VALUES ( ?, ?, ? )));
 331             foreach my $position ( $marker->each_position ) {
 332                 my $mapid = $maphash{$position->{'map'}};
 333                 if( ! $mapid ) {
 334                     $self->warn("Map " . $position->{'map'}. " does not exist, please add it before adding this marker");
 335                     next;
 336                 }
 337                     $sth->execute($marker->id,$position->{'position'},
 338                                   $mapid);
 339             }
 340         };
 341         if($@ ) {
 342             if( $@ =~ /Duplicate entry/ ) {
 343                 return undef;
 344             }
 345             $self->warn($@);
 346             $self->warn("Working on marker \n" . $marker->to_string());
 347             $marker = undef;
 348         }
 349     }
 350     $marker->adaptor($self) if( $marker);
 351     return $marker;
 352 }
 353
 354 =head2 delete
 355
 356  Title   : delete
 357  Usage   : $markeradaptor->delete($marker);
 358  Function: Removes a marker from the database
 359  Returns : none
 360  Args    : Bio::DB::Map::MarkerI object
 361
 362 =cut
 363
 364 sub delete{
 365    my ($self,$markerid) = @_;
 366
 367    if( ! $markerid ) {
 368        $self->warn("did not specify a valid marker id to remove");
 369    }
 370    eval  {
 371        # delete from map_positions
 372        my $sth = $self->prepare(q(DELETE FROM map_position
 373                                   WHERE markerid = ?));
 374        $sth->execute($markerid);
 375        # delete from aliases
 376        $sth = $self->prepare(q(DELETE FROM marker_alias WHERE markerid = ?));
 377        $sth->execute($markerid);
 378        # delete from marker
 379        $sth = $self->prepare(q(DELETE FROM marker WHERE markerid = ?));
 380        $sth->execute($markerid);
 381    };
 382    if($@) {
 383        $self->warn($@);
 384        return 0;
 385    }
 386    return 1;
 387 }
 388
 389 =head2 add_duplicate_marker
 390
 391  Title   : add_marker_duplicate_marker
 392  Usage   : boolean $adaptor->add_duplicate_marker($marker );
 393  Function: Tries to find a duplicate marker for a marker and
 394            updates it to contain merge of the two information srcs
 395  Returns : boolean if marker was added
 396  Args    : Bio::DB::Map::MarkerI object
 397
 398
 399 =cut
 400
 401 sub add_duplicate_marker {
 402    my ($self,$marker) = @_;
 403    return 0 unless( defined $marker && ref($marker)
 404                      && $marker->isa('Bio::DB::Map::MarkerI') );
 405
 406    my @potential = $self->get('-pcrprimers' => [ $marker->pcrfwd,
 407                                                  $marker->pcrrev ] );
 408
 409    if( ! @potential ) {
 410        @potential = $self->get('-name' => $marker->probe );
 411        if( ! @potential ) {
 412            @potential = $self->get('-name' => $marker->locus );
 413            if( ! @potential ) {
 414                @potential = $self->get('-names' => [ $marker->each_alias ] );
 415            }
 416        }
 417    }
 418
 419    if( @potential > 1) { $self->warn("got back " . scalar @potential .
 420                                      " markers for query!");
 421                      }
 422    my $dup = shift @potential; # take the first one
 423    return 0 if ( ! $dup );
 424
 425    foreach my $map ( $marker->each_position ) {
 426        if( $dup->get_position($map->{'map'} ) ) {
 427            $dup->add_position($map->{'position'}, $map->{'map'} );
 428        }
 429    }
 430
 431    foreach my $alias ( $marker->each_alias ) {
 432        if( ! $dup->is_alias($alias) ) {
 433            $dup->add_alias($alias);
 434        }
 435    }
 436
 437    if( $dup->locus ne $marker->locus ) {
 438        $dup->add_alias($marker->locus);
 439    }
 440    if( $dup->probe  ne $marker->probe ) {
 441        $dup->add_alias($marker->probe);
 442    }
 443    return $self->write($dup);
 444 }
 445
 446
 447 sub _get_markers_by_ids {
 448     my ($self, @ids) = @_;
 449     return () unless ( @ids);
 450
 451     my $TEMPTABLESQL = q(CREATE TEMPORARY TABLE __markers
 452                          ( markerid integer(11) not null PRIMARY KEY));
 453     my $TEMPLOAD = q(INSERT INTO __markers (markerid) values ( ? ));
 454     my $MARKERSQL = q(SELECT
 455                       m.markerid  as '-id',
 456                       m.locus     as '-locus',
 457                       m.probe     as '-probe',
 458                       m.type      as '-type',
 459                       m.chrom     as '-chrom',
 460                       m.fwdprimer as '-pcrfwd',
 461                       m.revprimer as '-pcrrev',
 462                       m.length    as '-length'
 463                       FROM  marker m, __markers t
 464                       WHERE m.markerid = t.markerid);
 465
 466     my $ALIASSQL =q(SELECT
 467                     m.alias as alias,
 468                     m.markerid as markerid,
 469                     m.source as source
 470                     FROM marker_alias m, __markers t
 471                     WHERE m.markerid = t.markerid );
 472
 473     my $POSITIONSQL = q(SELECT
 474                         p.markerid as markerid,
 475                         map.name as mapname, p.position as position
 476                         FROM   map, map_position p, __markers t
 477                         WHERE  p.mapid = map.mapid AND
 478                         p.markerid = t.markerid);
 479     my %markers;
 480
 481     # create table no matter what, but don't die if table already exists
 482     # should actually write if( ! exists ) SQL code, but
 483     # can't find the syntax
 484
 485     eval { $self->prepare($TEMPTABLESQL)->execute() };
 486     if( $@ ) {
 487         # this is going to warn whenever we write > 1 marker at a
 488         # time, but there is no reason to pay the create/drop overhead
 489     }
 490
 491     eval {
 492         my $sth = $self->prepare($TEMPLOAD);
 493         foreach my $id ( @ids ) {
 494             $sth->execute($id);
 495         }
 496         $sth->finish();
 497
 498         $sth = $self->prepare($MARKERSQL);
 499         $sth->execute();
 500         my $row;
 501         while( defined($row = $sth->fetchrow_hashref)  ) {
 502             $markers{$row->{'-id'}} = new Bio::DB::Map::Marker( '-adaptor' => $self,
 503                                     %{$row} );
 504         }
 505         $sth->finish();
 506
 507         $sth = $self->prepare($ALIASSQL);
 508         $sth->execute();
 509         while( defined($row = $sth->fetchrow_hashref) ) {
 510             $markers{$row->{'markerid'}}->add_alias($row->{'alias'},
 511                                                     $row->{'source'});
 512         }
 513         $sth->finish();
 514
 515         $sth = $self->prepare($POSITIONSQL);
 516         $sth->execute();
 517         while( defined($row = $sth->fetchrow_hashref) ) {
 518             $markers{$row->{'markerid'}}->add_position($row->{'position'},
 519                                                        $row->{'mapname'});
 520         }
 521         $sth->finish();
 522     };
 523     if( $@ ) { $self->warn($@); }
 524     eval { $self->prepare('DELETE FROM __markers')->execute() };
 525     return values %markers;
 526 }
 527
 528 sub _get_markers_by_names {
 529     my ($self, @names) = @_;
 530     return () unless ( @names);
 531
 532     my $LOCUSFIND = 'SELECT markerid FROM marker WHERE locus = ?';
 533     my $PROBEFIND = 'SELECT markerid FROM marker WHERE probe = ?';
 534     my $ALIASFIND = 'SELECT markerid from marker_alias  WHERE alias = ?';
 535
 536     my @ids;
 537     eval {
 538         my $sth;
 539         # same basic code as the id search except we have
 540         # to build up the list of ids by searching
 541         # 3 different fields, probe, locus, and alias
 542         # to see if the name matches any of these
 543         #
 544         # if the name matches > 1 locus or alias (probe is unique)
 545         # then we spit a warning and do not process that marker
 546
 547         my $probe = $self->prepare($PROBEFIND);
 548         my $locus = $self->prepare($LOCUSFIND);
 549         my $alias = $self->prepare($ALIASFIND);
 550
 551         NAME: foreach my $name ( @names ) {
 552             my @tids;
 553             $probe->execute($name);
 554             while( my ($tid) = $probe->fetchrow_array ) {
 555                 push @tids, $tid;
 556             }
 557             if( ! @tids ) {
 558
 559                 $locus->execute($name);
 560                 while( my ($tid) = $locus->fetchrow_array ) {
 561                     push @tids, $tid;
 562                 }
 563                 if( ! @ids ) {
 564                     $alias->execute($name);
 565                     while( my ($tid) = $alias->fetchrow_array ) {
 566                         push @tids, $tid;
 567                     }
 568                     if( @tids > 1 ) {
 569                         $self->warn("Requestion marker ($name) which matches > 1 Alias, please be more specific or request by markerid");
 570                         next NAME;
 571                     }
 572                 } elsif( @tids > 1 ) {
 573                     $self->warn("Requesting arker ($name) which matches > 1 Locus, please be more specific or request by markerid");
 574                     next NAME;
 575                 }
 576             }
 577             push @ids, @tids;
 578         }
 579     };
 580     if( $@ ) {
 581         $self->warn($@);
 582     }
 583     return $self->_get_markers_by_ids(@ids);
 584 }
 585
 586 sub _get_marker_by_primers {
 587     my ($self, $primer1,$primer2) = @_;
 588     my $SQL = q(SELECT markerid FROM marker
 589                 WHERE fwdprimer = ? AND revprimer = ?);
 590     my $marker;
 591     eval {
 592         my $sth = $self->prepare($SQL);
 593         $sth->execute($primer1,$primer2);
 594         my ($row) = $sth->fetchrow_array;
 595         if( $row ) {
 596             ( $marker)  = $self->get('-id' => $row);
 597         } else {
 598             $sth->execute($primer2,$primer1);
 599             ($row) = $sth->fetchrow_array;
 600             if( $row ) {
 601                 ( $marker) = $self->get('-id' => $row);
 602             }
 603         }
 604     };
 605     if( $@ ){
 606         $self->warn($@);
 607     }
 608     return $marker;
 609 }
 610
 611 sub prepare {
 612     my ($self, @args) = @_;
 613     $self->SUPER::prepare(@args);
 614 }
 615 1;