G2C::Documentation for classes
Introduction to documentation
perlmod2www.pl
These pages have been automatically generated by perlmod2www.pl release 1.1. For any problem or suggestion, please contact Raphael Leplae - see also - SourceForge - for more information.
Navigation
- Top right panel
- Displays the directory tree with the Perl modules using "Perl syntax" for the paths. Click on one path to display in the bottom right panel the Perl modules available. The All modules link displays all the modules available in the bottom right panel (default view)
- Bottom right panel
- Displays the modules available in a particular directory level or all the modules available (shown by default). Click on one of the modules to display the documentation in the main (this) panel. Clicking on the library level name will display in the main panel the table of content for the level.
- Main panel
- Display documentation about a particular Perl module. The documentation is subdivided in several parts (may vary) presenting the POD found in the file, information about included packages, inheritance, subroutines code, etc...
warning
The content presented in these pages might not be 100% accurate! Some data might be missing, in particular in the Perl source code which is presented only as a complement to the POD. Better access the original source code either through the "Raw content" link in the documentation page if available or directly through the Perl module file.
GeneTargeting::ControlledVocabulary
- Description
- Implements controlled vocabularies/dictionaries for the GeneTargeting package.
- Included modules
- Carp
- Data::Dumper
Methods
_get_cv_table_for_dbentry_and_field
sub _get_cv_table_for_dbentry_and_field { my ( $self, $dbentry, $field ) = @_; my $dbentry_type; if (ref($dbentry)) { $dbentry_type = ref($dbentry); } else { $dbentry_type = $dbentry; } my $dbentry_to_fields_to_cv_table = $GeneTargeting::Defs::dbentry_type_to_field_to_cv_table{$dbentry_type}; if (defined($dbentry_to_fields_to_cv_table)) { my $cv_table = $dbentry_to_fields_to_cv_table->{$field}; if (defined($cv_table)) { return $cv_table; } else { confess "No CV table defined for field:" . $field . " of dbentry:" . $dbentry_type; } } else { confess "Unknown dbentry_type:" . $dbentry_type; } }
_get_cv_table_rows
sub _get_cv_table_rows { my ($self, $dbh, $table_name) = @_; my $sql = "select id, name, display_id, synonyms from " . $table_name; my $sth = $dbh->prepare($sql); $sth->execute(); my $cvitems = []; while ( my ($id, $name, $display_id, $synonyms) = $sth->fetchrow() ) { my $cvitem = GeneTargeting::DBEntry::ControlledVocabularyItem->new(); $cvitem->id($id); $cvitem->name($name); $cvitem->display_id($display_id); $cvitem->set_synonym_list_from_db_format_synonym_str($synonyms); push @$cvitems, $cvitem; } return $cvitems; }
_null_cv_item
sub _null_cv_item { my ( $self ) = @_; my $cvitem = GeneTargeting::DBEntry::ControlledVocabularyItem->new(); #$cvitem->id($id); #$cvitem->name($name); #$cvitem->display_id($display_id); return $cvitem; }
get_cv_item_for_obj_field_value
param - $dbentry - Either the object or ref($dbentry) param - $field - The name of the object field/subroutinte that represents the supplied value. param - $value - The value we use to find a match in the appropriate cv table #DEPRECATED - we need to invert the logic of this boolean flag... param - $syn_chk - An optional boolean meaning we can check any synonyms. return - a GeneTargeting::DBEntry::ControlledVocabularyItem if a suitable match is found.
sub get_cv_item_for_obj_field_value { my ( $self, $dbentry, $field, $value, $syn_chk ) = @_; #TODO - syn checks should be enabled by default... fix in all using scripts $syn_chk = 1; return $self->_null_cv_item() unless $value; my $controlled_vocab = $self->{_controlled_vocab}; unless(($dbentry and ref($dbentry) and $dbentry->isa('GeneTargeting::DBEntry')) || $dbentry =~ /^GeneTargeting::DBEntry/ ) { confess "Please supply a valid dbentry!"; } confess "Must pass a field" unless $field; confess "Must pass a value" unless $value; my $cv_table = $self->_get_cv_table_for_dbentry_and_field($dbentry, $field); unless (defined($cv_table) && $controlled_vocab->{$cv_table}) { confess "No cv_table known for dbentry:" . $dbentry . " with field:" . $field; } if ($controlled_vocab->{$cv_table}) { my $valid_cv_items = $controlled_vocab->{$cv_table}; #Match on the names first foreach my $valid_cv_item (@$valid_cv_items) { my $name = $valid_cv_item->name(); if ($value eq $name) { return $valid_cv_item; } } #Now, optionally, check for any synonym matches if ($syn_chk) { foreach my $valid_cv_item (@$valid_cv_items) { if ($valid_cv_item->has_synonym($value)) { return $valid_cv_item; } } } return undef; } else { confess "No matching cv_table found!"; } }
get_value_for_obj_field_cvi_id
Sub adaptors can call this when they need to create a new object, and need to convert the cv database table foreign key into a proper string object. param - $dbentry - Either the object or ref($dbentry) param - $field - The name of the object field/subroutinte that represents the supplied value. param - $cv_item_id - The database id of the cv_item related to the field. return - a GeneTargeting::DBEntry::ControlledVocabularyItem if a suitable match is found.
sub get_value_for_obj_field_cvi_id { my ( $self, $dbentry, $field, $cv_item_id ) = @_; return $self->_null_cv_item() unless $cv_item_id; my $controlled_vocab = $self->{_controlled_vocab}; unless(defined($dbentry) && ((ref($dbentry) =~ /^GeneTargeting::DBEntry/) || ($dbentry =~ /^GeneTargeting::DBEntry/))) { confess "Please supply a valid dbentry obj or class name!"; } unless($field && $cv_item_id) { confess "Please supply a valid field and cv_item_id to be checked!"; } my $cv_table = $self->_get_cv_table_for_dbentry_and_field($dbentry, $field); unless (defined($cv_table) && $controlled_vocab->{$cv_table}) { confess "No cv_table known for dbentry:" . $dbentry . " with field:" . $field; } if ($controlled_vocab->{$cv_table}) { my $valid_cv_items = $controlled_vocab->{$cv_table}; foreach my $valid_cv_item (@$valid_cv_items) { if ($cv_item_id == $valid_cv_item->id()) { return $valid_cv_item; } } return undef; } else { confess "No matching cv_table found!"; } }
init
Used to fetch the controlled vocabulary information from the tables starting cv_ in the database
my $cv = GeneTargeting::ControlledVocabulary->init($dba); Note this done autmatically for you when calling $dba->dbh, so you dont need to call it explicitly.
sub init { my( $pkg, $dba ) = @_; my $self = {}; bless $self, $pkg; my $dbh = $dba->dbh() or die; $self->{_controlled_vocab} = {}; my %tables = map {$_->[0], 1} @{ $dbh->selectall_arrayref("show tables") }; foreach my $tab (sort keys %tables) { if ($tab =~ m/^cv_gt_/i) { $self->{_controlled_vocab}->{$tab} = $self->_get_cv_table_rows($dbh, $tab); } } return $self; }
GeneTargeting::DBEntry::ComponentHit
- Inherit
- GeneTargeting::DBEntry
- Description
- A sub-alignment from a pairwise similarity search. One or more ComponentHits making up a GeneTargeting::DBEntry::Hit
- Included modules
- Carp
- Constructor
my $seq = GeneTargeting::DBEntry::ComponentHit->new;
- Database storage
- See GeneTargeting::DBSQL::ComponentHitAdaptor
Methods
BPlite_HSP
Get/Set method for the BPlite_HSP of the ComponentHit vs the query
sub BPlite_HSP { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_BPlite_HSP'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_BPlite_HSP'}; }
P_value
Get/Set method for a P_value generated by the search programme for comparison of the alignement of the the query and subject sequences.
sub P_value { my( $self, $score ) = @_; if (defined($score)) { #Can be zero $self->{'_gene_targeting_dbentry_component_hit_P_value'} = $score; } return $self->{'_gene_targeting_dbentry_component_hit_P_value'}; }
cigar_line
Get/Set method for the cigar_line, a compact text encoding of the information required to reconstruct a gapped alignment from two stored ungapped sequences, and the position, strand, and query frame information.
sub cigar_line { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_cigar_line'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_cigar_line'}; }
conf_id
Get/Set method for a the unique database id of the Conf (search parameter) object that configured the search programme.
sub conf_id { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_conf_id'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_conf_id'}; }
hit_id
Get/Set method for the unique database id of the Hit (subject) sequence.
sub hit_id { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_hit_id'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_hit_id'}; }
percent_id
Get/Set method for the percentage identity between the Component and Hit sequence.
sub percent_id { my( $self, $value ) = @_; if ($value) { unless (($value >= 0) and ($value <= 100)) { confess "Percent_id out of valid range: $value\n"; } $self->{'_gene_targeting_dbentry_component_hit_percent_id'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_percent_id'}; }
query_end
Get/Set method for the sequence position of the end of the match on the query sequence.
sub query_end { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_query_end'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_query_end'}; }
query_frame
Get/Set method for the query frame. May be 0, 1 or 2.
sub query_frame { my( $self, $value ) = @_; if (defined($value)) { #Can be zero if (($value < 0) or ($value > 2)) { confess "Query frame must be 0, 1, 2\n"; } $self->{'_gene_targeting_dbentry_component_hit_query_frame'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_query_frame'}; }
query_id
Get/Set method for the unique database id of the query sequence.
sub query_id { my( $self, $value ) = @_; if (defined $value) { $self->{'_gene_targeting_dbentry_component_hit_query_id'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_query_id'}; }
query_name
Get/Set method for the human readable name of the query sequence. Not stored by store_ComponentHit, but used by sang_cDNA_DB_dump and _reload for database dumping and restoration.
sub query_name { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_query_name'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_query_name'}; }
query_start
Get/Set method for the sequence position of the start of the match on the query (Component) sequence.
sub query_start { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_query_start'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_query_start'}; }
query_strand
Get/Set method for the strand of the match of the query sequence. Can be 0 (no strand information), 1, or -1, for the forward and reverse strands, respectively.
sub query_strand { my( $self, $value ) = @_; if (defined($value)) { #Can be zero $self->{'_gene_targeting_dbentry_component_hit_query_strand'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_query_strand'}; }
score
Get/Set method for a score generated by the search programme for comparison of the alignement of the the query and subject sequences. For a BLAST-type seach this would be the HSP score.
sub score { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_score'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_score'}; }
soft_masked
Get/Set method for soft_masked
sub soft_masked { my( $self, $value ) = @_; if (defined($value)) { $self->{'_gene_targeting_dbentry_component_hit_soft_masked'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_soft_masked'}; }
subject_end
Get/Set method for the sequence position of the end of the match on the subject sequence.
sub subject_end { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_subject_end'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_subject_end'}; }
subject_frame
Get/Set method for the subject frame. May be 0, 1 or 2.
sub subject_frame { my( $self, $value ) = @_; if (defined($value)) { #Can be zero if (($value < 0) or ($value > 2)) { confess "Subject frame must be 0, 1, 2\n"; } $self->{'_gene_targeting_dbentry_component_hit_subject_frame'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_subject_frame'}; }
subject_start
Get/Set method for the sequence position of the start of the match on the subject (Hit) sequence.
sub subject_start { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_component_hit_subject_start'} = $value; } return $self->{'_gene_targeting_dbentry_component_hit_subject_start'}; }
subject_strand
Get/Set method for the strand of the match for the subject sequence. Can be 0 (no strand information), 1, or -1, for the forward and reverse strands, respectively.
sub subject_strand { my( $self, $value ) = @_; if (defined($value)) { #Can be zero $self->{'_gene_targeting_dbentry_component_hit_subject_strand'} = $value; #print STDERR "Set subject_strand to: $value\n"; } return $self->{'_gene_targeting_dbentry_component_hit_subject_strand'}; }
GeneTargeting::DBEntry::Conf::Exonerate
- Inherit
- GeneTargeting::DBEntry::Conf
- Description
- Object holding configuration parameters for an exonerate search. See: http://www.ebi.ac.uk/~guy/exonerate
- Private package variables
- @param = qw{ args fasta_dir ext_db_id query_batch_size }
- Included modules
- Carp
- Database storage
- See GeneTargeting::DBSQL::ConfAdaptor;
Methods
parameters
sub parameters { return @param; }
GeneTargeting::DBEntry::Conf
- Inherit
- GeneTargeting::DBEntry
- Description
- Baseclass for configuration objects. See GeneTargeting::DBEntry::Exonerate
- Included modules
- Carp
- Constructor
my $Conf = GeneTargeting::DBEntry::Conf->new;
- Database storage
- See GeneTargeting::DBSQL::ConfAdaptor
- Get/Set methods
$Conf->id(2); my $id = $Conf->id; $Conf->name('WuBlastX_SWALL'); my $Conf_name = $Conf->name; $Conf->description('Translated WuBlastX search of SWALL'); my $description = $Conf->description; $Conf->text('text');
Methods
_conf_text_from_parameters
sub _conf_text_from_parameters { my( $self ) = @_; my $txt = ''; foreach my $param ($self->parameters) { my $value = $self->$param(); $value = '' unless $value; $txt .= "$param $value\n"; } return $txt; }
_initialize_params_from_text
sub _initialize_params_from_text { my( $self, $txt ) = @_; foreach my $line (split /\n/, $txt) { my ($param, $value) = split /\s+/, $line, 2; $self->$param($value); } }
align_type
sub align_type { confess "Derived class must handle this specifically\n"; }
description
Get/Set method for the human readable description for the Conf. Usually restricted to a single line of text.
sub description { my( $self, $description ) = @_; if ($description) { $self->{'_genetargeting_dbentry_conf_description'} = $description; } return $self->{'_genetargeting_dbentry_conf_description'}; }
id
Get/Set method for the unique numerical id for the Conf. Auto-generated integer produced by MySQL upon storing the Conf object in the database.
sub id { my( $self, $conf_id ) = @_; if (defined $conf_id) { $self->{'_genetargeting_dbentry_conf_id'} = $conf_id; } return $self->{'_genetargeting_dbentry_conf_id'}; }
make_get_set_methods
Magic routine to create the get/set methods for an object derived from the GeneTargeting::DBEntry::Conf class
sub make_get_set_methods { my( $pkg ) = @_; my @parameters = $pkg->parameters; # Make a get-set method for each parameter foreach my $param (@parameters) { no strict 'refs'; my $sub = "${pkg}::$param"; my $field = "_$param"; # Check that this method doesn't already exist if (defined(&$sub)) { confess "Method '$sub' is already defined!"; } # Insert a subroutine ref into the symbol # table under this name. (This is the bit # that need strict refs turned off.) *$sub = sub { my( $self, $arg ) = @_; if (defined $arg) { $self->{$field} = $arg; } return $self->{$field}; }; } }
name
Get/Set method for the human readable name for the Conf. Enforced as unique within the database.
sub name { my( $self, $name ) = @_; if ($name) { $self->{'_genetargeting_dbentry_conf_name'} = $name; } return $self->{'_genetargeting_dbentry_conf_name'}; }
new
Constructor for objects of type GeneTargeting::DBEntry::Conf;
sub new { my( $pkg ) = @_; return bless {}, $pkg; }
parameters
sub parameters { my ($pkg) = caller(1); die "Error: module '$pkg' doesn't implement the 'parameters' method\n"; }
text
Get/Set method for the Conf text. This is use to encode the get/method names and their values as a single string for storage in the MySQL db.
sub text { my( $self, $text ) = @_; if ($text) { $self->_initialize_params_from_text($text); } else { return $self->_conf_text_from_parameters; } }
GeneTargeting::DBEntry::ControlledVocabularyItem
- Inherit
- GeneTargeting::DBEntry
- Description
- Object representing a single entry in a ControlledVocabulary.
- Private package variables
- $SEPERATOR = ","
- Included modules
- Carp
Methods
add_synonym
$cvi->add_synonym('wt'); If you have several synynoms to add, call the method iterativly with each. Synonyms should not contain any white space chars.
sub add_synonym { my( $self, $synonym ) = @_; $self->{'_gene_targeting_dbentry_cvitem_synonyms'} ||= {}; my $synonyms = $self->{'_gene_targeting_dbentry_cvitem_synonyms'}; $synonyms->{$synonym} = 1; }
display_id
sub display_id { my( $self, $value ) = @_; if (defined $value) { $self->{'_gene_targeting_dbentry_cvitem_display_id'} = $value; } return $self->{'_gene_targeting_dbentry_cvitem_display_id'}; }
get_all_synonyms
Retrieves a list ref to all the synonyms associated with the CV item, or undef.
sub get_all_synonyms { my( $self ) = @_; unless ($self->{'_gene_targeting_dbentry_cvitem_synonyms'}) { return; } return [keys (%{$self->{'_gene_targeting_dbentry_cvitem_synonyms'}})]; }
get_db_format_synonym_list
Getter that provides the synonym tags in a single string formatted to be stored in the database. Using the separator hardcoded in this module: '$SEPARATOR';
sub get_db_format_synonym_list { my ( $self ) = @_; my $synonym_list = $self->get_all_synonyms() or return; my $synonym_str; foreach my $synonym (@$synonym_list) { $synonym_str .= $synonym . $SEPERATOR; } chop($synonym_str); return $synonym_str; }
has_synonym
Boolean test method that checks to see if the CV item has a synonym that matchs the supplied string. if ($cvi->has_synonym('ko')) { #do something }
sub has_synonym { my ( $self, $synonym ) = @_; my $synonyms = $self->{'_gene_targeting_dbentry_cvitem_synonyms'} or return; return $synonyms->{$synonym}; }
id
Get/Set method for the unique database id of the ControlledVocabularyItem.
sub id { my( $self, $value ) = @_; if (defined $value) { $self->{'_gene_targeting_dbentry_cvitem_id'} = $value; } return $self->{'_gene_targeting_dbentry_cvitem_id'}; }
name
sub name { my( $self, $value ) = @_; if (defined $value) { $self->{'_gene_targeting_dbentry_cvitem_name'} = $value; } return $self->{'_gene_targeting_dbentry_cvitem_name'}; }
set_synonym_list_from_db_format_synonym_str
Setter/Convertor from the database stored synonym string to individual synonyms. As the synonyms are stored as a single string, rather than as distinct synonyms, we have this method to split the string apart into it's component synonyms. Splits on the separator hardcoded in this module: $SEPARATOR';
sub set_synonym_list_from_db_format_synonym_str { my ( $self, $db_format_synonym_str ) = @_; my @synonym_list = split($SEPERATOR, $db_format_synonym_str); foreach my $synonym (@synonym_list) { $self->add_synonym($synonym); } }
GeneTargeting::DBEntry::DNAProbe
- Inherit
- GeneTargeting::DBEntry
- Description
- Object representing a Southern blot probe design.
- Included modules
- Carp
- Constructor
my $probe = $GeneTargeting::DBEntry::DNAProbe; $probe->name('5primebetapix'); $probe->description('Upstream of Beta pix'3)
- Database storage
- See GeneTargeting::DBSQL::DNAProbeAdaptor
Methods
assembly
Get/Set method for the genomic assembly's name from which the DNA sequence was derived
sub assembly { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_dnaprobe_assembly'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_assembly'}; }
chromosome
Get/Set method for the chromosome's name from which the sequence DNA was derived
sub chromosome { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_dnaprobe_chromosome'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_chromosome'}; }
description
Get/set method for the probe description.
sub description { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_dnaprobe_description'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_description'}; }
end
Get/Set method for the end coordinate of the DNA in the genomic sequence assembly Has to be > 1 and > start coordinate
sub end { my( $self, $value ) = @_; if (defined($value)) { unless ($value >= 1) { confess "end must be >= 1"; } unless ($value > $self->start) { confess "end must be greater than start"; } $self->{'_gene_targeting_dbentry_dnaprobe_end'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_end'}; }
end_bias
Get/Set method for the end_bias of the genome assembly from which the DNA was obtained Must be set to '5prime' or '3prime' or causes a fatal error
sub end_bias { my( $self, $value ) = @_; if ($value) { unless ($value eq '5prime' or $value eq '3prime') { confess "end_bias must be 5prime or 3prime"; } $self->{'_gene_targeting_dbentry_dnaprobe_end_bias'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_end_bias'}; }
id
Get/Set method for the unique database id for the DNAProbe.
sub id { my( $self, $value ) = @_; if (defined $value) { $self->{'_gene_targeting_dbentry_dnaprobe_id'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_id'}; }
max_length
Get/Set method for the max_length of the genome assembly from which the DNA was obtained
sub max_length { my( $self, $value ) = @_; if (defined($value)) { $self->{'_gene_targeting_dbentry_dnaprobe_max_length'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_max_length'}; }
min_length
Get/Set method for the min_length of the genome assembly from which the DNA was obtained
sub min_length { my( $self, $value ) = @_; if (defined($value)) { $self->{'_gene_targeting_dbentry_dnaprobe_min_length'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_min_length'}; }
name
Get/set method for the human readable name of the probe. Enforced as unique within the database.
sub name { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_dnaprobe_name'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_name'}; }
start
Get/Set method for the start coordinate of the DNA in the genomic sequence assembly Has to be > 1
sub start { my( $self, $value ) = @_; if (defined($value)) { unless ($value >= 1) { confess "start must be >= 1"; } $self->{'_gene_targeting_dbentry_dnaprobe_start'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_start'}; }
strand
Get/Set method for the strand of the genome assembly from which the DNA was obtained
sub strand { my( $self, $value ) = @_; if (defined($value)) { unless ($value == 1 or $value == -1) { confess "strand must be +1 or -1"; } $self->{'_gene_targeting_dbentry_dnaprobe_strand'} = $value; } return $self->{'_gene_targeting_dbentry_dnaprobe_strand'}; }
GeneTargeting::DBEntry::ExternalDB
- Description
- Object representing an external database (from which GeneTargeting::DBEntry::Xref objects are drawn)
- Included modules
- Carp
- Database storage
- See GeneTargeting::DBSQL::ExternalDBAdaptor
Methods
db_name
Get/Set method for the human readable name of the sequence database that was searched, yielding the hit
sub db_name { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_externaldb_name'} = $value; } return $self->{'_gene_targeting_dbentry_externaldb_name'}; }
description
Get/Set method for the text description of the hit in the external db
sub description { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_externaldb_description'} = $value; } return $self->{'_gene_targeting_dbentry_externaldb_description'}; }
display_label
Get/Set method for the label (generally used in html pages) to represent the database.
sub display_label { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_externaldb_display_label'} = $value; } return $self->{'_gene_targeting_dbentry_externaldb_display_label'}; }
id
Get/Set method for the unique database id of external db.
sub id { my( $self, $value ) = @_; if (defined $value) { $self->{'_gene_targeting_dbentry_externaldb_id'} = $value; } return $self->{'_gene_targeting_dbentry_externaldb_id'}; }
sequence_source
Get/Set method for the sequence_source to get amino acid or nucleotide sequences from the external db. Should start:
pfetch:: (pfetch ip, port, hardoded in Utils.pm) obda::/full_dir (use OBDA retrieval, full_dir points to dir that holds each of the index dirs name should be same as db_name)
Whichever is appropriate.
sub sequence_source { my( $self, $value ) = @_; if ($value) { unless ($value =~ /^pfetch::|^obda::\//) { confess "Must start: pfetch:: or obda::/"; } $self->{'_gene_targeting_dbentry_externaldb_sequence_source'} = $value; } return $self->{'_gene_targeting_dbentry_externaldb_sequence_source'}; }
GeneTargeting::DBEntry::Hit
- Inherit
- GeneTargeting::DBEntry
- Description
- Object representing a sequence match (Hit) from a pairwise similarity search, itself composed of several sub-alignments (ComponentHits)
- Included modules
- Carp
- Digest::MD5
- Constructor
my $hit = GeneTargeting::DBEntry::Hit->new;
- Database storage
- See GeneTargeting::DBSQL::HitAdaptor
Methods
BPlite_Sbjct
Get/Set method for the BPlite_Sbjct of the Hit vs the query
sub BPlite_Sbjct { my( $self, $BPlite_Sbjct ) = @_; if ($BPlite_Sbjct) { $self->{'_gene_targeting_dbentry_hit_BPlite_Sbjct'} = $BPlite_Sbjct; } return $self->{'_gene_targeting_dbentry_hit_BPlite_Sbjct'}; }
accession
Get/Set method for the unique database accession number for the sequence that produced the hit.
sub accession { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_accession'} = $value; } return $self->{'_gene_targeting_dbentry_hit_accession'}; }
add_ComponentHit
Method to add a ComponentHit object to the list of those that make up the Hit.
sub add_ComponentHit { my( $self, $value ) = @_; confess "Not an GeneTargeting::DBEntry::ComponentHit" unless $value->isa("GeneTargeting::DBEntry::ComponentHit"); $self->{'_gene_targeting_dbentry_hit_component_hit_list'} ||= []; push(@{$self->{'_gene_targeting_dbentry_hit_component_hit_list'}}, $value); }
add_Xref
Method to add an Xref object to the Hit.
sub add_Xref { my( $self, $value ) = @_; confess "Not an GeneTargeting::DBEntry::Xref" unless $value->isa("GeneTargeting::DBEntry::Xref"); $self->{'_gene_targeting_dbentry_hit_xref_list'} ||= []; push(@{$self->{'_gene_targeting_dbentry_hit_xref_list'}}, $value); }
db_name
Get/Set method for the human readable name of the sequence database that was searched, yielding the hit
sub db_name { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_db_name'} = $value; } return $self->{'_gene_targeting_dbentry_hit_db_name'}; }
description
Get/Set method for the text description of the Hit.
sub description { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_description'} = $value; } return $self->{'_gene_targeting_dbentry_hit_description'}; }
ext_db_id
Get/Set method for the external database id of the sequence, yielding the hit.
sub ext_db_id { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_ext_db_id'} = $value; } return $self->{'_gene_targeting_dbentry_hit_ext_db_id'}; }
gene_name
Get/Set method for the gene name of the hit, derived from SwissProt records.
sub gene_name { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_gene_name'} = $value; } return $self->{'_gene_targeting_dbentry_hit_gene_name'}; }
get_ComponentHits
Returns a reference to the array of ComponentHit objects that make up the Hit.
sub get_ComponentHits { my( $self ) = @_; if (my $array_ref = $self->{'_gene_targeting_dbentry_hit_component_hit_list'}) { return $array_ref; } else { return; } }
get_Xrefs
Returns a list of the Xrefs attached to the Hit.
sub get_Xrefs { my( $self ) = @_; if (my $xrefs = $self->{'_gene_targeting_dbentry_hit_xref_list'}) { return @$xrefs } else { return; } }
get_alignment_length
Returns ungapped alignment length by summing over all the ComponentHits. (Counting the 'M' states of the cigar strings).
my $length = $Hit->get_alignment_length;
sub get_alignment_length { my( $self ) = @_; my @ComponentHits = $self->get_all_ComponentHits; confess "No ComponentHits" unless @ComponentHits; my $total_match_length = 0; foreach my $ComponentHit (@ComponentHits) { my @pieces = ( $ComponentHit->cigar_line =~ /(\d*[MDI])/g ); foreach my $piece (@pieces) { my ($length) = ( $piece =~ /^(\d*)/ ); next unless $piece =~ /M$/; $total_match_length += $length; } } return $total_match_length; }
get_all_ComponentHits
Returns a list of the ComponentHit objects that make up the Hit.
sub get_all_ComponentHits { my( $self ) = @_; print STDERR "Method 'get_all_ComponentHits' is deprecated"; if (my $objects = $self->{'_gene_targeting_dbentry_hit_component_hit_list'}) { return @$objects; } else { return; } }
get_average_percent_id
Returns the average percent_id of Hit to the query sequence. Calculating an average from each of the ComponentHit taking account of their varying lengths.
my $percent_id = $Hit->get_get_average_percent_id;
sub get_average_percent_id { my( $self ) = @_; my @ComponentHits = $self->get_all_ComponentHits; confess "No ComponentHits" unless @ComponentHits; my $pid_match_length_product = 0; my $total_match_length = 0; foreach my $ComponentHit (@ComponentHits) { my $match_length = $ComponentHit->query_end - $ComponentHit->query_start + 1; $pid_match_length_product += $ComponentHit->percent_id * $match_length; $total_match_length += $match_length; } my $percent_id = $pid_match_length_product / $total_match_length; return $percent_id; }
get_best_ComponentHit_score_and_P_value
Returns the best Score, and the P_Value and percent id of that ComponentHit from the list of those that make up the Hit.
sub get_best_ComponentHit_score_and_P_value { my( $self ) = shift (@_); unless (@{$self->{'_gene_targeting_dbentry_hit_component_hit_list'}}) { confess "No ComponentHits attached to Hit\n"; } my $max_score = 0; my $P_value = 0; my $percent_id = 0; my $ComponentHits = $self->{'_gene_targeting_dbentry_hit_component_hit_list'}; foreach my $ComponentHit (@$ComponentHits) { if ($ComponentHit->score > $max_score) { $max_score = $ComponentHit->score; $P_value = $ComponentHit->P_value; $percent_id = $ComponentHit->percent_id; } } return ($max_score, $P_value, $percent_id); }
get_best_P_value_for_ComponentHit
Returns the best (numerically small) P_value, from the ComponentHit attached to the Hit. Warns if none are attached.
my $P_value = $Hit->get_best_P_value_for_ComponentHit;
sub get_best_P_value_for_ComponentHit { my( $self ) = @_; my $P_value; my @Component_hits = $self->get_all_ComponentHits; warn "No ComponentHits" unless @Component_hits; foreach my $ComponentHit (@Component_hits) { my $current_P_value = $ComponentHit->P_value; unless (defined($current_P_value)) { confess 'No P value for ComponentHit con_id: ' . $ComponentHit->query_id . ' hit_id: ' . $ComponentHit->hit_id; } unless (defined($P_value)) { $P_value = $current_P_value; next; } if ($current_P_value < $P_value) { $P_value = $current_P_value; } } return $P_value; }
get_highest_percent_id_for_ComponentHit
Returns the highest percent_id of the ComponentHits attached to the Hit. Warns if none are attached.
my $percent_id = $Hit->get_highest_percent_id_for_ComponentHit;
sub get_highest_percent_id_for_ComponentHit { my( $self ) = @_; my $percent_id = 0; my @ComponentHits = $self->get_all_ComponentHits; confess "No ComponentHits" unless @ComponentHits; foreach my $ComponentHit (@ComponentHits) { my $current_percent_id = $ComponentHit->percent_id; if ($current_percent_id > $percent_id) { $percent_id = $current_percent_id; } } return $percent_id; }
get_total_score
Returns the total score for the ComponentHits attached to the Hit. Warns if none are attached.
my $total_score = $Hit->get_total_score;
sub get_total_score { my( $self ) = @_; my $score = 0; my @ComponentHits = $self->get_all_ComponentHits; warn "No ComponentHits" unless @ComponentHits; foreach my $ComponentHit (@ComponentHits) { $score += $ComponentHit->score; } return $score; }
id
Get/Set method for the unique database id of the Hit object.
sub id { my( $self, $value ) = @_; if (defined $value) { $self->{'_gene_targeting_dbentry_hit_id'} = $value; } return $self->{'_gene_targeting_dbentry_hit_id'}; }
match_string
Get/Set method for the match_string of the Hit vs the query
sub match_string { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_match_string'} = $value; } return $self->{'_gene_targeting_dbentry_hit_match_string'}; }
md5hex
Get/Set method for 128bit MD5 hex checksum of the Hit sequence.
sub md5hex { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_md5sum'} = $value; } return $self->{'_gene_targeting_dbentry_hit_md5sum'}; }
score
Get/Set method for the score of the Hit vs the query
sub score { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_score'} = $value; } return $self->{'_gene_targeting_dbentry_hit_score'}; }
seq_length
Get/Set method for length of the Hit Hit sequence.
sub seq_length { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_seq_length'} = $value; } return $self->{'_gene_targeting_dbentry_hit_seq_length'}; }
sequence
Get/Set method for sequence of the Hit. Autosets seq_length and md5hex based on the sequence.
sub sequence { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_sequence'} = $value; $self->seq_length(length($value)); my $md5 = Digest::MD5->new; $md5->add($value); $self->md5hex(uc($md5->hexdigest)); } return $self->{'_gene_targeting_dbentry_hit_sequence'}; }
url
Get/Set method for the url to the hit sequence.
sub url { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_url'} = $value; } return $self->{'_gene_targeting_dbentry_hit_url'}; }
xref_id
Get/Set method for the unique xref_id of the Hit object.
sub xref_id { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_hit_xref_id'} = $value; } return $self->{'_gene_targeting_dbentry_hit_xref_id'}; }
GeneTargeting::DBEntry
- Description
- Base class for the business objects stored and retrieved in the GeneTargeting (analysis) database
- Private package variables
- $allow_address_defaults_for_contacts;
- $cv_object;
- Included modules
- Carp
- Data::Dumper
- GeneTargeting::DBEntry::ComponentHit
- GeneTargeting::DBEntry::Conf
- GeneTargeting::DBEntry::Conf::Exonerate
- GeneTargeting::DBEntry::ControlledVocabularyItem
- GeneTargeting::DBEntry::DNAProbe
- GeneTargeting::DBEntry::ExternalDB
- GeneTargeting::DBEntry::Hit
- GeneTargeting::DBEntry::Job
- GeneTargeting::DBEntry::Sequence
- GeneTargeting::DBEntry::Xref
- GeneTargeting::Defs
- GeneTargeting::Utils qw ( validate_g2c_stable_id validate_date_string get_todays_date )
Methods
_literature_item_is_valid
sub _literature_item_is_valid { my ( $self, $literature ) = @_; if ($self->isa("GeneTargeting::DBEntry::Literature")) { confess "Error - Unable to add Literature to another Literature Object!"; } unless (defined($literature) && ref($literature) && $literature->isa("GeneTargeting::DBEntry::Literature")) { confess "Expected a GeneTargeting::DBEntry::Literature argument"; } unless ($literature->dbprimary_acc()) { confess "Literature must have a dbprimary_acc set!"; } my $lit_types = $literature->get_all_types(); unless (defined($lit_types) && (scalar(@$lit_types) > 0)) { confess "Literature must have at least one type set!" } return 1; }
actual_date
Get/Set method for the actual_date for the DBEntry, date needs to be in the format DD/MM/YYYY, or confesses fatally, however, will silently convert '.' and ':' to '/' in passed date. Passing 'today' (case-insensitive) will set date_stored appropriately. Returned date will always be of the format: DD/MM/YYYY e.g. my $date = '15:02:2007'; $obj->actual_date($date); print $obj->actual_date; # prints '15/02/2007'
sub actual_date { my( $self, $value ) = @_; if ($value) { if (lc($value) eq 'today') { $value = get_todays_date(); } my $date = validate_date_string($value); unless ($date) { confess "Invalid date passed: '$value'"; } $self->{'_gene_targeting_dbentry_actual_date'} = $date; } return $self->{'_gene_targeting_dbentry_actual_date'}; }
add_contact
Given GeneTargeting::DBEntry:: Person and Address objects, adds a 'contact' composed of the two, to the DBEntry; Not all DBEntry subtypes are permitted contacts, see GeneTargeting::Defs::acceptable_object_person_address_types for acceptable object types. Other types will confess with a fatal error.
e.g. $dbentry->add_contact($person, $address);
If $dbentry->allow_address_defaults is true, then one can add a contact consisting only of a Person object, and the ContactAdaptor will attempt to find a
sub add_contact { my ( $self, $person, $address ) = @_; #Various type-checking if ($self->isa("GeneTargeting::DBEntry::Person") or $self->isa("GeneTargeting::DBEntry::Address")) { confess 'Cannot add a contact to either a Person or Address object: ' . Dumper($self); } #Check the object type is allowed to have contacts my $type = ref($self); unless ($GeneTargeting::Defs::acceptable_object_person_address_types{$type}) { confess "DBEntry of type '$type' cannot have contacts: " . Dumper($self); } #Validate the Person unless ($person and ref($person) and $person->isa("GeneTargeting::DBEntry::Person")) { confess "Expected a GeneTargeting::DBEntry::Person object"; } #Validate the Address, or see if default is allowed if ($address) { unless (ref($address) and $address->isa("GeneTargeting::DBEntry::Address")) { confess "Expected a GeneTargeting::DBEntry::Address object"; } } else { unless (allow_address_defaults_for_contacts()) { confess 'Expected a GeneTargeting::DBEntry::Address object ' . ' unless DBEntry::allow_address_defaults it true'; } } $self->{'_gene_targeting_dbentry_contacts'} ||= []; my $contact = [$person, $address]; push(@{$self->{'_gene_targeting_dbentry_contacts'}}, $contact); }
add_literature
Attaches a Literature object to the DBEntry, as long as it is not a Literature object itself. Literature object must have dbprimary_acc and source_external_db set, and at least one type
sub add_literature { my ( $self, $literature ) = @_; if ($self->isa("GeneTargeting::DBEntry::Literature")) { confess "Cannot add a Literature obj to another Literature obj"; } unless (defined($literature) and ref($literature) and $literature->isa("GeneTargeting::DBEntry::Literature")) { confess "Expected a GeneTargeting::DBEntry::Literature object"; } unless ($literature->dbprimary_acc()) { confess "Literature must have a dbprimary_acc set"; } unless ($literature->source_external_db) { confess "Literature object must have source_external_db set"; } my $lit_types = $literature->get_all_types() or confess "Literature must have at least one type set!"; $self->{'_gene_targeting_dbentry_literature'} ||= []; push(@{$self->{'_gene_targeting_dbentry_literature'}}, $literature); }
add_note
Attaches the passed GeneTargeting::DBEntry::Note object to the DBEntry.
sub add_note { my ( $self, $note ) = @_; unless ($note && ref($note) && $note->isa("GeneTargeting::DBEntry::Note")) { confess "Expected a GeneTargeting::DBEntry::Note argument"; } $self->{'_gene_targeting_dbentry_notes'} ||= []; push(@{$self->{'_gene_targeting_dbentry_notes'}}, $note); }
add_os_code
Add an os_code to the DBEntry. os_codes are validated using the cv_gt_os_code table, unknown os_codes will throw a fatal error. i.e. for human
$obj->add_os_code(9606);
sub add_os_code { my( $self, $os_code ) = @_; confess "Must pass an os_code" unless $os_code; my $cv = $self->get_ControlledVocabulary(); my $cvi = $cv->get_cv_item_for_obj_field_value($self, 'os_code', $os_code) or confess "Unknown os_code: '$os_code'"; $self->{'_gene_targeting_dbentry_os_codes'} ||= {}; my $os_code_hash = $self->{'_gene_targeting_dbentry_os_codes'}; $os_code_hash->{$os_code}++; }
add_protocol
Given a Protocol object, adds it to the DBEntry.
$db_entry->add_protocol($protcol);
Note one cannot add a Protocol object to another Protocol object.
sub add_protocol { my ( $self, $protocol ) = @_; if ($self->isa("GeneTargeting::DBEntry::Protocol")) { confess "Cannot add a Resource object to another Protocol object"; } unless ($protocol and ref($protocol) and $protocol->isa("GeneTargeting::DBEntry::Protocol")) { confess "Expected a GeneTargeting::DBEntry::Protocol argument"; } $self->{'_gene_targeting_dbentry_protocols'} ||= []; push (@{$self->{'_gene_targeting_dbentry_protocols'}}, $protocol); }
add_resource
Adds a Resource object to the DBEntry, providing it is not a Resource object itself.
$db_entry->add_resource($resource); Note the resource object must be valid before it can be attached, this is due to the resource items being kept in a hash and keyed via resource->target(). Repeated resource items will be dropped silently.
sub add_resource { my ( $self, $resource ) = @_; if ($self->isa("GeneTargeting::DBEntry::Resource")) { confess "Cannot add a Resource object to another Resource object"; } unless ($resource and ref($resource) and $resource->isa("GeneTargeting::DBEntry::Resource")) { confess "Expected a GeneTargeting::DBEntry::Resource argument"; } unless ($resource->source and $resource->source_path) { confess "source and source_path attributes must be set"; } $self->{'_gene_targeting_dbentry_resources'} ||= {}; my $hash_key = $resource->source_path . $resource->source; unless( $self->{'_gene_targeting_dbentry_resources'}-> {$hash_key} ) { $self->{'_gene_targeting_dbentry_resources'}->{$hash_key} = $resource; } }
add_synonym
Method to add a synonym to to the object.
$xref2->add_synonym('NR1);
sub add_synonym { my( $self, $value ) = @_; unless ($value) { confess "Must pass a string to add as a synonym"; } $self->{'_gene_targeting_dbentry_synonyms'} ||= {}; my $synonym_hash = $self->{'_gene_targeting_dbentry_synonyms'}; $synonym_hash->{$value} = 1; }
add_xref2
Attaches the passed GeneTargeting::DBEntry::Xref2 object to the DBEntry. (type checked)
sub add_xref2 { my( $self, $xref2 ) = @_; unless ($xref2 and ref($xref2) and $xref2->isa("GeneTargeting::DBEntry::Xref2")) { confess "Expected a GeneTargeting::DBEntry::Xref2 argument"; } $self->{'_gene_targeting_dbentry_xref2_members'} ||= []; push(@{$self->{'_gene_targeting_dbentry_xref2_members'}}, $xref2); }
allow_address_defaults_for_contacts
Class method to allow contacts to be attached to DBEntry objects that consist only of Person object, rather than a Person and Address object pair. Set to any true value to allow defaulting on Address, which will then subsequently be fetched (if possible) from G2Cdb by the ContactAdaptor.
e.g. GeneTargeting::DBEntry::allow_address_defaults_for_contacts('true');
sub allow_address_defaults_for_contacts { my ( $value ) = @_; if (ref($value)) { confess 'Class not instance method, invoke as: ' . 'GeneTargeting::DBEntry::allow_address_defaults_for_contacts'; } if (defined($value)) { $allow_address_defaults_for_contacts = $value; } return $allow_address_defaults_for_contacts; }
clone
Needs to be overridden by subclassed of GeneTargeting::DBEntry objects
sub clone { my ( $self ) = @_; confess "clone method needs to be overridden in " . ref($self); }
date_created
Get/Set method for the date_created for the DBEntry, date needs to be in the format DD/MM/YYYY, or confesses fatally, however, will silently convert '.' and ':' to '/' in passed date. Returned date will always be of the format: DD/MM/YYYY e.g. my $date = '15:02:2007'; $obj->date_created($date); print $obj->date_created; #prints '15/02/2007'
sub date_created { my( $self, $value ) = @_; if ($value) { my $date = validate_date_string($value); unless ($date) { confess "Invalid date passed: '$value'"; } $self->{'_gene_targeting_dbentry_date_created'} = $date; } return $self->{'_gene_targeting_dbentry_date_created'}; }
date_modified
Get/Set method for the date_modified for the DBEntry, date needs to be in the formatDD/MM/YYYY, or confesses fatally, however, will silently convert '.' and ':' to '/' in passed date. Returned date will always be of the format: DD/MM/YYYY e.g. my $date = '15:02:2007'; $obj->date_modified($date); print $obj->date_modified; #prints '15/02/2007'
sub date_modified { my( $self, $value ) = @_; if ($value) { my $date = validate_date_string($value); unless ($date) { confess "Invalid date passed: '$value'"; } $self->{'_gene_targeting_dbentry_date_modified'} = $date; } return $self->{'_gene_targeting_dbentry_date_modified'}; }
display_xref_id
Get/Set method for the display_xref_id of the gene.
sub display_xref_id { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_display_xref_id'} = $value; } return $self->{'_gene_targeting_dbentry_display_xref_id'}; }
get_ControlledVocabulary
my $cv_obj = $db_entry->get_ControlledVocabulary();
sub get_ControlledVocabulary { confess "Call initalise_ControlledVocabulary first" unless $cv_object; return $cv_object; }
get_all_contacts
Returns a reference to an array of the 'contacts' attached to the DBEntry object. The array will be empty if none were attached. Contacts are not objects per se, but a reference to an array of two elements, a Person object, and an Address object.
e.g. my $contacts = $dbentry->get_all_contacts();
sub get_all_contacts { my ( $self ) = @_; $self->{'_gene_targeting_dbentry_contacts'} ||= []; return $self->{'_gene_targeting_dbentry_contacts'}; }
get_all_literature
Returns a list, potentially empty, of all the Literature items attached to this DBEntry. Note: These items need to be loaded explicitly, so if you have just retrieved the dbentry from the database, you'll need to use the LiteratureAdaptor to fetch them for this object.
sub get_all_literature { my ( $self ) = @_; $self->{'_gene_targeting_dbentry_literature'} ||= []; return $self->{'_gene_targeting_dbentry_literature'}; }
get_all_notes
Returns a list, potentially empty, of all the notes in this DBEntry. Note: As these items are lazy loaded, if you have just retrieved the dbentry from the database, you'll need to use the fetch_notes_for_object method in the base adaptor to fetch/load them into this dbentry.
sub get_all_notes { my ( $self ) = @_; $self->{'_gene_targeting_dbentry_notes'} ||= []; return $self->{'_gene_targeting_dbentry_notes'}; }
get_all_os_codes
Returns a list ref to all the os_codes associated with the object, or undef.
sub get_all_os_codes { my( $self ) = @_; unless ($self->{'_gene_targeting_dbentry_os_codes'}) { return; } return [keys (%{$self->{'_gene_targeting_dbentry_os_codes'}})]; }
get_all_protocols
Returns all the Protocols attached to the DBEntry, as an arraf reference, which will be empty if none were attached.
my $protocols = $db_entry->get_all_protocols():
sub get_all_protocols { my ( $self ) = @_; confess "Invocation error" unless ref($self); $self->{'_gene_targeting_dbentry_protocols'} ||= []; return $self->{'_gene_targeting_dbentry_protocols'}; }
get_all_resources
Returns all the Resources attached to the DBEntry, as an array reference, which will be empty if none were attached.
my $resources = $db_entry->get_all_resources();
Note Resources need to be fetched explicitly from the database for the object with a ResourceAdaptor. It doesnt happen automatically.
sub get_all_resources { my ( $self ) = @_; $self->{'_gene_targeting_dbentry_resources'} ||= {}; return [values (%{$self->{'_gene_targeting_dbentry_resources'}})]; }
get_all_synonyms
Returns a list reference to synonyms for the DBEntry, or undefined should none exist.
my $synonyms = $xtref2->get_all_synonyms;
sub get_all_synonyms { my ( $self ) = @_; unless ($self->{'_gene_targeting_dbentry_synonyms'}) { return; } return [keys (%{$self->{'_gene_targeting_dbentry_synonyms'}})]; }
get_all_xref2s
Returns a list reference to the GeneTargeting::DBEntry::Xref2 objects attached to the DBEntry, or undef, should none be attached.
sub get_all_xref2s { my ( $self ) = @_; if (my $array_ref = $self->{'_gene_targeting_dbentry_xref2_members'}) { return $array_ref; } else { return; } }
has_os_code
Boolean test method that checks to see if the object is known to be related to an organism by it's os_code. if ($obj->has_os_code(9606)) { #do something }
sub has_os_code { my ( $self, $os_code ) = @_; confess "Must pass an os_code to has_os_code" unless $os_code; my $cv = $self->get_ControlledVocabulary(); my $cvi = $cv->get_cv_item_for_obj_field_value($self, 'os_code', $os_code) or confess "Must pass a valid os_code to has_os_code - you supplied:" . $os_code; my $os_code_hash = $self->{'_gene_targeting_dbentry_os_codes'}; if ($os_code) { return $os_code_hash->{$os_code}; } return; }
has_synonym
Boolean test method that checks to see if the object has the synonym. if ($obj->has_synonym($synonym)) { #do something }
sub has_synonym { my ( $self, $synonym ) = @_; confess "Must pass a $synonym to has_synonym" unless $synonym; my $synonym_hash = $self->{'_gene_targeting_dbentry_synonyms'}; if ($synonym) { return $synonym_hash->{$synonym}; } return; }
initalise_ControlledVocabulary
GeneTargeting::DBEntry::initalise_ControlledVocabulary($cv_object);
sub initalise_ControlledVocabulary { my ( $obj ) = @_; unless (($obj) and ref($obj) and $obj->isa('GeneTargeting::ControlledVocabulary')) { confess "Must pass a GeneTargeting::ControlledVocabulary object"; } $cv_object = $obj; }
new
Constructor for GeneTargeting::DBEntry:: class objects
sub new { my( $pkg ) = @_; if ($pkg eq 'GeneTargeting::DBEntry') { confess 'Only subclasses of GeneTargeting::DBEntry can be' . ' instantiated'; } #Check controlled vocabulary is initialised get_ControlledVocabulary() unless $pkg->isa('GeneTargeting::DBEntry::ControlledVocabularyItem'); return bless {}, $pkg; }
os_code
Returns the os_code of the object if it has been set, and is permitted to have just a single os_code, else confesses
sub os_code { my ( $self ) = @_; my $obj_type = ref($self); #Can't call if allowed to have multiple os_codes if ($GeneTargeting::Defs::object_types_allowed_multiple_os_codes{$obj_type}) { confess "Can't call os_code as Object of type '$obj_type' " . " is allowed multiple os_codes"; } #Can't call if not allowed to have an os_code if ($GeneTargeting::Defs::object_types_that_must_not_have_os_code{$obj_type}) { confess "Can't call os_code as Object of type '$obj_type' " . " is not allowed to have an os_code"; } my $os_codes = $self->get_all_os_codes; unless ($os_codes and @$os_codes == 1) { confess "Bad os_code for ", Dumper($self); } my $os_code = $os_codes->[0]; return $os_code; }
private
Get/setter for the private property of DBEntry objects. Valid values are the integers 0-999 (which is checked). 0 is considered public, anything higer is (somewhat) private. If $obj->private() is called to get the attribute, without it previously having been set explicitly, then it will be set to the default for that object type, and returned See: %GeneTargeting::Defs::default_object_privacy
sub private { my ( $self, $value ) = @_; if (defined($value)) { if ($value < 0 or $value > 999 or int($value) != $value) { confess "Invalid private: '$value' for: " . Dumper($self); } $self->{'_gene_targeting_dbentry_private'} = $value; } unless (defined($self->{'_gene_targeting_dbentry_private'})) { my $default_privacy = $GeneTargeting::Defs::default_object_privacy{ref($self)}; unless (defined($default_privacy)) { confess "No default privacy set for objects of class: " . ref($self); } $self->{'_gene_targeting_dbentry_private'} = $default_privacy; } return $self->{'_gene_targeting_dbentry_private'}; }
source_external_db
Get/Set method for associating the DBEntry with a ExternalDb object.
sub source_external_db { my( $self, $value ) = @_; unless ($GeneTargeting::Defs::objects_allowed_a_source_external_db2{ref($self)}) { confess "Object of type: " . ref($self) . " is not allowed a source_external_db: " . Dumper($self); } if (defined($value)) { unless (defined($value) && ref($value) && $value->isa("GeneTargeting::DBEntry::ExternalDB2")) { confess "Expected a GeneTargeting::DBEntry::ExternalDB2 argument"; } $self->{'_gene_targeting_dbentry_external_db'} = $value; } return $self->{'_gene_targeting_dbentry_external_db'}; }
stable_id
Get/Set method for the stable_id of the DBEntry object. Automatically checks the stable_id is valid for the subclass of DBEntry and objects of that subclass are permitted to have stable_ids
sub stable_id { my( $self, $value ) = @_; if ($value) { validate_g2c_stable_id($value, ref($self)); $self->{'_gene_targeting_dbentry_stable_id'} = $value; } return $self->{'_gene_targeting_dbentry_stable_id'}; }
GeneTargeting::DBEntry::Job
- Inherit
- GeneTargeting::DBEntry
- Description
- Object to hold a job for a particular type of analysis for a given set of sequences. In the Southern blot design system these would be putative probes for searching against the target genome with an alignment programme such as Exonerate.
- Private package variables
- %valid = ( 'created' => 1, 'submitted' => 1, 'running' => 1, 'success' => 1, 'failed' => 1, )
- Included modules
- Carp
- Constructor
my $job = $GeneTargeting::DBEntry::Job; $job->analysis_conf_id(3) $job->state('created');
- Database storage
- See GeneTargeting::DBSQL::JobAdaptor
Methods
analysis_conf_id
Get/set method for the analysis_conf_id (i.e. the type of the analysis performed) for the job
sub analysis_conf_id { my( $self, $conf_id ) = @_; if ($conf_id) { $self->{'_gene_targeting_dbentry_job_analysis_conf_id'} = $conf_id; } return $self->{'_gene_targeting_dbentry_job_analysis_conf_id'}; }
id
Get/Set method for the unique database id for the job
sub id { my( $self, $job_id ) = @_; if (defined $job_id) { $self->{'_gene_targeting_dbentry_job_id'} = $job_id; } return $self->{'_gene_targeting_dbentry_job_id'}; }
state
Get/set method for the state of the job. Can be set to one of 'created', 'submitted', 'running', 'success', 'failed'
sub state { my( $self, $state ) = @_; if ($state) { unless ($valid{$state}) { confess "Invalid state"; } $self->{'_gene_targeting_dbentry_job_state'} = $state; } return $self->{'_gene_targeting_dbentry_job_state'}; }
GeneTargeting::DBEntry::Sequence
- Inherit
- GeneTargeting::DBEntry
- Description
- Object to hold fragment of genomic sequence from a known position in an assembly. For the object to be stored in the databsase the assembly, chromosome, and start and ending coordinates and strand must be set.
- Included modules
- Carp
- GeneTargeting::Utils qw ( validate_nucleotide_seq )
- Constructor
my $seq = GeneTargeting::DBEntry::Sequence->new; $seq->assembly('NCBIM33'); $seq->chromosome('Y'); $seq->start(22052902); $seq->end(22052962); $seq->strand(1); $seq->dna('GTTTTATTAGCTTCAAATCAGACAATACCATGAAAGTTCATT TTCAGAAGGGTTAAGTGGA');
- Database storage
- See GeneTargeting::DBSQL::SequenceAdaptor
Methods
assembly
Get/Set method for the genomic assembly's name from which the DNA sequence was derived
sub assembly { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_sequence_assembly'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_assembly'}; }
chromosome
Get/Set method for the chromosome's name from which the sequence DNA was derived
sub chromosome { my( $self, $value ) = @_; if ($value) { $self->{'_gene_targeting_dbentry_sequence_chromosome'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_chromosome'}; }
distance_from_ideal
Get/Set method for the distance_from_ideal for the sequence.
sub distance_from_ideal { my( $self, $value ) = @_; if (defined($value)) { $self->{'_gene_targeting_dbentry_sequence_distance_from_ideal'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_distance_from_ideal'}; }
dna
Get/set for the sequence dna Checks dna validity (ATGCN)
sub dna { my( $self, $value ) = @_; if ($value) { unless (validate_nucleotide_seq($value)) { confess "Invalid dna"; } $self->{'_gene_targeting_dbentry_sequence_dna'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_dna'}; }
end
Get/Set method for the end coordinate of the DNA in the genomic sequence assembly Has to be > 1 and > start coordinate
sub end { my( $self, $value ) = @_; if (defined($value)) { unless ($value >= 1) { confess "end must be >= 1"; } unless ($value > $self->start) { confess "end must be greater than start"; } $self->{'_gene_targeting_dbentry_sequence_end'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_end'}; }
id
Get/Set method for the unique database id for the sequence.
sub id { my( $self, $value ) = @_; if (defined $value) { $self->{'_gene_targeting_dbentry_sequence_id'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_id'}; }
is_unique
Get/Set method for whether the Sequence object was found to be unique in the genome, with the chosen search programme and parameters. If true, only a single (self-hit) was found by the search. If this is the case score_ratio should be left undefined.
sub is_unique { my( $self, $value ) = @_; if (defined($value)) { $self->{'_gene_targeting_dbentry_sequence_is_unique'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_is_unique'}; }
new_from_Slice
Given a Bio::EnsEMBL::Slice object, creates a GeneTargeting::DBEntry::Sequence object from it, setting the assembly, chromosome, start, end, strand and dna attributes of the latter.
sub new_from_Slice { my ( $pkg, $slice ) = @_; unless ($slice and $slice->isa('Bio::EnsEMBL::Slice')) { confess "Must pass a Bio::EnsEMBL::Slice"; } my $objref = {}; bless $objref, $pkg; if (my $assembly = $slice->coord_system->version) { $objref->assembly($assembly); } else { confess "Could not get assembly (coord_system->version)" . "from Slice object"; } if ($slice->coord_system_name eq 'chromosome' and $slice->seq_region_name) { $objref->chromosome($slice->seq_region_name); } else { confess "Cannot set chromosome from Slice object"; } if ($slice->start) { $objref->start($slice->start) } else { confess "Cannot set start from Slice object"; } if ($slice->end) { $objref->end($slice->end); } else { confess "Cannot set end from Slice object"; } if ($slice->strand) { $objref->strand($slice->strand); } else { confess "Cannot set strand from Slice object"; } if ($slice->seq) { $objref->dna($slice->seq); } else { confess "Cannot dna strand from Slice object"; } return $objref; }
overall_score
Get/Set method for the overall_score of the sequence, combining (for example) distance_from_ideal, percent_repetitive and score_ratio.
sub overall_score { my( $self, $value ) = @_; if (defined($value)) { $self->{'_gene_targeting_dbentry_sequence_overall_score'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_overall_score'}; }
percent_repetitive
Get/Set method for the percent_repetitive for the sequence.
sub percent_repetitive { my( $self, $value ) = @_; if (defined($value)) { $self->{'_gene_targeting_dbentry_sequence_percent_repetitive'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_percent_repetitive'}; }
score_ratio
Get/Set method for score_ratio for Sequence object. This is the ratio of the self_hit score to the next highest score for the Sequence to the genome.
sub score_ratio { my( $self, $value ) = @_; if (defined($value)) { $self->{'_gene_targeting_dbentry_sequence_score_ratio'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_score_ratio'}; }
self_hit
Get/Set method for genome 'self_hit' to the Sequence object, which must be an object of the class GeneTargeting::DBEntry::ComponentHit This is attribute is not stored in the GeneTargeting database.
sub self_hit { my( $self, $value ) = @_; if ($value) { unless ($value->isa('GeneTargeting::DBEntry::ComponentHit')) { confess "Must pass a GeneTargeting::DBEntry::ComponentHit object"; } $self->{'_gene_targeting_dbentry_sequence_self_hit'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_self_hit'}; }
start
Get/Set method for the start coordinate of the DNA in the genomic sequence assembly Has to be > 1
sub start { my( $self, $value ) = @_; if (defined($value)) { unless ($value >= 1) { confess "start must be >= 1"; } $self->{'_gene_targeting_dbentry_sequence_start'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_start'}; }
strand
Get/Set method for the strand of the genome assembly from which the DNA was obtained
sub strand { my( $self, $value ) = @_; if (defined($value)) { unless ($value == 1 or $value == -1) { confess "strand must be +1 or -1"; } $self->{'_gene_targeting_dbentry_sequence_strand'} = $value; } return $self->{'_gene_targeting_dbentry_sequence_strand'}; }
GeneTargeting::DBEntry::Xref
- Inherit
- GeneTargeting::DBEntry
- Description
- A cross-reference to an entry in an external database.
- Included modules
- Carp
- Database storage
- See GeneTargeting::DBSQL::XrefAdaptor
Methods
accession
Get/Set method for the unique database accession number for the sequence that produced the hit.
sub accession { my( $self, $accession ) = @_; if ($accession) { $self->{'_gene_targeting_dbentry_xref_accession'} = $accession; } return $self->{'_gene_targeting_dbentry_xref_accession'}; }
db_name
Get/Set method for the human readable name of the sequence database that was searched, yielding the hit
sub db_name { my( $self, $db_name ) = @_; if ($db_name) { $self->{'_gene_targeting_dbentry_xref_db_name'} = $db_name; } return $self->{'_gene_targeting_dbentry_xref_db_name'}; }
description
Get/Set method for the text description of the Hit.
sub description { my( $self, $description ) = @_; if ($description) { $self->{'_gene_targeting_dbentry_xref_description'} = $description; } return $self->{'_gene_targeting_dbentry_xref_description'}; }
ext_db_id
Get/Set method for the external database id of the sequence, yielding the hit.
sub ext_db_id { my( $self, $ext_db_id ) = @_; if ($ext_db_id) { $self->{'_gene_targeting_dbentry_xref_ext_db_id'} = $ext_db_id; } return $self->{'_gene_targeting_dbentry_xref_ext_db_id'}; }
gene_name
Get/Set method for the gene name of the hit, derived from SwissProt records.
sub gene_name { my( $self, $gene_name ) = @_; if ($gene_name) { $self->{'_gene_targeting_dbentry_xref_gene_name'} = $gene_name; } return $self->{'_gene_targeting_dbentry_xref_gene_name'}; }
id
Get/Set method for the unique database id of the Hit object.
sub id { my( $self, $id ) = @_; if (defined $id) { $self->{'_gene_targeting_dbentry_xref_id'} = $id; } return $self->{'_gene_targeting_dbentry_xref_id'}; }
GeneTargetingDB
- Included modules
- Usage
- Add a 'use GeneTargetingDB;' to programs if you want to use the GeneTargeting::DBEntry objects and store and fetch them from the MySQL database, with the various GeneTargeting::DBSQL::DBAdaptor objects
GeneTargeting::DBSQL::BaseAdaptor
- Description
- This is the super class from which all the GeneTargeting::DBSQL:: adaptors inherit, and is not used directly.
- Synopsis
use GeneTargetingDB;
- Private package variables
- %debug_by_adaptor_type;
- $all_debug;
- $debug_privacy;
- Included modules
- Carp
- Data::Dumper
- GeneTargeting::Defs
- GeneTargeting::Utils qw ( map_dbentry_type_to_adaptor map_adaptor_type_to_dbentry validate_date_string convert_date_string_to_mysql_date_string convert_mysql_date_string_to_date_string verify_known_taxon_id strip_dbentry_type_prefix validate_g2c_stable_id_not_fatal )
- Scalar::Util ' weaken '
Methods
DBAdaptor
sub DBAdaptor { my( $self, $dba ) = @_; if ($dba) { $self->{'genetargeting_dbsql_baseadaptor_db_adaptor'} = $dba; weaken($self->{'genetargeting_dbsql_baseadaptor_db_adaptor'}); } return $self->{'genetargeting_dbsql_baseadaptor_db_adaptor'}; }
_fetch_source_external_db2_via_id
sub _fetch_source_external_db2_via_id { my ($self, $source_external_db2_id) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $extdb2_aptr = $dba->get_ExternalDB2Adaptor() or confess "Cant get an ExternalDB2Adaptor"; my $id = $extdb2_aptr->fetch_by_db_id($source_external_db2_id) or confess "Failed to fetch_by_db_id '$source_external_db2_id'"; return $id; }
_fetch_stable_id_into_object
sub _fetch_stable_id_into_object { my ( $self, $obj ) = @_; unless ($obj && ref($obj) && ref($obj) =~ /^GeneTargeting::DBEntry::/) { confess "Expected a DBEntry subtype object"; } unless ($obj->id()) { confess "Supplied DBEntry subtype must have an id set"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by _fetch_stable_id_into_object " . ref($obj); my $sth = $dba->dbh->prepare(q{ SELECT stable_id FROM object_stable_id WHERE obj_db_object_type_id = ? AND obj_db_id = ? }); $sth->execute($object_type_cvi->id(), $obj->id); my ( $stable_id ) = $sth->fetchrow; if ($stable_id) { $obj->stable_id($stable_id); } return $stable_id; }
_get_obj_date_id
sub _get_obj_date_id { my ( $self, $obj_db_id, $obj_db_object_type_id ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare( q{ SELECT object_date_id FROM object_date WHERE obj_db_id = ? AND obj_db_object_type_id = ? } ); $sth->execute( $obj_db_id , $obj_db_object_type_id ); return $sth->fetchrow(); }
_get_obj_dbid
sub _get_obj_dbid { my ( $self, $obj ) = @_; unless ($obj and ref($obj) and $obj->isa('GeneTargeting::DBEntry')) { confess "Must pass GeneTargeting::DBEntry object"; } my $obj_dbid = $obj->id or confess "id not set"; return $obj_dbid; }
_insert_object_with_stable_id
sub _insert_object_with_stable_id { my ( $self, $obj ) = @_; unless ($obj && ref($obj) && ref($obj) =~ /^GeneTargeting::DBEntry::/) { confess "Expected a DBEntry subtype object"; } unless ($obj->id()) { confess "Supplied DBEntry subtype must have an id set"; } unless ($obj->stable_id()) { confess "Supplied DBEntry subtype must have a stable_id set"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by _insert_object_stable_id " . ref($obj); my $sth = $dba->dbh->prepare(q{ INSERT INTO object_stable_id( object_stable_id, stable_id, obj_db_object_type_id, obj_db_id, obsolete ) VALUES (NULL, ?, ?, ?, ?) }); $sth->execute($obj->stable_id, $object_type_cvi->id(), $obj->id, 0); return $sth->rows; }
_stable_id_exists
sub _stable_id_exists { my ( $self, $stable_id ) = @_; confess "Please supply a stable id" unless $stable_id; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT count(*) FROM object_stable_id WHERE stable_id = ? }); $sth->execute($stable_id); my $stable_id_count = $sth->fetchrow; return $stable_id_count; }
debug
Switch on/off and check debugging from any of the DBAdaptors
#Switch debugging on/off $gene_aptr->debug(1); #Switch on GeneAdaptor debugging $gene_aptr->debug('all'); #Switch on debugging in al #Adaptors #Check if debug is on if ($aptr->debug) { print 'something'; }
sub debug { my ( $self, $debug ) = @_; my $type = ref($self); if (defined($debug)) { if ($debug =~ /all/i) { $all_debug = 1; } else { $debug_by_adaptor_type{$type} = $debug; } } if ($all_debug) { return 1; } else { return $debug_by_adaptor_type{$type}; } }
debug_privacy
Sends debugging output to STDERR for objects that have been privacy filtered, for security layer debugging.
$any_aptr->debug_privacy(1);
sub debug_privacy { my ( $self, $privacy ) = @_; if (defined($privacy)) { $debug_privacy = $privacy; } return $debug_privacy; }
fetch_by_db_id
Fetches a GeneTargeting::DBEntry object from the database in a privacy aware manner, wrapping all the _fetch_by_db_id methods. Besides calling the _fetch_by_db_id in the appropriate GeneTargeing::DBSQL Adaptor, if an object is returned, also calls:
fetch_os_codes_for_object(); get_dates_for_object();
sub fetch_by_db_id { my ( $self, $id, @params ) = @_; my $obj = $self->filter_objects_by_privacy( $self->_fetch_by_db_id($id, @params) ); return unless ($obj); $self->fetch_os_codes_for_object($obj); unless ($self->get_dates_for_object($obj)) { # carp "No dates fetched for an object: " . Dumper($obj); } return $obj; }
fetch_by_stable_id
Fetches an DBEntry object from the database by its stable_id returning the object, or undef.
my $allele = $allele_aptr->fetch_by_stable_id('A00000001'); my $gene = $gene_aptr->fetch_by_stable_id($gene_stable_id);
sub fetch_by_stable_id { my ( $self, $stable_id ) = @_; confess "Must pass a stable_id" unless $stable_id; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT obj_db_id FROM object_stable_id WHERE stable_id = ? }); $sth->execute($stable_id); my $id = $sth->fetchrow; return unless $id; my $obj = $self->fetch_by_db_id($id); unless ($obj or $dba->privacy_filtered) { confess "fetch_by_stable_id failed with id '$id' and '$stable_id'"; } return $obj; }
fetch_common_attachments
Given a GeneTargeting::DBEntry object, fetches any Xref2, Contact, Literature and Note objects attched to the object, together with any linked Resource objects, both for the initial DBEntry, and the attached objects. This can be called from any subtype of GeneTargeting::DBSQL adaptor.
$any_aptr->fetch_common_attachments($db_entry);
sub fetch_common_attachments { my ( $self, $db_entry ) = @_; unless ($db_entry && ref($db_entry) && $db_entry->isa("GeneTargeting::DBEntry")) { confess "Expected a DBEntry subtype object"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $lit_aptr = $dba->get_LiteratureAdaptor or confess "Failed to get LiteratureAdaptor"; my $xref_aptr = $dba->get_Xref2Adaptor or confess "Failed to get Xref2Adaptor"; my $contact_aptr = $dba->get_ContactAdaptor or confess "Failed to get ContactAdaptor"; my $res_aptr = $dba->get_ResourceAdaptor or confess "Failed to get ResourceAdaptor"; $lit_aptr->fetch_for_object($db_entry); $xref_aptr->fetch_for_object($db_entry); $self->fetch_notes_for_object($db_entry); $contact_aptr->fetch_for_object($db_entry); #Finally add the Resource objects $res_aptr->fetch_for_object_deep($db_entry); }
fetch_generic_by_stable_id
Given a stable id for a GeneTargeting::DBEntry:: object fetches it from the database, respecting privacy
sub fetch_generic_by_stable_id { my ( $self, $required ) = @_; confess "Must pass a stable_id" unless $required; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my ($id, $obj_type) = $self->get_db_id_obj_type_for_stable_id($required); return unless $id; #Confesses my $aptr = $self->get_adaptor_by_dbentry_type($obj_type); my $obj = $aptr->fetch_by_db_id($id) or confess "Could not fetch id: '$id' of type: '$obj_type'"; return $obj; }
fetch_notes_by_object_dbid_and_type
Fetchs notes by an objects dbid and type rather than a concrete object. param $dbid - a valid database id from a specific object table param $type - a string i.e. GeneTargeting::DBEntry::Gene This method is provided to allow a web script to retrieve objects via these two params as it is unable to pass an object in the url string...
sub fetch_notes_by_object_dbid_and_type { my ( $self, $dbid, $type ) = @_; unless ($dbid) { confess "Please supply a valid dbid"; } carp "This should use Defs object_types hash\n"; unless ($type && $type =~ m/^GeneTargeting::/) { confess "Supplied type string does not start with GeneTargeting::"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($type, 'object_type', $type) or confess "Invalid object_type found by fetch_notes_by_object_dbid_and_type " . $type; my $sth = $dba->dbh->prepare(q{ SELECT object_note_id, note_text, datestamp FROM object_note WHERE obj_db_id = ? AND obj_db_object_type_id = ? ORDER BY datestamp }); $sth->execute($dbid, $object_type_cvi->id()); my $object_notes = []; while (my ($object_note_id, $note_text, $datestamp) = $sth->fetchrow) { my $note = GeneTargeting::DBEntry::Note->new(); $note->id($object_note_id); $note->parent_db_entry_db_id($dbid); $note->parent_db_entry_object_type($type); $note->note_text($note_text); $note->datestamp($datestamp); push @$object_notes, $note; } return $object_notes; }
fetch_notes_for_object
Fetchs object notes for GeneTargeting::DBEntry sub-type object. Confesses if the supplied object is not a subtype of GeneTargeting::DBEntry, or if it is, but does not have it's dbid set. param $obj - a suitable subtype object
sub fetch_notes_for_object { my ( $self, $obj ) = @_; unless ($obj && ref($obj) && $obj->isa("GeneTargeting::DBEntry")) { confess "Expected a DBEntry subtype object"; } if ($obj->isa("GeneTargeting::DBEntry::Note")) { confess "Unable to fetch notes for Note objects"; } unless ($obj->id()) { confess "Supplied DBEntry must have a dbid set"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by fetch_notes_for_object " . ref($obj); my $sth = $dba->dbh->prepare(q{ SELECT object_note_id, note_text, datestamp FROM object_note WHERE obj_db_id = ? AND obj_db_object_type_id = ? ORDER BY datestamp }); $sth->execute($obj->id(), $object_type_cvi->id()); my $object_notes = []; my $note_count = 0; while (my ($object_note_id, $note_text, $datestamp) = $sth->fetchrow) { my $note = GeneTargeting::DBEntry::Note->new(); $note->id($object_note_id); $note->parent_db_entry_db_id($obj->id()); $note->parent_db_entry_object_type(ref($obj)); $note->note_text($note_text); $note->datestamp($datestamp); $obj->add_note($note); $note_count++; } return $note_count; }
fetch_os_codes_for_object
Fetches os_codes for the passed GeneTargeting::DBEntry object. Validating they are appropriate for the DBEntry subclass.
sub fetch_os_codes_for_object { my ( $self, $obj ) = @_; unless ($obj and ref($obj) and $obj->isa("GeneTargeting::DBEntry")) { confess "Expected a DBEntry subtype object"; } confess "id not set on DBEntry object" unless $obj->id; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $qry_sth = $dba->dbh->prepare(q{ SELECT os_code_id FROM object_os_code WHERE obj_db_id = ? AND obj_db_object_type_id = ? }); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by fetch_os_codes_for_object " . ref($obj); $qry_sth->execute($obj->id(), $object_type_cvi->id()); while (my ($os_code_id) = $qry_sth->fetchrow()) { my $cv_item = $cv->get_value_for_obj_field_cvi_id( ref($obj), 'os_code', $os_code_id) or confess "Invalid os_code_id found by fetch_os_codes_for_object " . $os_code_id; unless ( $obj->has_os_code($cv_item->name()) ) { $obj->add_os_code($cv_item->name()); } } $self->validate_os_codes_for_object($obj); }
fetch_synonyms_into_object
Fetches synonyms from the database that are associated with the object. param - takes a valid DBEntry subtype - note the dbid must be set in this obj.
sub fetch_synonyms_into_object { my ( $self, $obj ) = @_; unless ($obj && ref($obj) && ref($obj) =~ /^GeneTargeting::DBEntry::/) { confess "Expected a DBEntry subtype object"; } unless ($obj->id()) { confess "Supplied DBEntry subtype must have an id set"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by fetch_synonyms_into_object " . ref($obj); my $sth = $dba->dbh->prepare(q{ SELECT synonym FROM object_synonym WHERE obj_db_id = ? AND obj_db_object_type_id = ? }); $sth->execute($obj->id(), $object_type_cvi->id()); while (my ($synonym) = $sth->fetchrow()) { $obj->add_synonym($synonym); } }
filter_ids_by_privacy
Given a single id (scalar), or a list ref of ids filters them by Adaptor privacy, returning a list ref (if initially passed one), or the id, or undef (should it have been filtered out by privacy)
sub filter_ids_by_privacy { my ( $self, $id_list_or_id, $explict_aptr_type ) = @_; #Validate the call method unless ($self and ref($self) and ref($self) =~ /^GeneTargeting::DBSQL::/) { confess "Invocation error"; } return unless $id_list_or_id; my $aptr_privacy = $self->DBAdaptor->privacy; print STDERR "filter_ids_by_privacy - called with privacy set to: " , $self->DBAdaptor->privacy, "\n" if $debug_privacy; #Check if this/specifed type of object has privacy my $aptr_type = ref($self); my $dbentry_type; if ($explict_aptr_type) { $dbentry_type = map_adaptor_type_to_dbentry($explict_aptr_type); } else { $dbentry_type = map_adaptor_type_to_dbentry($aptr_type); } unless (defined($GeneTargeting::Defs::default_object_privacy{$dbentry_type})) { confess "No privacy for: $aptr_type ($dbentry_type)\n"; } #Convert to an id list my $id_list = []; my $passed_type = ref($id_list_or_id); if ($passed_type eq 'ARRAY') { $id_list = $id_list_or_id; } elsif ($id_list_or_id >= 1) { push (@$id_list, $id_list_or_id); } else { confess "Error with passed list/id"; } #Do the filtering my $pruned = 0; my $filtered_id_list = []; foreach my $id (@$id_list) { my $obj_privacy = $self->get_privacy_by_type_obj_db_id($dbentry_type, $id); print STDERR " Fetched Obj: $dbentry_type, id: $id, privacy: $obj_privacy\n" if $debug_privacy; if ($aptr_privacy >= $obj_privacy) { push (@$filtered_id_list, $id); } else { $pruned++; } } $self->DBAdaptor->privacy_filtered($pruned); print STDERR " Total pruned: $pruned\n" if $debug_privacy; #Workout what/how to return if ($passed_type eq 'ARRAY') { return $filtered_id_list; } elsif (@$filtered_id_list) { return $filtered_id_list->[0]; } else { return; } }
filter_ids_by_taxon_id
Given a listref of dbIDs (which one would expect to be present in the gene_id column of the gene table) filter them by their os_code, returning the filtered list by reference, or undef should none match. Checks that a listref is passed, and the os_code is known to the system else confesses. Using automagic guessing of object type by adaptor type my $filtered_ids = $my_aptr->filter_ids_by_taxon_id($ids, 10090); or using explicit object typing in case we're testing more than one type.
my $filtered_ids = $my_aptr->filter_ids_by_taxon_id($ids, 10090, "GeneTargeting::DBEntry::Gene"); or my $filtered_ids = $my_aptr->filter_ids_by_taxon_id($ids, 10090, ref($my_gene));
Note: The type parameter is optional.
sub filter_ids_by_taxon_id { my ( $self, $ids, $os_code, $object_type ) = @_; unless ($ids and ref($ids) =~ /ARRAY/) { confess "Must pass an array reference to a list of ids"; } return unless @$ids; unless ($os_code and verify_known_taxon_id($os_code)) { confess "Must pass a valid tax_id"; } unless ($object_type) { $object_type = map_adaptor_type_to_dbentry(ref($self)); unless ($object_type) { confess "filter_ids_by_taxon_id is unable to guess the object type"; } } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $ids_txt = join(',', @$ids); my $sth_text = qq{ SELECT distinct ooc.obj_db_id FROM object_os_code ooc, cv_gt_os_code cgoc, cv_gt_object_type cgot WHERE ooc.obj_db_id IN ($ids_txt) AND ooc.obj_db_object_type_id = cgot.id AND ooc.os_code_id = cgoc.id AND cgoc.name = ? AND cgot.name = ? }; my $sth = $dba->dbh->prepare($sth_text); my @filtered_ids; $sth->execute($os_code, $object_type); while (my @rows = $sth->fetchrow) { push (@filtered_ids, @rows); } if (@filtered_ids) { return\@ filtered_ids; } else { return; } }
filter_objects_by_privacy
Given a single object or a list ref of objects, filters them by Adaptor privacy, returning a list ref (if initially passed one), or the object, or undef (should it have been filtered out by privacy)
sub filter_objects_by_privacy { my ( $self, $obj_list_or_obj, $explict_aptr_type ) = @_; #Validate the call method unless ($self and ref($self) and ref($self) =~ /^GeneTargeting::DBSQL::/) { confess "Invocation error"; } return unless $obj_list_or_obj; my $aptr_privacy = $self->DBAdaptor->privacy; print STDERR "filter_objects_by_privacy - called with privacy set to: " , $self->DBAdaptor->privacy, "\n" if $debug_privacy; #Check if this/specifed type of object has privacy my $aptr_type = ref($self); my $dbentry_type; if ($explict_aptr_type) { $dbentry_type = map_adaptor_type_to_dbentry($explict_aptr_type); } else { $dbentry_type = map_adaptor_type_to_dbentry($aptr_type); } unless (defined($GeneTargeting::Defs::default_object_privacy{$dbentry_type})) { confess "No privacy for: $aptr_type ($dbentry_type)\n"; } #Convert to an object list my $obj_list = []; my $passed_type = ref($obj_list_or_obj); if ($passed_type =~ /^GeneTargeting::DBEntry::/) { push(@$obj_list, $obj_list_or_obj); } elsif ($passed_type eq 'ARRAY') { $obj_list = $obj_list_or_obj; } else { confess "Error with passed list/object"; } #Do the filtering my $pruned = 0; my $filtered_obj_list = []; foreach my $obj (@$obj_list) { unless (ref($obj) eq $dbentry_type) { confess "Types dont match '$dbentry_type' and '" . ref($obj) . "'"; } my $obj_privacy = $self->get_privacy_by_type_obj_db_id($dbentry_type, $obj->id); print STDERR " Fetched Obj: $dbentry_type, id: ", $obj->id, ", privacy: $obj_privacy\n" if $debug_privacy; if ($aptr_privacy >= $obj_privacy) { $obj->private($obj_privacy); push (@$filtered_obj_list, $obj); } else { $pruned++; } } $self->DBAdaptor->privacy_filtered($pruned); print STDERR " Total pruned: $pruned\n" if $debug_privacy; #Workout what/how to return if ($passed_type eq 'ARRAY') { return $filtered_obj_list; } elsif (@$filtered_obj_list) { return $filtered_obj_list->[0]; } else { return; } }
filter_stable_ids_by_privacy
sub filter_stable_ids_by_privacy { confess "Need to be written\n"; }
get_adaptor_by_dbentry_type
TODO: Needs to be written
sub get_adaptor_by_dbentry_type { my ( $self, $type) = @_; confess "Must pass a type string starting: GeneTargeting::DBEntry::" unless $type; #Auto-verified, or confesses my $obj_type = strip_dbentry_type_prefix($type); my $dba = $self->DBAdaptor or confess; my $aptr; if ($obj_type eq 'Allele') { $aptr = $dba->get_AlleleAdaptor or confess "Couldn't get AlleleAdaptor"; } elsif ($obj_type eq 'Colony') { $aptr = $dba->get_ColonyAdaptor or confess "Couldn't get ColonyAdaptor"; } elsif ($obj_type eq 'Disease') { $aptr = $dba->get_DiseaseAdaptor or confess "Couldn't get DiseaseAdaptor"; } elsif ($obj_type eq 'Experiment') { $aptr = $dba->get_ExperimentAdaptor or confess "Couldn't get ExperimentAdaptor"; } elsif ($obj_type eq 'Gene') { $aptr = $dba->get_GeneAdaptor or confess "Couldn't get GeneAdaptor"; } elsif ($obj_type eq 'GeneList') { $aptr = $dba->get_GeneListAdaptor or confess "Couldn't get GeneList Adaptor"; } elsif ($obj_type eq 'Vector') { $aptr = $dba->get_VectorAdaptor or confess "Couldn't get Vector Adaptor"; } else { confess "Don't know how to get Adaptor for obj_type: '$type'"; } return $aptr; }
get_dates_for_object
Given a GeneTargeting::DBEntry object fetches the dates for it stored in the object_date table, setting the following attributes (should a row have been fetched):
$obj->date_created(); $obj->actual_date(); #If if previously set $obj->date_modified; my $status = $my_aptr->get_dates_for_object($obj);
Returns true if the object date attributes were set.
sub get_dates_for_object { my ( $self, $obj ) = @_; #Verify passed object unless ($obj and ref($obj) and $obj->isa("GeneTargeting::DBEntry")) { confess "Expected a GeneTargeting::DBEntry:: object"; } confess "id not set for: " . Dumper($obj) unless $obj->id; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT created , actual , modified FROM object_date WHERE obj_db_id = ? AND obj_db_object_type_id = ? }); my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value( $obj , 'object_type' , ref($obj) ) or confess "Invalid object_type found by get_dates_for_object: " . Dumper($obj); $sth->execute( $obj->id() , $object_type_cvi->id() ); # See if we have a row in the object_date table # return if not my ( $created , $actual , $modified ) = $sth->fetchrow(); return unless $created; $created = convert_mysql_date_string_to_date_string($created); $actual = convert_mysql_date_string_to_date_string($actual); $modified = convert_mysql_date_string_to_date_string($modified); $obj->date_created($created); $obj->actual_date($actual) if $actual; $obj->date_modified($modified); return 1; }
get_db_id_obj_type_for_stable_id
Given a stable_id, checks if its present in the database. If so it returns the db id and full-qualified object type my ($id, $type) = get_db_id_obj_type_for_stable_id($stable_id); Privacy is respected.
sub get_db_id_obj_type_for_stable_id { my ( $self, $required ) = @_; confess "Must pass a stable_id" unless $required; return unless validate_g2c_stable_id_not_fatal($required); #Confesses on failure; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT os.obj_db_id , cv.name FROM object_stable_id os , cv_gt_object_type cv WHERE cv.id = os.obj_db_object_type_id AND obsolete = 0 AND stable_id= ? }); $sth->execute($required); my ($id, $obj_type) = $sth->fetchrow; return unless $id; my $aptr = $self->get_adaptor_by_dbentry_type($obj_type); if ($aptr->filter_ids_by_privacy($id)) { return ($id, $obj_type); } return; }
get_next_stable_id
Generates G2C stable identifiers in sequence, fetching from the stable_id_count table to determine the next one in the sequence for a particular identifier type, which is determined by the checking the class ('xxxx') of the GeneTargeting::DBSQL::xxxxAdaptor from which the method has been called. For this to work there must be an entry of that type in the stable_id_count table (controlled by an ENUM).
sub get_next_stable_id { my ( $self ) = @_; unless ($self and ref($self) and ref($self) =~ /^GeneTargeting::DBSQL/) { confess "Error"; } my $adaptor_type = ref($self); my $object_type = substr($adaptor_type, rindex($adaptor_type, ':') + 1); $object_type =~ s/Adaptor$// or confess "Error"; $object_type = 'GeneTargeting::DBEntry::' . $object_type; my $prefix = $GeneTargeting::Defs::stable_id_prefixes_by_object_type{$object_type} or confess "The '$object_type' type doesnt support stable_ids"; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth_lock = $dba->dbh->prepare(q{ LOCK TABLE stable_id_count WRITE }); $sth_lock->execute(); my $sth_unlock = $dba->dbh->prepare(q{ UNLOCK TABLES }); my $sth_count = $dba->dbh->prepare(q{ SELECT count from stable_id_count WHERE type = ? }); $sth_count->execute($object_type); my $count = $sth_count->fetchrow; unless (defined($count)) { $sth_unlock->execute(); confess "Error couldnt get count for '$adaptor_type'"; } $count++; my $sth_update = $dba->dbh->prepare(q{ UPDATE stable_id_count SET count = ? WHERE type = ? }); $sth_update->execute($count, $object_type); my $row_count = $sth_update->rows; unless ($row_count and ($row_count == 1)) { $sth_unlock->execute(); confess "Failed to update count for '$adaptor_type'"; } $sth_unlock->execute(); my $stable_id = $prefix . '0' x (8 - length($count)) . $count; return $stable_id; }
get_privacy
Get's the current privacy value for this Object.
sub get_privacy { my ( $self, $obj ) = @_; my $obj_dbid = $self->_get_obj_dbid($obj); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; print STDERR "get_privacy - called from ", ref($self) , " with a ", ref($obj), "\n" if $debug_privacy; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by get_privacy " . ref($obj); my $sth = $dba->dbh->prepare(q{ SELECT private FROM object_privacy WHERE obj_db_id = ? AND obj_db_object_type_id = ? }); $sth->execute( $obj_dbid , $object_type_cvi->id()); my ($private) = $sth->fetchrow() or confess "No value found for object id: $obj_dbid " . " type:" . ref($obj); $obj->private($private); return $private; }
get_privacy_by_type_obj_db_id
Todo: document me!
sub get_privacy_by_type_obj_db_id { my ( $self, $type, $obj_db_id ) = @_; confess "Must pass a type" unless $type; confess "Invalid DBEntry type '$type'" unless $GeneTargeting::Defs::object_types{$type}; confess "Must pass an obj_db_id" unless $obj_db_id; print STDERR "get_privacy_by_type_obj_db_id - called from ", ref($self) , " with type: '$type' obj_db_id: '$obj_db_id'\n" if $debug_privacy; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($type, 'object_type', $type) or confess "Invalid object_type found by get_privacy_by_type_obj_db_id " . $type; my $sth = $dba->dbh->prepare(q{ SELECT private FROM object_privacy WHERE obj_db_id = ? AND obj_db_object_type_id = ? }); $sth->execute($obj_db_id, $object_type_cvi->id()); my ($private) = $sth->fetchrow() or confess "No value found for object id: '$obj_db_id'" . " type: '$type'"; return $private; }
has_privacy
Checks to see if the object has a privacy setting.
sub has_privacy { my ( $self, $obj ) = @_; print STDERR "has_privacy - called from ", ref($self) , " with a ", ref($obj), "\n" if $debug_privacy; my $obj_dbid = $self->_get_obj_dbid($obj); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT private FROM object_privacy WHERE obj_db_id = ? AND obj_db_object_type = ? }); $sth->execute($obj_dbid, ref($obj) ); my ($private) = $sth->fetchrow(); unless (defined($private)) { return; } return 1; }
new
sub new { my( $pkg ) = @_; return bless {}, $pkg; }
store (PRIVACY AWARE)
This store method wraps the _store methods of the specific object adaptors It:
Validates os_codes for the passed object Stores the object Stores privacy for the object Calls: store_os_codes_from_object Calls: store_object_dates
sub store { my ( $self, $obj, @params ) = @_; $self->validate_os_codes_for_object($obj); $self->_store($obj, @params); $self->store_privacy($obj); $self->store_os_codes_from_object($obj); $self->store_object_dates($obj); }
store_cohort_test (PRIVACY AWARE)
This store_cohort_test method sets privacy.
sub store_cohort_test { my ( $self, $obj, @params ) = @_; $self->_store_cohort_test($obj, @params); $self->store_privacy($obj); }
store_notes_from_object
Takes a subtype object of GeneTargeting::DBEntry, and a short text note (255 or less chars) and records in the database. When the note is stored a timestamp is also recorded to assist with ordering any later queries. Confesses if the supplied object is not a subtype of GeneTargeting::DBEntry, or if it is, but does not have it's dbid set. Inserts into the object_note table if all is well. param $obj - a dbentry subtype object with some notes attached confesses if you try and store a Note object with notes attached...
sub store_notes_from_object { my ( $self, $obj ) = @_; unless ($obj && ref($obj) && $obj->isa("GeneTargeting::DBEntry")) { confess "Expected a DBEntry subtype object"; } if ($obj->isa("GeneTargeting::DBEntry::Note")) { confess "Unable to store notes for Note objects"; } unless ($obj->id()) { confess "Supplied DBEntry must have a dbid set"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by store_notes_from_object " . ref($obj); foreach my $note (@{$obj->get_all_notes()}) { my $sth = $dba->dbh->prepare(q{ INSERT INTO object_note ( object_note_id, obj_db_id, obj_db_object_type_id, note_text, datestamp ) VALUES (null, ?, ?, ?, now()) }); $sth->execute( $obj->id(), $object_type_cvi->id(), $note->note_text() ); my $obj_id = $sth->{'mysql_insertid'} or confess "Unable to get mysql_insertid"; $note->id($obj_id); } }
store_object_dates
Expects a GeneTargeting::DBEntry object ($obj) that has had its id set (ie already stored in the database). Writes a row in the object_date table, setting created, and modified to the current date (as returned by the MySQL server). If $obj->actual_date is set, then it will be stored in the row, else 'actual' is set to NULL.
$my_aptr->store_object_dates($obj);
Before attemping the INSERT, does a SELECT to check if a row already exists for the object (by obj_db_id and obj_db_object_type_id), confessing if there is a match. Before returning sets: $obj->created_date $obj->modified_date
sub store_object_dates { my ( $self, $obj ) = @_; #Verify passed object unless ($obj and ref($obj) and $obj->isa("GeneTargeting::DBEntry")) { confess "Expected a GeneTargeting::DBEntry:: object"; } confess "id not set for: " . Dumper($obj) unless $obj->id; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess 'Invalid object_type found: ' . ref($obj); my $mysql_actual_date = convert_date_string_to_mysql_date_string( $obj->actual_date()); #Check if object has dates already stored my $object_date_id = $self->_get_obj_date_id($obj->id, $object_type_cvi->id); if ($object_date_id) { confess q[object of type '] . ref($obj) . q[' already has dates stored] . qq[ with object_date_id '$object_date_id': ] . Dumper($obj); } #If not, do the insert my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ INSERT INTO object_date ( object_date_id , obj_db_id , obj_db_object_type_id , created , actual , modified ) VALUES ( null , ? , ? , now() , ? , now() ) }); $sth->execute( $obj->id() , $object_type_cvi->id() , $mysql_actual_date ); my $obj_id = $sth->{'mysql_insertid'} or confess "Unable to get mysql_insertid"; $self->get_dates_for_object($obj); return 1; }
store_os_codes_from_object
Given a GeneTargeting::DBEntry object, stores its os_code(s), returning a count of how many were stored Confesses if the supplied object is not a GeneTargeting::DBEntry, or doesnt have its id set. Carps if no os_codes are attached to the passed object
sub store_os_codes_from_object { my ( $self, $obj ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); #Passed object validation my $obj_id = $self->_get_obj_dbid($obj); my $store_count = 0; unless ($obj->get_all_os_codes) { #carp "No os_codes attached to: " . Dumper($obj) . "\n"; return $store_count; } my $ins_sth = $dba->dbh->prepare(q{ INSERT INTO object_os_code ( object_os_code_id, obj_db_id, obj_db_object_type_id, os_code_id ) VALUES (NULL, ?, ?, ?) }); foreach my $os_code (@{$obj->get_all_os_codes()}) { my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by store_os_codes_from_object " . ref($obj); my $os_code_cvi = $cv->get_cv_item_for_obj_field_value(ref($obj), 'os_code', $os_code) or confess "Invalid os_code found by store_os_codes_from_object " . $os_code; $ins_sth->execute( $obj_id , $object_type_cvi->id , $os_code_cvi->id ); my $object_os_code_id = $ins_sth->{'mysql_insertid'} or confess "Unable to get mysql_insertid"; $store_count++; } return $store_count; }
store_privacy
Give a GeneTargeting::DBEntry object, stores its privacy attribute which must be set prior to the call, otherwise a fatal error occurs. The insert will raise an error on the db server if privacy has already been stored for the object. Can be called from any adaptor subtype of GeneTargeting::DBSQL
$aptr->store_privacy($db_entry);
sub store_privacy { my ( $self, $obj ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $obj_id = $self->_get_obj_dbid($obj); #This will die if not set my $obj_type = ref($obj) or confess "Not an object"; unless ($GeneTargeting::Defs::object_types{$obj_type}) { confess "Unknown Object type: '$obj_type'"; } #This will blow up if Obj type is not permitted privacy my $private = $obj->private; print STDERR "store_privacy - called from ", ref($self) , " with a $obj_type, with id: '$obj_id'\n" if $debug_privacy; unless (defined ($obj->private())) { Carp::croak("Unable to store: Privacy not set in object of type:" . ref($obj) . ", with dbid:" . $obj->id()); } my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by store_privacy " . ref($obj); my $sth = $dba->dbh->prepare(q{ INSERT INTO object_privacy ( obj_db_id , obj_db_object_type_id , private) VALUES (?,?,?) }); $sth->execute( $obj_id , $object_type_cvi->id() , $private ); my $row_count = $sth->rows; unless ($row_count and $row_count == 1) { confess "No rows added"; } print STDERR " row stored in object_privacy, privacy '$private'\n" if $debug_privacy; }
store_synonyms_for_object
Stores synonyms belonging to the supplied object, but checks to see if they are already there first, and skips storing any duplicates. param - takes a valid DBEntry subtype - note the dbid must be set in this obj.
sub store_synonyms_for_object { my ( $self, $obj ) = @_; unless ($obj && ref($obj) && ref($obj) =~ /^GeneTargeting::DBEntry::/) { confess "Expected a DBEntry subtype object"; } unless ($obj->id()) { confess "Supplied DBEntry subtype must have an id set"; } #Do we have synonyms to store? my $synonyms = $obj->get_all_synonyms(); unless ($synonyms) { carp "Supplied object has no synonyms to store - " . ref($obj); return; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by _insert_object_stable_id " . ref($obj); foreach my $synonym (@$synonyms) { if (length($synonym) > 128) { carp "SKIPPING - Synonym is too long - '$synonym'"; next; } #Has this object already got this synonym? my $chk_syn_id_sth = $dba->dbh->prepare(q{ SELECT object_synonym_id FROM object_synonym WHERE obj_db_id = ? AND obj_db_object_type_id = ? AND synonym = ? }); $chk_syn_id_sth->execute($obj->id(), $object_type_cvi->id(), $synonym); my $fetched_syn_id = $chk_syn_id_sth->fetchrow(); unless ($fetched_syn_id) { my $ins_syn_sth = $dba->dbh->prepare(q{ INSERT INTO object_synonym ( object_synonym_id, obj_db_id, obj_db_object_type_id, synonym ) VALUES (null,?,?,?) }); $ins_syn_sth->execute($obj->id(), $object_type_cvi->id(), $synonym); } } }
update_object_dates
Expects a GeneTargeting::DBEntry object ($obj) that has had its id set (ie already stored in the database). Checks that the object has an appropriate row in the object_date table (by obj_db_id and obj_db_object_type_id), confessing if not, else does an UPDATE on the 'actual' and 'modified' columns. Uses $obj->actual_date for the former, and the current date (as returned by the MySQL server) for modified.
$my_aptr->update_object_dates($obj);
sub update_object_dates { my ( $self, $obj ) = @_; #Verify passed object unless ($obj and ref($obj) and $obj->isa("GeneTargeting::DBEntry")) { confess "Expected a GeneTargeting::DBEntry:: object"; } confess "id not set for: " . Dumper($obj) unless $obj->id; my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess 'Invalid object_type found: ' . ref($obj); my $mysql_actual_date = convert_date_string_to_mysql_date_string( $obj->actual_date()); #Check if object has dates already stored my $object_date_id = $self->_get_obj_date_id($obj->id, $object_type_cvi->id); unless ($object_date_id) { confess q[object of type '] . ref($obj) . q[' with db_id '] . $obj->id . q[' does not have dates set: ] . Dumper($obj); } #Do the UPDATE my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ UPDATE object_date SET actual = ? , modified = now() WHERE obj_db_id = ? AND obj_db_object_type_id = ?}); $sth->execute( $mysql_actual_date , $obj->id() , $object_type_cvi->id() ); $self->get_dates_for_object($obj); return 1; }
update_privacy
Updates the previously stored privacy for a GeneTargeting::DBEntry object. Can be called from any adaptor subtype of GeneTargeting::DBSQL
$aptr->update_privacy($db_entry);
sub update_privacy { my ( $self, $obj ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $obj_id = $self->_get_obj_dbid($obj); #This will die if not set my $obj_type = ref($obj) or confess "Not an object"; unless ($GeneTargeting::Defs::object_types{$obj_type}) { confess "Unknown Object type: '$obj_type'"; } #This will blow up if Obj type is not permitted privacy my $private = $obj->private; print STDERR "update_privacy - called from ", ref($self) , " with a ", ref($obj), "\n" if $debug_privacy; unless (defined ($obj->private())) { Carp::croak("Unable to update: Privacy not set in object of type:" . ref($obj) . ", with dbid:" . $obj->id()); } my $cv = GeneTargeting::DBEntry::get_ControlledVocabulary(); my $object_type_cvi = $cv->get_cv_item_for_obj_field_value($obj, 'object_type', ref($obj)) or confess "Invalid object_type found by update_privacy " . ref($obj); my $sth = $dba->dbh->prepare(q{ UPDATE object_privacy SET private = ? WHERE obj_db_id = ? AND obj_db_object_type_id = ? }); $sth->execute( $private , $obj_id , $object_type_cvi->id() ); my $row_count = $sth->rows; unless ($row_count and $row_count == 1) { confess "No rows changed"; } else { print STDERR " privacy updated to: '$private'\n" if $debug_privacy; } }
validate_os_codes_for_object
Validates presence and absence of os_codes in DBEntry subtype instance:
(1) Is object allowed to have os_code(s)? (2) Must object have 1 or more os_codes? (3) Is the object allowed multiple os_codes?
Rules are hardcoded in GeneTargeting::Defs
%object_types_that_must_not_have_os_code (1) %object_types_that_must_have_os_code (2) %object_types_allowed_multiple_os_codes (3)
A fatal error is thrown if any of the rules are broken
sub validate_os_codes_for_object { my ( $self, $obj ) = @_; unless ($obj && ref($obj) && $obj->isa("GeneTargeting::DBEntry")) { confess "Expected a DBEntry subtype object"; } my $obj_type = ref($obj); my $os_code_count = 0; if ($obj->get_all_os_codes) { $os_code_count = @{$obj->get_all_os_codes}; } #Is object allowed to have os_code(s)? if ($os_code_count and $GeneTargeting::Defs::object_types_that_must_not_have_os_code{$obj_type}) { confess "Object of type '$obj_type' not permitted to have os_code"; } #Must object have 1 or more os_codes? if ($os_code_count == 0 and $GeneTargeting::Defs::object_types_that_must_have_os_code{$obj_type}) { confess "Object of type '$obj_type' must have an os_code"; } #Is the object allowed multiple os_codes? if ($os_code_count > 1) { unless ($GeneTargeting::Defs::object_types_allowed_multiple_os_codes{$obj_type}) { confess "Object of type '$obj_type' not allowed multiple os_codes"; } } return 1; }
GeneTargeting::DBSQL::ConfAdaptor
- Inherit
- GeneTargeting::DBSQL::BaseAdaptor
- Description
- Database adaptor for storing and fetching GeneTargeting::DBEntry::Conf objects.
- Included modules
- Carp
- Usage
my $conf = GeneTargeting::DBEntry::Conf::Exonerate->new; $conf->name('Exonerate_mouse_NCBIM33'); $conf->description('Search against mouse genome NCBI33 assembly'); $conf->args('--bestn 1'); $conf_aptr->store($conf); my $conf = $conf_aptr->fetch_by_db_id(1); my $conf = $conf_aptr->fetch_by_name('Exonerate_mouse_NCBIM33');
- Constructor
my $dba = GeneTargeting::DBSQL::DBAdaptor->new; my $conf_aptr = $dba->get_ConfAdaptor() or confess "Could not get ConfAdaptor";
Methods
_fetch_Conf
sub _fetch_Conf { my( $self, $sth ) = @_; my ( $conf_id , $conf_name , $conf_class , $conf_description , $conf_text ) = $sth->fetchrow; if ($conf_id) { my $Conf = $conf_class->new; $Conf->id($conf_id); $Conf->name($conf_name); $Conf->description($conf_description); $Conf->text($conf_text); return $Conf; } return; }
debug
Switch debug output on/off in the ConfAdaptor
$conf_aptr->debug(1|0)
Debugging is switched on if the value passed is true
sub debug { my ( $self, $debug ) = @_; if (defined($debug)) { $self->{_genetargeting_dbsql_confadaptor_debug} = $debug; } return $self->{_genetargeting_dbsql_confadaptor_debug}; }
fetch_by_Job_id
my $conf = $conf_aptr->fetch_by_Job_id(1);
sub fetch_by_Job_id { my( $self, $required ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT c.conf_id , c.conf_name , c.conf_class , c.conf_description , c.conf_text FROM conf c , job j WHERE j.conf_id = c.conf_id AND j.job_id = ? }); $sth->execute($required); my $conf = $self->_fetch_Conf($sth); if ($self->debug and !$conf) { carp "Failed to fetch Conf with fetch_by_Job_id '$required'"; } return $conf; }
fetch_by_db_id
my $conf = $conf_aptr->fetch_by_db_id(1);
sub fetch_by_db_id { my( $self, $required ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT conf_id , conf_name , conf_class , conf_description , conf_text FROM conf WHERE conf_id = ? }); $sth->execute($required); my $conf = $self->_fetch_Conf($sth); if ($self->debug and !$conf) { carp "Failed to fetch Conf with fetch_by_db_id '$required'"; } return $conf; }
fetch_by_name
my $conf = $conf_aptr->fetch_by_name('Exonerate_mouse_NCBIM33');
sub fetch_by_name { my( $self, $required ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT conf_id , conf_name , conf_class , conf_description , conf_text FROM conf WHERE conf_name = ? }); $sth->execute($required); my $conf = $self->_fetch_Conf($sth); if ($self->debug and !$conf) { carp "Failed to fetch Conf with fetch_by_name '$required'"; } return $conf; }
store
$conf_aptr->store($conf);
Given a Conf object of class GeneTargeting::DBEntry::Conf, stores it in the database. Confesses on failure
sub store { my( $self, $Conf ) = @_; confess "Not an GeneTargeting::DBEntry::Conf" unless $Conf->isa("GeneTargeting::DBEntry::Conf"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "id already set" if $Conf->id; my $conf_name = $Conf->name or confess "name not set"; my $conf_text = $Conf->text or confess "text not set"; my $conf_description = $Conf->description; my $conf_class = ref($Conf); my $sth = $dba->dbh->prepare(q{ INSERT conf (conf_id , conf_name , conf_class , conf_description , conf_text ) VALUES (NULL , ? , ? , ? , ? ) }); $sth->execute($conf_name , $conf_class , $conf_description , $conf_text ); my $id = $sth->{'mysql_insertid'} or confess "Couldn't get mysql_insertid"; $Conf->id($id); }
GeneTargeting::DBSQL::DBAdaptor
- Description
- DBAdaptor for the GeneTargeting MySQL analysis database.
my $dba = GeneTargeting::DBSQL::DBAdaptor->new; $dba->host($host); $dba->db($db); $dba->user($user); $dba->pass($pass); $dba->privacy($privacy) $dba->dbh; #To actually make the connection
The method names are pretty self-explanatory. - Call the various get_Adaptor methods to get specific DBAdaptors allowing one to store and retrieve the various GeneTargeting::DBEntry:: objects from the database e.g.
my $seq_aptr = $dba->get_SequenceAdaptor();
Connecting to the database with $dba->dbh causes controlled vocabulary information to be read from the database, which is cached in the GeneTargeting::DBEntry module (this doesnt happen if $dba->db =~ /login/i) - Included modules
- Carp
- DBI
- GeneTargeting::ControlledVocabulary
- GeneTargeting::DBSQL::ConfAdaptor
- GeneTargeting::DBSQL::DNAProbeAdaptor
- GeneTargeting::DBSQL::ExternalDBAdaptor
- GeneTargeting::DBSQL::HitAdaptor
- GeneTargeting::DBSQL::JobAdaptor
- GeneTargeting::DBSQL::SequenceAdaptor
- GeneTargeting::DBSQL::SequenceHitAdaptor
- GeneTargeting::DBSQL::XrefAdaptor
- GeneTargeting::Defs
- GeneTargeting::Utils qw ( map_dbentry_type_to_adaptor set_taxon_dbh )
Methods
DESTROY
sub DESTROY { my ( $self ) = @_; if (my $dbh = $self->{'_genetargeting_dbsql_dbh'}) { $dbh->disconnect; } }
db
Name of the database to connect to on the MySQL server
sub db { my ( $self, $db ) = @_; if ($db) { $self->{'_genetargeting_dbsql_db'} = $db; } return $self->{'_genetargeting_dbsql_db'}; }
dbh
Method used to connect to the database, and get the database handle, also initalises the controlled vocabulary system by calling GeneTargeting::DBEntry::initalise_ControlledVocabulary Connecting to a database by calling $dba->dbh, causes the API to pick up controlled vocabulary information from the databasse. To stop this happening when connecting to the login database, this method checks $dba->db =~ /login/i, if its true, then cv pick-up is skipped.
sub dbh { my ( $self ) = @_; my $dbh; unless ($dbh = $self->{'_genetargeting_dbsql_dbh'}) { my $host = $self->host; my $port = $self->port; my $user = $self->user; my $db = $self->db; my $pass = $self->pass; my $privacy = $self->privacy; confess "No host specified" unless ($host); confess "No db specified" unless ($db); confess "No user specified" unless ($user); # Make the database connection my $dsn = "DBI:mysql:database=$db;host=$host;port=$port"; my $dbh = DBIconnect($dsn, $user, $pass, {'RaiseError' => 1}); $self->{'_genetargeting_dbsql_dbh'} = $dbh; if ($self->can('initialise')) { $self->initialise; } #This prevents connecting to the login database picking up #And potentially overwriting the cached controlled vocabulary #Information, or failing if cv tables are not present in the #Login database #unless ($db =~ /login|xref/i) { unless ($db =~ /login/i) { my $cv = GeneTargeting::ControlledVocabulary->init($self); GeneTargeting::DBEntry::initalise_ControlledVocabulary($cv); set_taxon_dbh($dbh); } } return $dbh; }
debug
Turn debugging on or off with ->debug(0) or ->debug(1) Actually not currently used by the module.
sub debug { my ( $self, $debug ) = @_; confess "dont call me"; if (defined($debug)) { GeneTargeting::DBSQL::BaseAdaptor->debug('all'); } return GeneTargeting::DBSQL::BaseAdaptor->debug($self); }
debug_privacy
sub debug_privacy { my ( $self, $privacy ) = @_; #Actually its stored in the BaseAdaptor; if (defined($privacy)) { GeneTargeting::DBSQL::BaseAdaptor->debug_privacy($privacy); } return GeneTargeting::DBSQL::BaseAdaptor->debug_privacy($privacy); }
get_Adaptor_by_DBEntry
Given a GeneTargeting::DBEntry object or a scalar string or such a class type, returns an Adaptor to fetch that DBEntry subtype. Confesses if nothing is passed, or a suitable Adaptor type cant be determined by the mappings in GeneTargeting::Defs.pm
sub get_Adaptor_by_DBEntry { my ( $dba, $db_entry ) = @_; confess "Must pass a GeneTargeting::DBEntry object (or type)" unless $db_entry; my $type; if (ref($db_entry)) { $type = ref($db_entry); } else { $type = $db_entry; } unless ($type =~ /^GeneTargeting::DBEntry::/) { confess "Bad GeneTargeting::DBEntry object (or type) '$type'"; } my $adaptor_type = map_dbentry_type_to_adaptor($type) or confess "Could not get Adaptor type for '$type'"; my $get_aptr_method = $GeneTargeting::Defs::adaptor_to_get_adaptor_mapping{$adaptor_type} or confess "Could not get method for '$adaptor_type'"; my $aptr = $dba->$get_aptr_method() or confess "Could not get Adaptor for $type"; return $aptr; }
get_AddressAdaptor
Used to obtain a GeneTargeting::DBSQL::AddressAdaptor object
sub get_AddressAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_address_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_address_adaptor'} = GeneTargeting::DBSQL::AddressAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_AlleleAdaptor
Used to obtain a GeneTargeting::DBSQL::AlleleAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Allele objects from the database
sub get_AlleleAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_alleleadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_alleleadaptor'} = GeneTargeting::DBSQL::AlleleAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_AntibodyAdaptor
Used to obtain a GeneTargeting::DBSQL::AntibodyAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Antibody objects from the database
sub get_AntibodyAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_antibodyadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_antibodyadaptor'} = GeneTargeting::DBSQL::AntibodyAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_CohortAdaptor
Used to obtain a GeneTargeting::DBSQL::CohortAdaptor object
sub get_CohortAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_cohort_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_cohort_adaptor'} = GeneTargeting::DBSQL::CohortAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_ColonyAdaptor
Used to obtain a GeneTargeting::DBSQL::ColonyAdaptor object
sub get_ColonyAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_colony_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_colony_adaptor'} = GeneTargeting::DBSQL::ColonyAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_ConfAdaptor
Used to obtain a GeneTargeting::DBSQL::ConfAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Conf objects from the database
sub get_ConfAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_confadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_confadaptor'} = GeneTargeting::DBSQL::ConfAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_ContactAdaptor
Used to obtain a GeneTargeting::DBSQL::ContactAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Address/Person objects from the database
sub get_ContactAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_contactadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_contactadaptor'} = GeneTargeting::DBSQL::ContactAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_DNAProbeAdaptor
Used to obtain a GeneTargeting::DBSQL::get_DNAProbeAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::DNAProbe objects from the database
sub get_DNAProbeAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_dnaprobeadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_dnaprobeadaptor'} = GeneTargeting::DBSQL::DNAProbeAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_DiseaseAdaptor
Used to obtain a GeneTargeting::DBSQL::DiseaseAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Disease objects from the database
sub get_DiseaseAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_diseaseadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_diseaseadaptor'} = GeneTargeting::DBSQL::DiseaseAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_ExperimentAdaptor
Used to obtain a GeneTargeting::DBSQL::ExperimentAdaptor object, allowing one to store/fetch subtypes of GeneTargeting::DBEntry::Experiment into/from the database
sub get_ExperimentAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_experimentadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_experimentadaptor'} = GeneTargeting::DBSQL::ExperimentAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_ExternalDB2Adaptor
Used to obtain a GeneTargeting::DBSQL::ExternalDB2Adaptor object, allowing one to store and fetch GeneTargeting::DBEntry::ExternalDB2
sub get_ExternalDB2Adaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_externaldb2_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_externaldb2_adaptor'} = GeneTargeting::DBSQL::ExternalDB2Adaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_ExternalDBAdaptor
Used to obtain a GeneTargeting::DBSQL::ExternalDBAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::ExternalDBAdaptor objects from the database
sub get_ExternalDBAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_externaldbadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_externaldbadaptor'} = GeneTargeting::DBSQL::ExternalDBAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_GeneAdaptor
Used to obtain a GeneTargeting::DBSQL::GeneAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Gene objects from the database
sub get_GeneAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_geneadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_geneadaptor'} = GeneTargeting::DBSQL::GeneAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_GeneListAdaptor
Used to obtain a GeneTargeting::DBSQL::GeneListAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::GeneList objects and their links to GeneTargeting::DBEntry::Gene objects
sub get_GeneListAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_gene_list_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_gene_list_adaptor'} = GeneTargeting::DBSQL::GeneListAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_GeneLoadAdaptor
Used to obtain a GeneTargeting::DBSQL::GeneLoadAdaptor object
sub get_GeneLoadAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_gene_load_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_gene_load_adaptor'} = GeneTargeting::DBSQL::GeneLoadAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_HitAdaptor
Used to obtain a GeneTargeting::DBSQL::HitAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Hit objects from the database
sub get_HitAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_hitadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_hitadaptor'} = GeneTargeting::DBSQL::HitAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_JobAdaptor
Used to obtain a GeneTargeting::DBSQL::JobAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Job objects from the database
sub get_JobAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_jobadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_jobadaptor'} = GeneTargeting::DBSQL::JobAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_LiteratureAdaptor
Used to obtain a GeneTargeting::DBSQL::LiteratureAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Literature objects from the database
sub get_LiteratureAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_literatureadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_literatureadaptor'} = GeneTargeting::DBSQL::LiteratureAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_LoginAdaptor
Used to obtain a GeneTargeting::DBSQL::LoginAdaptor object, allowing one to fetch privacy details for users from the login database
sub get_LoginAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_loginadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_loginadaptor'} = GeneTargeting::DBSQL::LoginAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_PersonAdaptor (2)
Used to obtain a GeneTargeting::DBSQL::ProtocolAdaptor object
sub get_PersonAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_person_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_person_adaptor'} = GeneTargeting::DBSQL::PersonAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_ProtocolAdaptor
sub get_ProtocolAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_protocol_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_protocol_adaptor'} = GeneTargeting::DBSQL::ProtocolAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_ResourceAdaptor
Used to obtain a GeneTargeting::DBSQL::ResourceAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Resource objects from the database
sub get_ResourceAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_resourceadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_resourceadaptor'} = GeneTargeting::DBSQL::ResourceAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_SequenceAdaptor
Used to obtain a GeneTargeting::DBSQL::SequenceAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Sequence objects from the database
sub get_SequenceAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_sequenceadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_sequenceadaptor'} = GeneTargeting::DBSQL::SequenceAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_SequenceHitAdaptor
Used to obtain a GeneTargeting::DBSQL::SequenceHitAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::SequenceHit objects from the database
sub get_SequenceHitAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_sequencehitadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_sequencehitadaptor'} = GeneTargeting::DBSQL::SequenceHitAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_TextSearchAdaptor
Used to obtain a GeneTargeting::DBSQL::TextSearchAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::TextSearch objects from the database
sub get_TextSearchAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_textsearchadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_textsearchadaptor'} = GeneTargeting::DBSQL::TextSearchAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_VectorAdaptor
Used to obtain a GeneTargeting::DBSQL::VectorAdaptor object
sub get_VectorAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_vector_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_vector_adaptor'} = GeneTargeting::DBSQL::VectorAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_Xref2Adaptor
Used to obtain a GeneTargeting::DBSQL::Xref2Adaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Xref2 objects
sub get_Xref2Adaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_xref2_adaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_xref2_adaptor'} = GeneTargeting::DBSQL::Xref2Adaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
get_XrefAdaptor
Used to obtain a GeneTargeting::DBSQL::XrefAdaptor object, allowing one to store and fetch GeneTargeting::DBEntry::Xref objects from the database
sub get_XrefAdaptor { my ( $self ) = @_; my $adaptor; unless ($adaptor = $self->{'_genetargeting_dbsql_xrefadaptor'}) { $adaptor = $self->{'_genetargeting_dbsql_xrefadaptor'} = GeneTargeting::DBSQL::XrefAdaptor->new; $adaptor->DBAdaptor($self); } return $adaptor; }
host
Name of the MySQL host machine
sub host { my ( $self, $host ) = @_; if ($host) { $self->{'_genetargeting_dbsql_host'} = $host; } unless ($self->{'_genetargeting_dbsql_host'}) { $self->{'_genetargeting_dbsql_host'} = $ENV{'HOST'}; } return $self->{'_genetargeting_dbsql_host'}; }
new
sub new { my( $pkg ) = @_; return bless {}, $pkg; }
pass
Password for the user
sub pass { my ( $self, $passwd ) = @_; if ($passwd) { $self->{'_genetargeting_dbsql_passwd'} = $passwd; } return $self->{'_genetargeting_dbsql_passwd'}; }
port
Port for the MySQL server
sub port { my ( $self, $port ) = @_; if ($port) { $self->{'_genetargeting_dbsql_port'} = $port; } unless ($self->{'_genetargeting_dbsql_port'}) { $self->{'_genetargeting_dbsql_port'} = 3306; } return $self->{'_genetargeting_dbsql_port'}; }
privacy
Set the privacy level for the DBAdaptor. Defaults to 0 (public). Which means only public objects and db_ids are returned by the privacy-enabled DBSQL Adaptors Setting privacy to a value >0 enhances privilege in fetching objects and db_ids. If $dba->privacy >= that stored in the object_privacy table for the requested object/id, then it will be returned. Valid range are intergers values 0-1000 inclusive.
sub privacy { my ( $self, $privacy ) = @_; if (defined($privacy)) { if ($privacy < 0 or $privacy > 1000) { confess "Invalid privacy: '$privacy'"; } unless (int($privacy) == $privacy) { confess "privacy must be an integer: '$privacy'"; } $self->{'_genetargeting_dbsql_privacy'} = $privacy; } #return a default privacy of 0 (i.e. public) unless (defined($self->{'_genetargeting_dbsql_privacy'})) { $self->{'_genetargeting_dbsql_privacy'} = 0; } return $self->{'_genetargeting_dbsql_privacy'}; }
privacy_filtered
Was the last fetch privacy_filtered?
sub privacy_filtered { my ( $self, $privacy_filtered ) = @_; if (defined($privacy_filtered)) { $self->{'_genetargeting_dbsql_privacy_filtered'} = $privacy_filtered; } return $self->{'_genetargeting_dbsql_privacy_filtered'}; }
user
User name to use to connect to the MySQL server
sub user { my ( $self, $user ) = @_; if ($user) { $self->{'_genetargeting_dbsql_user'} = $user; } return $self->{'_genetargeting_dbsql_user'}; }
GeneTargeting::DBSQL::DNAProbeAdaptor
- Inherit
- GeneTargeting::DBSQL::BaseAdaptor
- Description
- Database adaptor for storing and fetching GeneTargeting::DBEntry::DNAProbe objects, and also the Sequence ids that are linked to the DNAProbe
- Included modules
- Carp
- Constructor
my $dba = GeneTargeting::DBSQL::DBAdaptor->new; my $job_aptr = $dba->get_DNAProbeAdaptor() or confess "Could not get DNAProbeAdaptor";
Methods
debug
Switch debug output on/off in the DNAProbeAdaptor $dnaprobe_aptr->debug(1|0) Debugging is switched on if the value passed is true
sub debug { my ( $self, $debug ) = @_; if (defined($debug)) { $self->{_genetargeting_dbsql_dnaprobeadaptor_debug} = $debug; } return $self->{_genetargeting_dbsql_dnaprobeadaptor_debug}; }
delete
Given a GeneTargeting::DBEntry::DNAProbe object deletes it, returns a count of how many rows were deleted which should normally by one. Confesses if the id of the DNAProbe is not set, or no object is passed.
my $row_count = $dnaprobe_aptr->delete($dna_probe);
sub delete { my ( $self, $object ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Not an GeneTargeting::DBEntry::DNAProbe" unless $object->isa("GeneTargeting::DBEntry::DNAProbe"); my $id = $object->id or confess "DNAProbe id not set"; my $sth = $dba->dbh->prepare(q{ DELETE FROM probe WHERE probe_id = ? }); $sth->execute($id); return $sth->rows; }
delete_ProbeSequence_links
Given an object of class GeneTargeting::DBEntry::DNAProbe deletes rows from the probe_hit table by the id of the DNAProbe passed. Returns a count of how many rows (if any) were deleted
my $count = $dnaprobe_aptr->delete_ProbeSequence_links($dna_probe);
sub delete_ProbeSequence_links { my ( $self, $object ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Not an GeneTargeting::DBEntry::DNAProbe" unless $object->isa("GeneTargeting::DBEntry::DNAProbe"); my $id = $object->id or confess "DNAProbe id not set"; my $sth = $dba->dbh->prepare(q{ DELETE FROM probe_sequence WHERE probe_id = ? }); $sth->execute($id); return $sth->rows; }
fetch_all
my $probes = $dnaprobe_aptr->fetch_all();
sub fetch_all { my ( $self ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT probe_id FROM probe }); $sth->execute(); my @probe_ids; while (my @rows = $sth->fetchrow) { push (@probe_ids, @rows); } return unless @probe_ids; my @probes; foreach my $probe_id (@probe_ids) { my $probe = $self->fetch_by_db_id($probe_id) or confess "Could not fetch DNAProbe by id: '$probe_id'"; push (@probes, $probe); } return\@ probes; }
fetch_by_db_id
my $dnaprobe = $dnaprobe_aptr->fetch_by_db_id(1);
sub fetch_by_db_id { my ( $self, $required ) = @_; confess "Must pass a probe id" unless $required; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT probe_id , name , description , assembly , chromosome , start , end , strand , end_bias FROM probe WHERE probe_id = ? }); $sth->execute($required); my ( $probe_id, , $name , $description , $assembly , $chromosome , $start , $end , $strand , $end_bias ) = $sth->fetchrow; if ($probe_id) { my $dnaprobe = GeneTargeting::DBEntry::DNAProbe->new; $dnaprobe->id($probe_id); $dnaprobe->name($name); $dnaprobe->description($description); $dnaprobe->assembly($assembly); $dnaprobe->chromosome($chromosome); $dnaprobe->start($start); $dnaprobe->end($end); $dnaprobe->strand($strand); $dnaprobe->end_bias($end_bias); return $dnaprobe; } else { if ($self->debug) { carp "Failed to fetch DNAProbe with fetch_by_db_id '$required'"; } return; } }
fetch_by_name
my $dnaprobe = $dnaprobe_aptr->fetch_by_name('5prime_probe1');
sub fetch_by_name { my ( $self, $required ) = @_; confess "Must pass a probe name" unless $required; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT probe_id , name , description , assembly , chromosome , start , end , strand , end_bias FROM probe WHERE name = ? }); $sth->execute($required); my ( $probe_id, , $name , $description , $assembly , $chromosome , $start , $end , $strand , $end_bias ) = $sth->fetchrow; if ($probe_id) { my $dnaprobe = GeneTargeting::DBEntry::DNAProbe->new; $dnaprobe->id($probe_id); $dnaprobe->name($name); $dnaprobe->description($description); $dnaprobe->assembly($assembly); $dnaprobe->chromosome($chromosome); $dnaprobe->start($start); $dnaprobe->end($end); $dnaprobe->strand($strand); $dnaprobe->end_bias($end_bias); return $dnaprobe; } else { if ($self->debug) { carp "Failed to fetch DNAProbe with fetch_by_db_id '$required'"; } return; } }
get_Sequence_ids
Used to obtain the Sequence ids comprising a particular job.
my $seq_ids = $probe_aptr->get_Sequence_ids($job);
Returns a reference to an array of Sequence ids or undef.
sub get_Sequence_ids { my ($self, $obj ) = @_; confess "GeneTargeting::DBEntry::DNAProbe" unless $obj->isa("GeneTargeting::DBEntry::DNAProbe"); my $obj_id = $obj->id or confess "job_id not set"; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT sequence_id FROM probe_sequence WHERE probe_id = ? }); $sth->execute($obj_id); my (@ids); while (my (@rows) = $sth->fetchrow) { push(@ids, @rows); } unless (@ids) { if ($self->debug) { carp "No ids fetched with get_Sequence_ids for DNAProbe id '$obj_id'"; } return; } return\@ ids; }
store
Given a DNAProbe object of class GeneTargeting::DBEntry::DNAProbe, stores it in the database. Confesses on failure
$dnaprobe_aptr->store($dnaprobe);
sub store { my( $self, $obj ) = @_; confess "Not an GeneTargeting::DBEntry::DNAProbe" unless $obj->isa("GeneTargeting::DBEntry::DNAProbe"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "DNAProbe id already set" if $obj->id; #Mandatory my $name = $obj->name or confess "name not set"; my $assembly = $obj->assembly or confess "assembly not set"; my $chromosome = $obj->chromosome or confess "chromosome not set"; my $start = $obj->start or confess "start not set"; my $end = $obj->end or confess "end not set"; my $strand = $obj->strand or confess "strand not set"; #Optional my $description = $obj->description; my $end_bias = $obj->end_bias; my $sth = $dba->dbh->prepare(q{ INSERT probe ( probe_id , name , description , assembly , chromosome , start , end , strand , end_bias ) VALUES (NULL , ? , ? , ? , ? , ? , ? , ? , ? ) }); $sth->execute($name , $description , $assembly , $chromosome , $start , $end , $strand , $end_bias ); my $obj_id = $sth->{'mysql_insertid'} or confess "Couldn't get mysql_insertid"; $obj->id($obj_id); }
store_DNAProbe_Sequence
Used to store a row in the probe_sequence table, adding a sequence to a DNAProbe (both keyed by their id)
$dnaprobe_aptr->store_DNAProbe_Sequence($dnaprobe, $seq);
Confesses upon failure.
sub store_DNAProbe_Sequence { my ( $self, $dnaprobe, $sequence ) = @_; confess "Must pass a GeneTargeting::DBEntry::DNAProbe" unless $dnaprobe; confess "Not a GeneTargeting::DBEntry::DNAProbe" unless $dnaprobe->isa("GeneTargeting::DBEntry::DNAProbe"); my $dnaprobe_id = $dnaprobe->id or confess "id not set for DNAProbe"; confess "Must pass a GeneTargeting::DBEntry::Sequence" unless $sequence; confess "Not a GeneTargeting::DBEntry::Sequence" unless $sequence->isa("GeneTargeting::DBEntry::Sequence"); my $sequence_id = $sequence->id or confess "id not set for Sequence"; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ INSERT probe_sequence ( probe_id , sequence_id ) VALUES (? , ? ) }); $sth->execute($dnaprobe_id, , $sequence_id ); my $row_count = $sth->rows; unless ($row_count and ($row_count == 1)) { confess "No row inserted into probe_sequence"; } return 1; }
GeneTargeting::DBSQL::ExernalDBAdaptor
- Inherit
- GeneTargeting::DBSQL::BaseAdaptor
- Description
- Database adaptor for storing and fetching GeneTargeting::DBEntry::ExternalDB objects.
- Included modules
- Carp
- Usage
my $ext_db = GeneTargeting::DBEntry::ExternalDB->new; $ext_db->db_name('test'); $ext_db->display_label('test_db'); $ext_db->sequence_source('obda::/crap'); $ext_db->description('description here'); $ext_db_aptr->store($seq); my $fetched_ext_db = $ext_db_aptr->fetch_by_db_id(1); my $fetched_ext_db = $ext_db_aptr->fetch_by_name('test');
- Constructor
my $dba = GeneTargeting::DBSQL::DBAdaptor->new; my $ext_db_aptr = $dba->get_ExternalDBAdaptor() or confess "Could not get ExternalDBAdaptor";
Methods
_fetch_ExternalDB
sub _fetch_ExternalDB { my( $self, $sth ) = @_; my ( $external_db_id , $db_name , $description , $display_label , $sequence_source ) = $sth->fetchrow; if ($external_db_id) { my $ExternalDB = GeneTargeting::DBEntry::ExternalDB->new; $ExternalDB->id($external_db_id); $ExternalDB->db_name($db_name); $ExternalDB->description($description); $ExternalDB->display_label($display_label); $ExternalDB->sequence_source($sequence_source); return $ExternalDB; } else { return; } }
debug
Switch debug output on/off in the JobAdaptor $job_aptr->debug(1|0) Debugging is switched on if the value passed is true
sub debug { my ( $self, $debug ) = @_; if (defined($debug)) { $self->{_genetargeting_dbsql_externaldbadaptor_debug} = $debug; } return $self->{_genetargeting_dbsql_externaldbadaptor_debug}; }
fetch_by_db_id
my $ext_db = $ext_db_aptr->fetch_by_db_id(3);
sub fetch_by_db_id { my ( $self, $required ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT external_db_id , db_name , description , display_label , sequence_source FROM external_db WHERE external_db_id = ? }); $sth->execute($required); my $ExternalDB = $self->_fetch_ExternalDB($sth); if ($self->debug and !$ExternalDB) { carp "Failed to fetch ExternalDB by id: '$required'"; } return $ExternalDB; }
fetch_by_name
sub fetch_by_name { my ( $self, $required ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT external_db_id , db_name , description , display_label , sequence_source FROM external_db WHERE db_name = ? }); $sth->execute($required); my $ExternalDB = $self->_fetch_ExternalDB($sth); if ($self->debug and !$ExternalDB) { carp "Failed to fetch ExternalDB by name: '$required'"; } return $ExternalDB; }
store
$dba->store($ExternalDB);
Given an ExternalDB object of class GeneTargting::DBEntry::ExternalDB, stores it in the database. Confesses on failure
sub store { my( $self, $obj ) = @_; confess "Not an GeneTargeting::DBEntry::ExternalDB" unless $obj->isa("GeneTargeting::DBEntry::ExternalDB"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "ExternalDB id already set" if $obj->id; my $db_name = $obj->db_name or confess "db_name not set"; my $description = $obj->description; my $display_label = $obj->display_label; my $sequence_source = $obj->sequence_source; my $sth = $dba->dbh->prepare(q{ INSERT external_db ( external_db_id , db_name , description , display_label , sequence_source ) VALUES (NULL , ? , ? , ? , ? ) }); $sth->execute($db_name , $description , $display_label , $sequence_source ); my $obj_id = $sth->{'mysql_insertid'} or confess "Couldn't get mysql_insertid"; $obj->id($obj_id); }
GeneTargeting::DBSQL::HitAdaptor
- Inherit
- GeneTargeting::DBSQL::BaseAdaptor
- Description
- Database adaptor for storing/fetching GeneTargeting::DBEntry::Hit objects
- Included modules
- Carp
- Usage
$hit_aptr->store($hit);
- Constructor
my $dba = GeneTargeting::DBSQL::DBAdaptor->new; my $hit_aptr = $dba->HitAdaptor() or confess "Could not get HitAdaptor";
Methods
_fetch_Hit
sub _fetch_Hit { my( $self, $sth ) = @_; my ($hit_id , $md5hex , $seq_length , $db_name , $ext_db_id , $accession , $description , $gene_name , $xref_id) = $sth->fetchrow; if ($hit_id) { my $Hit = GeneTargeting::DBEntry::Hit->new; $Hit->id($hit_id); $Hit->md5hex($md5hex); $Hit->seq_length($seq_length); $Hit->db_name($db_name); $Hit->ext_db_id($ext_db_id); $Hit->accession($accession); $Hit->description($description) if $description; $Hit->gene_name($gene_name) if $gene_name; $Hit->xref_id($xref_id); return $Hit; } else { return; } }
fetch_by_Sequence_id_Conf_id
my $hits = $hit_aptr->fetch_by_Sequence_id_Conf_id(1, 2);
sub fetch_by_Sequence_id_Conf_id { my ( $self, $seq_id, $conf_id ) = @_; confess "Must pass a seq id" unless $seq_id; confess "Must pass a conf id" unless $conf_id; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sequencehit_aptr = $dba->get_SequenceHitAdaptor() or confess "Could not get_SequenceHitAdaptor"; my $sth = $dba->dbh->prepare(q{ SELECT distinct hit_id FROM sequence_hit WHERE sequence_id = ? and conf_id = ? }); $sth->execute($seq_id, $conf_id); my @hit_ids; while (my @rows = $sth->fetchrow) { push(@hit_ids, @rows); } return unless @hit_ids; my @hits; foreach my $hit_id (@hit_ids) { my $hit = $self->fetch_by_db_id($hit_id) or confess "Could not fetch Hit by id: $hit_id"; unless ($sequencehit_aptr->fetch_for_hit_by_sequence_id_conf_id( $hit, $seq_id, $conf_id)) { confess "No SequenceHits fetched for hit id: $hit_id" , ", sequence id: $seq_id, conf_id: $conf_id"; } push(@hits, $hit); } unless (@hits) { return; } return\@ hits; }
fetch_by_accession_and_db
Not tested
sub fetch_by_accession_and_db { my( $self, $accession, $db_name ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; unless ($accession and $db_name) { confess "Must pass accession and db_name"; } my $sth = $dba->dbh->prepare(q{ SELECT h.hit_id , h.md5hex , h.seq_length , e.db_name , e.external_db_id , x.accession , x.description , x.gene_name , h.xref_id FROM hit h , xref x , external_db e WHERE h.xref_id = x.xref_id AND x.external_db_id = e.external_db_id AND e.db_name = ? AND x.accession = ? }); $sth->execute($db_name , $accession); my $Hit = $self->_fetch_Hit($sth); return $Hit; }
fetch_by_accession_and_ext_db_id
my $hit = $hit_aptr->fetch_by_db_id('myacc', 4);
sub fetch_by_accession_and_ext_db_id { my( $self, $accession, $ext_db_id ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; unless ($accession and $ext_db_id) { confess "Must pass accession and db_name"; } my $sth = $dba->dbh->prepare(q{ SELECT h.hit_id , h.md5hex , h.seq_length , e.db_name , e.external_db_id , x.accession , x.description , x.gene_name , h.xref_id FROM hit h , xref x , external_db e WHERE h.xref_id = x.xref_id AND x.external_db_id = e.external_db_id AND x.accession = ? AND e.external_db_id = ? }); $sth->execute($accession , $ext_db_id); my $hit = $self->_fetch_Hit($sth); return $hit; }
fetch_by_db_id
my $hit = $hit_aptr->fetch_by_db_id(4);
sub fetch_by_db_id { my( $self, $required ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; unless ($required) { confess "Must pass id"; } my $sth = $dba->dbh->prepare(q{ SELECT h.hit_id , h.md5hex , h.seq_length , e.db_name , e.external_db_id , x.accession , x.description , x.gene_name , h.xref_id FROM hit h , xref x , external_db e WHERE h.xref_id = x.xref_id AND x.external_db_id = e.external_db_id AND h.hit_id = ? }); $sth->execute($required); my $Hit = $self->_fetch_Hit($sth); return $Hit; }
get_ExternalDB_ids
Not tested
sub get_ExternalDB_ids { my( $self, $Hit ) = @_; my $fail_count = 0; confess "Not a GeneTargeting::DBEntry::Hit" unless $Hit->isa('GeneTargeting::DBEntry::Hit'); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $db_name = $Hit->db_name or confess "db_name not set"; my $ExternalDB_aptr = $dba->get_ExternalDBAdaptor(); my $ExternalDB = $ExternalDB_aptr->fetch_by_name($db_name); if ($ExternalDB) { $Hit->ext_db_id($ExternalDB->id); } else { $fail_count++; } foreach my $Xref ($Hit->get_Xrefs) { my $db_name = $Xref->db_name or confess "db_name not set"; if ($db_name) { my $ExternalDB = $ExternalDB_aptr->fetch_by_name($db_name); if ($ExternalDB) { $Xref->ext_db_id($ExternalDB->id); } else { $fail_count++; } } } if ($fail_count) { return; } return 1; }
store
tested
sub store { my ( $self, $Hit ) = @_; confess "Not an GeneTargeting::DBEntry::Hit" unless $Hit->isa("GeneTargeting::DBEntry::Hit"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Hit id already set" if $Hit->id; #Mandatory my $ext_db_id = $Hit->ext_db_id or confess "ext_db_id not set"; my $accession = $Hit->accession or confess "accession not set"; my $seq_length = $Hit->seq_length or confess "seq_length not set"; #optional my $md5hex = $Hit->md5hex; my $gene_name = $Hit->gene_name; my $description = $Hit->description; if (length($accession) > 40) { confess "accession '$accession' is too long\n"; } #Check if we already have the Xref, else create and store one my $Xref_aptr = $dba->get_XrefAdaptor(); my $Xref = $Xref_aptr-> fetch_by_accession_and_ext_db_id($accession, $ext_db_id); unless ($Xref) { #Create an Xref for the Hit data, store it $Xref = GeneTargeting::DBEntry::Xref->new; $Xref->accession($accession); $Xref->ext_db_id($ext_db_id); $Xref->description($description); $Xref->gene_name($gene_name); $Xref_aptr->store($Xref); $Hit->add_Xref($Xref); #Recently added } #Insert into Hit table my $sth = $dba->dbh->prepare(q{ INSERT hit (hit_id , xref_id , md5hex , seq_length ) VALUES (NULL , ? , ? , ? ) }); $sth->execute($Xref->id , $md5hex , $seq_length); my $hit_id = $sth->{'mysql_insertid'} or confess "Couldn't get mysql_insertid"; $Hit->id($hit_id); #Finally store in hit_xref $sth = $dba->dbh->prepare(q{ INSERT hit_xref (hit_id , xref_id ) VALUES (? , ? ) }); $sth->execute($Hit->id , $Xref->id ); my $row_count = $sth->rows; unless ($row_count and ($row_count == 1)) { confess "No row inserted into hit_xref"; } return 1; }
GeneTargeting::DBSQL::JobAdaptor
- Inherit
- GeneTargeting::DBSQL::BaseAdaptor
- Description
- Database adaptor for storing and fetching GeneTargeting::DBEntry::Job objects, and also the Sequence ids that make up the job.
- Included modules
- Carp
- Usage
my $job = GeneTargeting::DBEntry::Job->new; $job->analysis_conf_id(10); $job->state('created'); $job_aptr->update($job) #For example to change the state stored in db $job_aptr->store($job); my $fetched_job = $job_aptr->fetch_by_db_id(1); $job_aptr->store_Job_Error($job, 'failed to complete'); $job_aptr->store_Job_Sequence($job, $sequence); my $seq_ids = $job_aptr->get_Sequence_ids($fetched_job);
- Constructor
my $dba = GeneTargeting::DBSQL::DBAdaptor->new; my $job_aptr = $dba->get_JobAdaptor() or confess "Could not get JobAdaptor";
Methods
debug
Switch debug output on/off in the JobAdaptor $job_aptr->debug(1|0) Debugging is switched on if the value passed is true
sub debug { my ( $self, $debug ) = @_; if (defined($debug)) { $self->{_genetargeting_dbsql_jobadaptor_debug} = $debug; } return $self->{_genetargeting_dbsql_jobadaptor_debug}; }
delete
Given a GeneTargeting::DBEntry::Job object deletes it, returns a count of how many rows were deleted which should normally by one. Confesses if the id of the Job is not set, or no object is passed.
my $row_count = $job_aptr->delete($job);
sub delete { my ( $self, $object ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Not an GeneTargeting::DBEntry::Job" unless $object->isa("GeneTargeting::DBEntry::Job"); my $id = $object->id or confess "Job id not set"; my $sth = $dba->dbh->prepare(q{ DELETE FROM job WHERE job_id = ? }); $sth->execute($id); return $sth->rows; }
delete_JobSequence_links
Given an object of class GeneTargeting::DBEntry::Job deletes rows from the job_sequence table by the id of the Job passed. Returns a count of how many rows (if any) were deleted
my $count = $job_aptr->delete_JobSequence_links($job);
sub delete_JobSequence_links { my ( $self, $object ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Not an GeneTargeting::DBEntry::Job" unless $object->isa("GeneTargeting::DBEntry::Job"); my $id = $object->id or confess "Job id not set"; my $sth = $dba->dbh->prepare(q{ DELETE FROM job_sequence WHERE job_id = ? }); $sth->execute($id); return $sth->rows; }
delete_errors
Given a GeneTargeting::DBEntry::Job object delete its errors by id from the job_error table, Returns a count of how many rows were deleted, which could be none, or any positive number. Confesses if the id of the Job is not set, or no object is passed.
my $row_count = $job_aptr->delete_errors($job);
sub delete_errors { my ( $self, $object ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Not an GeneTargeting::DBEntry::Job" unless $object->isa("GeneTargeting::DBEntry::Job"); my $id = $object->id or confess "Job id not set"; my $sth = $dba->dbh->prepare(q{ DELETE FROM job_error WHERE job_id = ? }); $sth->execute($id); return $sth->rows; }
fetch_by_db_id
my $job = $job_aptr->fetch_by_db_id(1);
sub fetch_by_db_id { my ( $self, $required ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT job_id , conf_id , state FROM job WHERE job_id = ? }); $sth->execute($required); my ( $job_id, , $conf_id , $state ) = $sth->fetchrow; if ($job_id) { my $Job = GeneTargeting::DBEntry::Job->new; $Job->id($job_id); $Job->analysis_conf_id($conf_id); $Job->state($state); return $Job; } else { if ($self->debug) { carp "Failed to fetch job with fetch_by_db_id '$required'"; } return; } }
get_Sequence_ids
Used to obtain the Sequence ids comprising a particular job.
my $seq_ids = $job_aptr->get_Sequence_ids($job);
Returns a reference to an array of Sequence ids or undef.
sub get_Sequence_ids { my ($self, $job ) = @_; confess "Not an GeneTargeting::DBEntry::Job" unless $job->isa("GeneTargeting::DBEntry::Job"); my $job_id = $job->id or confess "job_id not set"; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT s.sequence_id FROM sequence s , job_sequence js , job j WHERE s.sequence_id = js.sequence_id AND js.job_id = j.job_id AND j.job_id = ? }); $sth->execute($job_id); my (@ids); while (my (@rows) = $sth->fetchrow) { push(@ids, @rows); } unless (@ids) { if ($self->debug) { carp "No ids fetched with get_Sequence_ids for job id '$job_id'"; } return; } return\@ ids; }
get_ids_by_DNAProbe_name
my $ids = $job_aptr->get_ids_by_DNAProbe_name('probetest2');
sub get_ids_by_DNAProbe_name { my ( $self, $name ) = @_; confess "Must pass a name" unless $name; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT distinct js.job_id FROM probe p , probe_sequence ps , job_sequence js , job j WHERE p.probe_id = ps.probe_id AND ps.sequence_id = js.sequence_id AND p.name = ? }); $sth->execute($name); my (@ids); while (my (@rows) = $sth->fetchrow) { push(@ids, @rows); } unless (@ids) { if ($self->debug) { carp "No ids fetched with get_ids_by_DNAProbe_name for '$name'"; } return; } return\@ ids; }
store
Given a Job object of class GeneTargeting::DBEntry::Job, stores it in the database. Confesses on failure
$dba->store($Job);
sub store { my( $self, $Job ) = @_; confess "Not an GeneTargeting::DBEntry::Job" unless $Job->isa("GeneTargeting::DBEntry::Job"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Job id already set" if $Job->id; my $analysis_conf_id = $Job->analysis_conf_id or confess "analysis_conf_id not set"; my $state = $Job->state or confess "state not set"; my $sth = $dba->dbh->prepare(q{ INSERT job ( job_id , conf_id , state ) VALUES (NULL , ? , ? ) }); $sth->execute($analysis_conf_id , $state ); my $job_id = $sth->{'mysql_insertid'} or confess "Couldn't get mysql_insertid"; $Job->id($job_id); }
store_Job_Error
Used to store a row in the job_error table, allowing an error string (up to 80 chars) to be stored about a job
$job_aptr->store_Job_Error($job, 'crapped');
Confesses upon failure.
sub store_Job_Error { my ( $self, $Job, $error_string ) = @_; confess "Not an GeneTargeting::DBEntry::Job" unless $Job->isa("GeneTargeting::DBEntry::Job"); confess "Invalid Error" unless $error_string; if (length($error_string) > 80) { confess "Error too long"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $job_id = $Job->id or confess "Job id not set"; my $sth = $dba->dbh->prepare(q{ INSERT job_error ( job_id , error_string ) VALUES (? , ? ) }); $sth->execute($job_id, , $error_string ); my $row_count = $sth->rows; unless ($row_count and ($row_count == 1)) { confess "No row inserted into job_clone"; } return 1; }
store_Job_Sequence
Used to store a row in the job_sequence table, adding a sequence to a job (both keyed by their id)
$job_aptr->store_Job_Sequence($job, $seq);
Confesses upon failure.
sub store_Job_Sequence { my ( $self, $job, $sequence ) = @_; confess "Must pass a GeneTargeting::DBEntry::Job" unless $job; confess "Not an GeneTargeting::DBEntry::Job" unless $job->isa("GeneTargeting::DBEntry::Job"); my $sequence_id; if (ref($sequence) eq 'GeneTargeting::DBEntry::Sequence') { $sequence_id = $sequence->id or confess "Sequence id not set"; } else { $sequence_id = $sequence or confess "Must pass Sequence object or id"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $job_id = $job->id or confess "Job id not set"; my $sth = $dba->dbh->prepare(q{ INSERT job_sequence ( job_id , sequence_id ) VALUES (? , ? ) }); $sth->execute($job_id, , $sequence_id ); my $row_count = $sth->rows; unless ($row_count and ($row_count == 1)) { confess "No row inserted into job_Sequence"; } return 1; }
update
Used to update a Job in the database. Both the analysis_conf_id and the state can be updated.
$job_aptr->update($job);
Confesses upon failure.
sub update { my ( $self, $Job ) = @_; confess "Not an GeneTargeting::DBEntry::Job" unless $Job->isa("GeneTargeting::DBEntry::Job"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $job_id = $Job->id or confess "job_id not set"; my $analysis_conf_id = $Job->analysis_conf_id or confess "analysis_conf_id not set"; my $state = $Job->state or confess "state not set"; my $sth = $dba->dbh->prepare(q{ UPDATE job SET conf_id = ? , state = ? WHERE job_id = ? }); $sth->execute($analysis_conf_id , $state , $job_id ); my $row_count = $sth->rows; unless ($row_count and ($row_count == 1)) { carp "No rows changed"; } return 1; }
GeneTargeting::DBSQL::SequenceAdaptor
- Inherit
- GeneTargeting::DBSQL::BaseAdaptor
- Description
- Database adaptor for storing and fetching GeneTargeting::DBEntry::Sequence objects.
- Included modules
- Carp
- Usage
my $seq = GeneTargeting::DBEntry::Sequence->new; $seq->assembly('NCBIM33'); $seq->chromosome('Y'); $seq->start(22052902); $seq->end(22052962); $seq->strand(1); $seq->dna('GTTTTATTAGCTTCAAATCAGACAATACCATGAAAGTTCATT TTCAGAAGGGTTAAGTGGA'); $seq_aptr->store($seq); my $fetched_seq = $seq_aptr->fetch_by_db_id(1); my $fetched_seq = $seq_aptr->fetch_by_genomic_location( 'NCBIM33', 'Y', 22052902, 22052962, 1);
- Constructor
my $dba = GeneTargeting::DBSQL::DBAdaptor->new; my $seq_aptr = $dba->get_SequenceAdaptor() or confess "Could not get SequenceAdaptor";
Methods
_fetch_seq
sub _fetch_seq { my( $self, $sth ) = @_; my ( $sequence_id, , $assembly , $chromosome , $start , $end , $strand , $dna ) = $sth->fetchrow; if ($sequence_id) { my $seq = GeneTargeting::DBEntry::Sequence->new; $seq->id($sequence_id); $seq->assembly($assembly); $seq->chromosome($chromosome); $seq->start($start); $seq->end($end); $seq->strand($strand); $seq->dna($dna); return $seq; } else { return; } }
delete
Given a GeneTargeting::DBEntry::Sequence object deletes it, returns a count of how many rows were deleted which should normally by one. Confesses if the id of the sequence is not set, or no object is passed.
my $row_count = $sequence_aptr->delete($sequence);
sub delete { my ( $self, $object ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Not an GeneTargeting::DBEntry::Sequence" unless $object->isa("GeneTargeting::DBEntry::Sequence"); my $id = $object->id or confess "Sequence id not set"; my $sth = $dba->dbh->prepare(q{ DELETE FROM sequence WHERE sequence_id = ? }); $sth->execute($id); return $sth->rows; }
fetch_by_db_id
my $seq = $seq_aptr->fetch_by_db_id(2);
Given a unique sequence id, returns a GeneTargeting::DB::Sequence object, or undef on failure.
sub fetch_by_db_id { my ( $self, $required ) = @_; confess "Must pass id" unless $required; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT sequence_id , assembly , chromosome , start , end , strand , dna FROM sequence WHERE sequence_id = ? }); $sth->execute($required); my $seq = $self->_fetch_seq($sth); if ($self->debug and !$seq) { carp "Failed to fetch seq by id: '$required'"; } return $seq; }
fetch_by_genomic_location
my $seq = $seq_aptr->fetch_by_genomic_location( 'NCBIM33', 'Y', 22052902, 22052962, 1);
sub fetch_by_genomic_location { my ( $self, $assembly, $chromosome, $start, $end , $strand ) = @_; confess "Must pass assembly" unless $assembly; confess "Must pass chromosome" unless $chromosome; confess "Must pass start" unless $start; confess "Must pass end" unless $end; confess "Must pass strand" unless $strand; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT sequence_id , assembly , chromosome , start , end , strand , dna FROM sequence WHERE assembly = ? and chromosome = ? and start = ? and end = ? and strand = ? }); $sth->execute($assembly , $chromosome , $start , $end , $strand ); my $seq = $self->_fetch_seq($sth); if ($self->debug and !$seq) { carp "Failed to fetch seq by genomic location '$assembly'" . " '$chromosome' '$start' '$end' '$strand'"; } return $seq; }
store
$seq_aptr->store($sequence);
Given a sequence object of class GeneTargeting::DBEntry::Sequence, stores it in the database. Confesses on failure
sub store { my( $self, $obj ) = @_; confess "Not a GeneTargeting::DBEntry::Sequence" unless $obj->isa("GeneTargeting::DBEntry::Sequence"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Sequence id already set" if $obj->id; my $assembly = $obj->assembly or confess "assembly not set"; my $chromosome = $obj->chromosome or confess "chromosome not set"; my $start = $obj->start or confess "start not set"; my $end = $obj->end or confess "end not set"; my $strand = $obj->strand or confess "strand not set"; my $dna = $obj->dna or confess "dna not set"; my $sth = $dba->dbh->prepare(q{ INSERT sequence ( sequence_id , assembly , chromosome , start , end , strand , dna ) VALUES (NULL , ? , ? , ? , ? , ? , ? ) }); $sth->execute($assembly , $chromosome , $start , $end , $strand , $dna ); my $id = $sth->{'mysql_insertid'} or confess "Couldn't get mysql_insertid"; $obj->id($id); }
GeneTargeting::DBSQL::SequenceHitAdaptor
- Inherit
- GeneTargeting::DBSQL::BaseAdaptor
- Description
- Database adaptor for storing/fetching GeneTargeting::DBEntry::ComponentHit objects
- Included modules
- Carp
- Usage
$seq_hit_aptr->store($seq_hit);
Methods
delete_SequenceHit_links
Given an object of class GeneTargeting::DBEntry::Sequence deletes rows from the sequence_hit table by the id of the Sequences passed. Returns a count of how many rows (if any) were deleted
my $count = $sequence_hit_aptr->delete_SequenceHit_links($sequence);
sub delete_SequenceHit_links { my ( $self, $object ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Not an GeneTargeting::DBEntry::Sequence" unless $object->isa("GeneTargeting::DBEntry::Sequence"); my $id = $object->id or confess "Sequence id not set"; my $sth = $dba->dbh->prepare(q{ DELETE FROM sequence_hit WHERE sequence_id = ? }); $sth->execute($id); return $sth->rows; }
fetch_for_hit_by_sequence_id_conf_id
sub fetch_for_hit_by_sequence_id_conf_id { my ( $self, $hit, $sequence_id, $conf_id ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Not an GeneTargeting::DBEntry::Hit" unless $hit->isa("GeneTargeting::DBEntry::Hit"); my $hit_id = $hit->id or confess "Hit id not set"; confess "Must pass a sequence id" unless $sequence_id; confess "Must pass a conf id" unless $conf_id; my $sth = $dba->dbh->prepare(q{ SELECT sequence_id , hit_id , conf_id , score , P_value , query_start , query_end , query_frame , query_strand , subject_start , subject_end , subject_frame , subject_strand , cigar_line , percent_id , soft_masked FROM sequence_hit WHERE sequence_id = ? AND hit_id = ? AND conf_id = ? }); $sth->execute($sequence_id, $hit_id, $conf_id); my $obj_count; while (my ($sequence_id , $hit_id, , $conf_id , $score , $P_value , $query_start , $query_end , $query_frame , $query_strand , $subject_start , $subject_end , $subject_frame , $subject_strand , $cigar_line , $percent_id , $soft_masked ) = $sth->fetchrow) { my $componenthit = GeneTargeting::DBEntry::ComponentHit->new; $componenthit->query_id($sequence_id); $componenthit->hit_id($hit_id); $componenthit->conf_id($conf_id); $componenthit->score($score); $componenthit->P_value($P_value); $componenthit->query_start($query_start); $componenthit->query_end($query_end); $componenthit->query_frame($query_frame); $componenthit->query_strand($query_strand); $componenthit->subject_start($subject_start); $componenthit->subject_end($subject_end); $componenthit->subject_frame($subject_frame); $componenthit->subject_strand($subject_strand); $componenthit->cigar_line($cigar_line); $componenthit->percent_id($percent_id); $componenthit->soft_masked($soft_masked); $hit->add_ComponentHit($componenthit); $obj_count++; } return $obj_count; }
store
$sequencehit_aptr->store($component_hit);
sub store { my ( $self, $obj ) = @_; confess "Not an GeneTargeting::DBEntry::ComponentHit" unless $obj->isa("GeneTargeting::DBEntry::ComponentHit"); $self->store_ComponentHit($obj, 'Sequence'); }
store_ComponentHit
sub store_ComponentHit { my( $self, $obj, $mode ) = @_; my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my ($table_name, $id_name); if ($mode eq 'Sequence') { $table_name = 'sequence_hit'; $id_name = 'sequence_id'; } else { confess "Unknown mode supplied to 'store_ComponentHit'\n"; } #Mandatory my $query_id = $obj->query_id or confess "query_id not set"; my $hit_id = $obj->hit_id or confess "hit_id not set"; my $conf_id = $obj->conf_id or confess "conf_id not set"; my $score = $obj->score or confess "score not set"; my $query_start = $obj->query_start or confess "query_start not set"; my $query_end = $obj->query_end or confess "query_end not set\n\n", print_hash_ref($obj); my $subject_start = $obj->subject_start or confess "subject_start not set"; my $subject_end = $obj->subject_end or confess "subject_end not set"; my $query_strand = $obj->query_strand; my $subject_strand = $obj->subject_strand; unless (defined($query_strand)) { confess "query_strand not set"; } unless (defined($subject_strand)) { confess "subject_strand not set"; } #Optional my $P_value = $obj->P_value; my $cigar_line = $obj->cigar_line; my $query_frame = $obj->query_frame; my $subject_frame = $obj->subject_frame; my $percent_id = $obj->percent_id; my $soft_masked = $obj->soft_masked; my $sth = $dba->dbh->prepare(qq{ INSERT $table_name ($id_name , hit_id , conf_id , score , P_value , query_start , query_end , query_frame , query_strand , subject_start , subject_end , subject_frame , subject_strand , cigar_line , percent_id , soft_masked ) VALUES (? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? ) }); $sth->execute($query_id , $hit_id , $conf_id , $score , $P_value , $query_start , $query_end , $query_frame , $query_strand , $subject_start , $subject_end , $subject_frame , $subject_strand , $cigar_line , $percent_id , $soft_masked ); }
GeneTargeting::DBSQL::XrefAdaptor
- Inherit
- GeneTargeting::DBSQL::BaseAdaptor
- Description
- Database adaptor for storing and fetching GeneTargeting::DBEntry::Xref objects.
- Included modules
- Carp
- Usage
my $xref = GeneTargeting::DBEntry::Xref->new; $xref->ext_db_id(3); $xref->gene_name('blah1'); $xref->accession('AF83883'); $xref->db_name('test'); $xref->description('the blah1 gene'); $xref_aptr->store($xref); my $fetched_xref = $xref_aptr->fetch_by_db_id(2); my $xref = $xref_aptr->fetch_by_accession_and_ext_db_id('AF83883', 2);
- Constructor
my $dba = GeneTargeting::DBSQL::DBAdaptor->new; my $xref_aptr = $dba->get_XrefAdaptor() or confess "Could not get XrefAdaptor";
Methods
_fetch_Xref
sub _fetch_Xref { my ($self, $sth) = @_; my ($xref_id, $accession, $external_db_id , $description, $gene_name) = $sth->fetchrow; if ($xref_id) { my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $Xref = GeneTargeting::DBEntry::Xref->new; $Xref->id($xref_id); $Xref->accession($accession); $Xref->ext_db_id($external_db_id); $Xref->description($description); $Xref->gene_name($gene_name); my $sth = $dba->dbh->prepare(q{ SELECT db_name FROM external_db WHERE external_db_id = ? }); $sth->execute($external_db_id); my $db_name = $sth->fetchrow; unless ($db_name) { confess "Could not get db_name"; } $Xref->db_name($db_name); return $Xref; } return; }
fetch_by_accession_and_ext_db_id
my $xref = $xref_aptr->fetch_by_accession_and_ext_db_id('AF83883', 3);
sub fetch_by_accession_and_ext_db_id { my ($self, $accession, $ext_db_id) = @_; unless ($accession and $ext_db_id) { confess "Must pass accession and ext_db_id"; } my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; my $sth = $dba->dbh->prepare(q{ SELECT xref_id , accession , external_db_id , description , gene_name FROM xref WHERE accession = ? AND external_db_id = ? }); $sth->execute($accession, $ext_db_id); my $obj = $self->_fetch_Xref($sth); if ($self->debug and !$obj) { carp "Failed to fetch Xref by accesion, id: '$accession'" . ", '$ext_db_id'"; } return $obj; }
fetch_by_db_id
my $xref = $xref_aptr->fetch_by_db_id(1);
sub fetch_by_db_id { my ( $self, $required ) = @_; my $dba = $self->DBAdaptor; my $sth = $dba->dbh->prepare(q{ SELECT xref_id , accession , external_db_id , description , gene_name FROM xref WHERE xref_id = ? }); $sth->execute($required); my $obj = $self->_fetch_Xref($sth); if ($self->debug and !$obj) { carp "Failed to fetch Xref by id: '$required'"; } return $obj; }
store
$xref_aptr->store($xref);
sub store { my( $self, $obj ) = @_; confess "Not an GeneTargeting::DBEntry::Xref" unless $obj->isa("GeneTargeting::DBEntry::Xref"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; confess "Xref id already set" if $obj->id; my $ext_db_id = $obj->ext_db_id or confess "ext_db_id not set"; my $accession = $obj->accession or confess "accession not set"; if (length($accession) > 40) { confess "accession is too long"; } my $gene_name = $obj->gene_name; my $description = $obj->description; my $sth = $dba->dbh->prepare(q{ INSERT xref (xref_id , accession , external_db_id , description , gene_name ) VALUES (NULL , ? , ? , ? , ? ) }); $sth->execute($accession , $ext_db_id , $description , $gene_name ); my $obj_id = $sth->{'mysql_insertid'} or confess "Couldn't get mysql_insertid"; $obj->id($obj_id); }
store_from_Hit
$xref_aptr->store_from_Hit($Hit_obj);
Given a Hit object of type EST_DB::DB_Entry::Hit stores in the hit, stores the Xrefs attached to it. Returns a count of how many Xrefs were stored or undef.
sub store_from_Hit { my ($self, $Hit) = @_; confess "Not an GeneTargeting::DBEntry::Hit" unless $Hit->isa("GeneTargeting::DBEntry::Hit"); my $dba = $self->DBAdaptor or confess "DBAdaptor not set"; #Checking whether we have them already my @xrefs = $Hit->get_Xrefs; unless (@xrefs) { return; } my $count = 0; foreach my $xef (@xrefs) { my $retrieved_Xref = $self->fetch_by_accession_and_ext_db_id( $xef->accession, $xef->ext_db_id); unless ($retrieved_Xref) { $self->store_Xref($xef); } else { $xef = $retrieved_Xref; } #Check if we already have a row in hit_xref my $sth = $dba->dbh->prepare(q{ SELECT hit_id FROM hit_xref WHERE hit_id = ? AND xref_id = ? }); $sth->execute($Hit->id, $xef->id); my $retrieved_hit_id = $sth->fetchrow; unless ($retrieved_hit_id) { my $sth = $dba->dbh->prepare(q{ INSERT hit_xref (hit_id , xref_id ) VALUES (? , ? ) }); $sth->execute($Hit->id , $xef->id); $count++; } } return $count; }
GeneTargeting::Defs
- Description
- Use to hold (mostly) constant definitions and keep them from being repeated throughout the codebase. Variables are not exported to Main with Exporter, but instead need to be fully-qualified: Example use:
use GeneTargeting::Defs; print join("\n", @GeneTargeting::Defs::object_types), "\n";
- Private package variables
- $debug = 1
- Included modules
- Carp
GeneTargeting::Utils::Config
- Description
- Utility module to parse .ini configuration files and check that mandatory and optional parameters are found. Requires a 'configure_parameters' routine in the calling programme to find what the expected parameters are, which returns two references to hashes of arrays, representing the section and value format of the .ini file(s). If these are not found in the parsed file, a fatal error occurs.
sub configure_parameters { my $mandatory = {}; my $optional = {}; $mandatory->{'flank_size'} = ['size']; $mandatory->{'five_prime_arm'} = ['min', 'max']; $mandatory->{'five_prime_arm'} = ['min', 'max']; $optional->{'three_prime_arm'} = ['min', 'max']; return ($mandatory, $optional); }
The corresponding .ini file would need to contain at least the following first two sections []:[flank_size] size = 10000 [five_prime_arm] min = 6500 max = 15000 [three_prime_arm] min = 3500 max = 15000
Methods names will be the concatenated section_name_variable_name, so in the example above: flank_size_size, five_prime_arm_min, etc. - Thus they need to be valid Perl method names (they cannot contain spaces, and must start with a letter. This is checked, and causes a fatal error should they not be validated. These could then be acessed as: my $size = $config->flank_size_size(); $config->flank_size_size(1000); Information that MUST be present in the .ini file:
-------------------------------------------------- [binary paths] linux = /nfs/team71/analysis/mdr/bin/linux osf1 = /nfs/team71/analysis/mdr/bin/osf1 (Or an entry for whatever $^O says the os_type is) (Used by _set_path_by_os_type_from_config) [tmp_dir] loc = /tmp (Used by _set_tmp_dir to set $ENV{TMPDIR})
Optional sections in the .ini file---------------------------------- [http_proxy] url = http://wwwcache.sanger.ac.uk:3128
Utilises the Config::IniFiles library for .ini file parsing. - Synopsis
- my $config = GeneTargeting::Utils::Config->new($filename, $debug);
- Private package variables
- (@parameters, @values);
- Included modules
- Bio::EnsEMBL::DBSQL::DBAdaptor
- Carp
- Config::IniFiles
- GeneTargeting::DBSQL::DBAdaptor
Methods
ConfigIniFiles
Get/set method for the Config::IniFiles object created by the class. Shouldnt normally be set from outside the new constructor of GeneTargeting::Utils::Config::new
sub ConfigIniFiles { my ( $self, $cfg ) = @_; if ($cfg) { $self->{_genetargeting_utils_config} = $cfg; unless ($cfg->isa('Config::IniFiles')) { confess "Must pass a Config::Inifiles object"; } } return $self->{_genetargeting_utils_config}; }
_make_get_set_methods
Internal method called by the new method, creating the get/set methods for the object.
sub _make_get_set_methods { my ( $pkg, $parameters, $values ) = @_; # Make a get-set method for each parameter foreach my $param (@$parameters) { no strict 'refs'; my $get_set_sub = "${pkg}::$param"; my $field = "_$param"; # Check that this method doesn't already exist if (defined(&$get_set_sub)) { confess "Method '$get_set_sub' is already defined!"; } # Insert a subroutine ref into the symbol # table under this name. (This is the bit # that need strict refs turned off.) *$get_set_sub = sub { my( $self, $arg ) = @_; if (defined $arg) { $self->{$field} = $arg; } return $self->{$field}; }; } }
_multi_files_cfg
sub _multi_files_cfg { my ( $self, $conf_dir, $files, $debug ) = @_; my $master_cfg; foreach my $file (@$files) { unless ($master_cfg) { $master_cfg = Config::IniFiles->new(-file =>> $conf_dir . $file) or confess "Can't open / error parsing : $conf_dir" . $file; print STDERR "Parsed: ", $conf_dir . $file . "\n" if $debug; next; } my $temp_cfg = Config::IniFiles->new(-file => $conf_dir . $file, -import => $master_cfg) or confess "Can't open / error parsing : $conf_dir" . $file; print STDERR "Parsed: ", $conf_dir . $file . "\n" if $debug; $master_cfg = $temp_cfg; } return $master_cfg; }
_parse_config_file
Given a file name looks for it in the directory pointed to by the environment variable $GeneTargetingConfDir Confesses upon error.
sub _parse_config_file { my ( $self, $file, $debug ) = @_; my $conf_dir = $ENV{GeneTargetingConfDir}; unless ($conf_dir) { confess "Set ", '$GeneTargetingConfDir', " environment variable"; } unless (-d $conf_dir) { confess "Set ", '$GeneTargetingConfDir', " to a valid directory"; } unless ($conf_dir =~ /\/$/) { $conf_dir .= '/'; } #Make the default config file name based on $0 my $prog_name = $0; if (rindex($prog_name, '/') > -1) { $prog_name = substr($prog_name, rindex($prog_name, '/') + 1); } $prog_name .= '_defaults.ini'; my $cfg; if ($file) { #Is $file ARRAY ref or a single file ? if (ref($file) =~ /ARRAY/) { $cfg = $self->_multi_files_cfg($conf_dir, $file, $debug); } else { $cfg = Config::IniFiles->new(-file => $conf_dir . $file) or confess "Can't open / error parsing : $conf_dir" . $file; } print STDERR "Parsed: ", $conf_dir . $file . "\n" if $debug; } else { confess "Must pass a config file name or reference to an array" . " of config file names"; } return $cfg; }
_parse_parameters
Internal method called by new. Uses the passed Config::IniFiles object, together with mandatory and optional parameters (passed as hash refs) to validate the .ini configuration file.
sub _parse_parameters { my ( $self, $cfg, $mandatory, $optional, $debug ) = @_; print STDERR "\nParsing parameters\n" if $debug; print STDERR "------------------\n\n" if $debug; @parameters = (); @values = (); if (keys(%{$mandatory})) { print STDERR "Looking for mandatory:\n\n" if $debug; foreach my $section (keys(%{$mandatory})) { foreach my $var (@{$mandatory->{$section}}) { my $value = $cfg->val($section, $var); unless (defined($value)) { confess "'[$section]' '$var' not set"; } _push_parameter_and_value($section, $var, $value, $debug); } } print STDERR "\n" if $debug; } if (keys(%{$optional})) { print STDERR "Looking for optional:\n\n" if $debug; foreach my $section (keys(%{$optional})) { foreach my $var (@{$optional->{$section}}) { my $value = $cfg->val($section, $var); _push_parameter_and_value($section, $var, $value , $debug); } } print STDERR "\n" if $debug; } return (\@parameters,\@ values); }
_push_parameter_and_value
sub _push_parameter_and_value { my ( $section, $var, $value, $debug ) = @_; my $parameter = $section . '_' . $var; push(@parameters, $parameter); push(@values, $value); if ($debug) { my $parameter_combo = " ('[$section]', '$var')"; print STDERR $parameter_combo, ' ' x (40 - length($parameter_combo)); if (defined($value)) { print STDERR " : Value : $value\n"; } else { print STDERR " : Value : undefined\n"; } } }
_set_http_proxy
Internal method called by the new method to set the http_proxy environment variable should it be specified in the parsed .ini file
sub _set_http_proxy { my ( $self, $cfg, $debug ) = @_; my $url; if ($url = $cfg->val('http_proxy', 'url')) { $ENV{http_proxy} = $url; print STDERR 'Set $ENV{http_proxy} to ', "$url\n" if $debug; } else { print STDERR "'url' not set in '[http_proxy]' section of config file\n" if $debug; } }
_set_path_by_os_type_from_config
Internal method called by new. Given an object of class Config::IniFiles prepends a directory to $ENV{PATH} based on operating system type Expects to find something like this in the previously-parsed .ini file: [binary paths] linux = /nfs/bin/linux osf1 = /nfs/team71/analysis/mdr/bin/osf1 Confesses if the information is not found in the .ini file, or is not a valid directory
sub _set_path_by_os_type_from_config { my ( $self, $cfg, $debug ) = @_; my $os_type = $^O; print STDERR "os_type: $os_type\n" if $debug; my $bin_path; unless ($bin_path = $cfg->val('binary_paths', $os_type)) { confess "'$os_type' not set in '[binary paths]' section of config file"; } unless (-d $bin_path) { confess "Invalid binaries path for $os_type" ." '[binary paths]' section of config file\n"; } print STDERR "Prepending: $bin_path to " . '$PATH', "\n" if $debug; $ENV{PATH} = $bin_path . ':' . $ENV{PATH}; }
_set_tmp_dir
Internal method called by new. Sets the environment variable TMPDIR to value of the parameter loc in the [tmp_dir] section of the parsed .ini file.; Confess if the parameter is not set, or points to an invalid directory.
sub _set_tmp_dir { my ( $self, $cfg, $debug ) = @_; my $tmp_dir; unless ($tmp_dir = $cfg->val('tmp_dir', 'loc')) { confess "'loc' not set in 'tmp_dir' section of config file"; } unless (-d $tmp_dir) { confess "Set 'loc' not set in '[tmp_dir]' " . "section to a writable directory"; } $ENV{TMPDIR} = $tmp_dir; print STDERR 'Set $ENV{TMPDIR} to ', "$tmp_dir\n" if $debug; }
_set_values
Internal routine called by the new method, to initialise the values of the objects newly created attribute to those parsed from the .ini file.
sub _set_values { my ( $self, $parameters, $values, $debug) = @_; for (my $i = 0; $i <= $#$parameters; $i++) { my $method = $parameters->[$i]; my $value = $values->[$i]; $self->$method($value); if ($debug) { print STDERR 'Set $config->', $parameters->[$i]; if (defined($values->[$i])) { print STDERR "($values->[$i])"; } else { print STDERR "(undef)"; } print STDERR "\n"; } } print STDERR "\n" if $debug; }
_validate_method_names
Internal method called by new. Checks that the names passed by array reference do not contain any spaces, and start a with a letter.
sub _validate_method_names { my ( $self, $method_ref ) = @_; foreach my $method_name (@$method_ref) { $method_name =~ s/\s+$//; if ($method_name =~ /\s/) { confess "Whitespace in method name: '$method_name'"; } unless ($method_name =~ /^\w/ and ($method_name =~ /^\D/)) { confess "Method name must start with a letter: '$method_name'"; } } return; }
make_DBAdaptor_from_config
Given an object of class Config::IniFiles, attempts to make a connection to an Ensembl core database, returning a Bio::EnsEMBL::DBSQL::DBAdaptor object, and the text of the connection details as an array reference An optional parameter (if true) causes the connection details to be output to STDOUT
sub make_DBAdaptor_from_config { my ( $self, $output ) = @_; my $cfg = $self->ConfigIniFiles; my $db_name = $cfg->val('ensembl_database', 'db') or confess "'db' not set in '[ensembl_database]' section of config file"; my $host = $cfg->val('ensembl_database', 'host') or confess "'host' not set in '[ensembl_database]' section of config file"; my $user = $cfg->val('ensembl_database', 'user') or confess "'user' not set in '[ensembl_database]' section of config file"; my ($pass, $port) = ($cfg->val('ensembl_database', 'pass') , $cfg->val('ensembl_database', 'port')); my $dba = new Bio::EnsEMBL::DBSQL::DBAdaptor(-host => $host, -user => $user, -dbname => $db_name, -pass => $pass, -port => $port); my @txt; push (@txt, "Connected to host: $host"); push (@txt, " (port: $port)") if $port; push (@txt, ", as user: $user\n"); push (@txt, "Database : $db_name\n\n"); print @txt if $output; return ($dba,\@ txt); }
make_analysis_DBAdaptor_from_config
Given an object of class Config::IniFiles, attempts to make a connection to a GeneTargeting analysis database, returning a GeneTargeting::DBSQL::DBAdaptor object, and the text of the connection details as an array reference An optional parameter (if true) causes the connection details to be output to STDOUT The environment variable 'g2c_db_name' can be use to override the specified explicitly in the config file
sub make_analysis_DBAdaptor_from_config { my ( $self, $output ) = @_; return $self->make_g2c_dba_from_named_config('analysis_database', $output); }
make_g2c_dba_from_named_config
Given an object of class Config::IniFiles, attempts to make a connection to a G2C database, returning a GeneTargeting::DBSQL::DBAdaptor object, and the text of the connection details as an array reference param - name that identifies the connection details in the supplied config file. param - optional - boolean that causes details to be output to STDOUT. i.e. to get a typical g2c database adaptor,
my $verbose_output = 1; my $g2c_dba = $cfg->make_g2c_dba_from_named_config( 'analysis_database', $verbose_output );
sub make_g2c_dba_from_named_config { my ( $self, $name, $output ) = @_; my $cfg = $self->ConfigIniFiles; my $db_name = $cfg->val($name, 'db') or confess "'db' not set in '[". $name . "]' section of config file"; my $host = $cfg->val($name, 'host') or confess "'host' not set in '[". $name . "]' section of config file"; my $user = $cfg->val($name, 'user') or confess "'user' not set in '[". $name . "]' section of config file"; my ($pass, $port) = ($cfg->val($name, 'pass'), $cfg->val($name, 'port')); my $dba = GeneTargeting::DBSQL::DBAdaptor->new; $dba->host($host); $dba->db($db_name); $dba->user($user); $dba->pass($pass); $dba->port($port); $dba->dbh; my @txt; push (@txt, "Connected to host: $host"); push (@txt, " (port: $port)") if $port; push (@txt, ", as user: $user\n"); push (@txt, "Database : $db_name\n\n"); print @txt if ($output); return ($dba,\@ txt); }
new
Constructor for a GeneTargeting::Utils::Config object. Additional methods will be added to the information found in the main::configure_parameters methods my $config = GeneTargeting::Utils::Config->new($filename, $debug); Debugging is enabled when $debug is true.
sub new { my( $pkg, $file, $debug ) = @_; my $cfg = $pkg->_parse_config_file($file, $debug); my ($mandatory, $optional) = main::configure_parameters(); my ($parameters, $values) = $pkg->_parse_parameters($cfg , $mandatory, $optional, $debug); $pkg->_validate_method_names($parameters); $pkg->_make_get_set_methods($parameters, $values); my $objref = {}; bless $objref, $pkg; $objref->_set_values($parameters, $values, $debug); $objref->ConfigIniFiles($cfg); $objref->_set_path_by_os_type_from_config($cfg, $debug); $objref->_set_tmp_dir($cfg, $debug); $objref->_set_http_proxy($cfg, $debug); return $objref; }
GeneTargeting::Utils::Exonerate
- Description
- Utility module to parse exonerate output
- Synopsis
my $file = 'exonerate_output'; { my $exonerate_fh = parse_exonerate_file($file); unless ($exonerate_fh) { die "Could not open exonerate file for reading '$file': $!" } while (my $exonerate_result = get_next_exonerate_result($exonerate_fh)) { #Do something; } }
- Global variables
- @EXPORT = ('parse_exonerate_file', 'get_next_exonerate_result')
- Included modules
- Carp
- Exporter
- IO::File
Methods
_convert_exonerate_coordinates_to_ensembl
sub _convert_exonerate_coordinates_to_ensembl { my ( $result ) = @_; if ($result->{query_strand} == -1) { my $start = $result->{query_start}; $result->{query_start} = $result->{query_end}; $result->{query_end} = $start; } $result->{query_start}++; if ($result->{target_strand} == -1) { my $start = $result->{target_start}; $result->{target_start} = $result->{target_end}; $result->{target_end} = $start; } $result->{target_start}++; }
_count_soft_masked_bases
sub _count_soft_masked_bases { my ( $original_align ) = @_; my $uc_align = uc($original_align); my $align_length = length($original_align); my $char_diff = 0; for (my $i = 0; $i <= $align_length; $i++) { unless (substr($original_align, $i, 1) eq substr($uc_align, $i, 1)) { $char_diff++; } } return $char_diff; }
_parse_exonerate_alignment
sub _parse_exonerate_alignment { my ( $fh ) = @_; my ($query_seq, $target_seq, $ryo); while (defined(my $blank = <$fh>)) { my $query = <$fh>; my $homol = <$fh>; my $target = <$fh>; if ($query =~ s/^\s+\d+\s:\s// and $query =~ s/\s:\s+\d+$//) { chomp($query); } elsif ($query =~ /pArSe/) { #We have hit the -ryo line chomp($query); $ryo = $query; last; } else { confess "Error parsing -ryo output line\n"; } chomp($target); if ($target =~ s/^\s+\d+\s:\s// and $target =~ s/\s:\s+\d+$//) { } else { last; } $query_seq .= $query; $target_seq .= $target; } return ($query_seq, $target_seq, $ryo); }
_parse_exonerate_lines
sub _parse_exonerate_lines { my ( $fh ) = @_; my ($target, $target_id, $target_desc, $model, $score); if (defined($target = <$fh>) and $target =~ s/^\s+Target:\s//) { chomp($target); if ($target =~ /^(\S+)\s(.*)/) { $target_id = $1; $target_desc = $2; } else { $target_id = $target; } } else { confess "Error with Target: line"; } confess "Couldnt get target_id" unless $target_id; if (defined($model = <$fh>) and $model =~ s/^\s+Model:\s//) { chomp($model); } else { confess "Error with Model: line"; } if (defined($score = <$fh>) and $score =~ s/^\s+Raw score:\s//) { chomp($score); } else { confess "Error with Raw score: line"; } return ($target_id, $target_desc, $model, $score); }
_parse_exonerate_range_lines
sub _parse_exonerate_range_lines { my ( $fh ) = @_; my ($query_range, $query_start, $query_end, $target_range, $target_start , $target_end); if (defined($query_range = <$fh>) and $query_range =~ s/^\s+Query range:\s//) { chomp($query_range); ($query_start, $query_end) = split(/.->./, $query_range); } else { confess "Error with Query range: line"; } if (defined($target_range = <$fh>) and $target_range =~ s/^\s+Target range:\s//) { chomp($target_range); ($target_start, $target_end) = split(/.->./, $target_range); } else { confess "Error with Target range: line"; } return ($query_start, $query_end, $target_start, $target_end); }
_parse_exonerate_ryo_line
sub _parse_exonerate_ryo_line { my ( $ryo_line ) = @_; my @fields = split(/\s+/, $ryo_line); my ($query_strand, $target_strand); if ($fields[3] eq '+') { $query_strand = 1; } elsif ($fields[3] eq '-') { $query_strand = -1; } else { confess "Error with query_strand parsed from --ryo line" } if ($fields[7] eq '+') { $target_strand = 1; } elsif ($fields[7] eq '-') { $target_strand = -1; } else { confess "Error with target_strand parsed from --ryo line" } my $percent_id = $fields[10]; my $target_length = $fields[11]; return ($query_strand, $target_strand, $percent_id, $target_length); }
get_next_exonerate_result
Given an open filehandle pointing to an exonerate output filehandle returns a hash reference with these key-value pairs (from the example above) Containing:
percent_id : 63.22 target_strand : 1 target_length : 60688862 query_id : y2 target_desc : RepeatMask Dust query_start : 257 target_align_seq : gagaaaccctgtctcaaaaaaacaaaaagaaaaagaaaaaaaagtarget_id : 19.1-60688862 query_desc : chromosome:NCBIM33:15:82422538:82468212:1 target_start : 38732589 query_end : 343 soft_mask : 1 score : 147 query_align_seq : GTGAAGTCCTGTCTCAAAACAACCATAGCAGTAAAGTAAAAAAG target_end : 38732675 query_strand : 1
Base coordinates and strand conventions conform to those of Ensembl.
sub get_next_exonerate_result { my ( $fh ) = @_; my ($query_id, $query_desc, $target_id, $target_desc, $model , $score, $query_range, $target_range, $query_start , $query_end, $target_start, $target_end); #Skip the header my $query; while (defined($query = <$fh>) and $query !~ s/^\s+Query:\s//) { } return unless $query; chomp($query); if ($query =~ /^(\S+)\s(.*)/) { $query_id = $1; $query_desc = $2; } else { $query_id = $query; } confess "Couldnt get query_id" unless $query_id; #Parse Target: Model: and Score lines ($target_id, $target_desc, $model, $score) = _parse_exonerate_lines($fh); ($query_start, $query_end, $target_start , $target_end) = _parse_exonerate_range_lines($fh); my ($query_seq, $target_seq, $ryo_line) = _parse_exonerate_alignment($fh); my $soft_masked = _count_soft_masked_bases($target_seq); my ($query_strand, $target_strand, $percent_id , $target_length) = _parse_exonerate_ryo_line($ryo_line); my $result = {}; $result->{'query_id'} = $query_id; $result->{'query_desc'} = $query_desc; $result->{'query_start'} = $query_start; $result->{'query_end'} = $query_end; $result->{'query_align_seq'} = $query_seq; $result->{'target_id'} = $target_id; $result->{'target_desc'} = $target_desc; $result->{'target_start'} = $target_start; $result->{'target_end'} = $target_end; $result->{'target_align_seq'} = $target_seq; $result->{'score'} = $score; $result->{'soft_masked'} = $soft_masked; $result->{'query_strand'} = $query_strand; $result->{'target_strand'} = $target_strand; $result->{'percent_id'} = $percent_id; $result->{'target_length'} = $target_length; _convert_exonerate_coordinates_to_ensembl($result); return $result; }
parse_exonerate_file
Given a file name for an exonerate output file generated with:
/var/tmp/exonerate-1.0.0-linux/bin/exonerate --ryo '%S pArSe %pi %tl\n'\ --showvulgar false --query query_file --target target_file
Returns an IO::File or undef if opening the file fails.
C4 Alignment: ------------ Query: y2 chromosome:NCBIM33:15:82422538:82468212:1 Target: 19.1-60688862 RepeatMask Dust Model: ungapped:simple Raw score: 147 Query range: 256 -> 343 Target range: 38732588 -> 38732675 257 : GTGAAGTCCTGTCTCAAAACAACCATAGCAGTAAAGTAAAAAAGTAGGGAAAAA : 310 | ||| |||||||||||| ||| | | | || ||||||| ||| || || 38732589 : gagaaaccctgtctcaaaaaaacaaaaagaaaaagaaaaaaaagaaggaaagaa : 38732642 311 : AATTAAAGCACAGAGCAAAACCAACCAACCAAG : 343 | || | ||| ||| || || ||| 38732643 : gaaagaaagaaagaaagaaagaaagaaagaaag : 38732675 y2 256 343 + 19.1-60688862 38732588 38732675 + 147 pArSe 63.22 60688862
sub parse_exonerate_file { my ( $file ) = @_; confess "Must pass a file name" unless $file; my $fh = new IO::File "<$file"; return $fh; }
GeneTargeting::Utils::GD
- Global variables
- @EXPORT
- Private package variables
- %valid_font_names = ( 'Small' => 1, 'Large' => 1, 'MediumBold' => 1, 'Tiny' => 1, 'Giant' => 1, )
- (%rgb_codes, %allocated_colours, @colours);
- Included modules
- Carp
- Exporter
- GD
Methods
GD_colour
Fetches a colour by name (or number) allocated in the GD object.
sub GD_colour { my ( $required ) = @_; confess "Must pass a colour" unless $required; my $colour = $allocated_colours{lc($required)}; unless (defined($colour)) { confess "Colour: $required not allocated"; } return $colour; }
_allocate_colours
Internal method called by GD to allocate the colours hardcoded in the module.
sub _allocate_colours { my ( $GD, $background_colour ) = @_; #Set background first $allocated_colours{$background_colour} = $GD->colorAllocate(@{$rgb_codes{$background_colour}}); foreach my $colour (keys(%rgb_codes)) { unless ($colour eq $background_colour) { my $allocated = $GD->colorAllocate(@{$rgb_codes{$colour}}); if ($allocated > -1) { $allocated_colours{$colour} = $allocated; push (@colours, $colour); } else { confess "Could not allocate: $colour\n"; } } } #print "**Allocated ", scalar(@colours), "\n"; }
indexed_GD_colour
Fetches a colour by numerical index (in order they were allocated);
sub indexed_GD_colour { my ( $index ) = @_; my $colour; if (defined($colour = $colours[$index])) { return $colour; } else { confess "Colour index $index not allocated"; } }
makeGD
sub makeGD { my ( $width, $height, $background_colour, $true_colour ) = @_; confess "Width and height not specified" unless $width and $height; $background_colour = 'white' unless $background_colour; my $GD; if ($true_colour) { $GD = GD::Image->newTrueColor($width, $height); } else { $GD = GD::Image->newPalette($width, $height); } confess "Could not create GD image object" unless $GD; _allocate_colours($GD, $background_colour); return $GD; }
validate_font_name
Given a font name, checks its validity (to hardcoded list). Returns, 1 on success, or confesses on failure.
sub validate_font_name { my ( $font_name ) = @_; unless ($valid_font_names{$font_name}) { confess "Invalid font: $font_name"; } return 1; }
GeneTargeting::Utils
- Description
- Utility package used extensively by the various scripts and modules. Individual routines exported to main on request.
- Global variables
- @EXPORT_OK
- Private package variables
- $temp_file_time;
- %checked_progs;
- %valid_mime_types;
- %mime_types_by_ext;
- $dbh;
- $debug;
- %latin_names_by_taxon_id;
- %taxon_ids;
- %taxon_ids_by_latin_name;
- Included modules
- Carp
- Data::Dumper
- Exporter
- GeneTargeting::Defs
- GeneTargeting::Utils::Config
- Term::ReadKey
- Time::Local
Methods
_get_output_from_ssahaClient
sub _get_output_from_ssahaClient { my ( $ssaha_read, $ssaha_err, $query_seq_count ) = @_; my (@stdout); while (defined (my $line = <$ssaha_read>)) { push (@stdout, $line); } unless (@stdout) { print STDERR "No STDOUT from ssahaClient\n" if $debug; return; } my $recvd_seqs_count = 0; while (defined (my $line = <$ssaha_err>)) { if ($line =~ s/^Setting numSequencesInFile to //) { chop($line); $recvd_seqs_count = $line; } } unless ($recvd_seqs_count == $query_seq_count) { confess "'Setting numSequencesInFile to x ' and " . "query_seq_count don't match"; } else { print STDERR "Matching numSequencesInFile and query_seq_count" . " ($query_seq_count)\n" if $debug; } return\@ stdout; }
_initialise_mime_types
sub _initialise_mime_types { %mime_types_by_ext = ( 'gif' => 'image/gif', 'png' => 'image/png', 'tif' => 'image/tif', 'tiff' => 'image/tiff', 'jpeg' => 'image/jpeg', 'jpg' => 'image/jpeg', 'jpe' => 'image/jpeg', 'mpeg' => 'video/mpeg', 'mpg' => 'video/mpeg', 'mpe' => 'video/mpeg', 'pdf' => 'application/pdf', 'qt' => 'video/quicktime', 'mov' => 'video/quicktime', 'avi' => 'video/x-msvideo', 'wmv' => 'video/x-ms-wmv', 'txt' => 'text/plain', 'doc' => 'application/msword', 'rtf' => 'application/rtf', 'zip' => 'application/zip', 'ppt' => 'application/vnd.ms-powerpoint', 'xls' => 'application/vnd.ms-excel', ); foreach my $mime_type (values(%mime_types_by_ext)) { $valid_mime_types{$mime_type}++; } }
_nice_table_dimensions
sub _nice_table_dimensions { my( @rows ) = @_; my $row = 0; my $max_col = 0; my $max_extra_col = 0; foreach my $r (@rows) { $row++; if (@$r > $max_col) { $max_col = @$r; } foreach my $c (@$r) { if (ref($c) eq 'ARRAY') { $row += @$c - 1; foreach my $sub (@$c) { if (@$sub > $max_extra_col) { $max_extra_col = @$sub; } } } } } my $col = $max_col + $max_extra_col - 1; return($row, $col); }
_parse_ssahaClient_results
sub _parse_ssahaClient_results { my ( $stdout ) = @_; return unless $stdout; my $ok_line = shift(@$stdout); unless ($ok_line =~ /^OK:/) { confess "Couldnt find line starting OK: in ssahaClient output"; } else { chomp($ok_line); print STDERR "OK: line is good: '$ok_line'\n" if $debug; } my (%ssaha_results); my $match_count = 0; foreach my $line (@$stdout) { chomp($line); unless ($line =~ /^RF|^FF/) { confess "Error parsing ssahaClient results"; } my @fields = split(/\s+/, $line); my $query_seq_id = splice(@fields, 1, 1); my %match_params; $match_params{'direction'} = $fields[0]; $match_params{'query_start'} = $fields[1]; $match_params{'query_end'} = $fields[2]; $match_params{'subject_id'} = $fields[3]; $match_params{'subject_start'} = $fields[4]; $match_params{'subject_end'} = $fields[5]; $match_params{'match_length'} = $fields[6]; $match_params{'percent_id'} = $fields[7]; $ssaha_results{$query_seq_id} ||= []; push(@{$ssaha_results{$query_seq_id}},\% match_params); $match_count++; } if ($match_count) { print STDERR "Parsed $match_count ssahaClient matches\n" if $debug; return\% ssaha_results; } else { print STDERR "No matches from ssahaClient\n" if $debug; return; } }
check_and_expand_if_stable_id
Passed a string determines if it is a stable id and expands it (if necessary) by padding with zeros, returns the padded stable_id and object_type or undef. Removes any whitespace before checking, and returns silently if nothing was passed, or nothing but whitespace.
e.g. my ($stable_id, $obj_type) = check_and_expand_if_stable_id($id); 'G1' returns ('G00000001', 'GeneTargeting::DBEntry::Gene') 'A001' returns ('A00000001', 'GeneTargeting::DBEntry::Allele')
Uppercases passed text, so 'g1' eq 'G1' -> 'G00000001'
sub check_and_expand_if_stable_id { my ( $text ) = @_; return unless $text; $text =~ s/\s+//g; return unless $text; $text = uc($text); my $first_char = substr($text, 0, 1); my $remainder = substr($text, 1); if (my $type = $GeneTargeting::Defs::object_types_by_stable_id_prefix{$first_char}) { return unless ($remainder =~ /^\d+$/ and length($remainder) <= 8); my $expanded_id = $first_char . '0' x (8 - length($remainder)) . $remainder; return ($expanded_id, $type); } }
check_programme_is_in_path
Checks the passed programme is in the current PATH, returning its location, else raises a fatal error. A second optional parameter (if defined) makes failure to find the programme non-fatal, though warns if GeneTargeting::Utils->debug_on has been called. Internally caches results so that which is only called once for each programme to be searched for.
sub check_programme_is_in_path { my ( $prog, $not_fatal ) = @_; confess "Must pass a programme name" unless $prog; return $checked_progs{$prog} if $checked_progs{$prog}; my $which_output = `which $prog 2> /dev/null`; unless ($which_output) { croak "$prog not found in PATH" unless $not_fatal; print STDERR "$prog not found in PATH" if $debug; } else { chomp($which_output); $checked_progs{$prog} = $which_output; } return $which_output; }
clones_for_slice
sub clones_for_slice { my ( $slice, $fh ) = @_; $fh =\* STDOUT unless $fh; # project to the clone coordinate system foreach my $segment (@{$slice->project('clone')}) { my ($from_start, $from_end, $pslice) = @$segment; print $fh "$from_start-$from_end projects to clone region: "; print $fh $pslice->seq_region_name(), ' ', $pslice->start(), '-', $pslice->end(), "(", $pslice->strand(), ")\n"; } print $fh "\n"; }
convert_date_string_to_mysql_date_string
Converts a date string of format DD/MM/YY or DD/MM/YYYY to a MySQL date string of YYYY-MM-DD Validates the passed date.
my $mysql_string = convert_date_string_to_mysql_date_string($date)
Returns undef if nothing was passed (i.e. false value)
sub convert_date_string_to_mysql_date_string { my ( $date ) = @_; return unless $date; my $padded_date = validate_date_string($date) or confess "Invalid date '$date'"; my ($day, $month, $year) = split("/", $padded_date); my $mysql_string = $year . '-' . $month . '-' . $day; return $mysql_string; }
convert_date_to_underscored
my $underscored_date = convert_date_to_underscored($date); # 23/03/08 -> 23_03_08 (for file names);
sub convert_date_to_underscored { my ( $date ) = @_; unless (validate_date_string($date)) { confess "Must pass a valid date"; } my $underscored_date = $date; $underscored_date =~ tr/\//_/; return $underscored_date; }
convert_date_to_unixtime
Given a date in DD/MM/YYYY format, returns the Unix time in seconds.
my $unix_time = convert_date_to_unixtime($date);
sub convert_date_to_unixtime { my ( $date ) = @_; unless (validate_date_string($date)) { confess "Invalid date"; } my ($day, $month, $year) = split(/\//,$date); #Month is 0 .. 11 my $unix_time = timelocal('00', '00', '00', $day, $month - 1, $year); return $unix_time; }
convert_mysql_date_string_to_date_string
Converts a MySQL date string of format YYYY-MM-DD to a date string of format DD/MM/YYYY, confirming the converted date is valid
my $date = convert_mysql_date_string_to_date_string($mysql_string); Returns undef if nothing pased.
sub convert_mysql_date_string_to_date_string { my ( $date_string ) = @_; return unless $date_string; my ($year, $month, $day_hour_min_sec) = split("-", $date_string); my ($day, $hour_min_sec) = split(" ", $day_hour_min_sec); unless ($year and $month and $day) { confess "Error converting '$date_string'"; } my $date = $day . '/' . $month . '/' . $year; unless (validate_date_string($date)) { print STDERR "Error converting '$date'"; print STDERR "DATE_STR = '$date_string'\n"; print STDERR "DY = '$day'\n"; print STDERR "MN = '$month'\n"; print STDERR "YR = '$year'\n"; confess; } return $date; }
convert_primer3_to_ensembl_style_coords
Converts from Primer3 output from bioperl (indexed on 0 seq coords) to Ensembl style where base is 1 and start is always less than end Pass hashref returned by calling Bio::Tools::Run::Primer3->primer_results() Returns (left_primer_start, left_primer_end, left_primer_length right_primer_start , right_primer_end, right_primer_length)
sub convert_primer3_to_ensembl_style_coords { my ( $results_hash ) = @_; my ($left_primer_start, $left_primer_length) = split(/,/, $results_hash->{'PRIMER_LEFT'}); unless (defined($left_primer_start) and $left_primer_length) { confess "Erroring parsing Primer3 result: $results_hash->{'PRIMER_LEFT'}"; } my ($right_primer_end, $right_primer_length) = split (/,/, $results_hash->{'PRIMER_RIGHT'}); unless (defined($right_primer_end) and $right_primer_length) { confess "Erroring parsing Primer3 result: $results_hash->{'PRIMER_RIGHT'}"; } #Adjust to starting from base 1 $left_primer_start++; $right_primer_end++; my $left_primer_end = $left_primer_start + $left_primer_length - 1; my $right_primer_start = $right_primer_end - $right_primer_length + 1; unless ($left_primer_end and $right_primer_start) { confess "Erroring parsing Primer3 result"; } return ($left_primer_start, $left_primer_end, $left_primer_length , $right_primer_start , $right_primer_end, $right_primer_length); }
convert_unixtime_to_date
sub convert_unixtime_to_date { my ( $unixtime ) = @_; unless ($unixtime and $unixtime > 0) { confess "Must pass a unixtime"; } my @time = localtime($unixtime); my $day = $time[3]; $day = '0' . $day if $day < 10; my $mon = $time[4] + 1; $mon = '0' . $mon if $mon < 10; my $year = $time[5] + 1900; my $date_string = "$day/$mon/$year"; unless (validate_date_string($date_string)) { confess "Invalid todays date generated"; } return $date_string; }
debug_off
Needs to be called with GeneTargeting::Utils->debug_on;
sub debug_off { $debug = 0; }
debug_on
Needs to be called with GeneTargeting::Utils->debug_on;
sub debug_on { $debug = 1; }
do_ssahaClient_search
Run the ssahaClient sequence search programme, with the passed server, port, server parameters and sequence(s) the latter of which should be a Bio:Seq object or a reference to an array of such objects.
e.g. my $results = do_ssahaClient_search($server, $port, $params, $seq); $params is optional, if is passed as undef a default is used: '13 13 2 0 DNA 200 0 none' If matches are obtained, a reference to a hash returned, the keys of which are the query sequence ids, the values being a reference to an array of hashes of the individual subject matches, the latter hashes being keyed by returned parameter name, these are direction query_start query_end subject_id subject_start subject_end match_length percent_id Extensive error checking is performed to make sure the number of seqs passed to ssahaClient is the same as that subsequently reported by the ssaha server, etc
Checks the current path for 'ssahaClient' before trying to call it, raising a fatal error if not found. Turn GeneTargeting::Utils->debug_on to track progress Requires: 'use Bio::SeqIO;' 'use IO:Handle;' 'use IPC::Open3;'
#Display the $results: foreach my $query_seq_id (keys(%$results)) { print "Matches found for: $query_seq_id\n"; foreach my $match (@{$results->{$query_seq_id}}) { print " direction : $match->{'direction'}\n"; print " query_start : $match->{'query_start'}\n"; print " query_end : $match->{'query_end'}\n"; print " subject_id : $match->{'subject_id'}\n"; print " subject_start: $match->{'subject_start'}\n"; print " subject_end : $match->{'subject_end'}\n"; print " match_length : $match->{'match_length'}\n"; print " percent_id : $match->{'percent_id'}\n"; print "\n"; } }
sub do_ssahaClient_search { my ( $server, $port, $parameters, $seq ) = @_; # Check for program, parameters, compose the line to run ssahaClient check_programme_is_in_path('ssahaClient'); unless ($server and $port) { confess "Must pass stuff"; } $parameters = '13 13 2 0 DNA 200 0 none' unless $parameters; unless ($seq and ref($seq) =~ /ARRAY|Bio::Seq/) { confess "Must pass a Bio::Seq object or ref to an array of them"; } my $prog = "ssahaClient $server $port $parameters"; my ($ssaha_read, $ssaha_write, $ssaha_err) = (IO::Handle->new , IO::Handle->new, IO::Handle->new); #Need to fully specify the package name for open3 eval { IPC::Open3::open3($ssaha_write, $ssaha_read, $ssaha_err, $prog); }; if ($@) { #The eval doesnt seem to be catching errors confess "open3 failed to launch ssahaClient: $!\n$@"; } # Check what type of seq parameter was passed and write them # Using Bio::SeqIO to the ssahaClient STDIN my $query_seq_count; { my $seqIO = Bio::SeqIO->new(-fh => $ssaha_write , -format => 'fasta'); if (ref($seq) eq 'ARRAY') { foreach my $single_seq (@$seq) { $seqIO->write_seq($single_seq) or confess "Could not write seq: $!"; } $query_seq_count = scalar(@$seq); } else { $seqIO->write_seq($seq) or confess "Could not write seq: $!"; $query_seq_count = 1; } } undef $ssaha_write; print STDERR "do_ssahaClient_search called with $query_seq_count seqs\n" if $debug; my $stdout = _get_output_from_ssahaClient($ssaha_read, $ssaha_err , $query_seq_count); my $results = _parse_ssahaClient_results($stdout); return $results; }
format_string_sixty_chrs_per_line
Takes a string and returns it formatted with 60 chars per line, each line separated by newlines, as a scalar. Used to output a sequence (string) in FASTA like format
sub format_string_sixty_chrs_per_line { my ( $string, $offset ) = @_; confess "Must pass a string" unless $string; $offset = 0 unless $offset; my $truncated_string = $string; my $formatted_string; while ($truncated_string =~ /(.{1,60})/g) { $formatted_string .= ' ' x $offset . "$1\n"; } return $formatted_string; }
get_Xref2_by_longest_seq_type
my $xref2 = get_Xref2_by_longest_seq_type($obj);
sub get_Xref2_by_longest_seq_type { my ( $obj, $seq_type ) = @_; unless ($obj and ref($obj) and $obj->isa('GeneTargeting::DBEntry')) { confess "Expected a 'GeneTargeting::DBEntry' object"; } unless ($seq_type and $seq_type =~ /^gene$|^transcript$|^protein$/) { confess "Must pass a valid seq_type"; } my $longest_xref; my $xrefs = $obj->get_all_xref2s; foreach my $xref (@$xrefs) { if ($xref->seq_type and $xref->seq_type eq $seq_type) { unless ($longest_xref) { $longest_xref = $xref; next; } if ($longest_xref and length($xref->seq) > length($longest_xref->seq)) { $longest_xref = $xref; } } } return $longest_xref; }
get_all_mime_types
Returns a list_ref to all the mime types we have hardcoded in the module.
sub get_all_mime_types { _initialise_mime_types() unless %mime_types_by_ext; return [values(%mime_types_by_ext)]; }
get_basedir
Gets the GeneTargetingBaseDir, verifying it is valid (as a directory, and seems to have the right contents)
my $dir = get_basedir();
sub get_basedir { my $base_dir = $ENV{'GeneTargetingBaseDir'} or show_perldoc("Must set\$ GeneTargetingBaseDir\n"); show_perldoc("Can't read directory '$base_dir'\n") unless -d $base_dir; show_perldoc('Error finding scripts with $GeneTargetingBaseDir') unless -f "$base_dir/scripts/db/create_db_tables"; return $base_dir; }
get_latin_name_by_taxon_id
Given a taxon_id returns the latin name
sub get_latin_name_by_taxon_id { my ( $tax_id ) = @_; unless (%taxon_ids) { initialise_os_codes(); } confess "Must pass a taxon_id" unless $tax_id; if ($latin_names_by_taxon_id{$tax_id}) { return $latin_names_by_taxon_id{$tax_id}; } else { return; } }
get_longest_ensembl_transcript
Given an object of class Bio::EnsEMBL::Gene returns its longest transcript or undef should none be present.
sub get_longest_ensembl_transcript { my ( $gene ) =@_; unless ($gene and ref($gene) and $gene->isa('Bio::EnsEMBL::Gene')) { confess "Exected a Bio::EnsEMBL::Gene object"; } my ($longest_transcript); foreach my $transcript (@{$gene->get_all_Transcripts}) { unless ($longest_transcript) { $longest_transcript = $transcript; next; } if ($transcript->length > $longest_transcript->length) { $longest_transcript = $transcript; } } if ($longest_transcript) { return $longest_transcript; } else { warn "Failed to get longest transcript\n"; } }
get_max_and_min_from_arrayref
??? Needs to be written
sub get_max_and_min_from_arrayref { my ( $positions ) = @_; my ($min, $max); for (my $i = 0; $i <= $#$positions; $i++) { unless ($max) { $max = $positions->[$i]; $min = $positions->[$i]; next; } if ($positions->[$i] < $min) { $min = $positions->[$i]; } if ($positions->[$i] > $max) { $max = $positions->[$i]; } } return ($max, $min); }
get_mime_type
Given a file extension, or filename.ext (with or without full path spec) guesses mime type from the hardcoded types in the module. Case-insensitive. Confesses if nothing is passed
sub get_mime_type { my ( $ext ) = @_; confess "Nothing pased" unless $ext; _initialise_mime_types() unless %mime_types_by_ext; $ext = lc($ext); if (index($ext, '/') >= 0) { $ext = substr($ext, rindex($ext, '/') + 1); } if (index($ext, '.') >= 0) { $ext = substr($ext, rindex($ext, '.') + 1); } return $mime_types_by_ext{$ext}; }
get_password
Gets a password interactively from the command prompt using Term::ReadKey
my $pass = get_password('Mesg');
sub get_password { my( $prompt ) = @_; $prompt ||= 'Password: '; # Prompt for password print STDERR $prompt; ReadMode('noecho'); my $password = ReadLine(0); print STDERR "\n"; chomp $password; ReadMode('normal'); return $password; }
get_string_for_feature
sub get_string_for_feature { my ( $feature ) = @_; my $stable_id = $feature->stable_id(); my $seq_region = $feature->slice()->seq_region_name(); my $start = $feature->start(); my $end = $feature->end(); my $strand = $feature->strand(); return ("$stable_id, $seq_region:$start-$end($strand)"); }
get_taxon_id_by_latin_name
Given a latin_name returns the taxon_id
sub get_taxon_id_by_latin_name { my ( $name ) = @_; confess "Must pass a latin name" unless $name; unless (%taxon_ids) { initialise_os_codes(); } if ($taxon_ids_by_latin_name{$name}) { return $taxon_ids_by_latin_name{$name}; } else { return; } }
get_temp_dir
Returns the directory pointed to by the environment variable $TMPDIR. Causes a fatal error if the variable is undefined or the directory is not valid.
sub get_temp_dir { my $tmp_dir = $ENV{TMPDIR}; $tmp_dir =~ s/\/$// if $tmp_dir; unless ($tmp_dir and -d $tmp_dir) { croak 'Set $TMPDIR to a writable directory'; } return $tmp_dir; }
get_temp_filename
my $temp_file = get_temp_filename();
Returns a temporary filename based upon the current programme name name, unix time and process id. The numerical portion of the name is incremented by one each subsequent time the subroutine is called.
sub get_temp_filename { $temp_file_time = scalar(time) unless $temp_file_time; my $temp = '_' . $0 . '_' . $$ . '_' . $temp_file_time; $temp_file_time++; $temp =~ tr/.\///d; return $temp; }
get_time
sub get_time { my @time = localtime(time); my $sec = $time[0]; $sec = '0' . $sec if $sec < 10; my $min = $time[1]; $min = '0' . $min if $min < 10; my $hour = $time[2]; $hour = '0' . $hour if $hour < 10; my $time_string = "$hour:$min:$sec"; return $time_string; }
get_todays_date
Returns the date in DD/MM/YYYY format.
e.g. my $date = get_todays_date;
sub get_todays_date { my $date_string = convert_unixtime_to_date(time); return $date_string; }
initialise_os_codes
Called by the DBAdaptor upon initialisation...
sub initialise_os_codes { unless ($dbh) { confess "initialise_os_codes found no current database handle"; } if (%taxon_ids) { confess "initialise_os_codes has already been called"; } %taxon_ids = (); %latin_names_by_taxon_id = (); %taxon_ids_by_latin_name = (); my $sth = $dbh->prepare( "SELECT name, display_id, synonyms FROM cv_gt_os_code"); $sth->execute(); while (my ($name, $display_id, $synonyms) = $sth->fetchrow) { $taxon_ids{$name} = $synonyms; $latin_names_by_taxon_id{$name} = $display_id; $taxon_ids_by_latin_name{$display_id} = $name; } }
interrogate_coord_system
Pass a Bio::EnsEMBL::CoordSystem
sub interrogate_coord_system { my ( $coord_sys, $fh ) = @_; $fh =\* STDOUT unless $fh; print $fh "REF : ", ref($coord_sys), "\n"; print $fh "name : ", $coord_sys->name, "\n"; print $fh "version : ", $coord_sys->version, "\n"; print $fh "is_top_level : ", $coord_sys->is_top_level, "\n"; print $fh "is_sequence_level: ", $coord_sys->is_sequence_level, "\n"; print $fh "is_default : ", $coord_sys->is_default, "\n"; print $fh "rank : ", $coord_sys->rank, "\n"; print $fh "\n"; }
interrogate_gene
Pass a Bio::EnsEMBL::Gene object. Outputs a txt report about the gene and its exons to STDOUT (or optionally, the passed filehandle). Orders the Exons by the order of translation.
sub interrogate_gene { my ( $gene, $fh ) = @_; $fh =\* STDOUT unless $fh; print $fh ref($gene), "\n"; print $fh "display_id: ", $gene->display_id, "\n"; print $fh "db_id : ", $gene->dbID, "\n"; print $fh "biotype : ", $gene->biotype, "\n"; print $fh "strand : ", $gene->strand, "\n"; print $fh "is_known : ", $gene->is_known, "\n"; my $exons = $gene->get_all_Exons(); my $exon_count = 1; if ($gene->strand == 1) { print $fh "\nGene is on the forward strand (exons in order of translation)\n"; foreach my $exon (sort {$a->start <=> $b->start} @$exons) { print $fh "Exon ", $exon_count, " (", $exon->stable_id, '): ' , $exon->start, '-', $exon->end; print $fh " Strand: ", $exon->strand, " Length: ", $exon->length, "\n"; $exon_count++; } } else { print $fh "\nGene is on the reverse strand (exons in order of translation)\n"; foreach my $exon (sort {$b->start <=> $a->start} @$exons) { print $fh "Exon ", $exon_count, " (", $exon->stable_id, '): ' , $exon->end, '-', $exon->start; print $fh " Strand: ", $exon->strand, " Length: ", $exon->length, "\n"; $exon_count++; } } print $fh "\n\n"; }
interrogate_genes
Pass an array reference to a number of Bio::EnsEMBL::Gene objects
sub interrogate_genes { my ( $genes_ref, $fh ) = @_; $fh =\* STDOUT unless $fh; unless ($genes_ref) { print $fh "No genes\n"; } print $fh "Number of genes: ", scalar(@$genes_ref), "\n"; foreach my $gene (@{$genes_ref}) { interrogate_gene($gene); } print $fh "\n"; }
interrogate_slice
Pass a Bio::EnsEMBL::Slice, and optionally a Bio::EnsEMBL::DBSQL::GeneAdaptor
sub interrogate_slice { my ( $slice, $gene_aptr, $fh ) = @_; $fh =\* STDOUT unless $fh; my $coord_system = $slice->coord_system(); print $fh "REF : ", ref($slice), "\n"; print $fh "name : ", $slice->name, "\n"; print $fh "seq_region_name : ", $slice->seq_region_name, "\n"; #Chr name print $fh "seq_region_length: ", $slice->seq_region_length, "\n"; #Chr length print $fh "strand : ", $slice->strand, "\n"; print $fh "start : ", $slice->start, "\n"; print $fh "end : ", $slice->end, "\n"; print $fh "length : ", $slice->length, "\n"; print $fh "\n"; if ($gene_aptr) { my $genes_ref = $gene_aptr->fetch_all_by_Slice($slice); interrogate_genes($genes_ref, $fh); } }
make_primers_with_primer3
Pass a Bio::Seq compliant object, a size_range (e.g. '500-1000') for the product, and the primer salt conc. Contains other hardcoded primer3 parameters. Requires Bio::Tools::Run::Primer3; Returns a reference to an array of hashes, if primers are picked, or undef. Each hash has the keys: left_primer_start, left_primer_end, left_primer_length, left_primer, right_primer_start, right_primer_end, right_primer_length, right_primer, product_size Positions returned are 1-based, like Bioperl and Ensembl
sub make_primers_with_primer3 { my ( $seq, $size_range, $primer_salt_conc ) = @_; my ($tmp_dir, $temp_file) = (get_temp_dir(), get_temp_filename()); $temp_file = $tmp_dir . '/' . $temp_file; my $primer3 = Bio::Tools::Run::Primer3->new(-seq => $seq, -outfile => $temp_file); unless ($primer3->executable) { confess "primer3 can not be found. Is it installed?\n"; } # PRIMER_PRODUCT_MIN_TM, PRIMER_PRODUCT_MAX_TM, PRIMER_PRODUCT_OPT_TM # PRIMER_PRODUCT_OPT_SIZE (this one is optional) # # Exclude regions like this (dont pick 0-1000 or 2000-3000) # 'EXCLUDED_REGION' => '0,1000 2000,3000' $primer3->add_targets('PRIMER_PRODUCT_SIZE_RANGE' => $size_range, 'PRIMER_MIN_SIZE' => 20, 'PRIMER_MAX_SIZE' => 22, 'PRIMER_OPT_SIZE' => 21, 'PRIMER_MIN_GC' => 40, 'PRIMER_MAX_GC' => 50, 'PRIMER_OPT_GC_PERCENT' => 45, 'PRIMER_MIN_TM' => 55, 'PRIMER_MAX_TM' => 60, 'PRIMER_GC_CLAMP' => 1, 'PRIMER_SALT_CONC' => $primer_salt_conc, 'PRIMER_NUM_RETURN' => 20); # Bio::Tools::Primer3 object returned, check we got primers my $primer3_results = $primer3->run; my @primer_results; for (my $i = 0; $i < $primer3_results->number_of_results; $i++) { my $results_hash = $primer3_results->primer_results($i); print_hash_ref($results_hash) if $debug; my ($left_primer_start, $left_primer_end, $left_primer_length , $right_primer_start , $right_primer_end, $right_primer_length) = convert_primer3_to_ensembl_style_coords($results_hash); my $left_primer = $results_hash->{'PRIMER_LEFT_SEQUENCE'} or confess "Error parsing primer3 output 'PRIMER_LEFT_SEQUENCE'\n"; my $right_primer = $results_hash->{'PRIMER_RIGHT_SEQUENCE'} or confess "Error parsing primer3 output 'PRIMER_RIGHT_SEQUENCE'\n"; my $product_size = $results_hash->{'PRIMER_PRODUCT_SIZE'} or confess "Error parsing primer3 output 'PRIMER_PRODUCT_SIZE'\n"; my $primer_result = { 'left_primer_start' => $left_primer_start , 'left_primer_end' => $left_primer_end, , 'left_primer_length' => $left_primer_length , 'left_primer' => $left_primer , 'right_primer_start' => $right_primer_start , 'right_primer_end' => $right_primer_end, , 'right_primer_length' => $right_primer_length , 'right_primer' => $right_primer, , 'product_size' => $product_size }; push (@primer_results, $primer_result); } undef $primer3; unlink $temp_file if -f $temp_file; if (@primer_results) { return\@ primer_results; } else { } }
make_xref_with_pfetch
Given an accession, and external_db_id tries to make an Xref object with sequence fetched via Pfetch.
e.g. my $xref = make_xref_with_pfetch($acc, $ext_db_id); Note you will get an Xref back even if the pfetch fetch fails, it simply wont have a sequence and a description.
If a third optional parameter is passed which is an array ref (checked), then a warning msg will be inserted in the array if the pfetch fails.
sub make_xref_with_pfetch { my ( $acc, $ext_db_id, $warnings ) = @_; confess "Must pass an accession" unless $acc; confess "Must pass an external_db_id" unless $ext_db_id; my $description; my $xref = GeneTargeting::DBEntry::Xref2->new; my ($primary_acc, $version) = split (/\./, $acc); $xref->dbprimary_acc($primary_acc); $xref->display_label($acc); $xref->ext_db_id($ext_db_id); #Lets see if can get the sequence my $text = `pfetch $acc`; print STDERR "pfetch $acc\n"; unless ($text =~ /no match/) { chomp($text); my @lines = split("\n", $text); my $id_line = shift(@lines) or confess "Couldnt get id line for '$acc'"; print STDERR "$id_line\n"; if ($id_line =~ /\|/) { #GenBank my @fields = split(/\|/, $id_line); ($primary_acc, $version) = split (/\./, $fields[3]); $description = $fields[4]; $description =~ s/^\s+//; print STDERR "PARSED PRIMARY ACC: $primary_acc\n"; print STDERR "PARSED VERSION : $version\n"; print STDERR "PARSED DESCRIPTION: $description\n"; } elsif ($id_line =~ /^>(\w+)\.(\d+)/) { $primary_acc = $1; $version = $2; $description = substr($id_line, index($id_line, " ") + 1); print STDERR "All GOOD\n"; print STDERR "PARSED PRIMARY ACC: $primary_acc\n"; print STDERR "PARSED VERSION : $version\n"; print STDERR "PARSED DESCRIPTION: $description\n"; } if ($version) { $xref->version($version); } else { confess "Failed to get version for $acc\n"; } $xref->description($description) if $description; my $seq; foreach my $line (@lines) { $seq .= $line; } confess "Couldnt get sequence for '$acc'" unless $seq; #$xref->description($id_line); $xref->seq($seq); return $xref; } elsif ($warnings and ref($warnings) and ref($warnings) =~ /ARRAY/) { push (@$warnings, "Couldn't fetch '$acc' with pfetch\n"); return; } }
map_adaptor_type_to_dbentry
Given a GeneTargeting::DBSQL::xxxxAdaptor object, or a scalar string of such a type, returns the GeneTargeting::DBEntry type
sub map_adaptor_type_to_dbentry { my ( $adaptor ) = @_; confess "Must pass an object or type" unless $adaptor; my $type; if (ref($adaptor)) { $type = ref($adaptor); } else { $type = $adaptor } my $dbentry_type = $GeneTargeting::Defs::adaptor_dbentry_mapping{$type} or confess "No mapping for $type"; return $dbentry_type; }
map_dbentry_type_to_adaptor
Given a GeneTargeting::DBEntry object, or a scalar string of such a type, returns the GeneTargeting::DBSQL:: Adaptor type
sub map_dbentry_type_to_adaptor { my ( $dbentry ) = @_; confess "Must pass an object or type" unless $dbentry; my $type; if (ref($dbentry)) { $type = ref($dbentry); } else { $type = $dbentry } my $adaptor_type = $GeneTargeting::Defs::dbentry_adaptor_mapping{$type} or confess "No mapping for $type"; return $adaptor_type; }
output_GD
Given a GD object, a file_name and optionally an img type 'png', 'gif' or 'jpg' renders the image to the file. If no img type is supplied trys to generate a png first, else a gif. Returns the file name of the file written which will have the '.img type' appended.
sub output_GD { my ( $gd, $file_name, $image_type, $clobber ) = @_; $file_name =~ s/\.png$|\.gif$|\.jpg$//; local *FILE; if ($image_type) { unless (GD::Image->can("$image_type")) { confess "Cant generate: $image_type"; } } else { $image_type = (GD::Image->can("png")) ? 'png' : 'gif'; } $file_name .= ".$image_type"; if (-e $file_name and !$clobber) { confess "'$file_name' already exists"; } open (FILE, ">$file_name") or confess "Could not open '$file_name' for writing: $!"; binmode FILE; print FILE $gd->$image_type or confess "Could not write to '$file_name': $!"; close (FILE) or confess "Could not close '$file_name': $!"; return $file_name; }
print_hash_ref
Pass a hash reference to get its contents output to STDOUT. If a second optional parameter is true it truncates the keys of the hash so that: '_gene_targeting_dbentry_dnaprobe_assembly'
becomes
'assembly' Also returns the output txt as an array reference
sub print_hash_ref { my ( $hash_ref, $truncate ) = @_; unless ($hash_ref and $hash_ref =~ /HASH/) { print "Must pass a HASH reference\n\n"; return; } my %truncated_keys; foreach my $key (keys(%{$hash_ref})) { my $truncated_key = $key; $truncated_key =~ s/\w+_// if $truncate; $truncated_keys{$truncated_key} = $key; } my $max_key_length = 0; foreach my $key (keys(%truncated_keys)) { my $length = length($key); $max_key_length = $length if $length > $max_key_length; } $max_key_length += 2; my @txt; foreach my $key (sort keys(%truncated_keys)) { push (@txt, " $key ", ' ' x ($max_key_length - length($key)), ': '); if (defined($hash_ref->{$truncated_keys{$key}})) { push (@txt, $hash_ref->{$truncated_keys{$key}} . "\n"); } else { push (@txt, "<undef>\n"); } } push (@txt, " ", '-' x $max_key_length, "\n"); print @txt; return\@ txt; }
print_list_of_hash_refs
sub print_list_of_hash_refs { my ( $list ) = @_; unless ($list and ref($list) =~ /ARRAY/) { confess "Must pass an ARRAY reference to a list of hashes" } foreach my $hash (@$list) { if (ref($hash)) { print ref($hash), "\n"; } print_hash_ref($hash); print "\n"; } }
set_taxon_dbh
Call this first to set the current database handle. This allows a degree of lazy loading, but other methods in the block should call something like this to enact the lazy loading. unless (%taxon_ids) { initialise_os_codes(); } The main reason for this requirement is to deal with a completely empty database, that is being rebuilt from scratch... param -- A database handle that has (or will have) the taxon data in it.
sub set_taxon_dbh { my ( $current_dbh ) = @_; $dbh = $current_dbh; }
show_perldoc
Outputs the passed txt to STDERR, followed by the POD of the program, afer a two second delay, then confesses.
sub show_perldoc { my ( $text ) = shift(@_); $text = "HELP:" unless $text; chomp($text); print STDERR "\n$text\n\n"; sleep 2; my @perldoc = `perldoc -T $0`; foreach my $line (@perldoc) { print STDERR $line; } unless ($text eq 'HELP:') { confess "\n" , $text; } else { die 'Exiting'; } }
sort_objects_by_external_db
Given a reference to an array of GeneTargeting::DBEntry objects sorts them by $object->source_external_db->db_name and $object->source_external_db->id and returns referecnes to two hashes keyed by these.
e.g. my ($sorted_by_name, $sorted_by_id) = sort_objects_by_external_db($objects);
sub sort_objects_by_external_db { my ( $objects ) = @_; unless ($objects and ref($objects) and ref($objects) =~ /ARRAY/) { confess "Must pass a reference to an array"; } unless (@$objects) { confess "Empty array"; } my $sorted_by_name = {}; my $sorted_by_id = {}; foreach my $object (@$objects) { unless ($object and ref($object) and $object->isa('GeneTargeting::DBEntry')) { confess "Must be a GeneTargeting::DBEntry object", Dumper($object); } my $src_ext_db = $object->source_external_db or confess "Could not get source_external_db"; $sorted_by_name->{$src_ext_db->db_name} ||= []; push (@{$sorted_by_name->{$src_ext_db->db_name}}, $object); $sorted_by_id->{$src_ext_db->id} ||= []; push (@{$sorted_by_id->{$src_ext_db->id}}, $object); } return ($sorted_by_name, $sorted_by_id); }
strip_dbadaptor_type_prefix
Given 'GeneTargeting::DBSQL::GeneAdaptor' would return 'Gene'
sub strip_dbadaptor_type_prefix { my ( $dbadaptor ) = @_; unless ($dbadaptor && ref($dbadaptor) && ref($dbadaptor) =~ /^GeneTargeting::DBSQL/) { confess "Expected a adaptor subtype object"; } my @splits = split (/^GeneTargeting::DBSQL::/, ref($dbadaptor)); confess "Error " unless $splits[1]; $splits[1] =~ s/Adaptor$//; return $splits[1]; }
strip_dbentry_type_prefix
If supplied with a dbentry it will return the ref($dbentry) string minus the GeneTargeting::DBEntry:: prefix - used to shorten our HTTP GET strings a bit. Polymorphic - you can pass the object or an appropriate type
sub strip_dbentry_type_prefix { my ( $db_entry ) = @_; unless ($db_entry) { confess "Must pass a GeneTargeting::DBEntry object or scalar " . " string of the type"; } my $type; if (ref($db_entry)) { $type = ref($db_entry); } else { $type = $db_entry; } unless ($type =~ /^GeneTargeting::DBEntry::/) { confess "Bad GeneTargeting::DBEntry object (or type) '$type'"; } my @splits = split (/^GeneTargeting::DBEntry::/, $type); confess "Error " unless $splits[1]; return $splits[1]; }
test_integer
Confirmed the passed value is an integer number, returning true or undef unless (test_integer($number)) { # do something }
sub test_integer { my ( $number ) = @_; return undef unless validate_number($number); return 1 if $number =~ m/^[+\-]?\d+\.?0*$/; return undef; }
validate_date_string
Validates the passed date in format DD/MM/YYYY returning the date if its valid, or undef. Will silently convert '.' and ':' to '/' in passed date
e.g. my $date = validate_date_string($date);
Confesses if nothing is passed.
sub validate_date_string { my ( $date ) = @_; confess "Nothing passed" unless $date; #Silently convert '.' and ':' to '/' in passed date $date =~ s/\./\//g; $date =~ s/:/\//g; my $slash_count = ($date =~ tr/\///); unless ($slash_count == 2) { #Not enough slashes in date return; } my ($day, $month, $year) = split("/", $date); unless (length($year) == 4) { confess q[Must pass 'DD/MM/YYYY' not 'DD/MM/YY']; } my $padded_date = $day . '/'. $month . '/' . $year; if ($padded_date =~ /^(?:(?:(?:0?[1-9]|1\d|2[0-8])\/(?:0?[1-9]|1[0-2]))\/(?:(?:1[6-9]|[2-9]\d)\d{2}))$|^(?:(?:(?:31\/0?[13578]|1[02])|(?:(?:29|30)\/(?:0?[1,3-9]|1[0-2])))\/(?:(?:1[6-9]|[2-9]\d)\d{2}))$|^(?:29\/0?2\/(?:(?:(?:1[6-9]|[2-9]\d)(?:0[48]|[2468][048]|[13579][26]))))$/) { return $padded_date; } elsif ($month =~ /^12$|^10$/ and $day eq '31') { return $padded_date; } else { return; } }
validate_g2c_stable_id
Verifies the passed G2C stable id, confessing if invalid Returns the type of the stable_id if successful.
my $type = validate_g2c_stable_id($id);
A second optional parameter allows one to explicitly check the stable_id type
my $type = validate_g2c_stable_id($gene_id , 'GeneTargeting::DBEntry::Gene');
- stable_id
- (returned/expected) type
- A00000001
- GeneTargeting::DBEntry::Allele
- M00000001
- GeneTargeting::DBEntry::Colony
- X00000001
- GeneTargeting::DBEntry::Experiment
- G00000001
- GeneTargeting::DBEntry::Gene
- L00000001
- GeneTargeting::DBEntry::GeneList
- V00000001
- GeneTargeting::DBEntry::Vector
Check GeneTargeting::Defs for full list.
sub validate_g2c_stable_id { my ( $id, $type ) = @_; confess "Must pass an id" unless $id; if ($type) { unless ($GeneTargeting::Defs::stable_id_prefixes_by_object_type{$type}) { confess "Object of class '$type' cannot have a stable_id"; } } #Prefix unless ($id =~ /(^$GeneTargeting::Defs::valid_stable_id_prefixes)\d/) { confess "Invalid stable_id: '$id'"; } my $prefix = $1; #Following digits my $digits = substr($id, length($prefix)); unless ($digits =~ /^\d\d\d\d\d\d\d\d$/ and $digits ne '00000000') { confess "Invalid stable_id: '$id'"; } #Now optional type-checking my $inferred_obj_type = $GeneTargeting::Defs::object_types_by_stable_id_prefix{$prefix}; if ($type and $inferred_obj_type ne $type) { confess "Invalid stable_id: '$id' as type: '$type'" } return $inferred_obj_type; }
validate_g2c_stable_id_not_fatal
Verifies the passed G2C stable id, returning the type of the stable_id if successful, or undef
my $type = validate_g2c_stable_id_not_fatal($id);
A second optional parameter allows one to explicitly check the stable_id type
my $type = validate_g2c_stable_id_not_fatal($gene_id, 'GeneTargeting::DBEntry::Gene');
- stable_id
- (returned/expected) type
- A00000001
- GeneTargeting::DBEntry::Allele
- M00000001
- GeneTargeting::DBEntry::Colony
- X00000001
- GeneTargeting::DBEntry::Experiment
- G00000001
- GeneTargeting::DBEntry::Gene
- L00000001
- GeneTargeting::DBEntry::GeneList
- V00000001
- GeneTargeting::DBEntry::Vector
Check GeneTargeting::Defs for full list.
sub validate_g2c_stable_id_not_fatal { my ( $id, $type ) = @_; confess "Must pass an id" unless $id; if ($type) { unless ($GeneTargeting::Defs::stable_id_prefixes_by_object_type{$type}) { carp "Object of class '$type' cannot have a stable_id"; return; } } #Prefix unless ($id =~ /(^$GeneTargeting::Defs::valid_stable_id_prefixes)\d/) { carp "Invalid stable_id: '$id'"; return; } my $prefix = $1; #Following digits my $digits = substr($id, length($prefix)); unless ($digits =~ /^\d\d\d\d\d\d\d\d$/ and $digits ne '00000000') { carp "Invalid stable_id: '$id'"; return; } #Now optional type-checking my $inferred_obj_type = $GeneTargeting::Defs::object_types_by_stable_id_prefix{$prefix}; if ($type and $inferred_obj_type ne $type) { carp "Invalid stable_id: '$id' as type: '$type'"; return; } return $inferred_obj_type; }
validate_nucleotide_seq
Given a string (DNA) sequence, checks all characters are one of AaTtGgCcNn . If the sequence is valid returns 1, else returns undef. Each invalid char causes a warning to be issued to STDERR 'Invalid character in sequence: ?'
sub validate_nucleotide_seq { my ( $sequence ) = @_; confess "No sequence" unless $sequence; my $seq_length = length($sequence); for (my $i = 0; $i < $seq_length; $i++) { my $char = substr($sequence, $i, 1); unless ($char =~ /[ATGCN]/i) { print STDERR "Invalid character in sequence: '$char'"; return; } } return 1; }
validate_number
Validate the passed value is a number, returning true or undef
unless ($validate_number) { # do something }
sub validate_number { my ( $number ) = @_; return undef unless defined $number && length $number; # Accept obviously right things. return 1 if $number =~ m/^\d+$/; # Throw out obviously wrong things. return undef if $number =~ m/[^+\-\.eE0-9]/; # Split the number into parts. my ( $num, $e, $exp ) = split /(e|E)/, $number, 2; # Check that the exponent is valid. if ($e) { return undef unless $exp =~ m/^[+\-]?\d+$/; } # Check the number. return undef unless $num =~ m/\d/; return undef unless $num =~ m/^[+\-]?\d*\.?\d*$/; return 1; }
validate_privacy
Validates the passed numerical privacy, which must be an integer between 0 and 999, returning true or false.
e.g. if (validate_privacy($privacy)) { #Do something }
sub validate_privacy { my ( $privacy ) = @_; confess "Must pass a privacy value" unless defined($privacy); unless ($privacy >= 0 and $privacy <= 999 and int($privacy) == $privacy) { return; } return 1; }
verify_known_taxon_id
Given a taxon_id checks if it is one of those hardcoded into the module, returning the common name Currently knows:
10090 mouse 9606 human
sub verify_known_taxon_id { my ( $tax_id ) = @_; confess "Must pass a taxon_id" unless $tax_id; unless (%taxon_ids) { initialise_os_codes(); } if ($taxon_ids{$tax_id}) { return $taxon_ids{$tax_id}; } else { return; } }
verify_mime_type
Given a mime_type returns true if its known. Confess if nothing is passed
sub verify_mime_type { my ( $type ) = @_; confess "Nothing passed" unless $type; _initialise_mime_types() unless %mime_types_by_ext; return $valid_mime_types{$type}; }
write_Slice_to_fasta
??? Needs to be written
sub write_Slice_to_fasta { my ( $slice, $seq_id, $file_name ) = @_; unless ($slice and $slice->isa('Bio::EnsEMBL::Slice')) { confess "Must pass a Bio::EnsEMBL::Slice"; } confess "Must pass a seq_id" unless $seq_id; confess "Must pass a file name" unless $file_name; my $SeqIO_out = Bio::SeqIO->new( -FILE => ">$file_name", -FORMAT => 'FASTA', ); my $Seq = Bio::Seq->new( -id => $seq_id, -seq => $slice->seq ); $SeqIO_out->write_seq($Seq); }
GeneTargeting::Utils::HTMLReport
- Description
- Utility module to construct an html file in memory, appending and prepending to it as necessary:
my $html = GeneTargeting::Utils::HTMLReport->new; $html->header('Header txt'); $html->title('Test output'); $html->append('text'); $html->prepend('text); $html->write('filename');
Call $html->clear to start building afresh. Also has a number of methods which when passed Ensembl objects, adds various report information to the html. - Included modules
- Carp
- IO::File
- Constructor
- my $html = GeneTargeting::Utils::HTMLReport->new;
Methods
append
Appends the txt passed as an array reference to the html being held for subsequent output.
e.g. $html->append('Example output');
sub append { my ( $self, $lines ) = @_; push (@{$self->{_genetargeting_utils_htmlreport_html}}, @$lines); }
append_line
e.g. $html->append_line('line');
sub append_line { my ( $self, $line ) = @_; push (@{$self->{_genetargeting_utils_htmlreport_html}}, $line); }
clear
e.g. $html->clear();
sub clear { my ( $self ) = @_; $self->{_genetargeting_utils_htmlreport_html} = []; }
debug
Get/set method for the debug status of the module. Pass a true value to switch debuggins on;
e.g. $html->debug(1); my $status = $html->debug;
sub debug { my ( $self, $flag ) = @_; if (defined($flag)) { $self->{'_genetargeting_utils_htmlreport_debug'} = $flag; } return $self->{'_genetargeting_utils_htmlreport_debug'}; }
debug_off
e.g $html->debug_off();
sub debug_off { my ( $self ) = @_; $self->{'_genetargeting_utils_htmlreport_debug'} = 0; }
debug_on
e.g. $html->debug_on();
sub debug_on { my ( $self ) = @_; $self->{'_genetargeting_utils_htmlreport_debug'} = 1; }
header
sub header { my ( $self, $txt ) = @_; if ($txt) { $self->{'_genetargeting_utils_htmlreport_header'} .= $txt; } return $self->{'_genetargeting_utils_htmlreport_header'} }
make_anchor_name
my $html = $html->make_anchor_name('name', 'full_name');
Given a name, returns a html string thus: <A NAME="name">visible_name</A> If visible_name is not specified then it defaults to the same as name
sub make_anchor_name { my ( $self, $name, $visible_name ) = @_; confess "Must pass a name" unless $name; $visible_name = $name unless $visible_name; my $html = '<A NAME="' . $name . '">' . $visible_name . '</A>'; return $html; }
make_link
Given a url, string to be displayed with mouseover, and the visible name of the link, returns the required html
sub make_link { my ( $self, $url, $mouseover, $name ) = @_; confess "Must pass a url" unless $url; confess "Must pass a name" unless $name; $mouseover = '' unless $mouseover; my $html = '<A HREF="' . $url . '"'; $html .= ' onMouseOver="window.status=' . "'" . $mouseover; $html .= "'" . '; return true;"'; $html .= ' onMouseOut="window.status=' . "''; return true;" . '" alt ="">'; $html .= $name . '</A>'; return $html; }
new
Constructor for a GeneTargeting::Utils::HTMLReport object. my $html = GeneTargeting::Utils::HTMLReport->new;
sub new { my( $pkg ) = @_; my $self = {}; $self->{_genetargeting_utils_htmlreport_html} = []; bless $self, $pkg; }
output_Gene_Exon_report
Given a Bio::EnsEMBL::Gene object, outputs a report on its exons to the html buffer.
sub output_Gene_Exon_report { my ( $self, $gene, $offset, $display_reversed ) = @_; unless ($gene and $gene->isa("Bio::EnsEMBL::Gene")) { confess "Must pass a Bio::EnsEMBL::Gene object"; } my @html; push (@html, '<PRE>'); push (@html, "Exon report: (in order of translation)\n" , "------------\n\n "); my $exons = $gene->get_all_Exons(); my $exon_count = 1; if ($gene->strand == 1) { foreach my $exon (sort {$a->start <=> $b->start} @$exons) { my ($start, $end) = ($exon->start, $exon->end); if ($offset) { unless ($display_reversed) { $start += $offset; $end += $offset; } else { $start = $offset - $start; $end = $offset - $end; } } push (@html , "Exon " . ' ' x (2 - length($exon_count)) . $exon_count . ': ' . ' ' x (8 - length($start)) . $start . ' - ' . ' ' x (8 - length($end)) . $end . " (" . ' ' x (4 - length($exon->length)) . $exon->length . " bp)\n" ); $exon_count++; } } else { foreach my $exon (sort {$b->start <=> $a->start} @$exons) { my ($start, $end) = ($exon->start, $exon->end); if ($offset) { $start += $offset; $end += $offset; } push (@html , "Exon " . ' ' x (2 - length($exon_count)) . $exon_count . ': ' . ' ' x (8 - length($end)) . $end . ' - ' . ' ' x (8 - length($start)) . $start . " (" . ' ' x (4 - length($exon->length)) . $exon->length . " bp)\n" ); $exon_count++; } } push(@html, "</PRE>"); $self->append(\@html); }
output_Gene_report
When passed a gene adaptor of class Bio::EnsEMBL::DBSQL::GeneAdaptor, and a stable gene if, fetches it from the Ensembl database, and outputs salient details to the html buffer.
sub output_Gene_report { my ( $self, $gene ) = @_; unless ($gene and $gene->isa("Bio::EnsEMBL::Gene")) { confess "Must pass a Bio::EnsEMBL::Gene object"; } my @html; push (@html, '<PRE>'); push (@html, "Gene:\n -----\n\n "); push (@html , "Gene : " . $gene->stable_id . " (dbID: " . $gene->dbID . ")\n" , "Biotype : " . $gene->biotype . "\n" , "Strand : "); if ($gene->strand == 1) { push (@html, "forward (+)\n"); } else { push (@html, "reverse (-)\n"); } push (@html, , "Transcripts: " ); if ($gene->get_all_Transcripts) { push(@html, scalar(@{$gene->get_all_Transcripts})); } else { push (@html, 'None'); } push(@html, "\n\n </PRE>"); $self->append(\@html); }
output_Slice_genomic_region
Given a Bio::EnsEMBL::Slice object, outputs selected attributes concerning its location etc to the html buffer
sub output_Slice_genomic_region { my ( $self, $slice, $display_reversed ) = @_; unless ($slice and $slice->isa('Bio::EnsEMBL::Slice')) { confess "Must pass a Bio::EnsEMBL::Slice object" } my @html; push (@html , "<PRE>Genomic region fetched:\n" , "-----------------------\n\n " , "name : ", $slice->name, "\n" , "seq_region_name : ", $slice->seq_region_name, "\n" , "seq_region_length: ", $slice->seq_region_length, "\n" , "strand : "); if ($slice->strand == 1) { push (@html, "forward (+) relative to the genome assembly\n"); } else { push (@html, "reverse (-) relative to the genome assembly\n"); } unless ($display_reversed) { push (@html , "start : ", $slice->start, , " (left side of screen)\n" , "end : ", $slice->end, "\n" ); } else { push (@html , "start : ", $slice->end, , " (left side of screen)\n" , "end : ", $slice->start, "\n" ); } push (@html , "length : ", $slice->length, "\n\n " , "</PRE>" ); $self->append(\@html); }
output_biodas_features
Given a reference to an array of Bio::Das::Feature objects and a title string outputs them to the html being constructed, with <A HREF to the url link of the features. An optional offset can be subtracted from the start and end coordinates, so as to make the coordinates relative to some start point (such) as the start of a slice.
sub output_biodas_features { my ( $self, $feat_list, $title, $offset ) = @_; my @html; push (@html, '<PRE>'); $title = 'Untitled ' unless $title; push (@html, "$title\n" . '-' x length($title) . "\n\n "); if ($feat_list) { foreach my $feat (@$feat_list) { my ($label, $start, $end, $strand) = ($feat->label, $feat->start , $feat->end, $feat->strand); if ($offset) { $start = $start - $offset; $end = $end - $offset; } push (@html, "Cell line: " . '<A HREF="' . $feat->link . '">' . $feat->label . "</A> " . ' ' x (10 - length($feat->label)) . ' ' x (9 - length($start)) . $start . " - " . ' ' x (9 - length($end)) . $end . " (Strand: "); #Add strand information if available if (defined($feat->strand)) { if ($feat->strand == 1) { push (@html, ' forward '); } else { push (@html, ' reverse '); } push (@html, "relative to genome assembly)\n"); } } } else { push (@html, "None\n"); } push (@html, "\n </PRE>"); $self->append(\@html); }
output_date
Needs no parameters.
sub output_date { my ( $self ) = @_; my @html; push (@html , "<PRE>Date: ", scalar(localtime(time)) . "\n\n " , '</PRE>' ); $self->append(\@html); }
output_db_details
When passed a Bio::EnsEMBL::DBSQL::DBAdaptor object, outputs db and hostname etc to the html buffer
$html->output_db_details($db);
sub output_db_details { my ( $self, $db ) = @_; unless ($db and $db->isa('Bio::EnsEMBL::DBSQL::DBAdaptor')) { confess "Must pass a Bio::EnsEMBL::DBSQL::DBAdaptor object"; } my @html; push (@html , "<PRE>Database connection to:\n" , "-----------------------\n\n " , "host : " . $db->host . "\n" , "database: " . $db->dbname . "\n\n " , '</PRE>' ); $self->append(\@html); }
output_db_details_2
sub output_db_details_2 { my ( $self, $DBAdaptors ) = @_; $self->append_line('<br><b>Connected to Ensembl databases: <br>'); foreach my $dba (@$DBAdaptors) { $self->append_line(sprintf('%20s', $dba->species()) . ' ' . sprintf('%-12s', $dba->group()) . ' db: ' . sprintf('%-30s', $dba->dbc->dbname()) . ' on host: ' . sprintf('%9s', $dba->dbc->host()) . ' port: ' . sprintf('%6s', $dba->dbc->port()) . ' as user: ' . sprintf('%12s', $dba->dbc->username()) . "\n"); } $self->append_line('</b>'); }
output_flank_details
Pass the flank size.
sub output_flank_details { my ( $self, $flank_size ) = @_; my @html; push (@html , "<PRE>Flanking DNA size:\n" , "------------------\n\n " , "Including $flank_size bases either side of gene\n\n " , '</PRE>' ); $self->append(\@html); }
output_header
When passed a gene_id (or any scalar) outputs it together with the running programme's name to the html buffer
sub output_header { my ( $self, $gene_id ) = @_; my $prog_name = $0; if (rindex($prog_name, '/') > -1) { $prog_name = substr($prog_name, rindex($prog_name, '/') + 1); } my @html; push(@html , "<center>" , "<H3>" , "<U>$prog_name report for: " . $gene_id , "</U></H3>" , "</center>" ); $self->append(\@html); }
output_restriction_sites
Given a Bio::Restriction::Analysis and a coordinate offset outputs a txt report of the restriction sites found by the previous analysis.
sub output_restriction_sites { my ( $self, $analysis, $slice, $relative, $reversed, $chr_offset ) = @_; unless ($analysis and $analysis->isa('Bio::Restriction::Analysis')) { confess "Must pass a Bio::Restriction::Analysis object"; } my @html; unless ($chr_offset) { push (@html, '<PRE>'); push (@html, "Restriction Map report: "); $chr_offset = 0; } my $offset = 0; unless ($relative) { unless ($reversed) { $offset = $slice->start - 1; push (@html, "(relative to chromosome start)\n"); } } push (@html, "(relative to start of fetched DNA)\n\n") unless $chr_offset; my $enzyme_collection = $analysis->enzymes; foreach my $enzyme ($enzyme_collection->each_enzyme) { my @positions = $analysis->positions($enzyme->name); if (@positions) { push(@html, ' ' x $chr_offset . $enzyme->name . ' ' x (8 - length($enzyme->name))); push(@html, "cuts " . ' ' x (3 - length(scalar(@positions))) . scalar(@positions) .' times: '); #Relative, or absolute coordinates? foreach my $position (sort {$a <=> $b } @positions) { $position += $offset; push (@html, ' ' x (6 - length($position)) . $position . " "); } push(@html, "\n"); } } unless ($chr_offset) { push (@html, "\n </PRE>"); } $self->append(\@html); }
prepend
Prepends the txt passed as an array reference to the html being held for subsequent output.
e.g. $html->prepend('<img src="picture.jpg">');
sub prepend { my ( $self, $lines ) = @_; unshift (@{$self->{_genetargeting_utils_htmlreport_html}}, @$lines); }
title
sub title { my ( $self, $txt ) = @_; if ($txt) { $self->{'_genetargeting_utils_htmlreport_title'} .= $txt; } return $self->{'_genetargeting_utils_htmlreport_title'} }
write
Writes the buffered html to the specified file. Confesses if no file name is passed or no html has been stored with append and prepend.
e.g. $html->write('test.html');
See ->write_mode for more details of whether previously existing files will be overwritten (not by default)
sub write { my ( $self, $file ) = @_; confess "Must pass a file name" unless $file; confess "No html to write" unless @{$self->{_genetargeting_utils_htmlreport_html}}; my $fh = new IO::File; if (-f $file and $self->write_mode eq 'noclobber') { confess "Output file already exists: '$file' set write_mode to" . " 'clobber' or 'append' if you want to force write"; } elsif (-f $file and $self->write_mode eq 'append') { $fh->open(">>$file") or confess "Could not open file for appending '$file': $!"; } else { $fh->open(">$file") or confess "Could not open file for writing '$file': $!"; } my ($header_txt, $title_txt); $header_txt = $self->header or $header_txt = ''; $title_txt = $self->title or $title_txt = 'Untitled : ' . scalar(localtime); #Header and title print $fh '<head>'; print $fh $header_txt; print $fh '<title>' . $title_txt . '</title>'; print $fh '</head><body>'; foreach my $line (@{$self->{_genetargeting_utils_htmlreport_html}}) { print $fh $line or confess "Could not write to file '$file': $!"; } print $fh '</body></html>'; undef $fh; }
write_mode
Get/set method to set the mode for writing files. This can be 'noclobber', 'append' or 'clobber', and by default is set to 'noclobber' so existing files will not be autamoatically overwritten.
sub write_mode { my ( $self, $value ) = @_; if ($value) { unless ($value =~ /^noclobber$|^append$|^clobber$/) { confess "write_mode must be one of 'noclobber|append|clobber'"; } $self->{_genetargeting_utils_htmlreport_write_mode} = $value; } unless ($self->{_genetargeting_utils_htmlreport_write_mode}) { $self->{_genetargeting_utils_htmlreport_write_mode} = 'noclobber'; } return $self->{_genetargeting_utils_htmlreport_write_mode}; }
write_to_fh
Writes the buffered html to the passed filehandle. If the latter is not specified it is assumed to be STDOUT
e.g. $html->write_to_fh(); e.g. $html->write_to_fh(\*STDERR);
Note this function assumes the header and title will have already been output, as it does not output the $html->header and $html->title
sub write_to_fh { my ( $self, $fh ) = @_; $fh =\* STDOUT unless $fh; confess "No html to write" unless @{$self->{_genetargeting_utils_htmlreport_html}}; foreach my $line (@{$self->{_genetargeting_utils_htmlreport_html}}) { print $fh $line or confess "Could not write_to_fh"; } }
GeneTargeting::Utils::Primer3
- Description
- Utility module to design primers with Primer3, utilising the wrapping provided by the Bio::Tools::Run::Primer3 module (tested with bioperl-run-1.4.tar.gz) Automatically converts to Bioperl/Ensembl base-numbering conventions, with start always less than end. Exports a number of subroutines into the main package by default.
- Global variables
- @EXPORT
- Included modules
- Bio::Seq
- Bio::Tools::Run::Primer3
- Carp
- Exporter
- IO::File
Methods
_convert_primer3_results_to_ensembl_style
Internal method used to convert Primer3 coordinates (which are zero-based) to Bioperl/Ensembl style coordinates that are one-based, with start always less than end. Also add a number of extra entries to the hashes making up the results. There are: PRIMER_LEFT_START PRIMER_LEFT_END PRIMER_LEFT_LENGTH PRIMER_RIGHT_START PRIMER_RIGHT_END PRIMER_RIGHT_LENGTH PRIMER_LEFT_TM_RECALC (see calculate_primer_Tm_inhouse) PRIMER_RIGHT_TM_RECALC PRIMER_GC_ALL_ENDS
sub _convert_primer3_results_to_ensembl_style { my ( $primer3_results ) = @_; for (my $i = 0; $i < $primer3_results->number_of_results; $i++) { my $results = $primer3_results->primer_results($i); my ($left_primer_start, $left_primer_length) = split(/,/, $results->{'PRIMER_LEFT'}); unless (defined($left_primer_start) and $left_primer_length) { confess "Erroring parsing Primer3 result: $results->{'PRIMER_LEFT'}"; } $left_primer_start++; $results->{'PRIMER_LEFT'} = $left_primer_start . ',' . $left_primer_length; my ($right_primer_end, $right_primer_length) = split (/,/, $results->{'PRIMER_RIGHT'}); unless (defined($right_primer_end) and $right_primer_length) { confess "Erroring parsing Primer3 result: $results->{'PRIMER_RIGHT'}"; } $right_primer_end++; $results->{'PRIMER_RIGHT'} = $right_primer_end . ',' . $right_primer_length; my $left_primer_end = $left_primer_start + $left_primer_length - 1; my $right_primer_start = $right_primer_end - $right_primer_length + 1; $results->{'PRIMER_LEFT_START'} = $left_primer_start; $results->{'PRIMER_LEFT_END'} = $left_primer_end; $results->{'PRIMER_LEFT_LENGTH'} = $left_primer_length; $results->{'PRIMER_RIGHT_START'} = $right_primer_start; $results->{'PRIMER_RIGHT_END'} = $right_primer_end; $results->{'PRIMER_RIGHT_LENGTH'} = $right_primer_length; #Recalculate the melting temperatures my $left_primer = $results->{'PRIMER_LEFT_SEQUENCE'}; my $right_primer = $results->{'PRIMER_RIGHT_SEQUENCE'}; my $left_tm = calculate_primer_Tm_inhouse($left_primer); my $right_tm = calculate_primer_Tm_inhouse($right_primer); $results->{'PRIMER_LEFT_TM_RECALC'} = $left_tm; $results->{'PRIMER_RIGHT_TM_RECALC'} = $right_tm; #See if we have GC at both ends my $gc_end_count = 0; if ($left_primer =~ /^G|^C/i) { $gc_end_count++; } if ($left_primer =~ /G$|C$/i) { $gc_end_count++; } if ($right_primer =~ /^G|^C/i) { $gc_end_count++; } if ($right_primer =~ /G$|C$/i) { $gc_end_count++; } $results->{'PRIMER_GC_ALL_ENDS'} = undef; $results->{'PRIMER_GC_ALL_ENDS'}++ if $gc_end_count == 4; } }
calculate_primer_Tm_inhouse
Pass the raw DNA sequence, returns back Tm calculated as TM = (length * 2) = (GC * 2) - 5 Verifies bases as one of ATGC, case insensitive
sub calculate_primer_Tm_inhouse { my ( $primer_dna ) = @_; chomp($primer_dna); confess "Must pass DNA seq" unless $primer_dna; $primer_dna = uc($primer_dna); my $dna_length = length($primer_dna); my $gc_count = 0; for (my $i = 0; $i < $dna_length; $i++) { if (substr($primer_dna, $i, 1) =~ /G|C/i) { $gc_count++; } elsif (substr($primer_dna, $i, 1) =~ /A|T/i){ } else { confess "Bad base: code(", ord(substr($primer_dna, $i, 1)), ")"; } } my $Tm = $dna_length * 2 + $gc_count * 2 - 5; return ($Tm); }
convert_primer3_results_to_arrayref_of_hashes
Passed a Bio::Tools::Run::Primer3 object (as produced by design_with_primer3) returns a reference to an array of the results (which are actually hashes) in their original order (i.e. best first).
my $results = convert_primer3_results_to_arrayref_of_hashes($primer3_results);
sub convert_primer3_results_to_arrayref_of_hashes { my ( $primer3_results ) = @_; my @results; for (my $i = 0; $i < $primer3_results->number_of_results; $i++) { my $results = $primer3_results->primer_results($i); push (@results, $results); } return\@ results; }
design_with_primer3
Given an object with either a ->seq of ->dna method, holding a DNA sequence, designs primers to it. Must also pass a full qualified filename for the (temporary) output file created by Primer3, and a reference to a hash of Primer3 parameters. Returns a Bio::Tools::Run::Primer3 object. See get_primer3_parameters_from_config for more information.
my $primer3_results = design_with_primer3($seq, $tmp_file, $parameters);
When PRIMER_PRODUCT_SIZE_RANGE is not specified explicitly (in the parameter hash) it is set to the sequence length - 100 bases. This 100 base default can be overridden by an optional fourth parameter.
my $primer3_results = design_with_primer3($seq, $tmp_file, $parameters, 50); my $best_result = $primer3_results->primer_results[0]; foreach my $key (keys(@{$best_result})) { print "$key : ", $best_result->{$key}, "\n"; } PRIMER_GC_ALL_ENDS :PRIMER_LEFT : 36,22 PRIMER_LEFT_END : 57 PRIMER_LEFT_END_STABILITY : 6.7000 PRIMER_LEFT_GC_PERCENT : 40.909 PRIMER_LEFT_LENGTH : 22 PRIMER_LEFT_PENALTY : 3.810351 PRIMER_LEFT_SELF_ANY : 4.00 PRIMER_LEFT_SELF_END : 0.00 PRIMER_LEFT_SEQUENCE : TCAGTTTTTATACCCCCTCAAC PRIMER_LEFT_START : 36 PRIMER_LEFT_TM : 57.190 PRIMER_LEFT_TM_RECALC : 57 PRIMER_PAIR_COMPL_ANY : 4.00 PRIMER_PAIR_COMPL_END : 2.00 PRIMER_PAIR_PENALTY : 6.2303 PRIMER_PRODUCT_SIZE : 963 PRIMER_RIGHT : 998,20 PRIMER_RIGHT_END : 998 PRIMER_RIGHT_END_STABILITY : 7.6000 PRIMER_RIGHT_GC_PERCENT : 50.000 PRIMER_RIGHT_LENGTH : 20 PRIMER_RIGHT_PENALTY : 2.419920 PRIMER_RIGHT_SELF_ANY : 6.00 PRIMER_RIGHT_SELF_END : 1.00 PRIMER_RIGHT_SEQUENCE : GTGCACCGCTAAGACTTTTG PRIMER_RIGHT_START : 979 PRIMER_RIGHT_TM : 58.580 PRIMER_RIGHT_TM_RECALC : 55
(Input fields have been omitted)
sub design_with_primer3 { my ( $seq, $tmp_file, $parameters, $length_wobble) = @_; $length_wobble = 100 unless $length_wobble; confess "Must pass an object with ->seq or ->dna method" unless $seq; confess "Must pass a temporary file name" unless $tmp_file; confess "Must pass Primer3 parameters" unless $parameters; my $seq_obj; if ($seq->can('seq')) { $seq_obj = $seq; } elsif ($seq->isa('GeneTargeting::DBEntry::Sequence')) { $seq_obj = Bio::Seq->new( -display_id => $seq->id, -seq => $seq->dna); } else { confess "Don't know how to get seq from obj $seq" } my $primer3 = Bio::Tools::Run::Primer3->new(-seq => $seq_obj, -outfile => $tmp_file); unless ($primer3->executable) { confess "primer3 can not be found. Is it installed?\n"; } my $size_range = ($seq_obj->length - $length_wobble) . '-' . ($seq_obj->length); my %targets = ( 'PRIMER_PRODUCT_SIZE_RANGE' => $size_range , 'PRIMER_MIN_SIZE' => 20, , 'PRIMER_MAX_SIZE' => 22, , 'PRIMER_OPT_SIZE' => 21, , 'PRIMER_MIN_GC' => 40, , 'PRIMER_MAX_GC' => 50, , 'PRIMER_OPT_GC_PERCENT' => 45, , 'PRIMER_MIN_TM' => 55, , 'PRIMER_MAX_TM' => 60, , 'PRIMER_GC_CLAMP' => 1, , 'PRIMER_SALT_CONC' => 50, , 'PRIMER_NUM_RETURN' => 20); $primer3->add_targets(%targets); #Set parameters, calculating PRIMER_PRODUCT_SIZE_RANGE #my $size_range; #my ($size_min, $size_max); #unless ($parameters->{'PRIMER_PRODUCT_SIZE_RANGE'}) { # $size_min = $seq_obj->length - $length_wobble; # $size_max = $seq_obj->length; # $size_range = $size_min . '-' . $size_max . ' '; #} #$parameters->{'PRIMER_PRODUCT_SIZE_RANGE'} = "$size_min" . '-' . "$size_max"; #my %test = %{$parameters}; #$primer3->add_targets(%test); my $primer3_results = $primer3->run; unless ($primer3_results->number_of_results) { return; } _convert_primer3_results_to_ensembl_style($primer3_results); return $primer3_results; }
get_primer3_parameters_from_config
Passed an object of class GeneTargeting::Utils::Config, gets the Primer3 configuration information from the .ini style file which was loaded into the object. The .ini file section should look something like the one below and each one also needs to be specified in the script which will use them in the configure_parameters subroutine. See design_primer3, and design_primer3_defaults.ini for examples. Returns a reference to a hash of the parameters keyed by parameter name.
my $parameters = get_primer3_parameters_from_config($cfg);
[primer3] PRIMER_PRODUCT_SIZE_RANGE = 400-600 PRIMER_MIN_SIZE = 20 PRIMER_MAX_SIZE = 22 PRIMER_OPT_SIZE = 21 PRIMER_MIN_GC = 40 PRIMER_MAX_GC = 50 PRIMER_OPT_GC_PERCENT' = 45 PRIMER_MIN_TM = 55 PRIMER_MAX_TM = 60 PRIMER_GC_CLAMP = 1 PRIMER_SALT_CONC = 50 PRIMER_NUM_RETURN = 20
sub get_primer3_parameters_from_config { my ( $cfg ) = @_; my %parameters; my @possible_variables = $cfg->ConfigIniFiles->Parameters('primer3'); foreach my $possible (@possible_variables) { my $method_name = 'primer3_' . $possible; if ($cfg->can($method_name)) { $parameters{$possible} = $cfg->$method_name; } } return\% parameters; }
make_primer3_graphic
Makes an image of the primer pairs picked against a ruler of the original sequence. Uses Bio::Graphics, and Bio::SeqFeature::Generic, so use statements must be in the calling script outside of the module. Returns a Bio::Graphics::Panel for subsequent rendering.
my $panel = make_primer3_graphic($seq, $primer3_results);
sub make_primer3_graphic { my ( $seq, $primer3_results, $width ) = @_; $width = 1000 unless $width; my $panel = Bio::Graphics::Panel->new( -length => $seq->length, -key_style => 'between', -width => 1000, -pad_left => 30, -pad_right => 30, ); #Ruler $panel->add_track(arrow => Bio::SeqFeature::Generic->new(-start => 1, -end => $seq->length), -bump => 0, -double => 1, -tick => 2 ); #Render the primer pairs for (my $i = 0; $i <= $primer3_results->number_of_results; $i++) { my $results = $primer3_results->primer_results($i); my @positions = ([$results->{'PRIMER_LEFT_START'} , $results->{'PRIMER_LEFT_END'}], [$results->{'PRIMER_RIGHT_START'} , $results->{'PRIMER_RIGHT_END'}]); my $feat = Bio::Graphics::Feature->new(-segments =>\@ positions, -name => "Primer pair $i", -subtype => 'exon_crap', -type => 'gene_crap'); $panel->add_track([$feat], -glyph => 'generic', -bgcolor => 'red', -label => 1, -bump => 0); } return $panel; }
print_primer3_results
Pass a Bio::Tools::Run::Primer3 object, and optionally a filehandle
print_primer3_results($primer3_results)
sub print_primer3_results { my ( $primer3_results, $fh ) = @_; $fh =\* STDOUT unless $fh; print $fh "There are ", $primer3_results->number_of_results , " primer-pairs\n\n"; my $total_correct_gc_ends = 0; for (my $i = 0; $i <= $primer3_results->number_of_results; $i++) { my $results_hash = $primer3_results->primer_results($i); print $fh "Primer-pair ", $i + 1, "\n\n"; foreach my $variable (sort keys(%{$results_hash})) { if ($variable and $variable !~ /^SEQUENCE|^PRIMER_SEQUENCE_ID/) { print $fh $variable, ' ' x (30 - length($variable)); if ($results_hash->{$variable}) { print $fh $results_hash->{$variable}, "\n"; } else { print $fh "<undef>\n"; } } } print $fh "--------------------\n\n"; } }