Commit 37860307 authored by Steve Trevanion's avatar Steve Trevanion
Browse files

*** empty log message ***

parent 95ce7929
......@@ -69,15 +69,15 @@ use Data::Dumper;
=cut
sub new {
my $class = shift;
(my $serverroot = shift) or throw("You must supply a serverroot.");
my $self = {
'_serverroot' => $serverroot,
'_param' => { interactive => 1 },
'_warnings' => 0,
};
bless ($self, $class);
return $self;
my $class = shift;
(my $serverroot = shift) or throw("You must supply a serverroot.");
my $self = {
'_serverroot' => $serverroot,
'_param' => { interactive => 1 },
'_warnings' => 0,
};
bless ($self, $class);
return $self;
}
=head2 parse_common_options
......@@ -96,61 +96,59 @@ sub new {
=cut
sub parse_common_options {
my $self = shift;
# read commandline options
my %h;
Getopt::Long::Configure("pass_through");
&GetOptions( \%h,
'dbname|db_name=s',
'host|dbhost|db_host=s',
'port|dbport|db_port=n',
'user|dbuser|db_user=s',
'pass|dbpass|db_pass=s',
'conffile|conf=s',
'logfile|log=s',
'logpath=s',
'logappend|log_append=s',
'verbose|v=s',
'interactive|i=s',
'dry_run|dry|n=s',
'help|h|?',
);
# reads config file
my $conffile = $h{'conffile'} || $self->serverroot . "/sanger-plugins/vega/conf/ini-files/Conversion.ini";
$conffile = abs_path($conffile);
if (-e $conffile) {
open(CONF, $conffile) or throw(
"Unable to open configuration file $conffile for reading: $!");
my $serverroot = $self->serverroot;
while (<CONF>) {
chomp;
my $self = shift;
# remove comments
s/^[#;].*//;
s/\s+[;].*$//;
# read options into internal parameter datastructure, removing whitespace
next unless (/(\w\S*)\s*=\s*(\S*)\s*/);
my $name = $1;
my $val = $2;
if ($val =~ /\$SERVERROOT/) {
$val =~ s/\$SERVERROOT/$serverroot/g;
$val = abs_path($val);
}
$self->param($name, $val);
}
$self->param('conffile', $conffile);
} elsif ($conffile) {
warning("Unable to open configuration file $conffile for reading: $!");
# read commandline options
my %h;
Getopt::Long::Configure("pass_through");
&GetOptions( \%h,
'dbname|db_name=s',
'host|dbhost|db_host=s',
'port|dbport|db_port=n',
'user|dbuser|db_user=s',
'pass|dbpass|db_pass=s',
'conffile|conf=s',
'logfile|log=s',
'logpath=s',
'logappend|log_append=s',
'verbose|v=s',
'interactive|i=s',
'dry_run|dry|n=s',
'help|h|?',
);
# reads config file
my $conffile = $h{'conffile'} || $self->serverroot . "/sanger-plugins/vega/conf/ini-files/Conversion.ini";
$conffile = abs_path($conffile);
if (-e $conffile) {
open(CONF, $conffile) or throw(
"Unable to open configuration file $conffile for reading: $!");
my $serverroot = $self->serverroot;
while (<CONF>) {
chomp;
# remove comments
s/^[#;].*//;
s/\s+[;].*$//;
# read options into internal parameter datastructure, removing whitespace
next unless (/(\w\S*)\s*=\s*(\S*)\s*/);
my $name = $1;
my $val = $2;
if ($val =~ /\$SERVERROOT/) {
$val =~ s/\$SERVERROOT/$serverroot/g;
$val = abs_path($val);
}
$self->param($name, $val);
}
$self->param('conffile', $conffile);
} elsif ($conffile) {
warning("Unable to open configuration file $conffile for reading: $!");
}
# override configured parameter with commandline options
map { $self->param($_, $h{$_}) } keys %h;
return(1);
# override configured parameter with commandline options
map { $self->param($_, $h{$_}) } keys %h;
return(1);
}
=head2 parse_extra_options
......@@ -166,15 +164,15 @@ sub parse_common_options {
=cut
sub parse_extra_options {
my ($self, @params) = @_;
Getopt::Long::Configure("no_pass_through");
eval {
# catch warnings to pass to $self->error
local $SIG{__WARN__} = sub { die @_; };
&GetOptions(\%{ $self->{'_param'} }, @params);
};
$self->error($@) if $@;
return(1);
my ($self, @params) = @_;
Getopt::Long::Configure("no_pass_through");
eval {
# catch warnings to pass to $self->error
local $SIG{__WARN__} = sub { die @_; };
&GetOptions(\%{ $self->{'_param'} }, @params);
};
$self->error($@) if $@;
return(1);
}
=head2 allowed_params
......@@ -220,26 +218,28 @@ sub allowed_params {
=cut
sub get_common_params {
return qw(
conffile
dbname
host
port
user
pass
logpath
logfile
logappend
verbose
interactive
dry_run
return qw(
conffile
dbname
host
port
user
pass
logpath
logfile
logappend
verbose
interactive
dry_run
);
}
=head2 get_loutre_params
Example : my @allowed_params = $self->get_loutre_params, 'extra_param';
Description : Returns a list of commonly used parameters in for working with a loutre db
Arg : (optional) return a list to parse or not
Example : $support->parse_extra_options($support->get_loutre_params('parse'))
Description : Returns a list of commonly used loutre db parameters - parse option is
simply used to distinguish between reporting and parsing parameters
Return type : Array - list of common parameters
Exceptions : none
Caller : general
......@@ -247,13 +247,25 @@ sub get_common_params {
=cut
sub get_loutre_params {
return qw(
loutrehost
loutreport
loutreuser
loutrepass
loutredbname
);
my ($self,$p) = @_;
if ($p) {
return qw(
loutrehost=s
loutreport=s
loutreuser=s
loutrepass=s
loutredbname=s
);
}
else {
return qw(
loutrehost
loutreport
loutreuser
loutrepass
loutredbname
);
}
}
=head2 remove_vega_params
......@@ -268,10 +280,10 @@ sub get_loutre_params {
=cut
sub remove_vega_params {
my $self = shift;
foreach my $param (qw(dbname host port user pass)) {
$self->{'_param'}{$param} = undef;
}
my $self = shift;
foreach my $param (qw(dbname host port user pass)) {
$self->{'_param'}{$param} = undef;
}
}
=head2 confirm_params
......@@ -287,21 +299,21 @@ sub remove_vega_params {
=cut
sub confirm_params {
my $self = shift;
my $self = shift;
# print parameter table
print "Running script with these parameters:\n\n";
print $self->list_all_params;
# print parameter table
print "Running script with these parameters:\n\n";
print $self->list_all_params;
if ($self->param('host') eq 'web-4-11') {
# ask user if he wants to proceed
exit unless $self->user_proceed("**************\n\n You're working on web-4-11! Is that correct and you want to continue ?\n\n**************");
}
else {
# ask user if he wants to proceed
exit unless $self->user_proceed("Continue?");
}
return(1);
if ($self->param('host') eq 'ensdb-1-10') {
# ask user if he wants to proceed
exit unless $self->user_proceed("**************\n\n You're working on ensdb-1-10! Is that correct and you want to continue ?\n\n**************");
}
else {
# ask user if he wants to proceed
exit unless $self->user_proceed("Continue?");
}
return(1);
}
=head2 list_all_params
......@@ -362,7 +374,6 @@ sub create_commandline_options {
if ($settings->{'allowed_params'}) {
# exclude params explicitly stated
my %exclude = map { $_ => 1 } @{ $settings->{'exclude'} || [] };
foreach my $param ($self->allowed_params) {
unless ($exclude{$param}) {
my ($first, @rest) = $self->param($param);
......@@ -387,7 +398,6 @@ sub create_commandline_options {
foreach my $param (keys %param_hash) {
$options_string .= sprintf("--%s %s ", $param, $param_hash{$param});
}
return $options_string;
}
......@@ -689,8 +699,17 @@ sub get_database {
-dbname => $self->param("${prefix}dbname"),
-group => $database,
);
# explicitely set the dnadb to itself - by default the Registry assumes
#can use this approach to get dna from another db
# my $dna_db = $adaptors{$database}->new(
# -host => 'otterlive',
# -port => '3301',
# -user => $self->param("${prefix}user"),
# -pass => $self->param("${prefix}pass"),
# -dbname => 'loutre_human',
# );
# $dba->dnadb($dna_db);
# otherwise explicitely set the dnadb to itself - by default the Registry assumes
# a group 'core' for this now
$dba->dnadb($dba);
......@@ -928,26 +947,25 @@ sub get_chrlength {
=cut
sub get_ensembl_chr_mapping {
my ($self, $dba, $version) = @_;
$dba ||= $self->dba;
throw("get_ensembl_chr_mapping should be passed a Bio::EnsEMBL::DBSQL::DBAdaptor\n") unless ($dba->isa('Bio::EnsEMBL::DBSQL::DBAdaptor'));
my $sa = $dba->get_SliceAdaptor;
my @chromosomes = map { $_->seq_region_name }
@{ $sa->fetch_all('chromosome', $version) };
my %chrs;
foreach my $chr (@chromosomes) {
my $sr = $sa->fetch_by_region('chromosome', $chr, undef, undef, undef, $version);
my ($ensembl_name_attr) = @{ $sr->get_all_Attributes('ensembl_name') };
if ($ensembl_name_attr) {
$chrs{$chr} = $ensembl_name_attr->value;
} else {
$chrs{$chr} = $chr;
}
my ($self, $dba, $version) = @_;
$dba ||= $self->dba;
throw("get_ensembl_chr_mapping should be passed a Bio::EnsEMBL::DBSQL::DBAdaptor\n") unless ($dba->isa('Bio::EnsEMBL::DBSQL::DBAdaptor'));
my $sa = $dba->get_SliceAdaptor;
my @chromosomes = map { $_->seq_region_name }
@{ $sa->fetch_all('chromosome', $version) };
my %chrs;
foreach my $chr (@chromosomes) {
my $sr = $sa->fetch_by_region('chromosome', $chr, undef, undef, undef, $version);
my ($ensembl_name_attr) = @{ $sr->get_all_Attributes('ensembl_name') };
if ($ensembl_name_attr) {
$chrs{$chr} = $ensembl_name_attr->value;
} else {
$chrs{$chr} = $chr;
}
return \%chrs;
}
return \%chrs;
}
=head2 get_taxonomy_id
......@@ -1186,7 +1204,7 @@ sub log {
Arg[1] : String $txt - the warning text to log
Arg[2] : Int $indent - indentation level for log message
Arg[2] : Bool - add a line break before warning if true
Arg[3] : Bool - add a line break before warning if true
Example : my $log = $support->log_filehandle;
$support->log_warning('Log foo.\n', 1);
Description : Logs a message via $self->log and increases the warning counter.
......@@ -1438,6 +1456,26 @@ sub date {
return strftime "%Y-%m-%d %T", localtime;
}
=head2 format_time
Example : print $support->format_time($gene->modifed_date) . "\n";
Description : Prints timestamps from the database
Return type : String - nicely formatted time stamp
Exceptions : none
Caller : general
=cut
sub date_format {
my( $self, $time, $format ) = @_;
my( $d,$m,$y) = (localtime($time))[3,4,5];
my %S = ('d'=>sprintf('%02d',$d),'m'=>sprintf('%02d',$m+1),'y'=>$y+1900);
(my $res = $format ) =~s/%(\w)/$S{$1}/ge;
return $res;
}
=head2 mem
Example : print "Memory usage: " . $support->mem . "\n";
......@@ -1484,8 +1522,8 @@ sub commify {
Arg[2] : B::E::AttributeAdaptor
Arg[3] : string $coord_system_name (optional) - 'chromosome' by default
Arg[4] : string $coord_system_version (optional) - 'otter' by default
Example : $chroms = $support->fetch_non_hidden_slice($sa);
Description : retrieve all slices from a loutra database that don't have a hidden attribute
Example : $chroms = $support->fetch_non_hidden_slice($sa,$aa);
Description : retrieve all slices from a loutre database that don't have a hidden attribute
Return type : arrayref
Caller : general
Status : stable
......@@ -1493,31 +1531,72 @@ sub commify {
=cut
sub fetch_non_hidden_slices {
my $self = shift;
my $aa = shift or throw("You must supply an attribute adaptor");
my $sa = shift or throw("You must supply a slice adaptor");
my $cs = shift || 'chromosome';
my $cv = shift || 'Otter';
my $visible_chroms;
foreach my $chrom ( @{$sa->fetch_all($cs,$cv)} ) {
my $chrom_name = $chrom->name;
my $attribs = $aa->fetch_all_by_Slice($chrom,'hidden');
if ( scalar(@$attribs) > 1 ) {
$self->log_warning("More than one hidden attribute for chromosome $chrom_name\n");
}
elsif ($attribs->[0]->value == 0) {
push @$visible_chroms, $chrom;
}
elsif ($attribs->[0]->value == 1) {
$self->log_verbose("chromosome $chrom_name is hidden\n");
}
else {
$self->log_warning("No hidden attribute for chromosome $chrom_name\n");
}
}
return $visible_chroms;
my $self = shift;
my $aa = shift or throw("You must supply an attribute adaptor");
my $sa = shift or throw("You must supply a slice adaptor");
my $cs = shift || 'chromosome';
my $cv = shift || 'Otter';
my $visible_chroms;
foreach my $chrom ( @{$sa->fetch_all($cs,$cv)} ) {
my $chrom_name = $chrom->name;
my $attribs = $aa->fetch_all_by_Slice($chrom,'hidden');
if ( scalar(@$attribs) > 1 ) {
$self->log_warning("More than one hidden attribute for chromosome $chrom_name\n");
}
elsif ($attribs->[0]->value == 0) {
push @$visible_chroms, $chrom;
}
elsif ($attribs->[0]->value == 1) {
$self->log_verbose("chromosome $chrom_name is hidden\n");
}
else {
$self->log_warning("No hidden attribute for chromosome $chrom_name\n");
}
}
return $visible_chroms;
}
=head2 get_non_hidden_slice_names
Arg[1] : B::E::SliceAdaptor
Arg[2] : B::E::AttributeAdaptor
Arg[3] : string $coord_system_name (optional) - 'chromosome' by default
Arg[4] : string $coord_system_version (optional) - 'otter' by default
Example : $chrom_names = $support->get_non_hidden_slice_names($sa,$aa);
Description : retrieve names of all slices from a loutre database that don't have a hidden attribute
Return type : arrayref of names of all non-hidden slices
Caller : general
Status : stable
=cut
sub get_non_hidden_slice_names {
my $self = shift;
my $aa = shift or throw("You must supply an attribute adaptor");
my $sa = shift or throw("You must supply a slice adaptor");
my $cs = shift || 'chromosome';
my $cv = shift || 'Otter';
my $visible_chrom_names;
foreach my $chrom ( @{$sa->fetch_all($cs,$cv)} ) {
my $chrom_name = $chrom->seq_region_name;
my $attribs = $aa->fetch_all_by_Slice($chrom,'hidden');
if ( scalar(@$attribs) > 1 ) {
$self->log_warning("More than one hidden attribute for chromosome $chrom_name\n");
}
elsif ($attribs->[0]->value == 0) {
push @$visible_chrom_names, $chrom_name;
}
elsif ($attribs->[0]->value == 1) {
$self->log_verbose("chromosome $chrom_name is hidden\n");
}
else {
$self->log_warning("No hidden attribute for chromosome $chrom_name\n");
}
}
return $visible_chrom_names;
}
=head2 get_wanted_chromosomes
Arg[1] : B::E::U::ConversionSupport
......@@ -1525,47 +1604,47 @@ sub fetch_non_hidden_slices {
Arg[3] : B::E::AttributeAdaptor
Arg[4] : string $coord_system_name (optional) - 'chromosome' by default
Arg[5] : string $coord_system_version (optional) - 'otter' by default
Example : @chr_names = &Slice::get_wanted_chromosomes($support,$laa,$lsa);
Example : $chr_names = $support->get_wanted_chromosomes($laa,$lsa);
Description : retrieve names of slices from a lutra database that are ready for dumping to Vega.
Deals with list of names to ignore (ignore_chr = LIST)
Return type : arrayref
Return type : arrayref of slices
Caller : general
Status : stable
=cut
sub get_wanted_chromosomes {
my $self = shift;
my $aa = shift or throw("You must supply an attribute adaptor");
my $sa = shift or throw("You must supply a slice adaptor");
my $cs = shift || 'chromosome';
my $cv = shift || 'Otter';
my $export_mode = $self->param('release_type');
my $release = $self->param('vega_release');
my $names;
my $chroms = $self->fetch_non_hidden_slices($aa,$sa,$cs,$cv);
my $self = shift;
my $aa = shift or throw("You must supply an attribute adaptor");
my $sa = shift or throw("You must supply a slice adaptor");
my $cs = shift || 'chromosome';
my $cv = shift || 'Otter';
my $export_mode = $self->param('release_type');
my $release = $self->param('vega_release');
my $names;
my $chroms = $self->fetch_non_hidden_slices($aa,$sa,$cs,$cv);
CHROM:
foreach my $chrom (@$chroms) {
my $attribs = $aa->fetch_all_by_Slice($chrom);
my $vals = $self->get_attrib_values($attribs,'vega_export_mod');
if (scalar(@$vals > 1)) {
$self->log_warning ("Multiple attribs for \'vega_export_mod\', please fix before continuing");
exit;
}
next CHROM if (! grep { $_ eq $export_mode} @$vals);
$vals = $self->get_attrib_values($attribs,'vega_release',$release);
if (scalar(@$vals > 1)) {
$self->log_warning ("Multiple attribs for \'vega_release\' value = $release , please fix before continuing");
exit;
}
next CHROM if (! grep { $_ eq $release} @$vals);
my $name = $chrom->seq_region_name;
if (my @ignored = $self->param('ignore_chr')) {
next CHROM if (grep {$_ eq $name} @ignored);
}
push @{$names}, $name;
}
return $names;
foreach my $chrom (@$chroms) {
my $attribs = $aa->fetch_all_by_Slice($chrom);
my $vals = $self->get_attrib_values($attribs,'vega_export_mod');
if (scalar(@$vals > 1)) {
$self->log_warning ("Multiple attribs for \'vega_export_mod\', please fix before continuing");
exit;
}
next CHROM if (! grep { $_ eq $export_mode} @$vals);
$vals = $self->get_attrib_values($attribs,'vega_release',$release);
if (scalar(@$vals > 1)) {
$self->log_warning ("Multiple attribs for \'vega_release\' value = $release , please fix before continuing");
exit;
}
next CHROM if (! grep { $_ eq $release} @$vals);
my $name = $chrom->seq_region_name;
if (my @ignored = $self->param('ignore_chr')) {
next CHROM if (grep {$_ eq $name} @ignored);
}
push @{$names}, $name;
}
return $names;
}
......@@ -1589,33 +1668,33 @@ sub get_wanted_chromosomes {
=cut
sub get_attrib_values {
my $self = shift;
my $attribs = shift;
my $code = shift;
my $value = shift;
if (my @atts = grep {$_->code eq $code } @$attribs) {
my $r = [];
if ($value) {
if (my @values = grep {$_->value eq $value} @atts) {
foreach (@values) {
push @$r, $_->value;
}