lib/CXGN/Marker/PCR/Experiment.pm

   1
   2 =head1 NAME
   3
   4 CXGN::Marker::PCR::Experiment
   5
   6 =head1 AUTHOR
   7
   8 John Binns <zombieite@gmail.com>
   9
  10 =head1 DESCRIPTION
  11
  12 PCR experiment object for both retrieving and inserting marker experiment data.
  13
  14 =cut
  15
  16 use strict;
  17 package CXGN::Marker::PCR::Experiment;
  18 use Carp;
  19 use CXGN::Marker;
  20 use CXGN::Accession;
  21 use CXGN::Tools::Text;
  22 use Array::Compare;
  23 use CXGN::DB::SQLWrappers;
  24 use CXGN::Marker::Tools;
  25 use CXGN::DB::Connection;
  26
  27 =head2 new
  28
  29     my $experiment_for_viewing=CXGN::Marker::PCR::Experiment->new($dbh,$pcr_experiment_id);
  30     my $experiment_for_storing=CXGN::Marker::PCR::Experiment->new($dbh);
  31
  32 =cut
  33
  34 sub new
  35 {
  36     my $class=shift;
  37     my($dbh,$pcr_experiment_id)=@_;
  38     my $self=bless({},$class);
  39     if(CXGN::DB::Connection::is_valid_dbh($dbh))
  40     {
  41         $self->{dbh}=$dbh;
  42     }
  43     else
  44     {
  45         croak("'$dbh' is not a valid dbh");
  46     }
  47     if($pcr_experiment_id)
  48     {
  49
  50         #find experiment data
  51         my $pcr_query=$self->{dbh}->prepare
  52         ("
  53             SELECT
  54                 marker_experiment.marker_id,
  55                 marker_experiment.location_id,
  56                 pcr_experiment.pcr_experiment_id,
  57                 primer_id_fwd,
  58                 primer_id_rev,
  59                 primer_id_pd,
  60                 primer_type,
  61                 mg_concentration,
  62                 annealing_temp,
  63                 additional_enzymes,
  64                 protocol,
  65                 predicted,
  66                 stock_id
  67             FROM
  68                 pcr_experiment
  69                 left join marker_experiment using (pcr_experiment_id)
  70             WHERE
  71                 pcr_experiment_id=?
  72         ");
  73         $pcr_query->execute($pcr_experiment_id);
  74         my $pcr_hashref=$pcr_query->fetchrow_hashref();
  75
  76 # This was causing the page to die for markers 9654 and 9615. Not sure why this problem should
  77 # suddenly turn up. These markers had entries in pcr_experiment but not in marker_experiment,
  78 # so John considered them valid, but "orphan" experiments. There is a query in CXGN/Marker.pm
  79 # that specifically queries for orphan experiments. That's fine, but then the following check
  80 # fails. For now I'm just changing the field it checks. This shouldn't break anything. -beth, 2007-03-21
  81 #        unless($pcr_hashref->{marker_id})
  82         unless($pcr_hashref->{pcr_experiment_id})
  83         {
  84             croak"Orphan PCR experiment object created with ID of '$pcr_experiment_id'--there is no marker_experiment entry for this experiment";
  85         }
  86         unless($pcr_hashref->{pcr_experiment_id})
  87         {
  88             croak"PCR experiment not found with ID of '$pcr_experiment_id'";
  89         }
  90         while(my($key,$value)=each %$pcr_hashref)
  91         {
  92             $self->{$key}=$value;
  93         }
  94         $self->{predicted}?$self->{predicted}='t':$self->{predicted}='f';
  95
  96         #get primers, if they are present
  97         my $q=$dbh->prepare('select sequence from sequence where sequence_id=?');
  98         $q->execute($self->{primer_id_fwd});
  99         ($self->{fwd_primer})=$q->fetchrow_array();
 100         $q->execute($self->{primer_id_rev});
 101         ($self->{rev_primer})=$q->fetchrow_array();
 102
 103
 104         $q->execute($self->{primer_id_pd});
 105         ($self->{dcaps_primer})=$q->fetchrow_array();
 106
 107
 108         #get pcr products
 109         my $sizes;
 110         $q=$dbh->prepare("SELECT accession.accession_id,band_size,multiple_flag FROM pcr_exp_accession inner join pcr_product using(pcr_exp_accession_id) inner join accession on(pcr_exp_accession.accession_id=accession.accession_id) WHERE enzyme_id is null and pcr_experiment_id=?");
 111         $q->execute($self->{pcr_experiment_id});
 112         $sizes=$q->fetchall_arrayref();
 113         if($sizes->[0]){$self->{pcr_bands}=$self->query_results_to_bands_hash($sizes);}
 114         $q=$dbh->prepare("SELECT accession.accession_id,band_size,multiple_flag FROM pcr_exp_accession inner join pcr_product using(pcr_exp_accession_id) inner join accession on(pcr_exp_accession.accession_id=accession.accession_id) WHERE enzyme_id is not null and pcr_experiment_id=?");
 115         $q->execute($self->{pcr_experiment_id});
 116         $sizes=$q->fetchall_arrayref();
 117         if($sizes->[0]){$self->{pcr_digest_bands}=$self->query_results_to_bands_hash($sizes);}
 118
 119         #get enzyme
 120         $q=$dbh->prepare("SELECT enzyme_id,enzyme_name FROM pcr_exp_accession inner join pcr_product using(pcr_exp_accession_id) inner join enzymes using(enzyme_id) where pcr_experiment_id=?");
 121         $q->execute($self->{pcr_experiment_id});
 122         ($self->{enzyme_id},$self->{enzyme})=$q->fetchrow_array();#only fetching one row, because they all should be the same. there should be both db and api constraints ensuring that.
 123     }
 124     else#else we're creating and empty object
 125     {
 126         #initialize empty object--we want some things to have a default value, so the object it will be consistent
 127         #and able to be worked with even if you haven't set its predicted field, for instance
 128         $self->{predicted}='f';
 129     }
 130
 131     return $self;
 132 }
 133
 134 =head2 pcr_experiment_id
 135
 136     my $id=$experiment->pcr_experiment_id();
 137
 138 Returns the PCR experiment ID for this experiment. This cannot be set. It is set when the object is initially retrieved, or when it is stored.
 139
 140 =cut
 141
 142 #this function cannot be used as a setter, since this id is assigned by the database
 143 sub pcr_experiment_id
 144 {
 145     my $self=shift;
 146     return $self->{pcr_experiment_id};
 147 }
 148
 149 =head2 equals
 150
 151     my $experiment=CXGN::Marker::PCR::Experiment->new($dbh,$pcr_experiment_id);
 152     my $experiment_for_comparison=CXGN::Marker::PCR::Experiment->new($dbh,$possible_match_id);
 153     if($experiment->equals($experiment_for_comparison)){print"They are the same!";}
 154
 155 =cut
 156
 157 ##########################################
 158 # compare this pcr experiment with another
 159 ##########################################
 160
 161 sub check_pcr_band_arrays {
 162     my ($accession, $pcr_hash_1, $pcr_hash_2) = @_;
 163
 164     my $comp = Array::Compare->new();
 165
 166     my $croaking = "PCR bands (or digest bands) entry for accession '$accession' does not appear to be array ref";
 167
 168     unless ($pcr_hash_1->{$accession} and $pcr_hash_2->{$accession})           { return 0 }
 169     unless ((ref($pcr_hash_1->{$accession}) eq 'ARRAY'))                       { croak $croaking }
 170     unless ((ref($pcr_hash_2->{$accession}) eq 'ARRAY'))                       { croak $croaking }
 171     # Array::Compare::perm returns true if lists are the same or permutations of each other (bands may have been stored in any order)
 172     unless ($comp->perm($pcr_hash_1->{$accession}, $pcr_hash_2->{$accession})) { return 0 }
 173
 174     return 1;
 175 }
 176
 177 sub equals {
 178     my $self=shift;
 179     my($other)=@_;
 180
 181     unless ($other->isa('CXGN::Marker::PCR::Experiment')) { croak "Must send in a PCR experiment object to equals function" }
 182     unless ($self->marker_id() and $other->marker_id()) {
 183                                                             croak "Must set both PCR experiment objects' marker IDs before comparing\n-----\nself:\n".
 184                                                             $self->as_string()."-----\nother:\n".$other->as_string()
 185                                                         }
 186     unless ($self->protocol() and $other->protocol())      { croak "Must set both PCR experiment objects' protocols before comparing" }
 187     unless ($self->predicted() eq 'f' or $self->predicted() eq 't') {
 188                                                             croak "Can't check for equality; invalid predicted field for self:\n".$self->as_string();
 189                                                         }
 190     unless ($other->predicted() eq 'f' or $other->predicted() eq 't') {
 191                                                             croak "Can't check for equality; invalid predicted field for other object:\n".$other->as_string();
 192                                                         }
 193     if ($self->marker_id() ne $other->marker_id())                { return 0 }
 194     if ($self->fwd_primer() ne $other->fwd_primer())              { return 0 }
 195     if ($self->rev_primer() ne $other->rev_primer())              { return 0 }
 196     if ($self->primer_type() ne $other->primer_type())            { return 0 }
 197     if ($self->enzyme() ne $other->enzyme())                      { return 0 }
 198     if ($self->predicted() ne $other->predicted())                { return 0 }
 199     if ($self->protocol eq 'RFLP' and $other->protocol ne 'RFLP') { return 0 }
 200     if ($self->protocol ne 'RFLP' and $other->protocol eq 'RFLP') { return 0 }
 201
 202     my $pcr_hash_1 = $self->{pcr_bands};
 203     my $pcr_hash_2 = $other->{pcr_bands};
 204     # remove empty keys
 205     for my $k (keys(%{$pcr_hash_1}))  { delete $pcr_hash_1->{$k} if (@{$pcr_hash_1->{$k}} == 0) }
 206     for my $k (keys(%{$pcr_hash_2}))  { delete $pcr_hash_2->{$k} if (@{$pcr_hash_2->{$k}} == 0) }
 207
 208     # check pcr band arrays for all accessions in first object
 209     for my $accession (keys(%{$pcr_hash_1}))  { unless (&check_pcr_band_arrays($accession, $pcr_hash_1, $pcr_hash_2)) { return 0 } }
 210
 211     # then check pcr band arrays for all accessions in second object, in case the second has accessions the first doesn't
 212     for my $accession (keys(%{$pcr_hash_2}))  { unless (&check_pcr_band_arrays($accession, $pcr_hash_1, $pcr_hash_2)) { return 0 } }
 213
 214     $pcr_hash_1 = $self->{pcr_digest_bands};
 215     $pcr_hash_2 = $other->{pcr_digest_bands};
 216     # remove empty keys
 217     for my $k (keys(%{$pcr_hash_1}))  { delete $pcr_hash_1->{$k} if (@{$pcr_hash_1->{$k}} == 0) }
 218     for my $k (keys(%{$pcr_hash_2}))  { delete $pcr_hash_2->{$k} if (@{$pcr_hash_2->{$k}} == 0) }
 219     # check pcr digest band arrays for all accessions in first object
 220     for my $accession (keys(%{$pcr_hash_1}))  { unless (&check_pcr_band_arrays($accession, $pcr_hash_1, $pcr_hash_2)) { return 0 } }
 221     # then check pcr digest  band arrays for all accessions in second object, in case the second has accessions the first doesn't
 222     for my $accession (keys(%{$pcr_hash_2}))  { unless (&check_pcr_band_arrays($accession, $pcr_hash_1, $pcr_hash_2)) { return 0 } }
 223
 224     #only compare mg and temp IF they are present in BOTH objects... see note below
 225     if (($self->mg_conc() and $other->mg_conc()) and ($self->mg_conc() != $other->mg_conc())) { return 0 }
 226     if (($self->temp() and $other->temp()) and ($self->temp() != $other->temp()))             { return 0 }
 227
 228     #notes:
 229     #we did not compare missing temperature or mg concentration values, because yimin says experiments that are so similar
 230     #that the only difference is that one is missing a temp or mg conc are the same experiment
 231     #we did not compare additional_enzymes, because this is just a long text notes field, not essential data for the experiment,
 232     #and frequently subject to minor changes in its text. this is just feinan's extra COSII PCR data field.
 233
 234     return 1;
 235 }
 236
 237 =head2 exists
 238
 239 Returns its pcr_experiment_id if it already exists in the database, or undef if not.
 240
 241 =cut
 242
 243 ###################
 244 # storing functions
 245 ###################
 246 sub exists
 247 {
 248     my $self=shift;
 249     unless($self->{marker_id})
 250     {
 251         croak"Cannot test for an experiment's existence without knowing which marker it goes with--store marker and set experiment's marker ID before storing experiments";
 252     }
 253     unless($self->{protocol})
 254     {
 255         croak"I doubt an experiment like this one exists, since it has no experiment protocol. Set to unknown if necessary.";
 256     }
 257     if($self->{pcr_experiment_id})
 258     {
 259         #warn"I think it's pretty obvious that this experiment exists, since it seems to have been loaded from the database, or recently stored to the database--it already has an id of $self->{pcr_experiment_id}";
 260         return $self->{pcr_experiment_id};
 261     }
 262     unless($self->predicted() eq 'f' or $self->predicted() eq 't'){croak"Can't check for existence; invalid predicted field for self:\n".$self->as_string();}
 263     my $possible_matches_query=$self->{dbh}->prepare
 264     ("
 265         SELECT
 266             pcr_experiment_id
 267         FROM
 268             marker_experiment
 269         WHERE
 270             marker_id=?
 271             and pcr_experiment_id is not null
 272     ");
 273     $possible_matches_query->execute($self->marker_id());
 274     while(my($possible_match_id)=$possible_matches_query->fetchrow_array())
 275     {
 276         #print"possible match id: $possible_match_id\n";
 277         my $experiment_for_comparison=CXGN::Marker::PCR::Experiment->new($self->{dbh},$possible_match_id);
 278         if($self->equals($experiment_for_comparison))
 279         {
 280             $self->{pcr_experiment_id}=$experiment_for_comparison->{pcr_experiment_id};#ok, we've been found to already exist, so set our pcr_experiment_id
 281             return $self->{pcr_experiment_id};
 282         }
 283     }
 284     return;
 285 }
 286
 287 =head2 store_unless_exists
 288
 289 Stores this experiment in the database, as long as it does not exist. If it does not exist and it is stored, this function will return its new pcr_experiment_id. If the experiment does exists, it will set the pcr_experiment_id but NOT return it.
 290
 291 =cut
 292
 293 sub store_unless_exists {
 294     my $self=shift;
 295
 296     if ($self->exists()) { return }
 297
 298     unless ($self->{marker_id})                                     { croak "Cannot store experiment without marker ID" }
 299     unless ($self->{protocol})                                      { croak "Cannot store experiment without protocol. Use 'unknown' if necessary." }
 300     unless ($self->predicted() eq 'f' or $self->predicted() eq 't') { croak "Can't store; invalid predicted field for self:\n".$self->as_string() }
 301     if ($self->{pcr_experiment_id}) { croak "This experiment appears to have been stored already or created from an existing database entry" }
 302         ##################### TODO #########################
 303         #if we already have a PCR experiment ID, and someone
 304         #calls 'store_unless_exists', this is a perfectly
 305         #reasonable use case, but i have not implemented it yet.
 306         #they might want to modify an existing experiment. for
 307         #instance, it is common that someone might add digested
 308         #bands later, after having loaded an experiment with
 309         #only regular pcr bands a few months before. this object cannot yet handle this
 310         #situation. that is why it croaks here. if you need to add
 311         #this functionality, add it here. it would consist of some
 312         #kind of object integrity checking and checking for values
 313         #which have been added or modified and adding or modifying
 314         #those same values in the database. alternatively, you may
 315         #just want to write another class--CXGN::Marker::PCR::Experiment::Modfiable
 316         #or something like that which has fewer checks and just
 317         #directly accesses data in the database using an object
 318         #like lukas's modifiable form object.
 319     if ($self->{pcr_digest_bands}) {
 320         unless ($self->{enzyme_id}) { croak "Must have an enzyme set to store digest bands" }
 321     }
 322
 323     my $dbh = $self->{dbh};
 324     my $sql = CXGN::DB::SQLWrappers->new($self->{dbh});
 325
 326     if ($self->fwd_primer()) {
 327         my $fwd_info = $sql->insert_unless_exists('sequence',{'sequence'=>$self->fwd_primer()});
 328         $self->{fwd_primer_id} = $fwd_info->{id};
 329     }
 330     if($self->rev_primer()) {
 331         my $rev_info = $sql->insert_unless_exists('sequence',{'sequence'=>$self->rev_primer()});
 332         $self->{rev_primer_id} = $rev_info->{id};
 333     }
 334
 335     #print"INSERTING:\n".$self->as_string();
 336
 337     my $pcr_exp_insert = $self->{dbh}->prepare ('
 338         insert into sgn.pcr_experiment (
 339             mg_concentration,
 340             annealing_temp,
 341             primer_id_fwd,
 342             primer_id_rev,
 343             primer_type,
 344             additional_enzymes,
 345             predicted
 346         )
 347         values (?,?,?,?,?,?,?)
 348     ');
 349     $pcr_exp_insert->execute (
 350             $self->{mg_concentration},
 351             $self->{annealing_temp},
 352             $self->{fwd_primer_id},
 353             $self->{rev_primer_id},
 354             $self->{primer_type},
 355             $self->{additional_enzymes},
 356             $self->{predicted}
 357     );
 358     $self->{pcr_experiment_id} =$self->{dbh}->last_insert_id('pcr_experiment') or croak "Could not get last_insert_id from pcr_experiment";
 359
 360     my %accessions;
 361     for my $accession(keys(%{$self->{pcr_bands}}),keys(%{$self->{pcr_digest_bands}})) { $accessions{$accession} = 0 }
 362     # dummy value for now, until we get a pcr_exp_accession_id
 363
 364     my $exp_acc_insert = $self->{dbh}->prepare('insert into sgn.pcr_exp_accession (pcr_experiment_id,accession_id) values (?,?)');
 365     my $pcr_band_insert= $self->{dbh}->prepare('insert into sgn.pcr_product (pcr_exp_accession_id,enzyme_id,multiple_flag,band_size,predicted) values (?,?,?,?,?)');
 366
 367     for my $accession_id(keys(%accessions)) {
 368         $exp_acc_insert->execute($self->{pcr_experiment_id}, $accession_id);
 369         $accessions{$accession_id} = $self->{dbh}->last_insert_id('pcr_exp_accession') or croak "Could not get last_insert_id from pcr_exp_accession";
 370
 371         my @accession_pcr_bands;
 372         my @accession_pcr_digest_bands;
 373         if ($self->{pcr_bands}->{$accession_id}) { @accession_pcr_bands = @{$self->{pcr_bands}->{$accession_id}} }
 374         if ($self->{pcr_digest_bands}->{$accession_id}) { @accession_pcr_digest_bands = @{$self->{pcr_digest_bands}->{$accession_id}} }
 375         if ($accession_pcr_bands[0]) { #if there is at least one value in the pcr bands list for this accession
 376             for my $band(@accession_pcr_bands) {
 377                 #if the band entry starts with an m, it means multiple bands, so set the multiple flag. no enzyme insert for regular pcr bands.
 378                 if($band=~/^m/i) { $pcr_band_insert->execute($accessions{$accession_id},undef,1,undef,$self->{predicted}) }
 379                 else { $pcr_band_insert->execute($accessions{$accession_id},undef,undef,$band,$self->{predicted}) }
 380             }
 381         }
 382         if($accession_pcr_digest_bands[0]) { # if there is at least one value in the pcr digest bands list for this accession
 383             #if the band entry starts with an m, it means multiple bands, so set the multiple flag.
 384             for my $band(@accession_pcr_digest_bands) {
 385                 if ($band=~/^m/i) { $pcr_band_insert->execute($accessions{$accession_id},$self->{enzyme_id},1,undef,$self->{predicted}) }
 386                 else { $pcr_band_insert->execute($accessions{$accession_id},$self->{enzyme_id},undef,$band,$self->{predicted}) }
 387             }
 388         }
 389     }
 390
 391     #and now for a final test of this object
 392     if(my $oops_id=$self->store_unless_exists()) {
 393         my $croaking = "Oops, this object isn't working correctly. Immediately after being stored with ID "
 394             . "'$self->{pcr_experiment_id}', it tried to store itself again as a test, and  succeeded with ID '$oops_id' "
 395             . "(it should have failed, because it was already inserted!)";
 396         croak $croaking;
 397     }
 398
 399     return $self->{pcr_experiment_id};
 400 }
 401
 402 =head2 update_additional_enzymes
 403
 404     #this will actually update the pcr experiment entry in the database
 405     $experiment->update_additional_enzymes('All possible enzymes for blah blah blah are blah blah blah....');
 406
 407 =cut
 408
 409 #storing function for additional_enzymes field. this data is not essential to the experiment. it is just a text field with
 410 #notes that feinan wants to show up for cosii markers, so it has no special checks or anything.
 411 sub update_additional_enzymes
 412 {
 413     my $self=shift;
 414     my($additional_enzymes)=@_;
 415     if(length($additional_enzymes)>1023)
 416     {
 417         croak"Additional enzymes field contents size limit is exceeded by string '$additional_enzymes'";
 418     }
 419     unless($self->{pcr_experiment_id})
 420     {
 421         croak"This experiment object does not appear to have been loaded or inserted into the database yet, so you cannot update its enzymes";
 422     }
 423     my $sth=$self->{dbh}->prepare('update pcr_experiment set additional_enzymes=? where pcr_experiment_id=?');
 424     $sth->execute($additional_enzymes,$self->{pcr_experiment_id});
 425 }
 426
 427 =head2 as_string
 428
 429     #print out the whole experiment, for debugging, or for loading script output
 430     print $experiment->as_string();
 431
 432 =cut
 433
 434 #######################
 435 # display for debugging
 436 #######################
 437 sub as_string
 438 {
 439     my $self=shift;
 440     my $string="";
 441     $string.="<pcr_experiment>\n";
 442     my @marker_names;
 443     if($self->{marker_id})
 444     {
 445         @marker_names=CXGN::Marker->new($self->{dbh},$self->{marker_id})->name_that_marker();
 446     }
 447     else
 448     {
 449         @marker_names=('<no marker associated yet>');
 450     }
 451     $string.="\tMarker: @marker_names\n";
 452     $string.="\tPCR experiment ID: $self->{pcr_experiment_id}\n";
 453     if($self->{location_id})
 454     {
 455         $string.="\tThis is a mapping experiment; location ID: $self->{location_id}\n";
 456     }
 457     else
 458     {
 459         $string.="\tThis experiment does not yet have a map location associated with it in the marker_experiment table\n";
 460     }
 461     $string.="\tProtocol: $self->{protocol}\n";
 462     $string.="\tPrimers: $self->{fwd_primer} (fwd)\t\t$self->{rev_primer} (rev)\n";
 463     my $pt=$self->{primer_type};
 464     $pt||='';
 465     $string.="\tPrimer type: $pt\n";
 466     my $mg=$self->{mg_concentration};
 467     $mg||='';
 468     my $temp=$self->{annealing_temp};
 469     $temp||='';
 470     $string.="\tConditions: $mg MG - $temp C\n";
 471     if($self->{enzyme}){$string.="\tEnzyme: $self->{enzyme}\n";}
 472     $string.="\tBands:\n";
 473     my $bands=$self->pcr_bands_hash_of_strings();
 474     if($bands and %{$bands})
 475     {
 476         for my $accession(keys(%{$bands}))
 477         {
 478             $string.="\t".CXGN::Accession->new($self->{dbh},$accession)->extra_verbose_name().": ".$bands->{$accession}."\n";
 479         }
 480     }
 481     $string.="\tDigest bands:\n";
 482     $bands=$self->pcr_digest_bands_hash_of_strings();
 483     if($bands and %{$bands})
 484     {
 485         for my $accession(keys(%{$bands}))
 486         {
 487             $string.="\t".CXGN::Accession->new($self->{dbh},$accession)->extra_verbose_name().": ".$bands->{$accession}."\n";
 488         }
 489     }
 490     $string.="\tPredicted: $self->{predicted}\n";
 491     $string.="</pcr_experiment>\n";
 492 }
 493
 494 =head2 query_results_to_bands_hash
 495
 496 For internal use. Converts bands query results into a form that can be stored easily.
 497
 498 =cut
 499
 500 ###########################################
 501 # helpful functions mainly for internal use
 502 ###########################################
 503 sub query_results_to_bands_hash
 504 {
 505     my $self=shift;
 506     my($sizes)=@_;
 507     my %bands;
 508     for my $row(@{$sizes})
 509     {
 510         my($accession,$band_size,$multiple_flag)=@{$row};
 511         if($accession and ($band_size or $multiple_flag))
 512         {
 513             my $insert_value;
 514             if($band_size)
 515             {
 516                 $insert_value=$band_size;
 517             }
 518             elsif($multiple_flag)
 519             {
 520                 $insert_value='Multiple';
 521             }
 522             push(@{$bands{$accession}},$insert_value);
 523         }
 524         else
 525         {
 526             croak"Unable to load bands hash";
 527         }
 528     }
 529     return \%bands;
 530 }
 531
 532 =head2 join_bands_hash
 533
 534 For internal use. Converts bands into a more useful form.
 535
 536 =cut
 537
 538 sub join_bands_hash
 539 {
 540     my $self=shift;
 541     my($bands_hash)=@_;
 542     my %expected_structure;
 543     for my $accession(keys(%{$bands_hash}))
 544     {
 545         $expected_structure{$accession}=join('+',@{$bands_hash->{$accession}});
 546     }
 547     if(keys(%expected_structure))#if there are values to return, return them
 548     {
 549         return \%expected_structure;
 550     }
 551     else
 552     {
 553         return;
 554     }
 555 }
 556
 557 =head2 marker_id
 558
 559     my $id=$experiment->marker_id();
 560
 561 Gets the marker_id of marker which is involved in this experiment.
 562
 563     $experiment->marker_id($marker_id);
 564
 565 Sets the marker_id of marker which is involved in this experiment.
 566
 567 =cut
 568
 569 ###################
 570 # accessors/setters
 571 ###################
 572 sub marker_id
 573 {
 574     my $self=shift;
 575     my($value)=@_;
 576     if($value)
 577     {
 578         unless($value=~/^\d+$/)
 579         {
 580             croak"Marker ID must be a number, not '$value'";
 581         }
 582         unless(CXGN::Marker::Tools::is_valid_marker_id($self->{dbh},$value))
 583         {
 584             croak"Marker ID '$value' does not exist in the database";
 585         }
 586         $self->{marker_id}=$value;
 587     }
 588     return $self->{marker_id};
 589 }
 590
 591 =head2 fwd_primer
 592
 593 Returns or sets the forward primer.
 594
 595 =cut
 596
 597 sub fwd_primer
 598 {
 599     my $self=shift;
 600     my($value)=@_;
 601     if($value)
 602     {
 603         $value=$self->test_and_clean_primer($value);
 604         $self->{fwd_primer}=$value;
 605     }
 606     return $self->{fwd_primer};
 607 }
 608
 609 =head2 rev_primer
 610
 611 Returns or sets the reverse primer.
 612
 613 =cut
 614
 615
 616
 617
 618 sub rev_primer
 619 {
 620     my $self=shift;
 621     my($value)=@_;
 622     if($value)
 623     {
 624         $value=$self->test_and_clean_primer($value);
 625         $self->{rev_primer}=$value;
 626     }
 627     return $self->{rev_primer};
 628 }
 629
 630
 631
 632 sub dcaps_primer
 633 {
 634     my $self=shift;
 635     my($value)=@_;
 636     if($value)
 637     {
 638         $value=$self->test_and_clean_primer($value);
 639         $self->{dcaps_primer}=$value;
 640     }
 641     return $self->{dcaps_primer};
 642 }
 643
 644
 645 =head2 primer_type
 646
 647 Returns or sets the primer type.
 648
 649 =cut
 650
 651 sub primer_type
 652 {
 653     my $self=shift;
 654     my($value)=@_;
 655     if($value)
 656     {
 657         unless($value eq 'iUPA' or $value eq 'eUPA')
 658         {
 659             croak"'$value' is not a valid primer type";
 660         }
 661         $self->{primer_type}=$value;
 662     }
 663     return $self->{primer_type};
 664 }
 665
 666 =head2 mg_conc
 667
 668 Returns or sets the magnesium concentration.
 669
 670 =cut
 671
 672 sub mg_conc
 673 {
 674     my $self=shift;
 675     my($value)=@_;
 676     if($value)
 677     {
 678         unless(CXGN::Tools::Text::is_number($value))
 679         {
 680             croak"'$value' is not a valid number for mg concentration";
 681         }
 682         $self->{mg_concentration}=$value;
 683     }
 684     return $self->{mg_concentration};
 685 }
 686
 687 =head2 temp
 688
 689 Returns or sets the temperature. If you send in Fahrenheit you must have an 'F' after the degrees. It will convert it to Celsius for you.
 690
 691 =cut
 692
 693 sub temp
 694 {
 695     my $self=shift;
 696     my($value)=@_;
 697     if($value)
 698     {
 699         unless($value=~/^(\d*?\.?\d*?)[cf]?$/i)
 700         {
 701             croak"'$value' is an invalid anneal temp";
 702         }
 703         $value=~s/C$//i;#strip C for Celsius
 704         if($value=~s/F$//i)#if it was an F for Fahrenheit, convert it to Celsius
 705         {
 706             $value=($value+40)*5/9;
 707         }
 708         $self->{annealing_temp}=$value;
 709     }
 710     return $self->{annealing_temp};
 711 }
 712
 713 =head2 protocol
 714
 715 Returns or sets the experiment protocol.
 716
 717 =cut
 718
 719 sub protocol
 720 {
 721     my $self=shift;
 722     my($protocol)=@_;
 723     if($protocol)
 724     {
 725         unless($protocol eq 'AFLP' or $protocol eq 'CAPS' or $protocol eq 'RAPD' or $protocol eq 'SNP' or $protocol eq 'SSR' or $protocol eq 'RFLP' or $protocol eq 'PCR' or $protocol eq 'unknown' or $protocol =~ /Indel/i)
 726         {
 727             croak"Protocol '$protocol' is invalid.";
 728         }
 729         if($protocol eq 'RFLP')
 730         {
 731             croak"RFLP is not a valid PCR experiment protocol";
 732         }
 733         $self->{protocol}=$protocol;
 734     }
 735     return $self->{protocol};
 736 }
 737
 738 =head2 enzyme
 739
 740 Returns or sets the enzyme used to get the digest bands.
 741
 742 =cut
 743
 744 sub enzyme
 745 {
 746     my $self=shift;
 747     my($enzyme)=@_;
 748     if($enzyme)
 749     {
 750         $enzyme=~s/\s//g unless $enzyme=~/and/; #clear whitespace
 751         $enzyme=~s/(1+)$/'I' x length($1)/e; #1 -> I
 752
 753         # this isn't working for some reason
 754
 755         if ($enzyme eq 'PCR') { $enzyme = 'amplicon difference' }
 756         # TODO: change this to undef once everything is working
 757         elsif ($enzyme eq 'SNP') { $enzyme = 'unknown' }
 758         elsif (!$enzyme) { $enzyme = 'unknown' }
 759
 760         unless($self->{enzyme_id}=CXGN::Marker::Tools::get_enzyme_id($self->{dbh},$enzyme)) {
 761             croak "'$enzyme' is not a valid enzyme (you may need to add it to the enzyme table)";
 762         }
 763
 764         $self->{enzyme}=$enzyme;
 765     }
 766
 767     return $self->{enzyme};
 768 }
 769
 770 =head2 additional_enzymes
 771
 772 Returns or sets Feinan^s COSII additional_enzymes field.
 773
 774 =cut
 775
 776 sub additional_enzymes
 777 {
 778     my $self=shift;
 779     my($value)=@_;
 780     if($value){$self->{additional_enzymes}=$value;}
 781     return $self->{additional_enzymes};
 782 }
 783
 784 =head2 predicted
 785
 786 Returns or sets whether or not the band sizes stored in this object are predicted.
 787
 788 =cut
 789
 790 sub predicted
 791 {
 792     my $self=shift;
 793     my($value)=@_;
 794     if($value)
 795     {
 796         $value=lc($value);
 797         unless($value eq 't' or $value eq 'f')
 798         {
 799             croak"Predicted must be either 't' or 'f'";
 800         }
 801         $self->{predicted}=$value;
 802     }
 803     return $self->{predicted};
 804 }
 805
 806 =head2 add_pcr_bands_for_accession
 807
 808     $experiment->add_pcr_bands_for_accession('250+400','LA716');
 809
 810 =cut
 811
 812 #example use: $created_experiment->add_pcr_bands_string_for_accession('750+900','LA925');
 813 sub add_pcr_bands_for_accession
 814 {
 815     my $self=shift;
 816     my($bands_string,$accession)=@_;
 817     my $accession_object=CXGN::Accession->new($self->{dbh},$accession);
 818     unless($accession_object)
 819     {
 820         croak"Accession '$accession' not found\n";
 821     }
 822     my $accession_id=$accession_object->accession_id();
 823     unless($accession_id){croak("Accession '$accession' not found");}
 824     my @bands=split(/\+/,$bands_string);
 825     $self->{pcr_bands}->{$accession_id}=\@bands;
 826     $self->{pcr_bands}=$self->test_and_clean_bands($self->{pcr_bands});
 827 }
 828
 829 =head2 add_pcr_digest_bands_for_accession
 830
 831     $experiment->add_pcr_digest_bands_for_accession('250+400','LA716');
 832
 833 =cut
 834
 835 #example use: $created_experiment->add_pcr_digest_bands_string_for_accession('multiple','LA716');
 836 sub add_pcr_digest_bands_for_accession
 837 {
 838     my $self=shift;
 839     my($bands_string,$accession)=@_;
 840     my $accession_object=CXGN::Accession->new($self->{dbh},$accession);
 841     unless($accession_object)
 842     {
 843         croak"Accession '$accession' not found\n";
 844     }
 845     my $accession_id=$accession_object->accession_id();
 846     unless($accession_id){croak("Accession '$accession' not found");}
 847     my @bands=split(/\+/,$bands_string);
 848     $self->{pcr_digest_bands}->{$accession_id}=\@bands;
 849     $self->{pcr_digest_bands}=$self->test_and_clean_bands($self->{pcr_digest_bands});
 850 }
 851
 852 ######################
 853 # convenient accessors
 854 ######################
 855
 856 =head2 pcr_bands_hash_of_strings
 857
 858 Get PCR bands in a form that CXGN::Marker::PCR likes.
 859
 860 =cut
 861
 862 sub pcr_bands_hash_of_strings
 863 {
 864     my $self=shift;
 865     return $self->join_bands_hash($self->{pcr_bands});
 866 }
 867
 868 =head2 pcr_digest_bands_hash_of_strings
 869
 870 Get PCR digest bands in a form that CXGN::Marker::PCR likes.
 871
 872 =cut
 873
 874 sub pcr_digest_bands_hash_of_strings
 875 {
 876     my $self=shift;
 877     return $self->join_bands_hash($self->{pcr_digest_bands});
 878 }
 879
 880 =head2 test_and_clean_primer
 881
 882 For internal use.
 883
 884 =cut
 885
 886 #####
 887 # etc
 888 #####
 889 sub test_and_clean_primer
 890 {
 891     my $self=shift;
 892     my($primer)=@_;
 893
 894     $primer =~ s/\s//g;
 895
 896     unless($primer=~/[ATGCatgc]+/)#primers are known base pairs start to finish
 897     {
 898         croak"'$primer' is not a valid primer";
 899     }
 900     return uc($primer);#uppercase sequence data
 901 }
 902
 903 =head2 test_and_clean_bands
 904
 905 For internal use.
 906
 907 =cut
 908
 909 #bands must look like this: {'LA716'=>['Multiple'],'LA925'=>[750,900]}
 910 sub test_and_clean_bands
 911 {
 912     my $self=shift;
 913     my($bands)=@_;
 914     unless(ref($bands) eq 'HASH')
 915     {
 916         croak"Bands must be hash ref";
 917     }
 918     for my $accession_id(keys(%{$bands}))
 919     {
 920         unless(CXGN::Accession->new($self->{dbh},$accession_id)->accession_id()){croak"Accession '$accession_id' not found";}
 921         unless(ref($bands->{$accession_id}) eq 'ARRAY')
 922         {
 923             croak"Bands hash ref must contain array refs";
 924         }
 925         my @bands_array=@{$bands->{$accession_id}};#copy this array out to make the following code more readable, maybe
 926         for my $index(0..$#bands_array)
 927         {
 928             $bands_array[$index]=CXGN::Tools::Text::remove_all_whitespaces(lc($bands_array[$index]));
 929
 930             if($bands_array[$index]=~/^m/i){$bands_array[$index]='Multiple';}
 931
 932             unless ($bands_array[$index] eq 'Multiple'){
 933               $bands_array[$index] = int($bands_array[$index]);
 934             }
 935
 936             unless(($bands_array[$index] eq 'Multiple') or (CXGN::Tools::Text::is_number($bands_array[$index])))
 937             {
 938                 croak"'$bands_array[$index]' is an invalid band size";
 939             }
 940         }
 941         $bands->{$accession_id}=\@bands_array;#copy this array back in
 942     }
 943     return $bands;
 944 }
 945
 946 ##store the primers, or any other sequnces linked, in the sequence table, and link to pcr_experiment##
 947
 948 =head2 store_sequence
 949
 950  Usage: $self->store_sequence($sequence_name, $sequence);
 951  Desc:  store a primer, or any other sequence type, of the pcr_experiment in the sequence table ,
 952         and link to the experiment using pcr_experiment_sequence table.
 953  Ret:  a database id
 954  Args: a string with sequence type, and the sequence string
 955        sequence types should be listed in the cvterm table with cv_name =
 956        'sgn sequence type' (See L<Bio::Chado::Schema::Cv::Cvterm>->create_with for adding new sequence types)
 957  Side Effects: store a new sequence in sgn.sequence, if one does not exist.
 958                Sequences are converted to all upper-case.
 959
 960 Example
 961     my $id = $self->store_sequence('forward primer','ATCCGTGACGTAC');
 962
 963 =cut
 964
 965 sub store_sequence {
 966     my $self = shift;
 967     my $sequence_type = shift;
 968     my $seq = shift || die 'No sequence for type $sequence_type passed to store_sequence function! \n';
 969
 970     #find if the type is stored in the database
 971     my $q = "SELECT cvterm_id FROM public.cvterm
 972              WHERE name ilike ? AND cv_id =
 973              (SELECT cv_id FROM public.cv WHERE cv.name ilike ?) ";
 974     my $sth=$self->{dbh}->prepare($q);
 975     $sth->execute($sequence_type,'sgn sequence type');
 976     my ($type_id) = $sth->fetchrow_array();
 977     die "Sequence type $sequence_type does not exist in the database!\n Expected to find cvterm $sequence_type with cv_name 'sgn sequence type'!\n Please check your databae\n " if !$type_id;
 978     ##
 979     $seq =~ s/\s//g;
 980     unless($seq=~/[ATGCatgc]+/)   {
 981         croak"'$seq' is not a valid sequence";
 982     }
 983     $seq = uc($seq);#uppercase sequence data
 984     ##
 985     my $sql = CXGN::DB::SQLWrappers->new( $self->{dbh} );
 986     my $sequence = $sql->insert_unless_exists('sequence',{'sequence'=>$seq });
 987     #store the link
 988     $q = "Insert INTO sgn.pcr_experiment_sequence (sequence_id, pcr_experiment_id, type_id)
 989           VALUES (?,?,?) RETURNING pcr_experiment_sequence_id";
 990     $sth=$self->{dbh}->prepare($q);
 991     $sth->execute( $sequence->{id} ,  $self->{pcr_experiment_id} , $type_id );
 992     #my $pcr_seq = $sql->insert_unless_exists('pcr_experiment_sequence' , { 'sequence_id' => $sequence->{id} , 'pcr_experiment_id' => $self->{pcr_experiment_id} , 'type_id' => $type_id } );
 993     return ($sth->fetchrow_array());
 994 }
 995
 996
 997 ##get the associated sequences and their types from pcr_experiment_sequence##
 998
 999 =head2 get_sequences
1000
1001  Usage: $self->get_sequences
1002  Desc:  find the sequences associated with the marker, and their types
1003  Ret:   hashref {$sequence_type => [$seq1, $seq2] }
1004  Args:  none
1005  Side Effects: none
1006
1007 =cut
1008
1009 sub get_sequences {
1010     my $self = shift;
1011     my $q = "SELECT cvterm.name, sequence FROM sgn.pcr_experiment
1012              JOIN sgn.pcr_experiment_sequence USING (pcr_experiment_id)
1013              JOIN sgn.sequence USING (sequence_id)
1014              JOIN public.cvterm on cvterm_id = sgn.pcr_experiment_sequence.type_id
1015              WHERE pcr_experiment.pcr_experiment_id = ?";
1016     my $sth = $self->{dbh}->prepare($q);
1017     $sth->execute($self->{pcr_experiment_id});
1018     my %HoA;
1019     while ( my ($sequence_type, $sequence) = $sth->fetchrow_array() ) {
1020         push @ {$HoA{$sequence_type} }, $sequence ;
1021     }
1022     return \%HoA;
1023 }
1024
1025
1026
1027 1;