bin/delete_genotypes.pl

   1
   2 =head1 NAME
   3
   4 delete_genotypes.pl - delete genotypes from a breedbase database
   5
   6 =head1 DESCRIPTION
   7
   8  perl delete_genotypes.pl -H [host] -D [dbname] -t (for testing) file
   9
  10  -p protocol_id
  11
  12 If the -t flag is provided, the changes will be rolled back in the database.
  13
  14 =head1 AUTHOR
  15
  16 Lukas Mueller <lam87@cornell.edu>
  17
  18 =cut
  19
  20 use strict;
  21 use Getopt::Std;
  22 use DBI;
  23 use Bio::Chado::Schema;
  24 use CXGN::Phenome::Schema;
  25 use CXGN::Genotype;
  26
  27 our ($opt_H, $opt_D, $opt_t, $opt_p);
  28 getopts('H:D:tp:');
  29
  30 my $file = shift;
  31
  32 print "Password for $opt_H / $opt_D: \n";
  33 my $pw = <>;
  34 chomp($pw);
  35
  36 print STDERR "Connecting to database...\n";
  37 my $dsn = 'dbi:Pg:database='.$opt_D.";host=".$opt_H.";port=5432";
  38
  39 my $dbh = DBI->connect($dsn, "postgres", $pw);
  40
  41 print STDERR "Connecting to DBI schema...\n";
  42 my $bcs_schema = Bio::Chado::Schema->connect($dsn, "postgres", $pw);
  43 my $phenome_schema = CXGN::Phenome::Schema->connect($dsn, "postgres", $pw,  { on_connect_do => ['set search_path to public,phenome;'] });
  44
  45 $dbh->{RaiseError} = 1;
  46 $dbh->begin_work();
  47
  48 my $q0 = "SELECT count(*) FROM genotypeprop WHERE genotypeprop_id in (SELECT genotypeprop_id FROM nd_experiment_protocol join nd_experiment_genotype using(nd_experiment_id) JOIN genotypeprop USING(genotype_id) WHERE nd_protocol_id=?)";
  49
  50 my $h0 = $dbh->prepare($q0);
  51 $h0->execute($opt_p);
  52
  53 my ($count) = $h0->fetchrow_array();
  54 print "You are about to delete $count genotyping entries. Proceed? Y/n :";
  55 my $answer = (<>);
  56 chomp;
  57 if ($answer !~ m/y|Y/) {
  58     die "Aborted due to user request.";
  59 }
  60
  61 eval {
  62     CXGN::Genotype->delete_genotypes_with_protocol_id($bcs_schema, $opt_p);
  63 };
  64
  65 if ($@) {
  66     print STDERR "An error occurred $@... Not deleting.\n";
  67     $dbh->rollback();
  68 }
  69 else {
  70     print STDERR "Deletion successful. Commit? Y/N : ";
  71     my $answer = <>;
  72     if ($answer =~ m/Y|y/) {
  73         print STDERR "Deleting... ";
  74         $dbh->commit();
  75         print STDERR "Done.\n";
  76     }
  77 }
  78
  79
  80