=cut
sub new {
my ($caller, %args) = @_;
$caller->connect(%args);
}
=head2 get_Matrix_by_ID
Title : get_Matrix_by_ID
Usage : my $pfm = $db->get_Matrix_by_ID('V$CREB_01', 'PFM');
Function: fetches matrix data under the given TRANSFAC ID from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on the second argument (allowed
values are 'PFM', 'ICM', and 'PWM'); returns undef if
matrix with the given ID is not found
Args : (Matrix_ID, Matrix_type)
Matrix_ID is a string; Matrix_type is one of the
following: 'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or 'PWM' (position
weight matrix)
If Matrix_type is omitted, a PFM is retrieved by default.
=cut
sub get_Matrix_by_ID {
my ($self, $ID, $mt) = @_;
unless (defined $ID) {
$self->throw("No parameters passed to get_Matrix_by_ID.");
}
my $url = "http://www.cbil.upenn.edu/cgi-bin/tess/tess33?request=MTX-DBRTRV-Id&key=$ID";
# my $url = "http://www.cbil.upenn.edu/cgi-bin/tess/tess33?request=MTX-DBRTRV-Id&key=$ID";
return $self->_get_Matrix_by_URL($url, $mt);
}
=head2 get_Matrix_by_acc
Title : get_Matrix_by_acc
Usage : my $pfm = $db->get_Matrix_by_acc('V$CREB_01', 'PFM');
Function: fetches matrix data under the given TRANSFAC aaccession number
from database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on the second argument (allowed
values are 'PFM', 'ICM', and 'PWM'); returns undef if
matrix with the given ID is not found
Args : (Matrix_ID, Matrix_type)
Matrix_ID is a string; Matrix_type is one of the
following: 'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or 'PWM' (position
weight matrix)
If Matrix_type is omitted, a PFM is retrieved by default.
=cut
sub get_Matrix_by_acc {
my ($self, $acc, $mt) = @_;
unless (defined $acc) {
$self->throw("No parameters passed to get_Matrix_by_ID.");
}
my $url = "http://www.cbil.upenn.edu/cgi-bin/tess/tess33?request=MTX-DBRTRV-Accno&key=$acc";
return $self->_get_Matrix_by_URL($url, $mt);
}
sub get_MatrixSet {
my ($self, %args) = @_;
# not yet implemented
}
sub _get_Matrix_by_URL {
my ($self, $url, $mt) = @_;
my $HTMLpage = get $url || return undef;
my (@As, @Cs, @Gs, @Ts, $name, $ID, $acc);
my @lines = split "\n", $HTMLpage;
foreach my $line (@lines) {
$line =~ s/\r//;
$line =~ s/<\/{0,1}b>//gi;
$line =~ s/ //gi;
if ($line =~ /Name<\/td>| ([^<]+) | ([^<]+) | ([^<]+) new ( -ID => $ID,
-name => $name,
-tags => {acc=>$acc},
-matrix => [ \@As, \@Cs, \@Gs, \@Ts]
);
if (!defined($mt) or uc($mt) eq "PFM") {return $pfm;}
elsif (uc($mt) eq "ICM") {return $pfm->to_ICM;}
elsif (uc($mt) eq "PWM") {return $pfm->to_PWM;}
else { $self->throw("Unrecognized matrix format: $mt"); }
}
1;
TFBS-0.7.1/TFBS/Matrix.pm 0000775 0000000 0000000 00000025211 13057522667 0014636 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix - base class for matrix patterns, containing methods common
to all
=head1 DESCRIPTION
TFBS::Matrix is a base class consisting of universal constructor called by
its subclasses (TFBS::Matrix::*), and matrix manipulation methods that are
independent of the matrix type. It is not meant to be instantiated itself.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
Modified by Eivind Valen eivind.valen@gmail.com
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Matrix;
use vars '@ISA';
use PDL; # this dependency has to be eliminated in the future versions
use TFBS::PatternI;
use strict;
@ISA = qw(TFBS::PatternI);
# IUPAC codes
my %dna = ("A" => [12,0,0,0],
"C" => [0,12,0,0],
"G" => [0,0,12,0],
"T" => [0,0,0,12],
"U" => [0,0,0,12],
"R" => [6,0,6,0],
"Y" => [0,6,0,6],
"M" => [6,6,0,0],
"K" => [0,0,6,6],
"W" => [6,0,0,6],
"S" => [0,6,6,0],
"B" => [0,4,4,4],
"D" => [4,0,4,4],
"H" => [4,4,0,4],
"V" => [4,4,4,0],
"N" => [3,3,3,3]);
sub new {
my $class = shift;
my %args = @_;
my $self = bless {}, ref($class) || $class;
# first figure out how it was called
# we need (-dbh and (-ID or -name) for fetching it from a database
# or -matrix for direct matrix input
if (defined $args{'-matrix'}) {
$self->set_matrix($args{'-matrix'});
}
elsif (defined $args{'-matrixstring'}) {
$self->set_matrix($args{'-matrixstring'});
}
elsif (defined $args{-matrixfile}) {
my $matrixstring;
open (FILE, $args{-matrixfile})
or $self->throw("Could not open $args{-matrixfile}");
{
local $/ = undef;
$matrixstring = ;
}
$self->set_matrix($matrixstring);
}
else {
$self->throw("No matrix or db object provided.");
}
# Set the object data.
# Parameters specified in constructor call override those
# fetched from the database.
$self->{'ID'} = ($args{-ID} or
$self->{ID} or
"Unknown");
$self->{'name'} = ($args{-name} or
$self->{name} or
"Unknown");
$self->{'class'} = ($args{-class} or
$self->{class} or
"Unknown");
$self->{'strand'} = ($args{-strand} or
$self->{strand} or
"+");
$self->{'bg_probabilities'} =
($args{'-bg_probabilities'} || {A => 0.25,
C => 0.25,
G => 0.25,
T => 0.25});
$self->{'tags'} = $args{-tags} ? ((ref($args{-tags}) eq "HASH") ? $args{-tags} : {} ) :{};
return $self;
}
=head2 matrix
Title : matrix
Usage : my $matrix = $pwm->matrix();
$pwm->matrix( [ [12, 3, 0, 0, 4, 0],
[ 0, 0, 0,11, 7, 0],
[ 0, 9,12, 0, 0, 0],
[ 0, 0, 0, 1, 1,12]
]);
Function: get/set for the matrix data
Returns : a reference to 2D array of integers(PFM) or floats (ICM, PWM)
Args : none for get;
a four line string, reference to 2D array, or a 2D piddle for set
=cut
sub matrix {
my ($self, $matrixdata) = @_;
$self->set_matrix($matrixdata) if $matrixdata;
return $self->{'matrix'};
}
=head2 pdl_matrix
Title : pdl_matrix
Usage : my $pdl = $pwm->pdl_matrix();
Function: access the PDL matrix used to store the actual
matrix data directly
Returns : a PDL object, aka a piddle
Args : none
=cut
sub pdl_matrix {
pdl $_[0]->{'matrix'};
}
sub set_matrix {
my ($self, $matrixdata) = @_;
# The input matrix (specified as -array=> in the constructir call
# can either be
# * a 2D regular perl array with 4 rows,
# * a piddle (FIXME - check for 4 rows), or
# * a four-line string of numbers
# print STDERR "MATRIX>>>".$matrixdata;
if (ref($matrixdata) eq "ARRAY"
and ref($matrixdata->[0]) eq "ARRAY"
and scalar(@{$matrixdata}) == 4)
{
# it is a perl array
$self->{'matrix'} = $matrixdata;
}
elsif (ref($matrixdata) eq "PDL")
{
# it's a piddle
$self->{matrix} = _pdl_to_matrixref($matrixdata);
}
elsif (!ref($matrixdata))
#and (scalar split "\n",$matrixdata) == 4)
{
# it's a string then, but what string?
if ($matrixdata =~ /^DE/) {
# STAMP string
$self->{matrix} = $self->_matrix_from_STAMP_string($matrixdata);
} elsif ($matrixdata =~ /[ACGTURYMKWSBDHVNacgturymkwsbdhvn]{3,}/) {
$self->{matrix} = $self->_matrix_from_IUPAC_string($matrixdata);
} else {
# Regular string
$self->{matrix} = $self->_matrix_from_string($matrixdata);
}
}
else {
$self->throw("Wrong data type/format for -matrix.\n".
"Acceptable formats are Array of Arrays (4 rows),\n".
"PDL Array, (4 rows),\n".
"or plain string (4 lines).");
}
# $self->_set_min_max_score();
# print STDERR $self->prettyprint();
return 1;
}
sub _matrix_from_IUPAC_string {
my ($self, $matrixstring) = @_;
$matrixstring =~ s/^\s+//;
$matrixstring =~ s/\s+$//;
my @str = split(//, $matrixstring);
my @matrix;
for my $ltr (0..3) {
my @l = map {$dna{uc($_)}->[$ltr]} @str;
push @matrix, \@l;
}
return \@matrix;
}
sub _matrix_from_string {
my ($self, $matrixstring) = @_;
my @array = ();
foreach ((split "\n", $matrixstring)[0..3]) {
s/^\s+//;
s/\s+$//;
push @array, [split];
}
return \@array;
}
sub _matrix_from_STAMP_string {
my ($self, $matrixstring) = @_;
my @lines = split("\n", $matrixstring);
my (@a, @c, @g, @t);
# Remove garbage
shift(@lines);
pop(@lines);
for (@lines) {
my @l = split;
push @a, $l[1];
push @c, $l[2];
push @g, $l[3];
push @t, $l[4];
}
return [\@a, \@c, \@g, \@t];
}
sub _set_min_max_score {
my ($self) = @_;
my $transpose = $self->pdl_matrix->xchg(0,1);
$self->{min_score} = sum(minimum $transpose);
$self->{max_score} = sum(maximum $transpose);
}
sub _load {
my ($self, $field, $value) = @_;
if (substr(ref($self->{db}),0,5) eq "DBI::") {
# database retrieval
}
elsif (-d $self->{dbh}) {
# retrieval from .pwm files in a directory
$self->_lookup_in_matrixlist($field, $value)
or do {
warn ("Matrix with $field=>$value not found.");
return undef;
};
my $ID = $self->{ID};
my $DIR = $self->{dbh};
$self->set_matrix(scalar `cat $DIR/$ID.pwm`); # FIXME - temporary
}
else {
$self->throw("-dbh is not a valid database handle or a directory.");
}
}
=head2 revcom
Title : revcom
Usage : my $revcom_pfm = $pfm->revcom();
Function: create a matrix pattern object which is reverse complement
of the current one
Returns : a TFBS::Matrix::* object of the same type as the one
the method acted upon
Args : none
=cut
sub revcom {
my ($self) = @_;
my $revcom_matrix =
$self->new(-matrix => $self->pdl_matrix->slice('-1:0,-1:0'),
# the above line rotates the original matrix 180 deg,
-ID => ($self->{ID} or ""),
-name => ($self->{name} or ""),
-class => ($self->{class} or ""),
-strand => ($self->{strand} and $self->{strand} eq "-") ? "+" : "-",
-tags => ($self->{tags} or {}) );
return $revcom_matrix;
}
=head2 rawprint
Title : rawprint
Usage : my $rawstring = $pfm->rawprint);
Function: convert matrix data to a simple tab-separated format
Returns : a four-line string of tab-separated integers or floats
Args : none
=cut
sub rawprint {
my $self = shift;
my $pwmstring = sprintf ( $self->pdl_matrix );
$pwmstring =~ s/\[|\]//g; # lose []
$pwmstring =~ s/\n /\n/g; # lose leading spaces
my @pwmlines = split("\n", $pwmstring); # f
$pwmstring = join ("\n", @pwmlines[2..5])."\n";
return $pwmstring;
}
=head2 prettyprint
Title : prettyprint
Usage : my $prettystring = $pfm->prettyprint();
Function: convert matrix data to a human-readable string format
Returns : a four-line string with nucleotides and aligned numbers
Args : none
=cut
sub prettyprint {
my $self = shift;
my $pwmstring = sprintf ( $self->pdl_matrix );
$pwmstring =~ s/\[|\]//g; # lose []
$pwmstring =~ s/\n /\n/g; # lose leading spaces
my @pwmlines = split("\n", $pwmstring); #
@pwmlines = ("A [$pwmlines[2] ]",
"C [$pwmlines[3] ]",
"G [$pwmlines[4] ]",
"T [$pwmlines[5] ]");
$pwmstring = join ("\n", @pwmlines)."\n";
return $pwmstring;
}
=head2 STAMPprint
Title : STAMPprint
Usage : my $STAMPstring = $pfm->STAMPprint();
Function: Convert the matrix to STAMP readable format
Returns : A string of the matrix in a TRANSFAC like format for STAMP
Args : none
=cut
sub STAMPprint {
my $self = shift;
my $pwmstring = sprintf ( $self->pdl_matrix );
$pwmstring =~ s/\[|\]//g; # lose []
$pwmstring =~ s/\n\s+/\n/g; # lose leading spaces
my @pwmlines = split(/\n+/, $pwmstring);
@pwmlines = map { [ split(/\s+/, $_) ] } @pwmlines;
$pwmstring = "DE ".$self->{'ID'}."\t".$self->{'name'}."\t".$self->{'class'}."\n";
for my $row (0..$#{ $pwmlines[1] }) {
$pwmstring .= sprintf "%02d\t", $row;
$pwmstring .= $pwmlines[$_]->[$row]."\t" for (1..$#pwmlines);
$pwmstring .= "\n";
}
$pwmstring .= "XX\n";
return $pwmstring;
}
=head2 length
Title : length
Usage : my $pattern_length = $pfm->length;
Function: gets the pattern length in nucleotides
(i.e. number of columns in the matrix)
Returns : an integer
Args : none
=cut
sub length {
my $self = shift;
return $self->pdl_matrix->getdim(0);
}
sub _pdl_to_matrixref {
my ($matrixdata) = @_;
unless ($matrixdata->isa("PDL")) {
die "A non-PDL object passed to _pdl_to_matrixref";
}
my @list = list $matrixdata;
my @array;
my $matrix_width = scalar(@list) / 4;
for (0..3) {
push @array, [splice(@list, 0, $matrix_width)];
}
return \@array;
}
=head2 randomize_columns
Title : randomize_columns
Usage : $pfm->randomize_columns();
Function: Randomizes the columns of a matrix (in place).
Returns : Nothing
Args : none
=cut
sub randomize_columns {
my $self = shift;
my $matrix = $self->{'matrix'};
my $i = 0;
# Schwartzian Transform to get random permutation
map { ( undef, $$matrix[0][$i], $$matrix[1][$i], $$matrix[2][$i], $$matrix[3][$i] ) = @$_; $i++; }
sort { $a->[0] <=> $b->[0] }
map { [ rand(), $$matrix[0][$_], $$matrix[1][$_], $$matrix[2][$_], $$matrix[3][$_] ] } ( 0 .. ($self->length()-1) );
}
sub DESTROY {
# nothing
}
1;
TFBS-0.7.1/TFBS/Matrix/ 0000775 0000000 0000000 00000000000 13057522667 0014274 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Matrix/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0015160 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Matrix/.svn/all-wcprops 0000775 0000000 0000000 00000001106 13057522667 0017347 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 40
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Matrix
END
ICM.pm
K 25
svn:wc:ra_dav:version-url
V 47
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Matrix/ICM.pm
END
_Alignment.pm
K 25
svn:wc:ra_dav:version-url
V 54
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Matrix/_Alignment.pm
END
Alignment.pm
K 25
svn:wc:ra_dav:version-url
V 53
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Matrix/Alignment.pm
END
PFM.pm
K 25
svn:wc:ra_dav:version-url
V 47
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Matrix/PFM.pm
END
PWM.pm
K 25
svn:wc:ra_dav:version-url
V 47
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Matrix/PWM.pm
END
TFBS-0.7.1/TFBS/Matrix/.svn/entries 0000775 0000000 0000000 00000001450 13057522667 0016557 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/Matrix
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
ICM.pm
file
2009-08-07T13:10:46.000000Z
82d50dd52a35b43eb6db89437ff750a7
2008-01-24T20:21:25.772223Z
8
chrb
_Alignment.pm
file
2009-08-07T13:10:46.000000Z
62a9aba220bba9fa97a324e7f0105a7d
2008-01-24T20:21:25.772223Z
8
chrb
Alignment.pm
file
2009-08-07T13:10:46.000000Z
43a5ee65c66ae28efd38e6343eb47c6f
2008-01-24T20:21:25.772223Z
8
chrb
PFM.pm
file
2009-08-07T13:10:47.000000Z
cd3d067545004c1a5df52903395592ca
2008-01-24T20:21:25.772223Z
8
chrb
PWM.pm
file
2009-08-07T13:10:47.000000Z
5244969e644beb349a298d19d404c9c1
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/Matrix/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0016366 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/Matrix/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0017054 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Matrix/.svn/text-base/Alignment.pm.svn-base 0000775 0000000 0000000 00000016110 13057522667 0023047 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::ICM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::Alignment - class for alignment of PFM objects
=head1 SYNOPSIS
=over 1
=item * Making an alignment:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and retrieve
TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pfm1 = $db_obj->get_Matrix_by_ID("M0001", "PFM");
my $pfm2 = $db_obj->get_Matrix_by_ID("M0002", "PFM");
my $alignment= new TFBS::Matrix::Alignment(
-pfm1=>$pfm1,
-pfm2=>$pfm2,
-binary=>"/TFBS/Ext/matrix_aligner",
);
=head1 DESCRIPTION
TFBS::Matrix::Alignment is a class for representing and performing
pairwise alignments of profiles (in the form of TFBS::PFM objects)
Alignments are preformed using a semi-global variant of the
Needleman-Wunsch algorithm that only permits the opening of one internal gap.
Fore reference, the algorithm is described in Sandelin et al
Funct Integr Genomics. 2003 Jun 25
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code starts HERE:
package TFBS::Matrix::Alignment;
use vars '@ISA';
use strict;
use Bio::Root::Root;
use TFBS::Matrix;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
#alignment methods: for making and storing a single matrix-alignments
=head2 new
Title : new
Usage : my $alignment = TFBS::Matrix::Alignment->new(%args)
Function: constructor for the TFBS::Matrix::Alignment object
Returns : a new TFBS::Matrix::Alignment object
Args : # you must specify:
-pfm1, # a TFBS::Matrix::PFM object
-pfm2, # another TFBS::Matrix::PFM object
-binary, # a valid path to the comparison algorithm (matrixalign)
#######
-ext_penalty #OPTIONAL gap extension penalty in Needleman-Wunsch
algorithmstring. Default 0.01
-open_penalty, #OPTIONAL gap opening penalty in Needleman-Wunsch
algorithmstring. Default 3.0
=cut
sub new {
#defines and createa an alignment
# args: two pfm objects
# binary file
#optional scoring penalites
my ($class, %args) = @_;
my $self={
_pfm1=> $args{'-pfm1'},
_pfm2=> $args{'-pfm2'},
_ext_penalty=>$args{'-ext_penalty'}|| 0.01,
_open_penalty=> $args{'-open_penalty'}|| 3.00,
_strand=>'',
_align_string=>'',
_gaps=>'',
_aligned_positions =>'',
_score=>'',
};
bless $self, "TFBS::Matrix::Alignment";
# errorcheck:
# save temp files
my($fh1, $file1) = tmpnam();
print $fh1 $args{'-pfm1'}->rawprint()|| die " Cannot save temporary files for alignment";
my($fh2, $file2) = tmpnam();
print $fh2 $args{'-pfm2'}->rawprint()|| die " Cannot save temporary files for alignment";
#align
my @pfm1_string;
my @pfm2_string;
foreach (`$args{'-binary'} $file1 $file2 $self->{'_open_penalty'} $self->{'_ext_penalty'}`){
# my @pfm2_string;
my $max_length=$self->{'_pfm1'}->length();
$max_length=$self->{'_pfm2'}->length() if ( $self->{'_pfm2'}->length() > $self->{'_pfm1'}->length());
if (/^PFM1/){
s/PFM1//;
s/\t0/\t-/g;
@pfm1_string= split();
next;
}
if (/^PFM2/){
s/PFM2//;
s/\t0/\t-/g;
@pfm2_string= split();
next;
}
if (/^INFO/){
my @temp=split;
($self->{'_score'}, $self->{'_strand'}, $self->{'_aligned_positions'}, $self->{'_gaps'})= ($temp[3], $temp[6], $temp[7],$temp[8]);
next;
}
}
my $string= ($self->{'_pfm1'}->name()||$self->{'_pfm1'}->ID()||'PFM1')."\t\t";
my $string2=($self->{'_pfm2'}->name()||$self->{'_pfm2'}->ID()||'PFM2')."\t\t";;
if ($pfm1_string[0]==1){
$string.="-\t" x ($pfm2_string[0]-1);
foreach (my $j=1; $j< $pfm2_string[0]; $j++){
$string2.="$j\t";
}
}
if ($pfm2_string[0]==1){
$string2.="-\t" x ($pfm1_string[0]-1);
for (my $j=1; $j< $pfm1_string[0]; $j++){
$string.="$j\t";
}
}
$string.= join("\t", @pfm1_string);
$string2.= join("\t", @pfm2_string);
if ($pfm1_string[-1]==$self->{'_pfm1'}->length()){
$string.="\t-" x ($self->{'_pfm2'}->length()-$pfm2_string[-1]);
for (my $j=$pfm2_string[-1]+1; $j<= $self->{'_pfm2'}->length(); $j++){
$string2.="\t$j";
}
}
if ($pfm2_string[-1]==$self->{'_pfm2'}->length()){
$string2.="\t-" x ($self->{'_pfm1'}->length()-$pfm1_string[-1]);
for (my $j=$pfm1_string[-1]+1; $j<= $self->{'_pfm1'}->length(); $j++){
$string.="\t$j";
}
}
$self->{'_align_string'}= $string ."\n". $string2;
return $self;
}
# access functions
=head2 score
Title : score
Usage : my $score = $alignmentobject->score();
Function: access an alignment score (where each aligned position can contribute max 2)
Returns : a floating point number
Args : none
=cut
=head2 score
Title : gaps
Usage : my $nr_of_gaps = $alignmentobject->gaps();
Function: access the number of gaps in an alignment
Returns : an integer
Args : none
=cut
=head2 length
Title : length
Usage : my $length = $alignmentobject->length();
Function: access the length of an alignment (ie thenumber of aligned positions)
Returns : an integer
Args : none
=cut
=head2 strand
Title : strand
Usage : my $strand = $alignmentobject->strand();
Function: access the oriantation of the aligned patterns:
++= oriented as input
+-= second pattern is reverse-complemented
Returns : a string
Args : none
=cut
=head2 alignment
Title : alignment
Usage : my $alignment_string = $alignmentobject->alignment();
Function: access a string describing the alignment
Returns : an string, where each number refers to a position in repective PFM.
Position numbering is according to orientation: ie if the second profile is
reversed, position 1 corresponds to the last position in the input profile.
Gaps are denoted as - .
RXR-VDR - 1 2 3 - 4 5 -
PPARgamma-RXRal 1 2 3 4 5 6 7 8
Args : none
=cut
sub gaps{ return $_[0]->{'_gaps'};}
sub score{ return $_[0]->{'_score'};}
sub length{ return $_[0]->{'_aligned_positions'};}
sub strand{ return $_[0]->{'_strand'};}
sub alignment{ return $_[0]->{'_align_string'};}
1
TFBS-0.7.1/TFBS/Matrix/.svn/text-base/ICM.pm.svn-base 0000775 0000000 0000000 00000077371 13057522667 0021561 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::ICM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::ICM - class for information content matrices of nucleotide
patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::ICM object manually:
my $matrixref = [ [ 0.00, 0.30, 0.00, 0.00, 0.24, 0.00 ],
[ 0.00, 0.00, 0.00, 1.45, 0.42, 0.00 ],
[ 0.00, 0.89, 2.00, 0.00, 0.00, 0.00 ],
[ 0.00, 0.00, 0.00, 0.13, 0.06, 2.00 ]
];
my $icm = TFBS::Matrix::ICM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring = <new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::ICM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and retrieve
TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pfm = $db_obj->get_Matrix_by_ID("M0001", "ICM");
# or
my $pfm = $db_obj->get_Matrix_by_name("MyProfile", "ICM");
=item * retrieving list of individual TFBS::Matrix::ICM objects
from a TFBS::MatrixSet object
(see decumentation of TFBS::MatrixSet to learn how to create
objects for storage and manipulation of multiple matrices)
my @icm_list = $matrixset->all_patterns(-sort_by=>"name");
* drawing a sequence logo
$icm->draw_logo(-file=>"logo.png",
-full_scale =>2.25,
-xsize=>500,
-ysize =>250,
-graph_title=>"C/EBPalpha binding site logo",
-x_title=>"position",
-y_title=>"bits");
=back
=head1 DESCRIPTION
TFBS::Matrix::ICM is a class whose instances are objects representing
position weight matrices (PFMs). An ICM is normally calculated from a
raw position frequency matrix (see L
for the explanation of position frequency matrices). For example, given
the following position frequency matrix,
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
the standard computational procedure is applied to convert it into the
following information content matrix:
A:[2.00 0.30 0.00 0.00 0.24 0.00]
C:[0.00 0.00 0.00 1.45 0.42 0.00]
G:[0.00 0.89 2.00 0.00 0.00 0.00]
T:[0.00 0.00 0.00 0.13 0.06 2.00]
which contains the "weights" associated with the occurence of each
nucleotide at the given position in a pattern.
A TFBS::Matrix::PWM object is equipped with methods to search nucleotide
sequences and pairwise alignments of nucleotide sequences with the
pattern they represent, and return a set of sites in nucleotide
sequence (a TFBS::SiteSet object for single sequence search, and a
TFBS::SitePairSet for the alignment search).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code starts HERE:
package TFBS::Matrix::ICM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::SeqIO;
use TFBS::Matrix;
BEGIN {
# this will not fail if the modules are nit available
# but only if the user tries to actually draw a logo
eval "use SVG";
eval "use GD";
};
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
#################################################################
# PUBLIC METHODS
#################################################################
=head2 new
Title : new
Usage : my $icm = TFBS::Matrix::ICM->new(%args)
Function: constructor for the TFBS::Matrix::ICM object
Returns : a new TFBS::Matrix::ICM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"ICM");
my $self = bless $matrix, ref($class) || $class;
$self->_check_ic_validity();
return $self;
}
=head2 to_PWM
Title : to_PWM
Usage : my $pwm = $icm->to_PWM()
Function: converts an information content matrix (a TFBS::Matrix::ICM object)
to position weight matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::PWM object
Args : none; in the future releases, it should be able to accept
a user defined background probability of the four
nucleotides
=cut
sub to_PWM {
my ($self) = @_;
$self->throw ("Method to_PWM not yet implemented.");
}
=head2 draw_logo
Title : draw_logo
Usage : my $gdImageObj = $icm->draw_logo(%args)
Function: Draws a "sequence logo", a graphical representation
of a possibly degenerate fixed-width nucleotide
sequence pattern, from the information content matrix
Returns : a GD::Image object;
if you only need the image file you can ignore it
Args : -file, # the name of the output PNG image file
# OPTIONAL: default none
-xsize # width of the image in pixels
# OPTIONAL: default 600
-ysize # height of the image in pixels
# OPTIONAL: default 5/8 of -x_size
-startpos # start position in the logo for x axis
# OPTIONAL: default is 1
-margin # size of image margins in pixels
# OPTIONAL: default 15% of -y_size
-full_scale # the maximum value on the y-axis, in bits
# OPTIONAL: default 2.25
-graph_title,# the graph title
# OPTIONAL: default none
-x_title, # x-axis title; OPTIONAL: default none
-y_title # y-axis title; OPTIONAL: default none
-error_bars # reference to an array of S.D. values for each column; OPTIONAL
-ps # if true, produces a postscript string instead of a GD::Image object
-pdf # if true AND the -file argumant is used, produces an output pdf file
=cut
sub draw_logo {
no strict;
my $self = shift;
my %args = (-xsize => 600,
-full_scale => 2.25,
-graph_title=> "",
-x_title => "",
-y_title => "",
-startpos => 1,
@_);
# Other parameters that can be specified:
# -ysize -line_width -margin
# do not have a fixed default value
# - they are calculated from xsize if not specified
# draw postscript logo if asked for
if ($args{'-ps'} || $args{'-pdf'}){
return _draw_ps_logo($self, %args);
}
if ($args{'-svg'} || $args{'-SVG'}){
return _draw_svg_logo($self, %args);
}
my ($xsize,$FULL_SCALE, $x_title, $y_title)
= @args{qw(-xsize -full_scale -x_title y_title)} ;
my $PER_PIXEL_LINE = 300;
# calculate other parameters if not specified
my $line_width = ($args{-line_width} or int ($xsize/$PER_PIXEL_LINE) or 1);
my $ysize = ($args{-ysize} or $xsize/1.6);
# remark (the line above): 1.6 is a standard screen x:y ratio
my $margin = ($args{-margin} or $ysize*0.15);
my $image = GD::Image->new($xsize, $ysize);
my $white = $image->colorAllocate(255,255,255);
my $black = $image->colorAllocate(0,0,0);
my $motif_size = $self->pdl_matrix->getdim(0);
my $font = ((&GD::gdTinyFont(), &GD::gdSmallFont(), &GD::gdMediumBoldFont(),
&GD::gdLargeFont(), &GD::gdGiantFont())[int(($ysize-50)/100)]
or &GD::gdGiantFont());
my $title_font = ((&GD::gdSmallFont(), &GD::gdMediumBoldFont(),
&GD::gdLargeFont(), &GD::gdGiantFont())[int(($ysize-50)/100)]
or &GD::gdGiantFont());
# WRITE LABELS AND TITLE
# graph title #&GD::Font::MediumBold
$image->string($title_font,
$xsize/2-length($args{-graph_title})* $title_font->width() /2,
$margin/2 - $title_font->height()/2,
$args{-graph_title}, $black);
# x_title
$image->string($font,
$xsize/2-length($args{-x_title})*$font->width()/2,
$ysize-( $margin - $font->height()*0 - 5*$line_width)/2
- $font->height()/2*0,
$args{-x_title},
$black);
# y_title
$image->stringUp($font,
($margin -$font->width()- 5*$line_width)/2
- $font->height()/2 ,
$ysize/2+length($args{'-y_title'})*$font->width()/2,
$args{'-y_title'}, $black);
# DRAW AXES
# vertical: (top left to bottom right)
$image->filledRectangle($margin-$line_width, $margin-$line_width,
$margin-1, $ysize-$margin+$line_width,
$black);
# horizontal: (ditto)
$image->filledRectangle($margin-$line_width, $ysize-$margin+1,
$xsize-$margin+$line_width,$ysize-$margin+$line_width,
$black);
# DRAW VERTICAL TICKS AND LABELS
# vertical axis (IC 1 and 2)
my $ic_1 = ($ysize - 2* $margin) / $FULL_SCALE;
foreach my $i (1..$FULL_SCALE) {
$image->filledRectangle($margin-3*$line_width,
$ysize-$margin - $i*$ic_1,
$margin-1,
$ysize-$margin+$line_width - $i*$ic_1,
$black);
$image->string($font,
$margin-5*$line_width - $font->width,
$ysize - $margin - $i*$ic_1 - $font->height()/2,
$i,
$black);
}
# DRAW HORIZONTAL TICKS AND LABELS, AND THE LOGO ITSELF
# define function refs as hash elements
my %draw_letter = ( A => \&_png_draw_A,
C => \&_png_draw_C,
G => \&_png_draw_G,
T => \&_png_draw_T );
my $horiz_step = ($xsize -2*$margin) / $motif_size;
#this is to avoid clutter on X axis:
my $longest_label_length = length("$motif_size");
if (length ($args{-startpos}) > $longest_label_length) {
$longest_label_length = length ($args{-startpos});
}
if (length ($args{-startpos}+$motif_size) > $longest_label_length) {
$longest_label_length = length ($args{-startpos}+$motif_size);
}
my $draw_every_nth_label = int($longest_label_length*$font->width+2) / $horiz_step + 1;
foreach my $i (0..$motif_size) {
$image->filledRectangle($margin + $i*$horiz_step,
$ysize-$margin+1,
$margin + $i*$horiz_step+ $line_width,
$ysize-$margin+3*$line_width,
$black);
last if $i==$motif_size;
# get the $i-th column of matrix
my %ic;
($ic{A}, $ic{C}, $ic{G}, $ic{T}) = list $self->pdl_matrix->slice($i);
# sort nucleotides by increasing information content
my @draw_order = sort {$ic{$a}<=>$ic{$b}} qw(A C G T);
# draw logo column
my $xlettersize = $horiz_step /1.1;
my $ybottom = $ysize - $margin;
foreach my $base (@draw_order) {
my $ylettersize = int($ic{$base}*$ic_1 +0.5);
next if $ylettersize ==0;
# draw letter
$draw_letter{$base}->($image,
$margin + $i*$horiz_step,
$ybottom - $ylettersize,
$xlettersize, $ylettersize, $white);
$ybottom = $ybottom - $ylettersize-1;
}
if ($args{'-error_bars'} and ref($args{'-error_bars'}) eq "ARRAY") {
my $sd_pix = int($args{'-error_bars'}->[$i]*$ic_1);
my $yt = $ybottom - $sd_pix+1;
my $yb = $ybottom + $sd_pix-1;
my $xpos = $margin + ($i+0.45)*$horiz_step;
my $half_width;
if ($yb > $ysize-$margin+$line_width) {
$yb = $ysize-$margin+$line_width
}
else {
$image->line($xpos - $xlettersize/8, $yb,
$xpos + $xlettersize/8, $yb,
$black);
}
$image->line($xpos, $yt, $xpos, $yb, $black);
$image->line($xpos - 1 , $ybottom, $xpos+1, $ybottom, $black);
$image->line($xpos - $xlettersize/8, $yt,
$xpos + $xlettersize/8, $yt,
$black);
}
# print position number on x axis (The if condition is for avoiding clutter)
my $xlabel = $i+ $args{-startpos};
if ($args{-startpos}<0 and $xlabel>=0) {
$xlabel ++;
}
if ($xlabel % $draw_every_nth_label == 0) {
$image->string($font,
$margin + ($i+0.5)*$horiz_step - $font->width()/2,
$ysize - $margin +5*$line_width,
$xlabel,
$black);
}
}
# print $args{-file};
if ($args{-file}) {
open (PNGFILE, ">".$args{-file})
or $self->throw("Could not write to ".$args{-file});
print PNGFILE $image->png;
close PNGFILE;
}
return $image;
}
sub total_ic {
return $_[0]->pdl_matrix->sum();
}
=head2 _draw_ps_logo
Title : _draw_ps_logo
Usage : my $postscript_string = $icm->_draw_ps_logo(%args)
Internal method, should be accessed using draw_logo()
Function: Draws a "sequence logo", a graphical representation
of a possibly degenerate fixed-width nucleotide
sequence pattern, from the information content matrix
Returns : a postscript string;
if you only need the image file you can ignore it
Args : -file, # the name of the output PNG image file
# OPTIONAL: default none
-xsize # width of the image in pixels
# OPTIONAL: default 600
-ysize # height of the image in pixels
# OPTIONAL: default 5/8 of -x_size
-full_scale # the maximum value on the y-axis, in bits
# OPTIONAL: default 2.25
-graph_title,# the graph title
# OPTIONAL: default none
-x_title, # x-axis title; OPTIONAL: default none
-y_title # y-axis title; OPTIONAL: default none
=cut
sub _draw_ps_logo{
my $self = shift;
my %args = (-xsize => 600,
-full_scale => 2.25,
-graph_title=> "",
-x_title => "",
-y_title => "",
@_);
my $xsize= $args{'-xsize'};
my $max_ysize= $args{'-ysize'} ||int 5* $args{'-xsize'}/8;
my $ysize= $max_ysize*($args{'-full_scale'}-($args{'-full_scale'}-2))/$args{'-full_scale'};
my $x=100; # nternal, for placement on 'paper'
my $y=100;
my $out= "%!PS-Adobe-2.0
%%Orientation: Portrait
%%Pages: 1
%%BoundingBox: 0 0 ".($args{'-xsize'}*1.2)." ".( $max_ysize*1.5)."
%%BeginSetup
%%EndSetup
%%Magnification: 1.0000
%%EndProlog
%%end
%%save
gsave\n";
#colors and correction definitions
my %color;
$color{'black'}="0.000 0.000 0.000 setrgbcolor";
$color{'A'}="0.000 1.000 0.000 setrgbcolor";
$color{'C'}="0.000 0.000 1.000 setrgbcolor";
$color{'G'}="1.000 0.860 0.000 setrgbcolor";
$color{'T'}="1.000 0.000 0.000 setrgbcolor";
my $fontsize= int $ysize*0.68;
my $fontwidth=1.5*($xsize/$self->length());
my %w_correct; # correction of font widths
$w_correct{'A'}=0.95;
$w_correct{'T'}=1.05;
$w_correct{'C'}=0.90;
$w_correct{'G'}=0.90;
my %y_next;#correction of font heights
$y_next{'A'}=1;
$y_next{'T'}=1;
$y_next{'C'}=0.94;
$y_next{'G'}=0.94;
my %y_correct; #correction of font bounding boxes
$y_correct{'A'}=0;
$y_correct{'C'}=0.035*$fontsize;
$y_correct{'G'}=0.035*$fontsize;
$y_correct{'T'}=0;
#define y axis,tickmarks and scaling
my $font= $fontwidth/5;
$out.="newpath\n ". ($x-10)." ". ($y+2*$ysize/4 )." moveto\n". "$x ". ($y+2*$ysize/4 ) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-20). " ".( $y+$ysize/2)." moveto\n";
$out.=" (1) show\n grestore\n" ;
$out.="newpath\n ". ($x-10)." ". ($y+$ysize )." moveto\n". "$x ". ($y+$ysize) ." lineto\n stroke\n";
$out.="newpath\n ". ($x-10)." ". ($y+$max_ysize )." moveto\n". "$x ". ($y+$max_ysize) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-20). " ".( $y+$ysize)." moveto\n";
$out.=" (2) show\n grestore\n" ;
$out.="newpath\n $x $y moveto\n". ($x). " ".($y+$max_ysize) ." lineto\n stroke\n";
$out.="newpath\n $x $y moveto\n". ($x+$xsize). " ".($y) ." lineto\n stroke\n";
# draw titles if requested
if ($args{'-y_title'}){
$out.= "gsave\n/Times-Italic findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-40). " ".( $y+$ysize/2)." moveto\n";
$out.=" 90 rotate ($args{'-y_title'}) show\n grestore\n" ;
}
if ($args{'-x_title'}){
$out.= "gsave\n/Times-Italic findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x+$xsize/2.5). " ".( $y*(0.60))." moveto\n";
$out.=" ($args{'-x_title'}) show\n grestore\n" ;
}
if ($args{'-title'}){
$out.= "gsave\n/Times-Roman findfont $color{black} [".($font*2)." 0 0 $font 0 0] makefont setfont\n".($x+$xsize/3). " ".( $y+$max_ysize*1.1)." moveto\n";
$out.=" ($args{'-title'}) show\n grestore\n" ;
}
# define x axis and x tickmarks
my $col_width=($xsize/$self->length()) -0.006*$xsize;
my $x_now;
for(my $i=1; $i<=$self->length(); $i++){
$x_now=$x+$col_width*$i;
$out.="newpath\n ". ($x_now)." ". ($y)." moveto\n". ($x_now)." ". ($y-$ysize/20 ) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x_now-$col_width/2). " ".( $y-20)." moveto\n";
$out.=" ($i) show\n grestore\n" ;
}
# draw the logo
foreach my $i (0..$self->length()-1 ) { # get the $i-th column of matrix
my %ic;
($ic{A}, $ic{C}, $ic{G}, $ic{T}) = list $self->pdl_matrix->slice($i);
my @draw_order = sort {$ic{$a}<=>$ic{$b}} qw(A C G T);
#draw this position
foreach my $letter (@draw_order){
$ic{$letter}=0.0000001 if ( $ic{$letter}==0); # some interpretors do not uderstand size 0
$out.= "gsave\n/Helvetica-Bold findfont $color{$letter} [".$fontwidth*$w_correct{$letter}." 0 0 ";
$out.= $ic{$letter}*$fontsize*$y_next{$letter} ;
$y+=$y_correct{$letter}*$ic{$letter}; #movement that isletter specific, due to bounding boxes
$out.= " 0 0] makefont setfont\n$x $y moveto\n";
$out.= " ($letter) show\n grestore\n" ;
$y+=$fontsize*$ic{$letter}*0.75; #ic content move
}
$x+=$fontwidth/1.6;
$y=100;
}
# save as file if requested
if ($args{-file}) {
open (PSFILE, ">".$args{-file})
or $self->throw("Could not write to ".$args{-file});
print PSFILE $out;
close PSFILE;
}
if ($args{-pdf}){
system "ps2pdf $args{-file} ".$args{-file}.".pdf ";
system " mv $args{-file}.pdf $args{-file}";
}
return $out;
}
=head2 _draw_svg_logo
=cut
sub _draw_svg_logo {
my $self = shift;
my %args = (-xsize => 800,
-full_scale => 2.25,
-graph_title=> "",
-x_title => "",
-y_title => "",
@_);
my $max_ysize= $args{'-ysize'} ||int 5* $args{'-xsize'}/8;
my ($xsize,$FULL_SCALE, $x_title, $y_title)
= @args{qw(-xsize -full_scale -x_title y_title)} ;
my $PER_PIXEL_LINE = 200;
# calculate other parameters if not specified
my $ysize = ($args{-ysize} or $xsize/1.6);
my $line_width = ($args{-line_width} or $ysize/$PER_PIXEL_LINE);
# remark (the line above): 1.6 is a standard screen x:y ratio
my $margin = ($args{-margin} or $ysize*0.15);
my $image = SVG->new(width=>$xsize, height=>$ysize);
my $white = 'rgb(255,255,255)';
my $black = 'rgb(0,0,0)';
my $motif_size = $self->pdl_matrix->getdim(0);
my $fontsize = int ($ysize/25);
my $title_font = {width=>$fontsize*1.5, height=>$fontsize*1.5};
my $font = {width=>$fontsize, height=>$fontsize};
# WRITE LABELS AND TITLE
# graph title
$image->text(id=>"Title",
'font-size'=>$title_font->{width},
x => $xsize/2,
y => 0.6*$margin,
'text-anchor'=>'middle'
)->cdata($args{-graph_title});
# x title
$image->text(id=>"X_title",
'font-size'=>$font->{width},
x => $xsize/2,
y => $ysize -0.3*$margin,
'text-anchor'=>'middle'
)->cdata($args{-x_title});
# y title
my $g = $image->group;
$g->text(id=>"Y_title",
'font-size'=>$font->{width},
x => 0 ,
'text-anchor'=>'middle',
y => 0,
transform => 'rotate(-90) translate(-'.($ysize/2).','.($margin/2).')')->cdata($args{-y_title});
# DRAW AXES
# vertical: (top left to bottom right)
$image->rectangle(id => "y_axis",
style => {
#stroke => $black,
fill => $black
},
x => $margin-$line_width,
y => $margin,
width => $line_width,
height => $ysize -2*$margin
);
#$image->filledRectangle($margin-$line_width, $margin-$line_width,
# $margin-1, $ysize-$margin+$line_width, #
# $black);
# horizontal: (ditto)
$image->rectangle(id => "x_axis",
style => {
#stroke => $black,
fill => $black
},
x => $margin-$line_width,
y => $ysize-$margin,
width => $xsize-2*$margin+$line_width,
height => $line_width
);
#$image->filledRectangle($margin-$line_width, $ysize-$margin+1,
# $xsize-$margin+$line_width,$ysize-$margin+$line_width,
# $black);
# DRAW VERTICAL TICKS AND LABELS
# vertical axis (IC 1 and 2)
my $ic_1 = ($ysize - 2* $margin) / $FULL_SCALE;
foreach my $i (1..$FULL_SCALE) {
$image->rectangle(x => $margin-3*$line_width,
y => $ysize-$margin - $i*$ic_1,
width => 3*$line_width,
height => $line_width
);
$image->text(x => $margin-5*$line_width - $font->{width},
y => $ysize - $margin - $i*$ic_1 +$font->{height}/2,
'font-size'=>$font->{width},
'text-anchor'=>"right"
)->cdata($i);
}
# DRAW HORIZONTAL TICKS AND LABELS, AND THE LOGO ITSELF
# define function refs as hash elements
my %draw_letter = ( A => \&_svg_draw_A,
C => \&_svg_draw_C,
G => \&_svg_draw_G,
T => \&_svg_draw_T );
my $horiz_step = ($xsize -2*$margin) / $motif_size;
#this is to avoid clutter on X axis:
my $longest_label_length = length("$motif_size");
if (length ($args{-startpos}) > $longest_label_length) {
$longest_label_length = length ($args{-startpos});
}
if (length ($args{-startpos}+$motif_size) > $longest_label_length) {
$longest_label_length = length ($args{-startpos}+$motif_size);
}
my $draw_every_nth_label = int(($longest_label_length+0.25)*$font->{width}) / $horiz_step + 1;
foreach my $i (0..$motif_size) {
my $height = 3*$line_width;
if ($i and $i==$args{-startpos}*-1){
$height = 5*$line_width;
}
$image->rectangle(x => $margin + $i*$horiz_step -$line_width/2,
y => $ysize-$margin,
width => $line_width,
height => $height
);
last if $i==$motif_size;
# get the $i-th column of matrix
my %ic;
($ic{A}, $ic{C}, $ic{G}, $ic{T}) = list $self->pdl_matrix->slice($i);
# sort nucleotides by increasing information content
my @draw_order = sort {$ic{$a}<=>$ic{$b}} qw(A C G T);
# draw logo column
my $xlettersize = $horiz_step*0.95;
my $ybottom = $ysize - $margin;
foreach my $base (@draw_order) {
my $ylettersize = $ic{$base}*$ic_1;
next if $ylettersize ==0;
# draw letter
$draw_letter{$base}->($image,
$margin + $i*$horiz_step + 0.025* $horiz_step,
$ybottom - $ylettersize,
$xlettersize, $ylettersize, $white);
$ybottom = $ybottom - $ylettersize;
}
if ($args{'-error_bars'} and ref($args{'-error_bars'}) eq "ARRAY") {
my $sd_pix = int($args{'-error_bars'}->[$i]*$ic_1);
my $yt = $ybottom - $sd_pix+1;
my $yb = $ybottom + $sd_pix-1;
my $xpos = $margin + ($i+0.5)*$horiz_step;
my $half_width;
if ($yb > $ysize-$margin+$line_width) {
$yb = $ysize-$margin+$line_width
}
else {
$image->line(x1=>$xpos - $xlettersize/8, y1=> $yb,
x2=> $xpos + $xlettersize/8, y2=>$yb, stroke=>$black,
'stroke-width'=>$line_width);
}
$image->line(x1=>$xpos, y1=>$yt, x2=>$xpos, y2=>$yb, stroke=>$black,
'stroke-width'=>$line_width);
$image->line(x1=>$xpos - $line_width , y1=>$ybottom, x2=>$xpos+$line_width, y2=>$ybottom, stroke=>$black,
'stroke-width'=>$line_width);
$image->line(x1=>$xpos - $xlettersize/8, y1=>$yt,
x2=>$xpos + $xlettersize/8, y2=>$yt, stroke=>$black,
'stroke-width'=>$line_width);
}
# print position number on x axis
my $xlabel = $i+ $args{-startpos};
if ($args{-startpos}<0 and $xlabel>=0) {
$xlabel ++;
}
if ($xlabel % $draw_every_nth_label == 0) {
$image->text(x => $margin + ($i+0.5)*$horiz_step - $font->{width}/2,
y => $ysize - $margin +5*$line_width + $font->{width}/2,
'font-size'=>$font->{width},
'text-anchor'=>"bottom"
)->cdata($xlabel);
}
}
# print to $args{-file};
if ($args{-file}) {
open (SVGFILE, ">".$args{-file})
or $self->throw("Could not write to ".$args{-file});
my $xml = $image->xmlify;
$xml =~ s/\s+<\/text/<\/text/gs;
print SVGFILE $xml;
close SVGFILE;
}
return $image;
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
#################################################################
# INTERNAL METHODS
#################################################################
sub _check_ic_validity {
my ($self) = @_;
# to do
}
sub DESTROY {
# nothing
}
#################################################################
# UTILITY FUNCTIONS
#################################################################
# letter drawing routines
sub _png_draw_A {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $green = $im->colorAllocate(0,255,0);
my $outPoly = GD::Polygon->new();
$outPoly->addPt($x, $y+$ysize);
$outPoly->addPt($x+$xsize*.42, $y);
$outPoly->addPt($x+$xsize*.58, $y);
$outPoly->addPt($x+$xsize, $y+$ysize);
$outPoly->addPt($x+0.85*$xsize, $y+$ysize);
$outPoly->addPt($x+0.725*$xsize, $y+0.75*$ysize);
$outPoly->addPt($x+0.275*$xsize, $y+0.75*$ysize);
$outPoly->addPt($x+0.15*$xsize, $y+$ysize);
$im->filledPolygon($outPoly, $green);
if ($ysize>8) {
my $inPoly = GD::Polygon->new();
$inPoly->addPt($x+$xsize*.5, $y+0.2*$ysize);
$inPoly->addPt($x+$xsize*.34, $y+0.6*$ysize-1);
$inPoly->addPt($x+$xsize*.64, $y+0.6*$ysize-1);
$im->filledPolygon($inPoly, $white);
}
return 1;
}
sub _png_draw_C {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $blue = $im->colorAllocate(0,0,255);
$im->arc($x+$xsize*0.54, $y+$ysize/2,1.08*$xsize,$ysize,0,360,$blue);
$im->fill($x+$xsize/2, $y+$ysize/2, $blue);
if ($ysize>12) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
0.75*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize/2, $y+$ysize/4+1,
$x+$xsize*1.1, $y+(3*$ysize/4)-1,
$white);
}
elsif ($ysize>3) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
(0.75-0.75/$ysize)*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize*0.25, $y+$ysize/2,
$x+$xsize*1.1, $y+$ysize/2,
$white);
}
return 1;
}
sub _png_draw_G {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $yellow = $im->colorAllocate(200,200,0);
$im->arc($x+$xsize*0.54, $y+$ysize/2,1.08*$xsize,$ysize,0,360,$yellow);
$im->fill($x+$xsize/2, $y+$ysize/2, $yellow);
if ($ysize>20) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
0.75*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize/2, $y+$ysize/4+1,
$x+$xsize*1.1, $y+$ysize/2-1,
$white);
}
elsif($ysize>3) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
(0.75-0.75/$ysize)*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize*0.25, $y+$ysize/2,
$x+$xsize*1.1, $y+$ysize/2,
$white);
}
$im->filledRectangle($x+0.85*$xsize, $y+$ysize/2,
$x+$xsize,$y+(3*$ysize/4)-1,
$yellow);
$im->filledRectangle($x+0.6*$xsize, $y+$ysize/2,
$x+$xsize,$y+(5*$ysize/8)-1,
$yellow);
return 1;
}
sub _png_draw_T {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $red = $im->colorAllocate(255,0,0);
$im->filledRectangle($x, $y, $x+$xsize, $y+0.16*$ysize, $red);
$im->filledRectangle($x+0.42*$xsize, $y, $x+0.58*$xsize, $y+$ysize, $red);
return 1;
}
sub _svg_draw_A {
my ($im, $x, $y, $xsize, $ysize) = @_;
$im->polygon( points => [$x, $y+$ysize, $x+$xsize*.42, $y, $x+$xsize*.58, $y, $x+$xsize, $y+$ysize,
$x+0.85*$xsize, $y+$ysize, $x+0.725*$xsize, $y+0.75*$ysize, $x+0.275*$xsize, $y+0.75*$ysize,
$x+0.15*$xsize, $y+$ysize, $x, $y+$ysize],
fill => 'rgb(0,255,0)'
);
$im->polygon( points => [$x+$xsize*.5, $y+0.2*$ysize, $x+$xsize*.34, $y+0.6*$ysize, $x+$xsize*.64, $y+0.6*$ysize ],
fill => 'rgb(255,255,255)');
return 1;
}
sub _svg_draw_C {
my ($im, $x, $y, $xsize, $ysize) = @_;
$im->ellipse(cx=>$x+$xsize*0.54, cy=>$y+$ysize/2, rx=>$xsize*0.54, ry=>$ysize/2,
fill => 'rgb(0,0,255)');
$im->ellipse( cx=>$x+$xsize*0.53, cy=>$y+$ysize/2, rx=>$xsize*0.375, ry=>$ysize*0.375,
fill => 'rgb(255,255,255)');
$im->rectangle(x=>$x+$xsize/2, y=>$y+$ysize/4,
width =>$xsize*0.6, height =>$ysize/2,
fill=> 'rgb(255,255,255)');
return 1;
}
sub _svg_draw_G {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
$im->ellipse(cx => $x+$xsize*0.54, cy => $y+$ysize/2,
rx => 0.54*$xsize, ry => $ysize/2,
fill => 'rgb(200,200,0)');
$im->ellipse(cx => $x+$xsize*0.53, cy => $y+$ysize/2,
rx => 0.375*$xsize, ry => 0.375*$ysize,
fill => 'rgb(255,255,255)');
$im->rectangle(x=>$x+$xsize/2, y=>$y+$ysize/4,
width =>$xsize*0.6, height =>$ysize/2,
fill=> 'rgb(255,255,255)');
$im->rectangle(x=>$x+0.80*$xsize, y=>$y+$ysize/2,
width =>$xsize*0.208, height =>$ysize/4,
fill=> 'rgb(200,200,0)');
$im->rectangle(x=>$x+0.6*$xsize, y=>$y+$ysize/2,
width =>$xsize*0.408, height =>$ysize/8,
fill=> 'rgb(200,200,0)');
return 1;
}
sub _svg_draw_T {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
$im->polygon (points =>[$x, $y, $x+$xsize, $y, $x+$xsize, $y+0.16*$ysize,
$x+0.58*$xsize, $y+0.16*$ysize, $x+0.58*$xsize, $y+$ysize,
$x+0.42*$xsize, $y+$ysize, $x+0.42*$xsize, $y+0.16*$ysize,
$x, $y+0.16*$ysize],
fill => 'rgb(255,0,0)');
return 1;
}
1;
TFBS-0.7.1/TFBS/Matrix/.svn/text-base/PFM.pm.svn-base 0000775 0000000 0000000 00000037337 13057522667 0021571 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::PFM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::PFM - class for raw position frequency matrix patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::PFM object manually:
my $matrixref = [ [ 12, 3, 0, 0, 4, 0 ],
[ 0, 0, 0, 11, 7, 0 ],
[ 0, 9, 12, 0, 0, 0 ],
[ 0, 0, 0, 1, 1, 12 ]
];
my $pfm = TFBS::Matrix::PFM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring =
"12 3 0 0 4 0\n0 0 0 11 7 0\n0 9 12 0 0 0\n0 0 0 1 1 12";
my $pfm = TFBS::Matrix::PFM->new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::PFM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and
retrieve TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pfm = $db_obj->get_Matrix_by_ID("M0001", "PFM");
# or
my $pfm = $db_obj->get_Matrix_by_name("MyProfile", "PFM");
=item * retrieving list of individual TFBS::Matrix::PFM objects
from a TFBS::MatrixSet object
(See the L to learn how to create
objects for storage and manipulation of multiple matrices.)
my @pfm_list = $matrixset->all_patterns(-sort_by=>"name");
=item * convert a raw frequency matrix to other matrix types:
my $pwm = $pfm->to_PWM(); # convert to position weight matrix
my $icm = $icm->to_ICM(); # convert to information con
=back
=head1 DESCRIPTION
TFBS::Matrix::PFM is a class whose instances are objects representing
raw position frequency matrices (PFMs). A PFM is derived from N
nucleotide patterns of fixed size, e.g. the set of sequences
AGGCCT
AAGCCT
AGGCAT
AAGCCT
AAGCCT
AGGCAT
AGGCCT
AGGCAT
AGGTTT
AGGCAT
AGGCCT
AGGCCT
will give the matrix:
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
which contains the count of each nucleotide at each position in the
sequence. (If you have a set of sequences as above and want to
create a TFBS::Matrix::PFM object out of them, have a look at
TFBS::PatternGen::SimplePFM module.)
PFMs are easily converted to other types of matrices, namely
information content matrices and position weight matrices. A
TFBS::Matrix::PFM object has the methods to_ICM and to_PWM which
do just that, returning a TFBS::Matrix::ICM and TFBS::Matrix::PWM
objects, respectively.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Matrix::PFM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::SeqIO;
use TFBS::Matrix;
use TFBS::Matrix::ICM;
use TFBS::Matrix::PWM;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
use constant EXACT_SCHNEIDER_MAX => 30;
#######################################################
# PUBLIC METHODS
#######################################################
=head2 new
Title : new
Usage : my $pfm = TFBS::Matrix::PFM->new(%args)
Function: constructor for the TFBS::Matrix::PFM object
Returns : a new TFBS::Matrix::PFM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
Warnings : Warns if the matrix provided has columns with different
sums. Columns with different sums contradict the usual
origin of matrix data and, unless you are absolutely sure
that column sums _should_ be different, it would be wise to
check your matrices.
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"PFM");
my $self = bless $matrix, ref($class) || $class;
$self->_check_column_sums();
return $self;
}
=head2 column_sum
Title : column_sum
Usage : my $nr_sequences = $pfm->column_sum()
Function: calculates the sum of elements of one column
(the first one by default) which normally equals the
number of sequences used to derive the PFM.
Returns : the sum of elements of one column (an integer)
Args : columnn number (starting from 1), OPTIONAL - you DO NOT
need to specify it unless you are dealing with a matrix
=cut
sub column_sum {
my ($self, $column) = (@_,1);
return $self->pdl_matrix->slice($column-1)->sum;
}
=head2 to_PWM
Title : to_PWM
Usage : my $pwm = $pfm->to_PWM()
Function: converts a raw frequency matrix (a TFBS::Matrix::PFM object)
to position weight matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::PWM object
Args : none; in the future releases, it should be able to accept
a user defined background probability of the four
nucleotides
=cut
sub to_PWM {
my ($self, %args) = @_;
my $bg = ($args{'-bg_probabilities' } || $self->{'bg_probabilities'});
my $bg_pdl =
transpose pdl ($bg->{'A'}, $bg->{'C'}, $bg->{'G'}, $bg->{'T'});
my $nseqs = $self->pdl_matrix->sum / $self->length;
my $q_pdl = ($self->pdl_matrix +$bg_pdl*sqrt($nseqs))
/
($nseqs + sqrt($nseqs));
my $pwm_pdl = log2(4*$q_pdl);
my $PWM = TFBS::Matrix::PWM->new
( (map {("-$_", $self->{$_}) } keys %$self),
# do not want tags to point to the same arrayref as in $self:
-tags => \%{ $self->{'tags'}},
-bg_probabilities => \%{ $self->{'bg_probabilities'}},
-matrix => $pwm_pdl
);
return $PWM;
}
=head2 to_ICM
Title : to_ICM
Usage : my $icm = $pfm->to_ICM()
Function: converts a raw frequency matrix (a TFBS::Matrix::PFM object)
to information content matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::ICM object
Args : -small_sample_correction # undef (default), 'schneider' or 'pseudocounts'
How a PFM is converted to ICM:
For a PFM element PFM[i,k], the probability without
pseudocounts is estimated to be simply
p[i,k] = PFM[i,k] / Z
where
- Z equals the column sum of the matrix i.e. the number of motifs used
to construct the PFM.
- i is the column index (position in the motif)
- k is the row index (a letter in the alphacer, here k is one of
(A,C,G,T)
Here is how one normally calculates the pseudocount-corrected positional
probability p'[i,j]:
p'[i,k] = (PFM[i,k] + 0.25*sqrt(Z)) / (Z + sqrt(Z))
0.25 is for the flat distribution of nucleotides, and sqrt(Z) is the
recommended pseudocount weight. In the general case,
p'[i,k] = (PFM[i,k] + q[k]*B) / (Z + B)
where q[k] is the background distribution of the letter (nucleotide) k,
and B an arbitrary pseudocount value or expression (for no pseudocounts
B=0).
For a given position i, the deviation from random distribution in bits
is calculated as (Baldi and Brunak eq. 1.9 (2ed) or 1.8 (1ed)):
- for an arbitrary alphabet of A letters:
D[i] = log2(A) + sum_for_all_k(p[i,k]*log2(p[i,k]))
- special case for nucleotides (A=4)
D[i] = 2 + sum_for_all_k(p[i,k]*log2(p[i,k]))
D[i] equals the information content of the position i in the motif. To
calculate the entire ICM, you have to calculate the contrubution of each
nucleotide at a position i to D[i], i.e.
ICM[i,k] = p'[i,k] * D[i]
=cut
sub to_ICM {
my ($self, %args) = @_;
my $bg = ($args{'-bg_probabilities' } || $self->{'bg_probabilities'});
# compute ICM
my $bg_pdl =
transpose pdl ($bg->{'A'}, $bg->{'C'}, $bg->{'G'}, $bg->{'T'});
my $Z_pdl = $self->pdl_matrix->xchg(0,1)->sumover;
# pseudocount calculation
my $B = 0;
if (lc($args{'-small_sample_correction'} or "") eq "pseudocounts") {
$B = sqrt($Z_pdl);
}
else {
$B = 0; # do not add pseudocounts
}
my $p_pdl = ($self->pdl_matrix +$bg_pdl*$B)/ ($Z_pdl + $B);
my $plog_pdl = $p_pdl*log2($p_pdl);
$plog_pdl = $plog_pdl->badmask(0);
my $D_pdl = 2 + $plog_pdl->xchg(0,1)->sumover;
my $ic_pdl = $p_pdl * $D_pdl;
# apply Schneider correction if requested
if (lc($args{'-small_sample_correction'} or "") eq "schneider") {
my $columnsum_pdl = $ic_pdl->transpose->sumover;
my $corrected_columnsum_pdl =
$columnsum_pdl
+ _schneider_correction ($self->pdl_matrix, $bg_pdl);
$ic_pdl *= $corrected_columnsum_pdl/$columnsum_pdl;
}
# construct and return an ICM object
my $ICM = TFBS::Matrix::ICM->new
( (map {("-$_" => $self->{$_})} keys %$self),
-tags => \%{ $self->{'tags'}},
-bg_probabilities => \%{ $self->{'bg_probabilities'}},
-matrix => $ic_pdl
);
return $ICM;
}
=head2 draw_logo
Title : draw_logo
Usage : my $gd_image = $pfm->draw_logo()
Function: draws a sequence logo; similar to the
method in TFBS::Matrix::ICM, but can automatically calculate
error bars for drawing
Returns : a GD image object (see documentation of GD module)
Args : many; PFM-specific options are:
-small_sample_correction # One of
# "Schneider" (uses correction
# described by Schneider et al.
# (Schneider t et al. (1986) J.Biol.Chem.
# "pseudocounts" - standard pseudocount
# correction, more suitable for
# PFMs with large r column sums
# If the parameter is ommited, small
# sample correction is not applied
-draw_error_bars # if true, adds error bars to each position
# in the logo. To calculate the error bars,
# it uses the -small_sample_connection
# argument if explicitly set,
# or "Schneider" by default
For other args, see draw_logo entry in TFBS::Matrix::ICM documentation
=cut
sub draw_logo {
my ($self, %args) = @_;
if ($args{'-draw_error_bars'}) {
$args{'-small_sample_correction'} ||= "Schneider"; # default Schneider
my $pdl_no_correction =
$self->to_ICM()
->pdl_matrix->transpose->sumover;
my $pdl_with_correction =
$self->to_ICM(-small_sample_correction
=> $args{'-small_sample_correction'})
->pdl_matrix->transpose->sumover;
$args{'-error_bars'} =
[list ($pdl_no_correction - $pdl_with_correction)];
}
$self->to_ICM(%args)->draw_logo(%args);
}
=head2 add_PFM
Title : add_PFM
Usage : $pfm->add_PFM($another_pfm)
Function: adds the values of $pnother_pfm matrix to $pfm
Returns : reference to the updated $pfm object
Args : a TFBS::Matrix::PFM object
=cut
sub add_PFM {
my ($self, $pfm) = @_;
$pfm->isa("TFBS::Matrix::PFM")
or $self->throw("Wrong or no argument passed to add_PFM");
my $sum = $self->pdl_matrix + $pfm->pdl_matrix;
$self->set_matrix($sum);
return $self;
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
###############################################
# PRIVATE METHODS
###############################################
sub _check_column_sums {
my ($self) = @_;
my $pdl = $self->pdl_matrix->sever();
my $rowsums = $pdl->xchg(0,1)->sumover();
#if ($rowsums->where($rowsums != $rowsums->slice(0))->getdim(0) > 0) {
#$self->warn("PFM for ".$self->{ID}." has unequal column sums");
#}
}
sub DESTROY {
# does nothing
}
###############################################
# UTILITY FUNCTIONS
###############################################
sub log2 { log($_[0]) / log(2); }
sub _schneider_correction {
my ($pdl, $bg_pdl) = @_;
my $Hg = -sum ($bg_pdl*log2($bg_pdl));
my (@Hnbs, %saved_Hnb);
my $is_flat = _is_bg_flat(list $bg_pdl);
my @factorials = (1);
if (min($pdl->transpose->sumover) <= EXACT_SCHNEIDER_MAX) {
foreach my $i (1..max($pdl->transpose->sumover)) {
$factorials[$i] =$factorials[$i-1] * $i;
}
}
my @column_sums = list $pdl->transpose->sumover;
foreach my $colsum (@column_sums) {
if (defined($saved_Hnb{$colsum})) {
push @Hnbs, $saved_Hnb{$colsum};
}
else {
my $Hnb;
if ($colsum <= EXACT_SCHNEIDER_MAX) {
if ($is_flat) {
$Hnb = _schneider_Hnb_precomputed($colsum);
}
else {
$Hnb = _schneider_Hnb_exact($colsum, $bg_pdl,
\@factorials);
}
}
else {
$Hnb = _schneider_Hnb_approx($colsum, $Hg);
}
$saved_Hnb{$colsum} = $Hnb;
push @Hnbs, $Hnb;
}
}
return -$Hg + pdl(@Hnbs);
}
sub _schneider_Hnb_exact {
my ($n, $bg_pdl, $rFactorial) = @_;
my $is_flat = _is_bg_flat(list $bg_pdl);
return 0 if $n==1;
# my @fctrl = (1);
# foreach my $i (1..max($pdl->transpose->sumover)) {
# $rFactorial->[$i] =$rFactorial->[$i-1] * $i;
# }
# my @colsum = list $pdl->transpose->sumover;
my ($na, $nc, $ng, $nt) = ($n, 0,0,0);
# my $n = $colsum[0];
my $E_Hnb=0;
while (1) {
my $ns_pdl = pdl [$na, $nc, $ng, $nt];
my $Pnb = ($rFactorial->[$n]
/
($rFactorial->[$na]
*$rFactorial->[$nc]
*$rFactorial->[$ng]
*$rFactorial->[$nt])
)*prod($bg_pdl->transpose**pdl($na, $nc, $ng, $nt));
my $Hnb = -1 * sum(($ns_pdl/$n)*log2($ns_pdl/$n)->badmask(0));
$E_Hnb += $Pnb*$Hnb;
if ($nt) {
if ($ng) { $ng--; $nt++, }
elsif ($nc) { $nc--; $ng = $nt+1; $nt = 0; }
elsif ($na) { $na--; $nc = $nt+1; $nt = 0; }
else { last; }
}
else {
if ($ng) { $ng--; $nt++, }
elsif ($nc) { $nc--; $ng++; }
else { $na--; $nc++; $nt = 0; }
}
}
return $E_Hnb;
}
sub _schneider_Hnb_approx {
my ($colsum, $Hg) = @_;
return $Hg -3/(2*log(2)*$colsum);
}
sub _schneider_Hnb_precomputed {
my $i = shift;
if ($i<1 or $i>30) {
die "Precomputed params only available for colsums 1 to 30)";
}
my @precomputed =
(
0, # 1
0.75, # 2
1.11090234442608, # 3
1.32398964833609, # 4
1.46290503577084, # 5
1.55922640783176, # 6
1.62900374746751, # 7
1.68128673969433, # 8
1.7215504663901, # 9
1.75328193031842, # 10
1.77879136615189, # 11
1.79965855531179, # 12
1.81699248819687, # 13
1.8315892710679, # 14
1.84403166371213, # 15
1.85475371994775, # 16
1.86408383599326, # 17
1.87227404728809, # 18
1.87952034817826, # 19
1.88597702438913, # 20
1.89176691659196, # 21
1.89698887214968, # 22
1.90172322434865, # 23
1.90603586889234, # 24
1.90998133028897, # 25
1.91360509239859, # 26
1.91694538711761, # 27
1.92003457997914, # 28
1.92290025302018, # 29
1.92556605820924, # 30
);
return $precomputed[$i-1];
}
sub _is_bg_flat {
my @bg = @_;
my $ref = shift;
foreach my $other (@bg) {
return 0 unless $ref==$other;
}
return 1;
}
1;
TFBS-0.7.1/TFBS/Matrix/.svn/text-base/PWM.pm.svn-base 0000775 0000000 0000000 00000036220 13057522667 0021600 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::PWM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::PWM - class for position weight matrices of nucleotide
patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::PWM object manually:
my $matrixref = [ [ 0.61, -3.16, 1.83, -3.16, 1.21, -0.06],
[-0.15, -2.57, -3.16, -3.16, -2.57, -1.83],
[-1.57, 1.85, -2.57, -1.34, -1.57, 1.14],
[ 0.31, -3.16, -2.57, 1.76, 0.24, -0.83]
];
my $pwm = TFBS::Matrix::PWM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring = <new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::PWM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and retrieve
TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pwm = $db_obj->get_Matrix_by_ID("M0001", "PWM");
# or
my $pwm = $db_obj->get_Matrix_by_name("MyProfile", "PWM");
=item * retrieving list of individual TFBS::Matrix::PWM objects
from a TFBS::MatrixSet object
(see decumentation of TFBS::MatrixSet to learn how to create
objects for storage and manipulation of multiple matrices)
my @pwm_list = $matrixset->all_patterns(-sort_by=>"name");
=item * scanning a nucleotide sequence with a matrix
my $siteset = $pwm->search_seq(-file =>"myseq.fa",
-threshold => "80%");
=item * scanning a pairwise alignment with a matrix
my $site_pair_set = $pwm->search_aln(-file =>"myalign.aln",
-threshold => "80%",
-cutoff => "70%",
-window => 50);
=back
=head1 DESCRIPTION
TFBS::Matrix::PWM is a class whose instances are objects representing
position weight matrices (PWMs). A PWM is normally calculated from a
raw position frequency matrix (see L
for the explanation of position frequency matrices). For example, given
the following position frequency matrix:
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
The standard computational procedure is applied to convert it into the
following position weight matrix:
A:[ 0.61 -3.16 1.83 -3.16 1.21 -0.06]
C:[-0.15 -2.57 -3.16 -3.16 -2.57 -1.83]
G:[-1.57 1.85 -2.57 -1.34 -1.57 1.14]
T:[ 0.31 -3.16 -2.57 1.76 0.24 -0.83]
which contains the "weights" associated with the occurence of each
nucleotide at the given position in a pattern.
A TFBS::Matrix::PWM object is equipped with methods to search nucleotide
sequences and pairwise alignments of nucleotide sequences with the
pattern they represent, and return a set of sites in nucleotide
sequence (a TFBS::SiteSet object for single sequence search, and a
TFBS::SitePairSet for the alignment search).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Matrix::PWM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::Seq;
use Bio::SeqIO;
use TFBS::Matrix;
use TFBS::SiteSet;
use TFBS::Matrix::_Alignment;
use TFBS::Ext::pwmsearch;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
#################################################################
# PUBLIC METHODS
#################################################################
=head2 new
Title : new
Usage : my $pwm = TFBS::Matrix::PWM->new(%args)
Function: constructor for the TFBS::Matrix::PWM object
Returns : a new TFBS::Matrix::PWM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"PWM");
my $self = bless $matrix, ref($class) || $class;
$self->_set_min_max_score();
return $self;
}
=head2 search_seq
Title : search_seq
Usage : my $siteset = $pwm->search_seq(%args)
Function: scans a nucleotide sequence with the pattern represented
by the PWM
Returns : a TFBS::SiteSet object
Args : # you must specify either one of the following three:
-file, # the name od a fasta file (single sequence)
#or
-seqobj # a Bio::Seq object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-seqstring # a string containing the sequence
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
-subpart # subpart of the sequence to search, given as
# -subpart => { start => 140,
# end => 180 }
# where start and end are coordinates in the
# sequence; the coordinate range is interpreted
# in the BioPerl tradition (1-based, inclusive)
# OPTIONAL: by default searches entire alignment
=cut
sub search_seq {
my ($self, %args) = @_;
$self->_search(%args);
}
=head2 search_aln
Title : search_aln
Usage : my $site_pair_set = $pwm->search_aln(%args)
Function: Scans a pairwise alignment of nucleotide sequences
with the pattern represented by the PWM: it reports only
those hits that are present in equivalent positions of both
sequences and exceed a specified threshold score in both, AND
are found in regions of the alignment above the specified
conservation cutoff value.
Returns : a TFBS::SitePairSet object
Args : # you must specify either one of the following three:
-file, # the name of the alignment file in Clustal
format
#or
-alignobj # a Bio::SimpleAlign object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-alignstring # a multi-line string containing the alignment
# in clustal format
#############
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
-window, # size of the sliding window (inn nucleotides)
# for calculating local conservation in the
# alignment
# OPTIONAL: default 50
-cutoff # conservation cutoff (%) for including the
# region in the results of the pattern search
# OPTIONAL: default "70%"
-subpart # subpart of the alignment to search, given as e.g.
# -subpart => { relative_to => 1,
# start => 140,
# end => 180 }
# where start and end are coordinates in the
# sequence indicated by relative_to (1 for the
# 1st sequence in the alignment, 2 for the 2nd)
# OPTIONAL: by default searches entire alignment
-conservation
# conservation profile, a TFBS::ConservationProfile
# OPTIONAL: by default the conservation profile is
# computed internally on the fly (less efficient)
=cut
sub search_aln {
my ($self, %args) = @_;
unless ($args{-alignstring} or $args{-alignobj} or $args{-file}) {
$self->throw
("No alignment file, string or object passed to search_aln.");
}
$args{-pattern_set} = $self;
my $aln = ($args{-alignment_setup} or TFBS::Matrix::_Alignment->new(%args));
$aln->do_sitesearch(%args);
return $aln->site_pair_set;
}
sub max_score {
$_[0]->{max_score};
}
sub min_score {
$_[0]->{min_score};
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
#################################################################
# PRIVATE METHODS
#################################################################
sub _set_min_max_score {
my ($self) = @_;
my $transpose = $self->pdl_matrix->xchg(0,1);
$self->{min_score} = sum(minimum $transpose);
$self->{max_score} = sum(maximum $transpose);
}
sub _search {
# this method runs the pwmsearch C extension and parses the data
# similarly to _csearch, which will eventually be discontinued
my ($self, %args) = @_;
my $seqobj = $self->_to_seqobj(%args);
my ($subseq_start, $subseq_end) = (1,$seqobj->length);
if(my $subpart = $args{-subpart}) {
$subseq_start = $subpart->{-start};
$subseq_end = $subpart->{-end};
unless($subseq_start and $subseq_end) {
$self->throw("Option -subpart missing suboption -start or -end");
}
}
return TFBS::Ext::pwmsearch::pwmsearch($self, $seqobj,
($args{-threshold} or 0),
$subseq_start, $subseq_end);
}
sub _csearch {
# this is a wrapper around Wyeth Wasserman's's pwm_searchPFF program
# until we do a proper extension
my ($self) = shift; #the rest of @_ goes to _to_seqob;
my %args = @_;
my $PWM_SEARCH = $args{'-binary'}
|| "pwm_searchPFF";
# dump the sequence into a tempfile
my $seqobj = $self->_to_seqobj(@_);
my ($fastaFH, $fastafile);
if (defined $seqobj->{_fastaFH} and defined $seqobj->{_fastafile}) {
($fastaFH, $fastafile) = ($seqobj->{_fastaFH}, $seqobj->{_fastafile});
}
else {
($fastaFH, $fastafile) = tmpnam();
my $seqFH = Bio::SeqIO->newFh(-fh =>$fastaFH, -format=>"Fasta");
print $seqFH $seqobj;
}
# we need $fastafile below
# calculate threshold
my $threshold;
if ($args{-threshold}) {
if ($args{-threshold} =~ /(.+)%/) {
# percentage
$threshold = $self->{min_score} +
($self->{max_score} - $self->{min_score})* $1/100;
}
else {
# absolute value
$threshold = $args{-threshold};
}
}
else {
# no threshold given
$threshold = $self->{min_score} -1;
}
# convert piddle to text (there MUST be a better way)
my $pwmstring = sprintf ( $self->pdl_matrix );
$pwmstring =~ s/\[|\]//g; # lose []
$pwmstring =~ s/\n /\n/g; # lose leading spaces
my @pwmlines = split("\n", $pwmstring); # f
$pwmstring = join ("\n", @pwmlines[2..5])."\n";
# dump pwm into a tempfile
my ($pwmFH, $pwmfile) = tmpnam(); # we need $pwmfile below
print $pwmFH $pwmstring;
close $pwmFH;
# run pwmsearch
my $hitlist = TFBS::SiteSet->new();
my ($TFname, $TFclass) = ($self->{name}, $self->{class});
my @search_result_lines =
`$PWM_SEARCH $pwmfile $fastafile $threshold -n $TFname -c $TFclass`;
foreach (@search_result_lines) {
chomp;
my ($seq_id, $factor, $class, $strand, $score, $pos, $siteseq) =
(split)[0, 2, 3, 4, 5, 7, 9];
my $correct_strand = ($strand eq "+")? "-1" : "1";
my $site = TFBS::Site->new ( -seq_id => $seqobj->display_id()."",
-seqobj => $seqobj,
-strand => $correct_strand."",
-pattern => $self,
-siteseq => $siteseq."",
-score => $score."",
-start => $pos,
-end => $pos + length($siteseq) -1
);
$hitlist->add_site($site);
}
# cleanup
unlink $fastafile unless $seqobj->{_fastafile};
unlink $pwmfile;
return $hitlist;
}
sub _bsearch {
# this is Perl/PDL only search routine. For experimental purposes only
my ($self,%args) = @_; #the rest of @_ goes to _to_seqob;
my @PWMs;
# prepare the sequence
my $seqobj = $self->_to_seqobj(%args);
my $seqmatrix = (defined $seqobj->{_pdl_matrix})
? $seqobj->{_pdl_matrix}
: _seq_to_pdlmatrix($seqobj);
# calculate threshold
my $threshold;
if ($args{-threshold}) {
if ($args{-threshold} =~ /(.+)%/) {
# percentage
$threshold = $self->{min_score} +
($self->{max_score} - $self->{min_score})* $1/100;
}
else {
# absolute value
$threshold = $args{-threshold};
}
}
else {
# no threshold given
$threshold = $self->{min_score} -1;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm ($self, $self->revcom()) {
my $TFlength = $pwm->pdl_matrix->getdim(0);
my $position_score_pdl = zeroes($seqmatrix->getdim(0) - $TFlength + 1);
my $position_index_pdl = sequence($seqmatrix->getdim(0) - $TFlength + 1)+1;
foreach my $i (0..($TFlength-1)) {
my $columnproduct = $seqmatrix * $pwm->pdl_matrix->slice("$i,:");
$position_score_pdl +=
$columnproduct->xchg(0,1)->sumover->slice($i.":".($i-$TFlength));
}
my @hitpositions =
list $position_index_pdl->where($position_score_pdl >= $threshold);
my @hitscores =
list $position_score_pdl->where($position_score_pdl >= $threshold);
for my $i(0..$#hitpositions) {
my($pos,$score) = ($hitpositions[$i], $hitscores[$i]);
my $siteseq = scalar($seqobj->subseq($pos, $pos+$TFlength-1));
my $site = TFBS::Site->new ( -seq_id => $seqobj->display_id(),
-seqobj => $seqobj,
-strand => $pwm->{strand},
-Matrix => $pwm,
-siteseq => $siteseq,
-score => $score,
-start => $pos);
$hitlist->add_site($site);
}
}
return $hitlist;
}
sub _to_seqobj {
my ($self, %args) = @_;
my $seq;
if ($args{-file}) { # not a Bio::Seq
return Bio::SeqIO->new(-file => $args{-file},
-format => 'fasta',
-moltype => 'dna')->next_seq();
}
elsif ($args{-seqstring}
or $args{-seq})
{ # I guess it's a string then
return Bio::Seq->new(-seq => ($args{-seqstring} or $args{-seq}),
-id => ($args{-seq_id} or "undefined"),
-moltype => 'dna');
}
elsif ($args{'-seqobj'} and ref($args{'-seqobj'}) and $args{'-seqobj'}->can("seq")) {
# do nothing (maybe check later)
return $args{'-seqobj'};
}
#elsif (ref($format) =~ /Bio\:\:Seq/ and !defined $seq) {
# if only one parameter passed and it's a Bio::Seq
#return $format;
#}
else {
$self->throw ("Wrong parametes passed to search method: ".%args);
}
}
sub _seq_to_pdlmatrix {
# called from ?search
# not OO - help function for search
my $seqobj = shift;
my $seqstring = uc($seqobj->seq());
my @perlarray;
foreach (qw(A C G T)) {
my $seqtobits = $seqstring;
eval "\$seqtobits =~ tr/$_/1/"; # curr. letter $_ to 1
eval "\$seqtobits =~ tr/1/0/c"; # non-1s to 0
push @perlarray, [split("", $seqtobits)];
}
return byte (\@perlarray);
}
sub DESTROY {
# nothing
}
1;
TFBS-0.7.1/TFBS/Matrix/.svn/text-base/_Alignment.pm.svn-base 0000775 0000000 0000000 00000027373 13057522667 0023223 0 ustar 00root root 0000000 0000000 package TFBS::Matrix::_Alignment;
use vars qw(@ISA $AUTOLOAD);
use TFBS::SitePair;
use TFBS::SitePairSet;
use Bio::Root::Root;
use Bio::Seq;
use Bio::SimpleAlign;
use Bio::AlignIO;
use IO::String;
use PDL;
use strict;
@ISA =('Bio::Root::Root');
# CONSTANTS
use constant DEFAULT_WINDOW => 50;
use constant DEFAULT_CUTOFF => 70;
use constant DEFAULT_THRESHOLD => "80%";
sub new {
# this is ugly; OK, OK, I'll rewrite it as soon as I can
my ($caller, %args) = @_;
my $self = bless {}, ref $caller || $caller;
$self->window($args{-window} or DEFAULT_WINDOW);
$self->_parse_alignment(%args);
$self->seq1length(length(_strip_gaps($self->alignseq1())));
$self->seq2length(length(_strip_gaps($self->alignseq2())));
$self->_set_subpart_bounds($args{-subpart});
#
# If a conservation profile is provided, no need to compute it again.
# NOTE: conservation2 never seems to be used anywhere else so don't worry
# about the fact we are ignoring it if conservation is passed in :)
#
my $cp = $args{-conservation};
if ($cp) {
$self->conservation1([$cp->conservation()]);
} else {
$self->conservation1($self->_calculate_conservation($self->window(),1));
$self->conservation2($self->_calculate_conservation($self->window(),2));
}
$self->cutoff($args{-cutoff} or DEFAULT_CUTOFF);
#$self->threshold($args{-threshold} or DEFAULT_THRESHOLD);
#$self->_do_sitesearch
#(($args{-pattern_set} or $self->throw("No -matrixset parameter")),
# ($args{-threshold} or DEFAULT_THRESHOLD),
# ());
# $self->_set_start_end(%args); # Maybe later...
return $self;
}
sub DESTROY {
# empty
}
sub _parse_alignment {
my ($self, %args) = @_;
my ($seq1, $seq2, $start);
my $alignobj;
if (defined $args{'-alignstring'}) {
$alignobj = _alignstring_to_alignobj($args{'-alignstring'});
}
elsif (defined $args{'-file'}) {
$alignobj = _alignfile_to_alignobj($args{'-file'});
}
elsif (defined $args{-alignobj}) {
$alignobj = $args{'-alignobj'};
}
else {
$self->throw("No -alignstring, -file or -alignobj passed.");
}
my @match;
my ($seqobj1, $seqobj2) = $alignobj->each_seq;
($seq1, $seq2) = ($seqobj1->seq, $seqobj2->seq);
$start = 1;
$self->seq1name($seqobj1->display_id);
$self->seq2name($seqobj2->display_id);
$self->alignseq1($seq1);
$self->alignseq2($seq2);
my @seq1 = ("-", split('', $seq1) );
my @seq2 = ("-", split('', $seq2) );
$self->{alignseq1array} = [@seq1];
$self->{alignseq2array} = [@seq2];
my (@seq1index, @seq2index);
my ($i1, $i2) = (0, 0);
for my $pos (0..$#seq1) {
my ($s1, $s2) = (0, 0);
$seq1[$pos] ne "-" and $s1 = ++$i1;
$seq2[$pos] ne "-" and $s2 = ++$i2;
push @seq1index, $s1;
push @seq2index, $s2;
}
$self->pdlindex( pdl [ [list sequence($#seq1+1)],
[@seq1index],
[@seq2index],
[list zeroes ($#seq1+1)] ]) ;
return 1;
}
sub pdlindex {
my ($self, $input, $p1, $p2) = @_ ;
# print ("PARAMS ", join(":", @_), "\n");
if (ref($input) eq "PDL") {
$self->{pdlindex} = $input;
}
unless (defined $p2) {
return $self->{pdlindex};
}
else {
my @results = list
$self->{pdlindex}->xchg(0,1)->slice($p2)->where
($self->{pdlindex}->xchg(0,1)->slice($p1)==$input);
wantarray ? return @results : return $results[0];
}
}
sub lower_pdlindex {
my ($self, $input, $p1, $p2) = @_;
unless (defined $p2) {
$self->throw("Wrong number of parameters passed to lower_pdlindex");
}
my $result;
my $i = $input;
until ($result = $self->pdlindex($i, $p1 => $p2)) {
$i--;
last if $i==0;
}
return $result or 1;
}
sub higher_pdlindex {
my ($self, $input, $p1, $p2) = @_;
unless (defined $p2) {
$self->throw("Wrong number of parameters passed to lower_pdlindex");
}
my $result;
my $i = $input;
until ($result = $self->pdlindex($i, $p1 => $p2)) {
$i++;
last unless ($self->pdlindex($i, $p1=>0) > 0);
}
return $result;
}
sub _calculate_conservation {
my ($self, $WINDOW, $which) = @_;
my (@seq1, @seq2);
if ($which==2) {
@seq1 = @{$self->{alignseq2array}};
@seq2 = @{$self->{alignseq1array}};
}
else {
@seq1 = @{$self->{alignseq1array}};
@seq2 = @{$self->{alignseq2array}};
$which=1;
}
my @CONSERVATION;
my @match;
while ($seq1[0] eq "-") {
shift @seq1;
shift @seq2;
}
for my $i (0..$#seq1) {
push (@match,( uc($seq1[$i]) eq uc($seq2[$i]) ? 1:0))
unless ($seq1[$i] eq "-" or $seq1[$i] eq ".");
}
my @graph=($match[0]);
for my $i (1..($#match+$WINDOW/2)) {
$graph[$i] = ($graph[$i-1] or 0)
+ ($i>$#match ? 0: $match[$i])
- ($i<$WINDOW ? 0: $match[$i-$WINDOW]);
}
# at this point, the graph values are shifted $WINDOW/2 to the right
# i.e. the score at a certain position is the score of the window
# UPSTREAM of it: To fix it, we shoud discard the first $WINDOW/2 scores:
#$self->conservation1 ([]);
foreach my $pos (@graph[int($WINDOW/2)..$#graph]) {
push @CONSERVATION, 100*$pos/$WINDOW;
}
# correction
foreach my $pos (0..int($WINDOW/2)) {
$CONSERVATION[$pos] =
$CONSERVATION[$pos]*$WINDOW/(int($WINDOW/2)+$pos);
$CONSERVATION[$#CONSERVATION - $pos] =
$CONSERVATION[$#CONSERVATION - $pos]*$WINDOW/(int($WINDOW/2)+$pos);
}
return [@CONSERVATION];
}
sub _strip_gaps {
# a utility function
my $seq = shift;
$seq =~ s/\-|\.//g;
return $seq;
}
sub do_sitesearch {
my ($self, @args ) = @_;
my ($MATRIXSET, $THRESHOLD, $CUTOFF) =
$self->_rearrange([qw(PATTERN_SET THRESHOLD CUTOFF)], @args);
if (!$MATRIXSET) {
$self->throw("No -pattern_set passed to do_sitesearch");
}
$CUTOFF = ($CUTOFF or DEFAULT_CUTOFF);
$THRESHOLD = ($THRESHOLD or DEFAULT_THRESHOLD);
$self->site_pair_set(TFBS::SitePairSet->new());
return if(($self->subpart1 and $self->subpart1->{-start} == 0) or
($self->subpart2 and $self->subpart2->{-start} == 0));
# ^^^ If one of the subparts is a gap, there's no point in searching
my $seqobj1 = Bio::Seq->new(-seq=>_strip_gaps($self->alignseq1()),
-id => "Seq1");
my $siteset1 =
$MATRIXSET->search_seq(-seqobj => $seqobj1,
-threshold => $THRESHOLD,
-subpart => $self->subpart1);
my $siteset1_itr = $siteset1->Iterator(-sort_by => "start");
my $seqobj2 = Bio::Seq->new(-seq=>_strip_gaps($self->alignseq2()),
-id => "Seq2");
my $siteset2 =
$MATRIXSET->search_seq(-seqobj => $seqobj2,
-threshold => $THRESHOLD,
-subpart => $self->subpart2);
my $siteset2_itr = $siteset2->Iterator(-sort_by => "start");
my $site1 = $siteset1_itr->next();
my $site2 = $siteset2_itr->next();
while (defined $site1 and defined $site2) {
my $pos1_in_aln = $self->pdlindex($site1->start(), 1=>0);
my $pos2_in_aln = $self->pdlindex($site2->start(), 2=>0);
my $cmp = (($pos1_in_aln <=> $pos2_in_aln)
or ($site1->pattern->name() cmp $site2->pattern->name())
or ($site1->strand() cmp $site2->strand()));
if ($cmp==0) { ### match
if (# threshold test:
$self->conservation1->[$site1->start()]
>=
$self->cutoff()
)
{
my $site_pair = TFBS::SitePair->new($site1, $site2);
$self->site_pair_set->add_site_pair($site_pair);
}
$site1 = $siteset1_itr->next();
$site2 = $siteset2_itr->next();
}
elsif ($cmp<0) { ### $siteset1 is behind
$site1 = $siteset1_itr->next();
}
elsif ($cmp>0) { ### $siteset2 is behind
$site2 = $siteset2_itr->next();
}
}
}
sub _set_subpart_bounds {
my ($self, $subpart) = @_;
if(defined $subpart) {
my ($relative_to, $start, $end) = ($subpart->{-relative_to},
$subpart->{-start},
$subpart->{-end});
unless(defined($relative_to) and defined($start) and defined($end) ) {
$self->throw("Option -subpart missing suboption -relative_to, -start or -end");
}
if($relative_to == 1) {
my $other_start = $self->higher_pdlindex($start, 1 => 2);
my $other_end = $self->lower_pdlindex($end, 1 => 2);
($other_start, $other_end) = (0,0) if($other_start > $other_end);
$self->subpart1({ -start => $start, -end => $end });
$self->subpart2({ -start => $other_start, -end => $other_end });
}
elsif($relative_to == 2) {
my $other_start = $self->higher_pdlindex($start, 2 => 1);
my $other_end = $self->lower_pdlindex($end, 2 => 1);
($other_start, $other_end) = (0,0) if($other_start > $other_end);
$self->subpart1({ -start => $other_start, -end => $other_end });
$self->subpart2({ -start => $start, -end => $end });
}
else {
$self->throw("Suboption -relative_to should be 1 or 2");
}
}
}
sub _calculate_cutoff {
my ($self) = @_;
my $ile = 0.9;
my @conservation_array = sort {$a <=> $b} @{$self->conservation1()};
my $perc_90 = $conservation_array[int($ile*scalar(@conservation_array))];
return $perc_90;
}
sub _alignfile_to_string {
# a utility function
# DEPRECATED !!!
my $alignfile = shift;
if ($alignfile =~ /\.msf$/i) {
my $alignobj = Bio::SimpleAlign->new();
$alignobj->read_MSF($alignfile);
return _alignobj_to_string($alignobj);
}
else { #assumed clustalw - no AlignIO import yet
local $/ = undef;
open FILE, $alignfile
or die("Could not read alignfile $alignfile, stopped");
my $alignstring = ;
return $alignstring;
}
}
sub _alignfile_to_alignobj {
# a utility function
my ($alignfile, $format) = (@_,'clustalw');
if (!$format and $alignfile =~ /\.msf$/i) { $format = 'msf' ;}
my $alnio = Bio::AlignIO->new(-file=>$alignfile, -format=>$format);
return $alnio->next_aln;
}
sub _alignobj_to_string {
# a utility function
# DEPRECATED
my $alignobj = shift;
my $alignstring;
my $io = IO::String->new($alignstring);
my $alnio = Bio::AlignIO->new(-fh=>$io, -format=>"clustalw");
$alnio->write_aln($alignobj);
$alnio->close();
# $io->close;
return $alignstring;
}
sub _alignstring_to_alignobj {
# a utility function
my ($alignstring, $format) = (@_, 'clustalw');
my $io = IO::String->new($alignstring);
my $alnio = Bio::AlignIO->new(-fh=>$io, -format=>$format);
my $alignobj = $alnio->next_aln();
$alnio->close();
# $io->close;
return $alignstring;
}
# uglier than AUTOLOAD, but faster - a quick fix to get rid of Class::MethodMaker
sub cutoff
{ $_[0]->{'cutoff'} = $_[1] if exists $_[1]; $_[0]->{'cutoff'}; }
sub window
{ $_[0]->{'window '} = $_[1] if exists $_[1]; $_[0]->{'window '}; }
sub alignseq1
{ $_[0]->{'alignseq1'} = $_[1] if exists $_[1]; $_[0]->{'alignseq1'}; }
sub alignseq2
{ $_[0]->{'alignseq2'} = $_[1] if exists $_[1]; $_[0]->{'alignseq2'}; }
sub site_pair_set
{ $_[0]->{'site_pair_set'} = $_[1] if exists $_[1]; $_[0]->{'site_pair_set'};}
sub seq1name
{ $_[0]->{'seq1name'} = $_[1] if exists $_[1]; $_[0]->{'seq1name'}; }
sub seq2name
{ $_[0]->{'seq2name'} = $_[1] if exists $_[1]; $_[0]->{'seq2name'}; }
sub seq1length
{ $_[0]->{'seq1length'} = $_[1] if exists $_[1]; $_[0]->{'seq1length'}; }
sub seq2length
{ $_[0]->{'seq2length'} = $_[1] if exists $_[1]; $_[0]->{'seq2length'}; }
sub subpart1
{ $_[0]->{'subpart1'} = $_[1] if exists $_[1]; $_[0]->{'subpart1'}; }
sub subpart2
{ $_[0]->{'subpart2'} = $_[1] if exists $_[1]; $_[0]->{'subpart2'}; }
sub conservation1
{ $_[0]->{'conservation1'} = $_[1] if exists $_[1]; $_[0]->{'conservation1'};}
sub conservation2
{ $_[0]->{'conservation2'} = $_[1] if exists $_[1]; $_[0]->{'conservation2'};}
sub exclude_orf
{ $_[0]->{'exclude_orf'} = $_[1] if exists $_[1]; $_[0]->{'exclude_orf'}; }
sub start_at
{ $_[0]->{'start_at'} = $_[1] if exists $_[1]; $_[0]->{'start_at'}; }
sub end_at
{ $_[0]->{'end_at'} = $_[1] if exists $_[1]; $_[0]->{'end_at'}; }
1;
TFBS-0.7.1/TFBS/Matrix/Alignment.pm 0000775 0000000 0000000 00000016151 13057522667 0016557 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::ICM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::Alignment - class for alignment of PFM objects
=head1 SYNOPSIS
=over 1
=item * Making an alignment:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and retrieve
TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pfm1 = $db_obj->get_Matrix_by_ID("M0001", "PFM");
my $pfm2 = $db_obj->get_Matrix_by_ID("M0002", "PFM");
my $alignment= new TFBS::Matrix::Alignment(
-pfm1=>$pfm1,
-pfm2=>$pfm2,
-binary=>"/TFBS/Ext/matrix_aligner",
);
=head1 DESCRIPTION
TFBS::Matrix::Alignment is a class for representing and performing
pairwise alignments of profiles (in the form of TFBS::PFM objects)
Alignments are preformed using a semi-global variant of the
Needleman-Wunsch algorithm that only permits the opening of one internal gap.
Fore reference, the algorithm is described in Sandelin et al
Funct Integr Genomics. 2003 Jun 25
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code starts HERE:
package TFBS::Matrix::Alignment;
use vars '@ISA';
use strict;
use Bio::Root::Root;
use TFBS::Matrix;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
#alignment methods: for making and storing a single matrix-alignments
=head2 new
Title : new
Usage : my $alignment = TFBS::Matrix::Alignment->new(%args)
Function: constructor for the TFBS::Matrix::Alignment object
Returns : a new TFBS::Matrix::Alignment object
Args : # you must specify:
-pfm1, # a TFBS::Matrix::PFM object
-pfm2, # another TFBS::Matrix::PFM object
-binary, # a valid path to the comparison algorithm (matrixalign)
#######
-ext_penalty #OPTIONAL gap extension penalty in Needleman-Wunsch
algorithmstring. Default 0.01
-open_penalty, #OPTIONAL gap opening penalty in Needleman-Wunsch
algorithmstring. Default 3.0
=cut
sub new {
#defines and createa an alignment
# args: two pfm objects
# binary file
#optional scoring penalites
my ($class, %args) = @_;
my $self={
_pfm1=> $args{'-pfm1'},
_pfm2=> $args{'-pfm2'},
_ext_penalty=>$args{'-ext_penalty'}|| 0.01,
_open_penalty=> $args{'-open_penalty'}|| 3.00,
_strand=>'',
_align_string=>'',
_gaps=>'',
_aligned_positions =>'',
_score=>'',
};
bless $self, "TFBS::Matrix::Alignment";
# errorcheck:
# save temp files
my($fh1, $file1) = tmpnam();
print $fh1 $args{'-pfm1'}->rawprint()|| die " Cannot save temporary files for alignment";
my($fh2, $file2) = tmpnam();
print $fh2 $args{'-pfm2'}->rawprint()|| die " Cannot save temporary files for alignment";
#align
my @pfm1_string;
my @pfm2_string;
foreach (`$args{'-binary'} $file1 $file2 $self->{'_open_penalty'} $self->{'_ext_penalty'}`){
# my @pfm2_string;
my $max_length=$self->{'_pfm1'}->length();
$max_length=$self->{'_pfm2'}->length() if ( $self->{'_pfm2'}->length() > $self->{'_pfm1'}->length());
if (/^PFM1/){
s/PFM1//;
s/\t0/\t-/g;
@pfm1_string= split();
next;
}
if (/^PFM2/){
s/PFM2//;
s/\t0/\t-/g;
@pfm2_string= split();
next;
}
if (/^INFO/){
my @temp=split;
($self->{'_score'}, $self->{'_strand'}, $self->{'_aligned_positions'}, $self->{'_gaps'})= ($temp[3], $temp[6], $temp[7],$temp[8]);
next;
}
}
my $string= ($self->{'_pfm1'}->name()||$self->{'_pfm1'}->ID()||'PFM1')."\t\t";
my $string2=($self->{'_pfm2'}->name()||$self->{'_pfm2'}->ID()||'PFM2')."\t\t";;
if ($pfm1_string[0]==1){
$string.="-\t" x ($pfm2_string[0]-1);
foreach (my $j=1; $j< $pfm2_string[0]; $j++){
$string2.="$j\t";
}
}
if ($pfm2_string[0]==1){
$string2.="-\t" x ($pfm1_string[0]-1);
for (my $j=1; $j< $pfm1_string[0]; $j++){
$string.="$j\t";
}
}
$string.= join("\t", @pfm1_string);
$string2.= join("\t", @pfm2_string);
if ($pfm1_string[-1]==$self->{'_pfm1'}->length()){
$string.="\t-" x ($self->{'_pfm2'}->length()-$pfm2_string[-1]);
for (my $j=$pfm2_string[-1]+1; $j<= $self->{'_pfm2'}->length(); $j++){
$string2.="\t$j";
}
}
if ($pfm2_string[-1]==$self->{'_pfm2'}->length()){
$string2.="\t-" x ($self->{'_pfm1'}->length()-$pfm1_string[-1]);
for (my $j=$pfm1_string[-1]+1; $j<= $self->{'_pfm1'}->length(); $j++){
$string.="\t$j";
}
}
$self->{'_align_string'}= $string ."\n". $string2;
unlink $file2;
unlink $file1;
return $self;
}
# access functions
=head2 score
Title : score
Usage : my $score = $alignmentobject->score();
Function: access an alignment score (where each aligned position can contribute max 2)
Returns : a floating point number
Args : none
=cut
=head2 score
Title : gaps
Usage : my $nr_of_gaps = $alignmentobject->gaps();
Function: access the number of gaps in an alignment
Returns : an integer
Args : none
=cut
=head2 length
Title : length
Usage : my $length = $alignmentobject->length();
Function: access the length of an alignment (ie thenumber of aligned positions)
Returns : an integer
Args : none
=cut
=head2 strand
Title : strand
Usage : my $strand = $alignmentobject->strand();
Function: access the oriantation of the aligned patterns:
++= oriented as input
+-= second pattern is reverse-complemented
Returns : a string
Args : none
=cut
=head2 alignment
Title : alignment
Usage : my $alignment_string = $alignmentobject->alignment();
Function: access a string describing the alignment
Returns : an string, where each number refers to a position in respective PFM.
Position numbering is according to orientation: ie if the second profile is
reversed, position 1 corresponds to the last position in the input profile.
Gaps are denoted as - .
RXR-VDR - 1 2 3 - 4 5 -
PPARgamma-RXRal 1 2 3 4 5 6 7 8
Args : none
=cut
sub gaps{ return $_[0]->{'_gaps'};}
sub score{ return $_[0]->{'_score'};}
sub length{ return $_[0]->{'_aligned_positions'};}
sub strand{ return $_[0]->{'_strand'};}
sub alignment{ return $_[0]->{'_align_string'};}
1
TFBS-0.7.1/TFBS/Matrix/ICM.pm 0000775 0000000 0000000 00000077372 13057522667 0015265 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::ICM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::ICM - class for information content matrices of nucleotide
patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::ICM object manually:
my $matrixref = [ [ 0.00, 0.30, 0.00, 0.00, 0.24, 0.00 ],
[ 0.00, 0.00, 0.00, 1.45, 0.42, 0.00 ],
[ 0.00, 0.89, 2.00, 0.00, 0.00, 0.00 ],
[ 0.00, 0.00, 0.00, 0.13, 0.06, 2.00 ]
];
my $icm = TFBS::Matrix::ICM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring = <new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::ICM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and retrieve
TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pfm = $db_obj->get_Matrix_by_ID("M0001", "ICM");
# or
my $pfm = $db_obj->get_Matrix_by_name("MyProfile", "ICM");
=item * retrieving list of individual TFBS::Matrix::ICM objects
from a TFBS::MatrixSet object
(see decumentation of TFBS::MatrixSet to learn how to create
objects for storage and manipulation of multiple matrices)
my @icm_list = $matrixset->all_patterns(-sort_by=>"name");
* drawing a sequence logo
$icm->draw_logo(-file=>"logo.png",
-full_scale =>2.25,
-xsize=>500,
-ysize =>250,
-graph_title=>"C/EBPalpha binding site logo",
-x_title=>"position",
-y_title=>"bits");
=back
=head1 DESCRIPTION
TFBS::Matrix::ICM is a class whose instances are objects representing
position weight matrices (PFMs). An ICM is normally calculated from a
raw position frequency matrix (see L
for the explanation of position frequency matrices). For example, given
the following position frequency matrix,
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
the standard computational procedure is applied to convert it into the
following information content matrix:
A:[2.00 0.30 0.00 0.00 0.24 0.00]
C:[0.00 0.00 0.00 1.45 0.42 0.00]
G:[0.00 0.89 2.00 0.00 0.00 0.00]
T:[0.00 0.00 0.00 0.13 0.06 2.00]
which contains the "weights" associated with the occurrence of each
nucleotide at the given position in a pattern.
A TFBS::Matrix::PWM object is equipped with methods to search nucleotide
sequences and pairwise alignments of nucleotide sequences with the
pattern they represent, and return a set of sites in nucleotide
sequence (a TFBS::SiteSet object for single sequence search, and a
TFBS::SitePairSet for the alignment search).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code starts HERE:
package TFBS::Matrix::ICM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::SeqIO;
use TFBS::Matrix;
BEGIN {
# this will not fail if the modules are nit available
# but only if the user tries to actually draw a logo
eval "use SVG";
eval "use GD";
};
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
#################################################################
# PUBLIC METHODS
#################################################################
=head2 new
Title : new
Usage : my $icm = TFBS::Matrix::ICM->new(%args)
Function: constructor for the TFBS::Matrix::ICM object
Returns : a new TFBS::Matrix::ICM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"ICM");
my $self = bless $matrix, ref($class) || $class;
$self->_check_ic_validity();
return $self;
}
=head2 to_PWM
Title : to_PWM
Usage : my $pwm = $icm->to_PWM()
Function: converts an information content matrix (a TFBS::Matrix::ICM object)
to position weight matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::PWM object
Args : none; in the future releases, it should be able to accept
a user defined background probability of the four
nucleotides
=cut
sub to_PWM {
my ($self) = @_;
$self->throw ("Method to_PWM not yet implemented.");
}
=head2 draw_logo
Title : draw_logo
Usage : my $gdImageObj = $icm->draw_logo(%args)
Function: Draws a "sequence logo", a graphical representation
of a possibly degenerate fixed-width nucleotide
sequence pattern, from the information content matrix
Returns : a GD::Image object;
if you only need the image file you can ignore it
Args : -file, # the name of the output PNG image file
# OPTIONAL: default none
-xsize # width of the image in pixels
# OPTIONAL: default 600
-ysize # height of the image in pixels
# OPTIONAL: default 5/8 of -x_size
-startpos # start position in the logo for x axis
# OPTIONAL: default is 1
-margin # size of image margins in pixels
# OPTIONAL: default 15% of -y_size
-full_scale # the maximum value on the y-axis, in bits
# OPTIONAL: default 2.25
-graph_title,# the graph title
# OPTIONAL: default none
-x_title, # x-axis title; OPTIONAL: default none
-y_title # y-axis title; OPTIONAL: default none
-error_bars # reference to an array of S.D. values for each column; OPTIONAL
-ps # if true, produces a postscript string instead of a GD::Image object
-pdf # if true AND the -file argumant is used, produces an output pdf file
=cut
sub draw_logo {
no strict;
my $self = shift;
my %args = (-xsize => 600,
-full_scale => 2.25,
-graph_title=> "",
-x_title => "",
-y_title => "",
-startpos => 1,
@_);
# Other parameters that can be specified:
# -ysize -line_width -margin
# do not have a fixed default value
# - they are calculated from xsize if not specified
# draw postscript logo if asked for
if ($args{'-ps'} || $args{'-pdf'}){
return _draw_ps_logo($self, %args);
}
if ($args{'-svg'} || $args{'-SVG'}){
return _draw_svg_logo($self, %args);
}
my ($xsize,$FULL_SCALE, $x_title, $y_title)
= @args{qw(-xsize -full_scale -x_title y_title)} ;
my $PER_PIXEL_LINE = 300;
# calculate other parameters if not specified
my $line_width = ($args{-line_width} or int ($xsize/$PER_PIXEL_LINE) or 1);
my $ysize = ($args{-ysize} or $xsize/1.6);
# remark (the line above): 1.6 is a standard screen x:y ratio
my $margin = ($args{-margin} or $ysize*0.15);
my $image = GD::Image->new($xsize, $ysize);
my $white = $image->colorAllocate(255,255,255);
my $black = $image->colorAllocate(0,0,0);
my $motif_size = $self->pdl_matrix->getdim(0);
my $font = ((&GD::gdTinyFont(), &GD::gdSmallFont(), &GD::gdMediumBoldFont(),
&GD::gdLargeFont(), &GD::gdGiantFont())[int(($ysize-50)/100)]
or &GD::gdGiantFont());
my $title_font = ((&GD::gdSmallFont(), &GD::gdMediumBoldFont(),
&GD::gdLargeFont(), &GD::gdGiantFont())[int(($ysize-50)/100)]
or &GD::gdGiantFont());
# WRITE LABELS AND TITLE
# graph title #&GD::Font::MediumBold
$image->string($title_font,
$xsize/2-length($args{-graph_title})* $title_font->width() /2,
$margin/2 - $title_font->height()/2,
$args{-graph_title}, $black);
# x_title
$image->string($font,
$xsize/2-length($args{-x_title})*$font->width()/2,
$ysize-( $margin - $font->height()*0 - 5*$line_width)/2
- $font->height()/2*0,
$args{-x_title},
$black);
# y_title
$image->stringUp($font,
($margin -$font->width()- 5*$line_width)/2
- $font->height()/2 ,
$ysize/2+length($args{'-y_title'})*$font->width()/2,
$args{'-y_title'}, $black);
# DRAW AXES
# vertical: (top left to bottom right)
$image->filledRectangle($margin-$line_width, $margin-$line_width,
$margin-1, $ysize-$margin+$line_width,
$black);
# horizontal: (ditto)
$image->filledRectangle($margin-$line_width, $ysize-$margin+1,
$xsize-$margin+$line_width,$ysize-$margin+$line_width,
$black);
# DRAW VERTICAL TICKS AND LABELS
# vertical axis (IC 1 and 2)
my $ic_1 = ($ysize - 2* $margin) / $FULL_SCALE;
foreach my $i (1..$FULL_SCALE) {
$image->filledRectangle($margin-3*$line_width,
$ysize-$margin - $i*$ic_1,
$margin-1,
$ysize-$margin+$line_width - $i*$ic_1,
$black);
$image->string($font,
$margin-5*$line_width - $font->width,
$ysize - $margin - $i*$ic_1 - $font->height()/2,
$i,
$black);
}
# DRAW HORIZONTAL TICKS AND LABELS, AND THE LOGO ITSELF
# define function refs as hash elements
my %draw_letter = ( A => \&_png_draw_A,
C => \&_png_draw_C,
G => \&_png_draw_G,
T => \&_png_draw_T );
my $horiz_step = ($xsize -2*$margin) / $motif_size;
#this is to avoid clutter on X axis:
my $longest_label_length = length("$motif_size");
if (length ($args{-startpos}) > $longest_label_length) {
$longest_label_length = length ($args{-startpos});
}
if (length ($args{-startpos}+$motif_size) > $longest_label_length) {
$longest_label_length = length ($args{-startpos}+$motif_size);
}
my $draw_every_nth_label = int($longest_label_length*$font->width+2) / $horiz_step + 1;
foreach my $i (0..$motif_size) {
$image->filledRectangle($margin + $i*$horiz_step,
$ysize-$margin+1,
$margin + $i*$horiz_step+ $line_width,
$ysize-$margin+3*$line_width,
$black);
last if $i==$motif_size;
# get the $i-th column of matrix
my %ic;
($ic{A}, $ic{C}, $ic{G}, $ic{T}) = list $self->pdl_matrix->slice($i);
# sort nucleotides by increasing information content
my @draw_order = sort {$ic{$a}<=>$ic{$b}} qw(A C G T);
# draw logo column
my $xlettersize = $horiz_step /1.1;
my $ybottom = $ysize - $margin;
foreach my $base (@draw_order) {
my $ylettersize = int($ic{$base}*$ic_1 +0.5);
next if $ylettersize ==0;
# draw letter
$draw_letter{$base}->($image,
$margin + $i*$horiz_step,
$ybottom - $ylettersize,
$xlettersize, $ylettersize, $white);
$ybottom = $ybottom - $ylettersize-1;
}
if ($args{'-error_bars'} and ref($args{'-error_bars'}) eq "ARRAY") {
my $sd_pix = int($args{'-error_bars'}->[$i]*$ic_1);
my $yt = $ybottom - $sd_pix+1;
my $yb = $ybottom + $sd_pix-1;
my $xpos = $margin + ($i+0.45)*$horiz_step;
my $half_width;
if ($yb > $ysize-$margin+$line_width) {
$yb = $ysize-$margin+$line_width
}
else {
$image->line($xpos - $xlettersize/8, $yb,
$xpos + $xlettersize/8, $yb,
$black);
}
$image->line($xpos, $yt, $xpos, $yb, $black);
$image->line($xpos - 1 , $ybottom, $xpos+1, $ybottom, $black);
$image->line($xpos - $xlettersize/8, $yt,
$xpos + $xlettersize/8, $yt,
$black);
}
# print position number on x axis (The if condition is for avoiding clutter)
my $xlabel = $i+ $args{-startpos};
if ($args{-startpos}<0 and $xlabel>=0) {
$xlabel ++;
}
if ($xlabel % $draw_every_nth_label == 0) {
$image->string($font,
$margin + ($i+0.5)*$horiz_step - $font->width()/2,
$ysize - $margin +5*$line_width,
$xlabel,
$black);
}
}
# print $args{-file};
if ($args{-file}) {
open (PNGFILE, ">".$args{-file})
or $self->throw("Could not write to ".$args{-file});
print PNGFILE $image->png;
close PNGFILE;
}
return $image;
}
sub total_ic {
return $_[0]->pdl_matrix->sum();
}
=head2 _draw_ps_logo
Title : _draw_ps_logo
Usage : my $postscript_string = $icm->_draw_ps_logo(%args)
Internal method, should be accessed using draw_logo()
Function: Draws a "sequence logo", a graphical representation
of a possibly degenerate fixed-width nucleotide
sequence pattern, from the information content matrix
Returns : a postscript string;
if you only need the image file you can ignore it
Args : -file, # the name of the output PNG image file
# OPTIONAL: default none
-xsize # width of the image in pixels
# OPTIONAL: default 600
-ysize # height of the image in pixels
# OPTIONAL: default 5/8 of -x_size
-full_scale # the maximum value on the y-axis, in bits
# OPTIONAL: default 2.25
-graph_title,# the graph title
# OPTIONAL: default none
-x_title, # x-axis title; OPTIONAL: default none
-y_title # y-axis title; OPTIONAL: default none
=cut
sub _draw_ps_logo{
my $self = shift;
my %args = (-xsize => 600,
-full_scale => 2.25,
-graph_title=> "",
-x_title => "",
-y_title => "",
@_);
my $xsize= $args{'-xsize'};
my $max_ysize= $args{'-ysize'} ||int 5* $args{'-xsize'}/8;
my $ysize= $max_ysize*($args{'-full_scale'}-($args{'-full_scale'}-2))/$args{'-full_scale'};
my $x=100; # nternal, for placement on 'paper'
my $y=100;
my $out= "%!PS-Adobe-2.0
%%Orientation: Portrait
%%Pages: 1
%%BoundingBox: 0 0 ".($args{'-xsize'}*1.2)." ".( $max_ysize*1.5)."
%%BeginSetup
%%EndSetup
%%Magnification: 1.0000
%%EndProlog
%%end
%%save
gsave\n";
#colors and correction definitions
my %color;
$color{'black'}="0.000 0.000 0.000 setrgbcolor";
$color{'A'}="0.000 1.000 0.000 setrgbcolor";
$color{'C'}="0.000 0.000 1.000 setrgbcolor";
$color{'G'}="1.000 0.860 0.000 setrgbcolor";
$color{'T'}="1.000 0.000 0.000 setrgbcolor";
my $fontsize= int $ysize*0.68;
my $fontwidth=1.5*($xsize/$self->length());
my %w_correct; # correction of font widths
$w_correct{'A'}=0.95;
$w_correct{'T'}=1.05;
$w_correct{'C'}=0.90;
$w_correct{'G'}=0.90;
my %y_next;#correction of font heights
$y_next{'A'}=1;
$y_next{'T'}=1;
$y_next{'C'}=0.94;
$y_next{'G'}=0.94;
my %y_correct; #correction of font bounding boxes
$y_correct{'A'}=0;
$y_correct{'C'}=0.035*$fontsize;
$y_correct{'G'}=0.035*$fontsize;
$y_correct{'T'}=0;
#define y axis,tickmarks and scaling
my $font= $fontwidth/5;
$out.="newpath\n ". ($x-10)." ". ($y+2*$ysize/4 )." moveto\n". "$x ". ($y+2*$ysize/4 ) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-20). " ".( $y+$ysize/2)." moveto\n";
$out.=" (1) show\n grestore\n" ;
$out.="newpath\n ". ($x-10)." ". ($y+$ysize )." moveto\n". "$x ". ($y+$ysize) ." lineto\n stroke\n";
$out.="newpath\n ". ($x-10)." ". ($y+$max_ysize )." moveto\n". "$x ". ($y+$max_ysize) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-20). " ".( $y+$ysize)." moveto\n";
$out.=" (2) show\n grestore\n" ;
$out.="newpath\n $x $y moveto\n". ($x). " ".($y+$max_ysize) ." lineto\n stroke\n";
$out.="newpath\n $x $y moveto\n". ($x+$xsize). " ".($y) ." lineto\n stroke\n";
# draw titles if requested
if ($args{'-y_title'}){
$out.= "gsave\n/Times-Italic findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-40). " ".( $y+$ysize/2)." moveto\n";
$out.=" 90 rotate ($args{'-y_title'}) show\n grestore\n" ;
}
if ($args{'-x_title'}){
$out.= "gsave\n/Times-Italic findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x+$xsize/2.5). " ".( $y*(0.60))." moveto\n";
$out.=" ($args{'-x_title'}) show\n grestore\n" ;
}
if ($args{'-title'}){
$out.= "gsave\n/Times-Roman findfont $color{black} [".($font*2)." 0 0 $font 0 0] makefont setfont\n".($x+$xsize/3). " ".( $y+$max_ysize*1.1)." moveto\n";
$out.=" ($args{'-title'}) show\n grestore\n" ;
}
# define x axis and x tickmarks
my $col_width=($xsize/$self->length()) -0.006*$xsize;
my $x_now;
for(my $i=1; $i<=$self->length(); $i++){
$x_now=$x+$col_width*$i;
$out.="newpath\n ". ($x_now)." ". ($y)." moveto\n". ($x_now)." ". ($y-$ysize/20 ) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x_now-$col_width/2). " ".( $y-20)." moveto\n";
$out.=" ($i) show\n grestore\n" ;
}
# draw the logo
foreach my $i (0..$self->length()-1 ) { # get the $i-th column of matrix
my %ic;
($ic{A}, $ic{C}, $ic{G}, $ic{T}) = list $self->pdl_matrix->slice($i);
my @draw_order = sort {$ic{$a}<=>$ic{$b}} qw(A C G T);
#draw this position
foreach my $letter (@draw_order){
$ic{$letter}=0.0000001 if ( $ic{$letter}==0); # some interpretors do not uderstand size 0
$out.= "gsave\n/Helvetica-Bold findfont $color{$letter} [".$fontwidth*$w_correct{$letter}." 0 0 ";
$out.= $ic{$letter}*$fontsize*$y_next{$letter} ;
$y+=$y_correct{$letter}*$ic{$letter}; #movement that isletter specific, due to bounding boxes
$out.= " 0 0] makefont setfont\n$x $y moveto\n";
$out.= " ($letter) show\n grestore\n" ;
$y+=$fontsize*$ic{$letter}*0.75; #ic content move
}
$x+=$fontwidth/1.6;
$y=100;
}
# save as file if requested
if ($args{-file}) {
open (PSFILE, ">".$args{-file})
or $self->throw("Could not write to ".$args{-file});
print PSFILE $out;
close PSFILE;
}
if ($args{-pdf}){
system "ps2pdf $args{-file} ".$args{-file}.".pdf ";
system " mv $args{-file}.pdf $args{-file}";
}
return $out;
}
=head2 _draw_svg_logo
=cut
sub _draw_svg_logo {
my $self = shift;
my %args = (-xsize => 800,
-full_scale => 2.25,
-graph_title=> "",
-x_title => "",
-y_title => "",
@_);
my $max_ysize= $args{'-ysize'} ||int 5* $args{'-xsize'}/8;
my ($xsize,$FULL_SCALE, $x_title, $y_title)
= @args{qw(-xsize -full_scale -x_title y_title)} ;
my $PER_PIXEL_LINE = 200;
# calculate other parameters if not specified
my $ysize = ($args{-ysize} or $xsize/1.6);
my $line_width = ($args{-line_width} or $ysize/$PER_PIXEL_LINE);
# remark (the line above): 1.6 is a standard screen x:y ratio
my $margin = ($args{-margin} or $ysize*0.15);
my $image = SVG->new(width=>$xsize, height=>$ysize);
my $white = 'rgb(255,255,255)';
my $black = 'rgb(0,0,0)';
my $motif_size = $self->pdl_matrix->getdim(0);
my $fontsize = int ($ysize/25);
my $title_font = {width=>$fontsize*1.5, height=>$fontsize*1.5};
my $font = {width=>$fontsize, height=>$fontsize};
# WRITE LABELS AND TITLE
# graph title
$image->text(id=>"Title",
'font-size'=>$title_font->{width},
x => $xsize/2,
y => 0.6*$margin,
'text-anchor'=>'middle'
)->cdata($args{-graph_title});
# x title
$image->text(id=>"X_title",
'font-size'=>$font->{width},
x => $xsize/2,
y => $ysize -0.3*$margin,
'text-anchor'=>'middle'
)->cdata($args{-x_title});
# y title
my $g = $image->group;
$g->text(id=>"Y_title",
'font-size'=>$font->{width},
x => 0 ,
'text-anchor'=>'middle',
y => 0,
transform => 'rotate(-90) translate(-'.($ysize/2).','.($margin/2).')')->cdata($args{-y_title});
# DRAW AXES
# vertical: (top left to bottom right)
$image->rectangle(id => "y_axis",
style => {
#stroke => $black,
fill => $black
},
x => $margin-$line_width,
y => $margin,
width => $line_width,
height => $ysize -2*$margin
);
#$image->filledRectangle($margin-$line_width, $margin-$line_width,
# $margin-1, $ysize-$margin+$line_width, #
# $black);
# horizontal: (ditto)
$image->rectangle(id => "x_axis",
style => {
#stroke => $black,
fill => $black
},
x => $margin-$line_width,
y => $ysize-$margin,
width => $xsize-2*$margin+$line_width,
height => $line_width
);
#$image->filledRectangle($margin-$line_width, $ysize-$margin+1,
# $xsize-$margin+$line_width,$ysize-$margin+$line_width,
# $black);
# DRAW VERTICAL TICKS AND LABELS
# vertical axis (IC 1 and 2)
my $ic_1 = ($ysize - 2* $margin) / $FULL_SCALE;
foreach my $i (1..$FULL_SCALE) {
$image->rectangle(x => $margin-3*$line_width,
y => $ysize-$margin - $i*$ic_1,
width => 3*$line_width,
height => $line_width
);
$image->text(x => $margin-5*$line_width - $font->{width},
y => $ysize - $margin - $i*$ic_1 +$font->{height}/2,
'font-size'=>$font->{width},
'text-anchor'=>"right"
)->cdata($i);
}
# DRAW HORIZONTAL TICKS AND LABELS, AND THE LOGO ITSELF
# define function refs as hash elements
my %draw_letter = ( A => \&_svg_draw_A,
C => \&_svg_draw_C,
G => \&_svg_draw_G,
T => \&_svg_draw_T );
my $horiz_step = ($xsize -2*$margin) / $motif_size;
#this is to avoid clutter on X axis:
my $longest_label_length = length("$motif_size");
if (length ($args{-startpos}) > $longest_label_length) {
$longest_label_length = length ($args{-startpos});
}
if (length ($args{-startpos}+$motif_size) > $longest_label_length) {
$longest_label_length = length ($args{-startpos}+$motif_size);
}
my $draw_every_nth_label = int(($longest_label_length+0.25)*$font->{width}) / $horiz_step + 1;
foreach my $i (0..$motif_size) {
my $height = 3*$line_width;
if ($i and $i==$args{-startpos}*-1){
$height = 5*$line_width;
}
$image->rectangle(x => $margin + $i*$horiz_step -$line_width/2,
y => $ysize-$margin,
width => $line_width,
height => $height
);
last if $i==$motif_size;
# get the $i-th column of matrix
my %ic;
($ic{A}, $ic{C}, $ic{G}, $ic{T}) = list $self->pdl_matrix->slice($i);
# sort nucleotides by increasing information content
my @draw_order = sort {$ic{$a}<=>$ic{$b}} qw(A C G T);
# draw logo column
my $xlettersize = $horiz_step*0.95;
my $ybottom = $ysize - $margin;
foreach my $base (@draw_order) {
my $ylettersize = $ic{$base}*$ic_1;
next if $ylettersize ==0;
# draw letter
$draw_letter{$base}->($image,
$margin + $i*$horiz_step + 0.025* $horiz_step,
$ybottom - $ylettersize,
$xlettersize, $ylettersize, $white);
$ybottom = $ybottom - $ylettersize;
}
if ($args{'-error_bars'} and ref($args{'-error_bars'}) eq "ARRAY") {
my $sd_pix = int($args{'-error_bars'}->[$i]*$ic_1);
my $yt = $ybottom - $sd_pix+1;
my $yb = $ybottom + $sd_pix-1;
my $xpos = $margin + ($i+0.5)*$horiz_step;
my $half_width;
if ($yb > $ysize-$margin+$line_width) {
$yb = $ysize-$margin+$line_width
}
else {
$image->line(x1=>$xpos - $xlettersize/8, y1=> $yb,
x2=> $xpos + $xlettersize/8, y2=>$yb, stroke=>$black,
'stroke-width'=>$line_width);
}
$image->line(x1=>$xpos, y1=>$yt, x2=>$xpos, y2=>$yb, stroke=>$black,
'stroke-width'=>$line_width);
$image->line(x1=>$xpos - $line_width , y1=>$ybottom, x2=>$xpos+$line_width, y2=>$ybottom, stroke=>$black,
'stroke-width'=>$line_width);
$image->line(x1=>$xpos - $xlettersize/8, y1=>$yt,
x2=>$xpos + $xlettersize/8, y2=>$yt, stroke=>$black,
'stroke-width'=>$line_width);
}
# print position number on x axis
my $xlabel = $i+ $args{-startpos};
if ($args{-startpos}<0 and $xlabel>=0) {
$xlabel ++;
}
if ($xlabel % $draw_every_nth_label == 0) {
$image->text(x => $margin + ($i+0.5)*$horiz_step - $font->{width}/2,
y => $ysize - $margin +5*$line_width + $font->{width}/2,
'font-size'=>$font->{width},
'text-anchor'=>"bottom"
)->cdata($xlabel);
}
}
# print to $args{-file};
if ($args{-file}) {
open (SVGFILE, ">".$args{-file})
or $self->throw("Could not write to ".$args{-file});
my $xml = $image->xmlify;
$xml =~ s/\s+<\/text/<\/text/gs;
print SVGFILE $xml;
close SVGFILE;
}
return $image;
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
#################################################################
# INTERNAL METHODS
#################################################################
sub _check_ic_validity {
my ($self) = @_;
# to do
}
sub DESTROY {
# nothing
}
#################################################################
# UTILITY FUNCTIONS
#################################################################
# letter drawing routines
sub _png_draw_A {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $green = $im->colorAllocate(0,255,0);
my $outPoly = GD::Polygon->new();
$outPoly->addPt($x, $y+$ysize);
$outPoly->addPt($x+$xsize*.42, $y);
$outPoly->addPt($x+$xsize*.58, $y);
$outPoly->addPt($x+$xsize, $y+$ysize);
$outPoly->addPt($x+0.85*$xsize, $y+$ysize);
$outPoly->addPt($x+0.725*$xsize, $y+0.75*$ysize);
$outPoly->addPt($x+0.275*$xsize, $y+0.75*$ysize);
$outPoly->addPt($x+0.15*$xsize, $y+$ysize);
$im->filledPolygon($outPoly, $green);
if ($ysize>8) {
my $inPoly = GD::Polygon->new();
$inPoly->addPt($x+$xsize*.5, $y+0.2*$ysize);
$inPoly->addPt($x+$xsize*.34, $y+0.6*$ysize-1);
$inPoly->addPt($x+$xsize*.64, $y+0.6*$ysize-1);
$im->filledPolygon($inPoly, $white);
}
return 1;
}
sub _png_draw_C {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $blue = $im->colorAllocate(0,0,255);
$im->arc($x+$xsize*0.54, $y+$ysize/2,1.08*$xsize,$ysize,0,360,$blue);
$im->fill($x+$xsize/2, $y+$ysize/2, $blue);
if ($ysize>12) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
0.75*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize/2, $y+$ysize/4+1,
$x+$xsize*1.1, $y+(3*$ysize/4)-1,
$white);
}
elsif ($ysize>3) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
(0.75-0.75/$ysize)*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize*0.25, $y+$ysize/2,
$x+$xsize*1.1, $y+$ysize/2,
$white);
}
return 1;
}
sub _png_draw_G {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $yellow = $im->colorAllocate(200,200,0);
$im->arc($x+$xsize*0.54, $y+$ysize/2,1.08*$xsize,$ysize,0,360,$yellow);
$im->fill($x+$xsize/2, $y+$ysize/2, $yellow);
if ($ysize>20) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
0.75*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize/2, $y+$ysize/4+1,
$x+$xsize*1.1, $y+$ysize/2-1,
$white);
}
elsif($ysize>3) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
(0.75-0.75/$ysize)*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize*0.25, $y+$ysize/2,
$x+$xsize*1.1, $y+$ysize/2,
$white);
}
$im->filledRectangle($x+0.85*$xsize, $y+$ysize/2,
$x+$xsize,$y+(3*$ysize/4)-1,
$yellow);
$im->filledRectangle($x+0.6*$xsize, $y+$ysize/2,
$x+$xsize,$y+(5*$ysize/8)-1,
$yellow);
return 1;
}
sub _png_draw_T {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $red = $im->colorAllocate(255,0,0);
$im->filledRectangle($x, $y, $x+$xsize, $y+0.16*$ysize, $red);
$im->filledRectangle($x+0.42*$xsize, $y, $x+0.58*$xsize, $y+$ysize, $red);
return 1;
}
sub _svg_draw_A {
my ($im, $x, $y, $xsize, $ysize) = @_;
$im->polygon( points => [$x, $y+$ysize, $x+$xsize*.42, $y, $x+$xsize*.58, $y, $x+$xsize, $y+$ysize,
$x+0.85*$xsize, $y+$ysize, $x+0.725*$xsize, $y+0.75*$ysize, $x+0.275*$xsize, $y+0.75*$ysize,
$x+0.15*$xsize, $y+$ysize, $x, $y+$ysize],
fill => 'rgb(0,255,0)'
);
$im->polygon( points => [$x+$xsize*.5, $y+0.2*$ysize, $x+$xsize*.34, $y+0.6*$ysize, $x+$xsize*.64, $y+0.6*$ysize ],
fill => 'rgb(255,255,255)');
return 1;
}
sub _svg_draw_C {
my ($im, $x, $y, $xsize, $ysize) = @_;
$im->ellipse(cx=>$x+$xsize*0.54, cy=>$y+$ysize/2, rx=>$xsize*0.54, ry=>$ysize/2,
fill => 'rgb(0,0,255)');
$im->ellipse( cx=>$x+$xsize*0.53, cy=>$y+$ysize/2, rx=>$xsize*0.375, ry=>$ysize*0.375,
fill => 'rgb(255,255,255)');
$im->rectangle(x=>$x+$xsize/2, y=>$y+$ysize/4,
width =>$xsize*0.6, height =>$ysize/2,
fill=> 'rgb(255,255,255)');
return 1;
}
sub _svg_draw_G {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
$im->ellipse(cx => $x+$xsize*0.54, cy => $y+$ysize/2,
rx => 0.54*$xsize, ry => $ysize/2,
fill => 'rgb(200,200,0)');
$im->ellipse(cx => $x+$xsize*0.53, cy => $y+$ysize/2,
rx => 0.375*$xsize, ry => 0.375*$ysize,
fill => 'rgb(255,255,255)');
$im->rectangle(x=>$x+$xsize/2, y=>$y+$ysize/4,
width =>$xsize*0.6, height =>$ysize/2,
fill=> 'rgb(255,255,255)');
$im->rectangle(x=>$x+0.80*$xsize, y=>$y+$ysize/2,
width =>$xsize*0.208, height =>$ysize/4,
fill=> 'rgb(200,200,0)');
$im->rectangle(x=>$x+0.6*$xsize, y=>$y+$ysize/2,
width =>$xsize*0.408, height =>$ysize/8,
fill=> 'rgb(200,200,0)');
return 1;
}
sub _svg_draw_T {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
$im->polygon (points =>[$x, $y, $x+$xsize, $y, $x+$xsize, $y+0.16*$ysize,
$x+0.58*$xsize, $y+0.16*$ysize, $x+0.58*$xsize, $y+$ysize,
$x+0.42*$xsize, $y+$ysize, $x+0.42*$xsize, $y+0.16*$ysize,
$x, $y+0.16*$ysize],
fill => 'rgb(255,0,0)');
return 1;
}
1;
TFBS-0.7.1/TFBS/Matrix/PFM.pm 0000775 0000000 0000000 00000037334 13057522667 0015271 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::PFM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::PFM - class for raw position frequency matrix patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::PFM object manually:
my $matrixref = [ [ 12, 3, 0, 0, 4, 0 ],
[ 0, 0, 0, 11, 7, 0 ],
[ 0, 9, 12, 0, 0, 0 ],
[ 0, 0, 0, 1, 1, 12 ]
];
my $pfm = TFBS::Matrix::PFM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring =
"12 3 0 0 4 0\n0 0 0 11 7 0\n0 9 12 0 0 0\n0 0 0 1 1 12";
my $pfm = TFBS::Matrix::PFM->new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::PFM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and
retrieve TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pfm = $db_obj->get_Matrix_by_ID("M0001", "PFM");
# or
my $pfm = $db_obj->get_Matrix_by_name("MyProfile", "PFM");
=item * retrieving list of individual TFBS::Matrix::PFM objects
from a TFBS::MatrixSet object
(See the L to learn how to create
objects for storage and manipulation of multiple matrices.)
my @pfm_list = $matrixset->all_patterns(-sort_by=>"name");
=item * convert a raw frequency matrix to other matrix types:
my $pwm = $pfm->to_PWM(); # convert to position weight matrix
my $icm = $icm->to_ICM(); # convert to information con
=back
=head1 DESCRIPTION
TFBS::Matrix::PFM is a class whose instances are objects representing
raw position frequency matrices (PFMs). A PFM is derived from N
nucleotide patterns of fixed size, e.g. the set of sequences
AGGCCT
AAGCCT
AGGCAT
AAGCCT
AAGCCT
AGGCAT
AGGCCT
AGGCAT
AGGTTT
AGGCAT
AGGCCT
AGGCCT
will give the matrix:
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
which contains the count of each nucleotide at each position in the
sequence. (If you have a set of sequences as above and want to
create a TFBS::Matrix::PFM object out of them, have a look at
TFBS::PatternGen::SimplePFM module.)
PFMs are easily converted to other types of matrices, namely
information content matrices and position weight matrices. A
TFBS::Matrix::PFM object has the methods to_ICM and to_PWM which
do just that, returning a TFBS::Matrix::ICM and TFBS::Matrix::PWM
objects, respectively.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Matrix::PFM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::SeqIO;
use TFBS::Matrix;
use TFBS::Matrix::ICM;
use TFBS::Matrix::PWM;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
use constant EXACT_SCHNEIDER_MAX => 30;
#######################################################
# PUBLIC METHODS
#######################################################
=head2 new
Title : new
Usage : my $pfm = TFBS::Matrix::PFM->new(%args)
Function: constructor for the TFBS::Matrix::PFM object
Returns : a new TFBS::Matrix::PFM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
Warnings : Warns if the matrix provided has columns with different
sums. Columns with different sums contradict the usual
origin of matrix data and, unless you are absolutely sure
that column sums _should_ be different, it would be wise to
check your matrices.
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"PFM");
my $self = bless $matrix, ref($class) || $class;
$self->_check_column_sums();
return $self;
}
=head2 column_sum
Title : column_sum
Usage : my $nr_sequences = $pfm->column_sum()
Function: calculates the sum of elements of one column
(the first one by default) which normally equals the
number of sequences used to derive the PFM.
Returns : the sum of elements of one column (an integer)
Args : columnn number (starting from 1), OPTIONAL - you DO NOT
need to specify it unless you are dealing with a matrix
=cut
sub column_sum {
my ($self, $column) = (@_,1);
return $self->pdl_matrix->slice($column-1)->sum;
}
=head2 to_PWM
Title : to_PWM
Usage : my $pwm = $pfm->to_PWM()
Function: converts a raw frequency matrix (a TFBS::Matrix::PFM object)
to position weight matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::PWM object
Args : none; in the future releases, it should be able to accept
a user defined background probability of the four
nucleotides
=cut
sub to_PWM {
my ($self, %args) = @_;
my $bg = ($args{'-bg_probabilities' } || $self->{'bg_probabilities'});
my $bg_pdl =
transpose pdl ($bg->{'A'}, $bg->{'C'}, $bg->{'G'}, $bg->{'T'});
my $nseqs = $self->pdl_matrix->sum / $self->length;
my $q_pdl = ($self->pdl_matrix +$bg_pdl*sqrt($nseqs))
/
($nseqs + sqrt($nseqs));
my $pwm_pdl = log2(4*$q_pdl);
my $PWM = TFBS::Matrix::PWM->new
( (map {("-$_", $self->{$_}) } keys %$self),
# do not want tags to point to the same arrayref as in $self:
-tags => \%{ $self->{'tags'}},
-bg_probabilities => \%{ $self->{'bg_probabilities'}},
-matrix => $pwm_pdl
);
return $PWM;
}
=head2 to_ICM
Title : to_ICM
Usage : my $icm = $pfm->to_ICM()
Function: converts a raw frequency matrix (a TFBS::Matrix::PFM object)
to information content matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::ICM object
Args : -small_sample_correction # undef (default), 'schneider' or 'pseudocounts'
How a PFM is converted to ICM:
For a PFM element PFM[i,k], the probability without
pseudocounts is estimated to be simply
p[i,k] = PFM[i,k] / Z
where
- Z equals the column sum of the matrix i.e. the number of motifs used
to construct the PFM.
- i is the column index (position in the motif)
- k is the row index (a letter in the alphacer, here k is one of
(A,C,G,T)
Here is how one normally calculates the pseudocount-corrected positional
probability p'[i,j]:
p'[i,k] = (PFM[i,k] + 0.25*sqrt(Z)) / (Z + sqrt(Z))
0.25 is for the flat distribution of nucleotides, and sqrt(Z) is the
recommended pseudocount weight. In the general case,
p'[i,k] = (PFM[i,k] + q[k]*B) / (Z + B)
where q[k] is the background distribution of the letter (nucleotide) k,
and B an arbitrary pseudocount value or expression (for no pseudocounts
B=0).
For a given position i, the deviation from random distribution in bits
is calculated as (Baldi and Brunak eq. 1.9 (2ed) or 1.8 (1ed)):
- for an arbitrary alphabet of A letters:
D[i] = log2(A) + sum_for_all_k(p[i,k]*log2(p[i,k]))
- special case for nucleotides (A=4)
D[i] = 2 + sum_for_all_k(p[i,k]*log2(p[i,k]))
D[i] equals the information content of the position i in the motif. To
calculate the entire ICM, you have to calculate the contrubution of each
nucleotide at a position i to D[i], i.e.
ICM[i,k] = p'[i,k] * D[i]
=cut
sub to_ICM {
my ($self, %args) = @_;
my $bg = ($args{'-bg_probabilities' } || $self->{'bg_probabilities'});
# compute ICM
my $bg_pdl =
transpose pdl ($bg->{'A'}, $bg->{'C'}, $bg->{'G'}, $bg->{'T'});
my $Z_pdl = $self->pdl_matrix->xchg(0,1)->sumover;
# pseudocount calculation
my $B = 0;
if (lc($args{'-small_sample_correction'} or "") eq "pseudocounts") {
$B = sqrt($Z_pdl);
}
else {
$B = 0; # do not add pseudocounts
}
my $p_pdl = ($self->pdl_matrix +$bg_pdl*$B)/ ($Z_pdl + $B);
my $plog_pdl = $p_pdl*log2($p_pdl);
$plog_pdl = $plog_pdl->badmask(0);
my $D_pdl = 2 + $plog_pdl->xchg(0,1)->sumover;
my $ic_pdl = $p_pdl * $D_pdl;
# apply Schneider correction if requested
if (lc($args{'-small_sample_correction'} or "") eq "schneider") {
my $columnsum_pdl = $ic_pdl->transpose->sumover;
my $corrected_columnsum_pdl =
$columnsum_pdl
+ _schneider_correction ($self->pdl_matrix, $bg_pdl);
$ic_pdl *= $corrected_columnsum_pdl/$columnsum_pdl;
}
# construct and return an ICM object
my $ICM = TFBS::Matrix::ICM->new
( (map {("-$_" => $self->{$_})} keys %$self),
-tags => \%{ $self->{'tags'}},
-bg_probabilities => \%{ $self->{'bg_probabilities'}},
-matrix => $ic_pdl
);
return $ICM;
}
=head2 draw_logo
Title : draw_logo
Usage : my $gd_image = $pfm->draw_logo()
Function: draws a sequence logo; similar to the
method in TFBS::Matrix::ICM, but can automatically calculate
error bars for drawing
Returns : a GD image object (see documentation of GD module)
Args : many; PFM-specific options are:
-small_sample_correction # One of
# "Schneider" (uses correction
# described by Schneider et al.
# (Schneider t et al. (1986) J.Biol.Chem.
# "pseudocounts" - standard pseudocount
# correction, more suitable for
# PFMs with large r column sums
# If the parameter is ommited, small
# sample correction is not applied
-draw_error_bars # if true, adds error bars to each position
# in the logo. To calculate the error bars,
# it uses the -small_sample_connection
# argument if explicitly set,
# or "Schneider" by default
For other args, see draw_logo entry in TFBS::Matrix::ICM documentation
=cut
sub draw_logo {
my ($self, %args) = @_;
if ($args{'-draw_error_bars'}) {
$args{'-small_sample_correction'} ||= "Schneider"; # default Schneider
my $pdl_no_correction =
$self->to_ICM()
->pdl_matrix->transpose->sumover;
my $pdl_with_correction =
$self->to_ICM(-small_sample_correction
=> $args{'-small_sample_correction'})
->pdl_matrix->transpose->sumover;
$args{'-error_bars'} =
[list ($pdl_no_correction - $pdl_with_correction)];
}
$self->to_ICM(%args)->draw_logo(%args);
}
=head2 add_PFM
Title : add_PFM
Usage : $pfm->add_PFM($another_pfm)
Function: adds the values of $pnother_pfm matrix to $pfm
Returns : reference to the updated $pfm object
Args : a TFBS::Matrix::PFM object
=cut
sub add_PFM {
my ($self, $pfm) = @_;
$pfm->isa("TFBS::Matrix::PFM")
or $self->throw("Wrong or no argument passed to add_PFM");
my $sum = $self->pdl_matrix + $pfm->pdl_matrix;
$self->set_matrix($sum);
return $self;
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
###############################################
# PRIVATE METHODS
###############################################
sub _check_column_sums {
my ($self) = @_;
my $pdl = $self->pdl_matrix->sever();
my $rowsums = $pdl->xchg(0,1)->sumover();
if ($rowsums->where($rowsums != $rowsums->slice(0))->getdim(0) > 0) {
$self->warn("PFM for ".$self->{ID}." has unequal column sums");
}
}
sub DESTROY {
# does nothing
}
###############################################
# UTILITY FUNCTIONS
###############################################
sub log2 { log($_[0]) / log(2); }
sub _schneider_correction {
my ($pdl, $bg_pdl) = @_;
my $Hg = -sum ($bg_pdl*log2($bg_pdl));
my (@Hnbs, %saved_Hnb);
my $is_flat = _is_bg_flat(list $bg_pdl);
my @factorials = (1);
if (min($pdl->transpose->sumover) <= EXACT_SCHNEIDER_MAX) {
foreach my $i (1..max($pdl->transpose->sumover)) {
$factorials[$i] =$factorials[$i-1] * $i;
}
}
my @column_sums = list $pdl->transpose->sumover;
foreach my $colsum (@column_sums) {
if (defined($saved_Hnb{$colsum})) {
push @Hnbs, $saved_Hnb{$colsum};
}
else {
my $Hnb;
if ($colsum <= EXACT_SCHNEIDER_MAX) {
if ($is_flat) {
$Hnb = _schneider_Hnb_precomputed($colsum);
}
else {
$Hnb = _schneider_Hnb_exact($colsum, $bg_pdl,
\@factorials);
}
}
else {
$Hnb = _schneider_Hnb_approx($colsum, $Hg);
}
$saved_Hnb{$colsum} = $Hnb;
push @Hnbs, $Hnb;
}
}
return -$Hg + pdl(@Hnbs);
}
sub _schneider_Hnb_exact {
my ($n, $bg_pdl, $rFactorial) = @_;
my $is_flat = _is_bg_flat(list $bg_pdl);
return 0 if $n==1;
# my @fctrl = (1);
# foreach my $i (1..max($pdl->transpose->sumover)) {
# $rFactorial->[$i] =$rFactorial->[$i-1] * $i;
# }
# my @colsum = list $pdl->transpose->sumover;
my ($na, $nc, $ng, $nt) = ($n, 0,0,0);
# my $n = $colsum[0];
my $E_Hnb=0;
while (1) {
my $ns_pdl = pdl [$na, $nc, $ng, $nt];
my $Pnb = ($rFactorial->[$n]
/
($rFactorial->[$na]
*$rFactorial->[$nc]
*$rFactorial->[$ng]
*$rFactorial->[$nt])
)*prod($bg_pdl->transpose**pdl($na, $nc, $ng, $nt));
my $Hnb = -1 * sum(($ns_pdl/$n)*log2($ns_pdl/$n)->badmask(0));
$E_Hnb += $Pnb*$Hnb;
if ($nt) {
if ($ng) { $ng--; $nt++, }
elsif ($nc) { $nc--; $ng = $nt+1; $nt = 0; }
elsif ($na) { $na--; $nc = $nt+1; $nt = 0; }
else { last; }
}
else {
if ($ng) { $ng--; $nt++, }
elsif ($nc) { $nc--; $ng++; }
else { $na--; $nc++; $nt = 0; }
}
}
return $E_Hnb;
}
sub _schneider_Hnb_approx {
my ($colsum, $Hg) = @_;
return $Hg -3/(2*log(2)*$colsum);
}
sub _schneider_Hnb_precomputed {
my $i = shift;
if ($i<1 or $i>30) {
die "Precomputed params only available for colsums 1 to 30)";
}
my @precomputed =
(
0, # 1
0.75, # 2
1.11090234442608, # 3
1.32398964833609, # 4
1.46290503577084, # 5
1.55922640783176, # 6
1.62900374746751, # 7
1.68128673969433, # 8
1.7215504663901, # 9
1.75328193031842, # 10
1.77879136615189, # 11
1.79965855531179, # 12
1.81699248819687, # 13
1.8315892710679, # 14
1.84403166371213, # 15
1.85475371994775, # 16
1.86408383599326, # 17
1.87227404728809, # 18
1.87952034817826, # 19
1.88597702438913, # 20
1.89176691659196, # 21
1.89698887214968, # 22
1.90172322434865, # 23
1.90603586889234, # 24
1.90998133028897, # 25
1.91360509239859, # 26
1.91694538711761, # 27
1.92003457997914, # 28
1.92290025302018, # 29
1.92556605820924, # 30
);
return $precomputed[$i-1];
}
sub _is_bg_flat {
my @bg = @_;
my $ref = shift;
foreach my $other (@bg) {
return 0 unless $ref==$other;
}
return 1;
}
1;
TFBS-0.7.1/TFBS/Matrix/PWM.pm 0000775 0000000 0000000 00000036222 13057522667 0015305 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::PWM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::PWM - class for position weight matrices of nucleotide
patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::PWM object manually:
my $matrixref = [ [ 0.61, -3.16, 1.83, -3.16, 1.21, -0.06],
[-0.15, -2.57, -3.16, -3.16, -2.57, -1.83],
[-1.57, 1.85, -2.57, -1.34, -1.57, 1.14],
[ 0.31, -3.16, -2.57, 1.76, 0.24, -0.83]
];
my $pwm = TFBS::Matrix::PWM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring = <new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::PWM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and retrieve
TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pwm = $db_obj->get_Matrix_by_ID("M0001", "PWM");
# or
my $pwm = $db_obj->get_Matrix_by_name("MyProfile", "PWM");
=item * retrieving list of individual TFBS::Matrix::PWM objects
from a TFBS::MatrixSet object
(see decumentation of TFBS::MatrixSet to learn how to create
objects for storage and manipulation of multiple matrices)
my @pwm_list = $matrixset->all_patterns(-sort_by=>"name");
=item * scanning a nucleotide sequence with a matrix
my $siteset = $pwm->search_seq(-file =>"myseq.fa",
-threshold => "80%");
=item * scanning a pairwise alignment with a matrix
my $site_pair_set = $pwm->search_aln(-file =>"myalign.aln",
-threshold => "80%",
-cutoff => "70%",
-window => 50);
=back
=head1 DESCRIPTION
TFBS::Matrix::PWM is a class whose instances are objects representing
position weight matrices (PWMs). A PWM is normally calculated from a
raw position frequency matrix (see L
for the explanation of position frequency matrices). For example, given
the following position frequency matrix:
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
The standard computational procedure is applied to convert it into the
following position weight matrix:
A:[ 0.61 -3.16 1.83 -3.16 1.21 -0.06]
C:[-0.15 -2.57 -3.16 -3.16 -2.57 -1.83]
G:[-1.57 1.85 -2.57 -1.34 -1.57 1.14]
T:[ 0.31 -3.16 -2.57 1.76 0.24 -0.83]
which contains the "weights" associated with the occurrence of each
nucleotide at the given position in a pattern.
A TFBS::Matrix::PWM object is equipped with methods to search nucleotide
sequences and pairwise alignments of nucleotide sequences with the
pattern they represent, and return a set of sites in nucleotide
sequence (a TFBS::SiteSet object for single sequence search, and a
TFBS::SitePairSet for the alignment search).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Matrix::PWM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::Seq;
use Bio::SeqIO;
use TFBS::Matrix;
use TFBS::SiteSet;
use TFBS::Matrix::_Alignment;
use TFBS::Ext::pwmsearch;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
#################################################################
# PUBLIC METHODS
#################################################################
=head2 new
Title : new
Usage : my $pwm = TFBS::Matrix::PWM->new(%args)
Function: constructor for the TFBS::Matrix::PWM object
Returns : a new TFBS::Matrix::PWM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"PWM");
my $self = bless $matrix, ref($class) || $class;
$self->_set_min_max_score();
return $self;
}
=head2 search_seq
Title : search_seq
Usage : my $siteset = $pwm->search_seq(%args)
Function: scans a nucleotide sequence with the pattern represented
by the PWM
Returns : a TFBS::SiteSet object
Args : # you must specify either one of the following three:
-file, # the name od a fasta file (single sequence)
#or
-seqobj # a Bio::Seq object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-seqstring # a string containing the sequence
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
-subpart # subpart of the sequence to search, given as
# -subpart => { start => 140,
# end => 180 }
# where start and end are coordinates in the
# sequence; the coordinate range is interpreted
# in the BioPerl tradition (1-based, inclusive)
# OPTIONAL: by default searches entire alignment
=cut
sub search_seq {
my ($self, %args) = @_;
$self->_search(%args);
}
=head2 search_aln
Title : search_aln
Usage : my $site_pair_set = $pwm->search_aln(%args)
Function: Scans a pairwise alignment of nucleotide sequences
with the pattern represented by the PWM: it reports only
those hits that are present in equivalent positions of both
sequences and exceed a specified threshold score in both, AND
are found in regions of the alignment above the specified
conservation cutoff value.
Returns : a TFBS::SitePairSet object
Args : # you must specify either one of the following three:
-file, # the name of the alignment file in Clustal
format
#or
-alignobj # a Bio::SimpleAlign object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-alignstring # a multi-line string containing the alignment
# in clustal format
#############
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
-window, # size of the sliding window (inn nucleotides)
# for calculating local conservation in the
# alignment
# OPTIONAL: default 50
-cutoff # conservation cutoff (%) for including the
# region in the results of the pattern search
# OPTIONAL: default "70%"
-subpart # subpart of the alignment to search, given as e.g.
# -subpart => { relative_to => 1,
# start => 140,
# end => 180 }
# where start and end are coordinates in the
# sequence indicated by relative_to (1 for the
# 1st sequence in the alignment, 2 for the 2nd)
# OPTIONAL: by default searches entire alignment
-conservation
# conservation profile, a TFBS::ConservationProfile
# OPTIONAL: by default the conservation profile is
# computed internally on the fly (less efficient)
=cut
sub search_aln {
my ($self, %args) = @_;
unless ($args{-alignstring} or $args{-alignobj} or $args{-file}) {
$self->throw
("No alignment file, string or object passed to search_aln.");
}
$args{-pattern_set} = $self;
my $aln = ($args{-alignment_setup} or TFBS::Matrix::_Alignment->new(%args));
$aln->do_sitesearch(%args);
return $aln->site_pair_set;
}
sub max_score {
$_[0]->{max_score};
}
sub min_score {
$_[0]->{min_score};
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
#################################################################
# PRIVATE METHODS
#################################################################
sub _set_min_max_score {
my ($self) = @_;
my $transpose = $self->pdl_matrix->xchg(0,1);
$self->{min_score} = sum(minimum $transpose);
$self->{max_score} = sum(maximum $transpose);
}
sub _search {
# this method runs the pwmsearch C extension and parses the data
# similarly to _csearch, which will eventually be discontinued
my ($self, %args) = @_;
my $seqobj = $self->_to_seqobj(%args);
my ($subseq_start, $subseq_end) = (1,$seqobj->length);
if(my $subpart = $args{-subpart}) {
$subseq_start = $subpart->{-start};
$subseq_end = $subpart->{-end};
unless($subseq_start and $subseq_end) {
$self->throw("Option -subpart missing suboption -start or -end");
}
}
return TFBS::Ext::pwmsearch::pwmsearch($self, $seqobj,
($args{-threshold} or 0),
$subseq_start, $subseq_end);
}
sub _csearch {
# this is a wrapper around Wyeth Wasserman's's pwm_searchPFF program
# until we do a proper extension
my ($self) = shift; #the rest of @_ goes to _to_seqob;
my %args = @_;
my $PWM_SEARCH = $args{'-binary'}
|| "pwm_searchPFF";
# dump the sequence into a tempfile
my $seqobj = $self->_to_seqobj(@_);
my ($fastaFH, $fastafile);
if (defined $seqobj->{_fastaFH} and defined $seqobj->{_fastafile}) {
($fastaFH, $fastafile) = ($seqobj->{_fastaFH}, $seqobj->{_fastafile});
}
else {
($fastaFH, $fastafile) = tmpnam();
my $seqFH = Bio::SeqIO->newFh(-fh =>$fastaFH, -format=>"Fasta");
print $seqFH $seqobj;
}
# we need $fastafile below
# calculate threshold
my $threshold;
if ($args{-threshold}) {
if ($args{-threshold} =~ /(.+)%/) {
# percentage
$threshold = $self->{min_score} +
($self->{max_score} - $self->{min_score})* $1/100;
}
else {
# absolute value
$threshold = $args{-threshold};
}
}
else {
# no threshold given
$threshold = $self->{min_score} -1;
}
# convert piddle to text (there MUST be a better way)
my $pwmstring = sprintf ( $self->pdl_matrix );
$pwmstring =~ s/\[|\]//g; # lose []
$pwmstring =~ s/\n /\n/g; # lose leading spaces
my @pwmlines = split("\n", $pwmstring); # f
$pwmstring = join ("\n", @pwmlines[2..5])."\n";
# dump pwm into a tempfile
my ($pwmFH, $pwmfile) = tmpnam(); # we need $pwmfile below
print $pwmFH $pwmstring;
close $pwmFH;
# run pwmsearch
my $hitlist = TFBS::SiteSet->new();
my ($TFname, $TFclass) = ($self->{name}, $self->{class});
my @search_result_lines =
`$PWM_SEARCH $pwmfile $fastafile $threshold -n $TFname -c $TFclass`;
foreach (@search_result_lines) {
chomp;
my ($seq_id, $factor, $class, $strand, $score, $pos, $siteseq) =
(split)[0, 2, 3, 4, 5, 7, 9];
my $correct_strand = ($strand eq "+")? "-1" : "1";
my $site = TFBS::Site->new ( -seq_id => $seqobj->display_id()."",
-seqobj => $seqobj,
-strand => $correct_strand."",
-pattern => $self,
-siteseq => $siteseq."",
-score => $score."",
-start => $pos,
-end => $pos + length($siteseq) -1
);
$hitlist->add_site($site);
}
# cleanup
unlink $fastafile unless $seqobj->{_fastafile};
unlink $pwmfile;
return $hitlist;
}
sub _bsearch {
# this is Perl/PDL only search routine. For experimental purposes only
my ($self,%args) = @_; #the rest of @_ goes to _to_seqob;
my @PWMs;
# prepare the sequence
my $seqobj = $self->_to_seqobj(%args);
my $seqmatrix = (defined $seqobj->{_pdl_matrix})
? $seqobj->{_pdl_matrix}
: _seq_to_pdlmatrix($seqobj);
# calculate threshold
my $threshold;
if ($args{-threshold}) {
if ($args{-threshold} =~ /(.+)%/) {
# percentage
$threshold = $self->{min_score} +
($self->{max_score} - $self->{min_score})* $1/100;
}
else {
# absolute value
$threshold = $args{-threshold};
}
}
else {
# no threshold given
$threshold = $self->{min_score} -1;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm ($self, $self->revcom()) {
my $TFlength = $pwm->pdl_matrix->getdim(0);
my $position_score_pdl = zeroes($seqmatrix->getdim(0) - $TFlength + 1);
my $position_index_pdl = sequence($seqmatrix->getdim(0) - $TFlength + 1)+1;
foreach my $i (0..($TFlength-1)) {
my $columnproduct = $seqmatrix * $pwm->pdl_matrix->slice("$i,:");
$position_score_pdl +=
$columnproduct->xchg(0,1)->sumover->slice($i.":".($i-$TFlength));
}
my @hitpositions =
list $position_index_pdl->where($position_score_pdl >= $threshold);
my @hitscores =
list $position_score_pdl->where($position_score_pdl >= $threshold);
for my $i(0..$#hitpositions) {
my($pos,$score) = ($hitpositions[$i], $hitscores[$i]);
my $siteseq = scalar($seqobj->subseq($pos, $pos+$TFlength-1));
my $site = TFBS::Site->new ( -seq_id => $seqobj->display_id(),
-seqobj => $seqobj,
-strand => $pwm->{strand},
-Matrix => $pwm,
-siteseq => $siteseq,
-score => $score,
-start => $pos);
$hitlist->add_site($site);
}
}
return $hitlist;
}
sub _to_seqobj {
my ($self, %args) = @_;
my $seq;
if ($args{-file}) { # not a Bio::Seq
return Bio::SeqIO->new(-file => $args{-file},
-format => 'fasta',
-moltype => 'dna')->next_seq();
}
elsif ($args{-seqstring}
or $args{-seq})
{ # I guess it's a string then
return Bio::Seq->new(-seq => ($args{-seqstring} or $args{-seq}),
-id => ($args{-seq_id} or "undefined"),
-moltype => 'dna');
}
elsif ($args{'-seqobj'} and ref($args{'-seqobj'}) and $args{'-seqobj'}->can("seq")) {
# do nothing (maybe check later)
return $args{'-seqobj'};
}
#elsif (ref($format) =~ /Bio\:\:Seq/ and !defined $seq) {
# if only one parameter passed and it's a Bio::Seq
#return $format;
#}
else {
$self->throw ("Wrong parameters passed to search method: ".%args);
}
}
sub _seq_to_pdlmatrix {
# called from ?search
# not OO - help function for search
my $seqobj = shift;
my $seqstring = uc($seqobj->seq());
my @perlarray;
foreach (qw(A C G T)) {
my $seqtobits = $seqstring;
eval "\$seqtobits =~ tr/$_/1/"; # curr. letter $_ to 1
eval "\$seqtobits =~ tr/1/0/c"; # non-1s to 0
push @perlarray, [split("", $seqtobits)];
}
return byte (\@perlarray);
}
sub DESTROY {
# nothing
}
1;
TFBS-0.7.1/TFBS/Matrix/_Alignment.pm 0000775 0000000 0000000 00000027374 13057522667 0016727 0 ustar 00root root 0000000 0000000 package TFBS::Matrix::_Alignment;
use vars qw(@ISA $AUTOLOAD);
use TFBS::SitePair;
use TFBS::SitePairSet;
use Bio::Root::Root;
use Bio::Seq;
use Bio::SimpleAlign;
use Bio::AlignIO;
use IO::String;
use PDL;
use strict;
@ISA =('Bio::Root::Root');
# CONSTANTS
use constant DEFAULT_WINDOW => 50;
use constant DEFAULT_CUTOFF => 70;
use constant DEFAULT_THRESHOLD => "80%";
sub new {
# this is ugly; OK, OK, I'll rewrite it as soon as I can
my ($caller, %args) = @_;
my $self = bless {}, ref $caller || $caller;
$self->window($args{-window} or DEFAULT_WINDOW);
$self->_parse_alignment(%args);
$self->seq1length(length(_strip_gaps($self->alignseq1())));
$self->seq2length(length(_strip_gaps($self->alignseq2())));
$self->_set_subpart_bounds($args{-subpart});
#
# If a conservation profile is provided, no need to compute it again.
# NOTE: conservation2 never seems to be used anywhere else so don't worry
# about the fact we are ignoring it if conservation is passed in :)
#
my $cp = $args{-conservation};
if ($cp) {
$self->conservation1([$cp->conservation()]);
} else {
$self->conservation1($self->_calculate_conservation($self->window(),1));
$self->conservation2($self->_calculate_conservation($self->window(),2));
}
$self->cutoff($args{-cutoff} or DEFAULT_CUTOFF);
#$self->threshold($args{-threshold} or DEFAULT_THRESHOLD);
#$self->_do_sitesearch
#(($args{-pattern_set} or $self->throw("No -matrixset parameter")),
# ($args{-threshold} or DEFAULT_THRESHOLD),
# ());
# $self->_set_start_end(%args); # Maybe later...
return $self;
}
sub DESTROY {
# empty
}
sub _parse_alignment {
my ($self, %args) = @_;
my ($seq1, $seq2, $start);
my $alignobj;
if (defined $args{'-alignstring'}) {
$alignobj = _alignstring_to_alignobj($args{'-alignstring'});
}
elsif (defined $args{'-file'}) {
$alignobj = _alignfile_to_alignobj($args{'-file'});
}
elsif (defined $args{-alignobj}) {
$alignobj = $args{'-alignobj'};
}
else {
$self->throw("No -alignstring, -file or -alignobj passed.");
}
my @match;
my ($seqobj1, $seqobj2) = $alignobj->each_seq;
($seq1, $seq2) = ($seqobj1->seq, $seqobj2->seq);
$start = 1;
$self->seq1name($seqobj1->display_id);
$self->seq2name($seqobj2->display_id);
$self->alignseq1($seq1);
$self->alignseq2($seq2);
my @seq1 = ("-", split('', $seq1) );
my @seq2 = ("-", split('', $seq2) );
$self->{alignseq1array} = [@seq1];
$self->{alignseq2array} = [@seq2];
my (@seq1index, @seq2index);
my ($i1, $i2) = (0, 0);
for my $pos (0..$#seq1) {
my ($s1, $s2) = (0, 0);
$seq1[$pos] ne "-" and $s1 = ++$i1;
$seq2[$pos] ne "-" and $s2 = ++$i2;
push @seq1index, $s1;
push @seq2index, $s2;
}
$self->pdlindex( pdl [ [list sequence($#seq1+1)],
[@seq1index],
[@seq2index],
[list zeroes ($#seq1+1)] ]) ;
return 1;
}
sub pdlindex {
my ($self, $input, $p1, $p2) = @_ ;
# print ("PARAMS ", join(":", @_), "\n");
if (ref($input) eq "PDL") {
$self->{pdlindex} = $input;
}
unless (defined $p2) {
return $self->{pdlindex};
}
else {
my @results = list
$self->{pdlindex}->xchg(0,1)->slice($p2)->where
($self->{pdlindex}->xchg(0,1)->slice($p1)==$input);
wantarray ? return @results : return $results[0];
}
}
sub lower_pdlindex {
my ($self, $input, $p1, $p2) = @_;
unless (defined $p2) {
$self->throw("Wrong number of parameters passed to lower_pdlindex");
}
my $result;
my $i = $input;
until ($result = $self->pdlindex($i, $p1 => $p2)) {
$i--;
last if $i==0;
}
return $result or 1;
}
sub higher_pdlindex {
my ($self, $input, $p1, $p2) = @_;
unless (defined $p2) {
$self->throw("Wrong number of parameters passed to lower_pdlindex");
}
my $result;
my $i = $input;
until ($result = $self->pdlindex($i, $p1 => $p2)) {
$i++;
last unless ($self->pdlindex($i, $p1=>0) > 0);
}
return $result;
}
sub _calculate_conservation {
my ($self, $WINDOW, $which) = @_;
my (@seq1, @seq2);
if ($which==2) {
@seq1 = @{$self->{alignseq2array}};
@seq2 = @{$self->{alignseq1array}};
}
else {
@seq1 = @{$self->{alignseq1array}};
@seq2 = @{$self->{alignseq2array}};
$which=1;
}
my @CONSERVATION;
my @match;
while ($seq1[0] eq "-") {
shift @seq1;
shift @seq2;
}
for my $i (0..$#seq1) {
push (@match,( uc($seq1[$i]) eq uc($seq2[$i]) ? 1:0))
unless ($seq1[$i] eq "-" or $seq1[$i] eq ".");
}
my @graph=($match[0]);
for my $i (1..($#match+$WINDOW/2)) {
$graph[$i] = ($graph[$i-1] or 0)
+ ($i>$#match ? 0: $match[$i])
- ($i<$WINDOW ? 0: $match[$i-$WINDOW]);
}
# at this point, the graph values are shifted $WINDOW/2 to the right
# i.e. the score at a certain position is the score of the window
# UPSTREAM of it: To fix it, we should discard the first $WINDOW/2 scores:
#$self->conservation1 ([]);
foreach my $pos (@graph[int($WINDOW/2)..$#graph]) {
push @CONSERVATION, 100*$pos/$WINDOW;
}
# correction
foreach my $pos (0..int($WINDOW/2)) {
$CONSERVATION[$pos] =
$CONSERVATION[$pos]*$WINDOW/(int($WINDOW/2)+$pos);
$CONSERVATION[$#CONSERVATION - $pos] =
$CONSERVATION[$#CONSERVATION - $pos]*$WINDOW/(int($WINDOW/2)+$pos);
}
return [@CONSERVATION];
}
sub _strip_gaps {
# a utility function
my $seq = shift;
$seq =~ s/\-|\.//g;
return $seq;
}
sub do_sitesearch {
my ($self, @args ) = @_;
my ($MATRIXSET, $THRESHOLD, $CUTOFF) =
$self->_rearrange([qw(PATTERN_SET THRESHOLD CUTOFF)], @args);
if (!$MATRIXSET) {
$self->throw("No -pattern_set passed to do_sitesearch");
}
$CUTOFF = ($CUTOFF or DEFAULT_CUTOFF);
$THRESHOLD = ($THRESHOLD or DEFAULT_THRESHOLD);
$self->site_pair_set(TFBS::SitePairSet->new());
return if(($self->subpart1 and $self->subpart1->{-start} == 0) or
($self->subpart2 and $self->subpart2->{-start} == 0));
# ^^^ If one of the subparts is a gap, there's no point in searching
my $seqobj1 = Bio::Seq->new(-seq=>_strip_gaps($self->alignseq1()),
-id => "Seq1");
my $siteset1 =
$MATRIXSET->search_seq(-seqobj => $seqobj1,
-threshold => $THRESHOLD,
-subpart => $self->subpart1);
my $siteset1_itr = $siteset1->Iterator(-sort_by => "start");
my $seqobj2 = Bio::Seq->new(-seq=>_strip_gaps($self->alignseq2()),
-id => "Seq2");
my $siteset2 =
$MATRIXSET->search_seq(-seqobj => $seqobj2,
-threshold => $THRESHOLD,
-subpart => $self->subpart2);
my $siteset2_itr = $siteset2->Iterator(-sort_by => "start");
my $site1 = $siteset1_itr->next();
my $site2 = $siteset2_itr->next();
while (defined $site1 and defined $site2) {
my $pos1_in_aln = $self->pdlindex($site1->start(), 1=>0);
my $pos2_in_aln = $self->pdlindex($site2->start(), 2=>0);
my $cmp = (($pos1_in_aln <=> $pos2_in_aln)
or ($site1->pattern->name() cmp $site2->pattern->name())
or ($site1->strand() cmp $site2->strand()));
if ($cmp==0) { ### match
if (# threshold test:
$self->conservation1->[$site1->start()]
>=
$self->cutoff()
)
{
my $site_pair = TFBS::SitePair->new($site1, $site2);
$self->site_pair_set->add_site_pair($site_pair);
}
$site1 = $siteset1_itr->next();
$site2 = $siteset2_itr->next();
}
elsif ($cmp<0) { ### $siteset1 is behind
$site1 = $siteset1_itr->next();
}
elsif ($cmp>0) { ### $siteset2 is behind
$site2 = $siteset2_itr->next();
}
}
}
sub _set_subpart_bounds {
my ($self, $subpart) = @_;
if(defined $subpart) {
my ($relative_to, $start, $end) = ($subpart->{-relative_to},
$subpart->{-start},
$subpart->{-end});
unless(defined($relative_to) and defined($start) and defined($end) ) {
$self->throw("Option -subpart missing suboption -relative_to, -start or -end");
}
if($relative_to == 1) {
my $other_start = $self->higher_pdlindex($start, 1 => 2);
my $other_end = $self->lower_pdlindex($end, 1 => 2);
($other_start, $other_end) = (0,0) if($other_start > $other_end);
$self->subpart1({ -start => $start, -end => $end });
$self->subpart2({ -start => $other_start, -end => $other_end });
}
elsif($relative_to == 2) {
my $other_start = $self->higher_pdlindex($start, 2 => 1);
my $other_end = $self->lower_pdlindex($end, 2 => 1);
($other_start, $other_end) = (0,0) if($other_start > $other_end);
$self->subpart1({ -start => $other_start, -end => $other_end });
$self->subpart2({ -start => $start, -end => $end });
}
else {
$self->throw("Suboption -relative_to should be 1 or 2");
}
}
}
sub _calculate_cutoff {
my ($self) = @_;
my $ile = 0.9;
my @conservation_array = sort {$a <=> $b} @{$self->conservation1()};
my $perc_90 = $conservation_array[int($ile*scalar(@conservation_array))];
return $perc_90;
}
sub _alignfile_to_string {
# a utility function
# DEPRECATED !!!
my $alignfile = shift;
if ($alignfile =~ /\.msf$/i) {
my $alignobj = Bio::SimpleAlign->new();
$alignobj->read_MSF($alignfile);
return _alignobj_to_string($alignobj);
}
else { #assumed clustalw - no AlignIO import yet
local $/ = undef;
open FILE, $alignfile
or die("Could not read alignfile $alignfile, stopped");
my $alignstring = ;
return $alignstring;
}
}
sub _alignfile_to_alignobj {
# a utility function
my ($alignfile, $format) = (@_,'clustalw');
if (!$format and $alignfile =~ /\.msf$/i) { $format = 'msf' ;}
my $alnio = Bio::AlignIO->new(-file=>$alignfile, -format=>$format);
return $alnio->next_aln;
}
sub _alignobj_to_string {
# a utility function
# DEPRECATED
my $alignobj = shift;
my $alignstring;
my $io = IO::String->new($alignstring);
my $alnio = Bio::AlignIO->new(-fh=>$io, -format=>"clustalw");
$alnio->write_aln($alignobj);
$alnio->close();
# $io->close;
return $alignstring;
}
sub _alignstring_to_alignobj {
# a utility function
my ($alignstring, $format) = (@_, 'clustalw');
my $io = IO::String->new($alignstring);
my $alnio = Bio::AlignIO->new(-fh=>$io, -format=>$format);
my $alignobj = $alnio->next_aln();
$alnio->close();
# $io->close;
return $alignstring;
}
# uglier than AUTOLOAD, but faster - a quick fix to get rid of Class::MethodMaker
sub cutoff
{ $_[0]->{'cutoff'} = $_[1] if exists $_[1]; $_[0]->{'cutoff'}; }
sub window
{ $_[0]->{'window '} = $_[1] if exists $_[1]; $_[0]->{'window '}; }
sub alignseq1
{ $_[0]->{'alignseq1'} = $_[1] if exists $_[1]; $_[0]->{'alignseq1'}; }
sub alignseq2
{ $_[0]->{'alignseq2'} = $_[1] if exists $_[1]; $_[0]->{'alignseq2'}; }
sub site_pair_set
{ $_[0]->{'site_pair_set'} = $_[1] if exists $_[1]; $_[0]->{'site_pair_set'};}
sub seq1name
{ $_[0]->{'seq1name'} = $_[1] if exists $_[1]; $_[0]->{'seq1name'}; }
sub seq2name
{ $_[0]->{'seq2name'} = $_[1] if exists $_[1]; $_[0]->{'seq2name'}; }
sub seq1length
{ $_[0]->{'seq1length'} = $_[1] if exists $_[1]; $_[0]->{'seq1length'}; }
sub seq2length
{ $_[0]->{'seq2length'} = $_[1] if exists $_[1]; $_[0]->{'seq2length'}; }
sub subpart1
{ $_[0]->{'subpart1'} = $_[1] if exists $_[1]; $_[0]->{'subpart1'}; }
sub subpart2
{ $_[0]->{'subpart2'} = $_[1] if exists $_[1]; $_[0]->{'subpart2'}; }
sub conservation1
{ $_[0]->{'conservation1'} = $_[1] if exists $_[1]; $_[0]->{'conservation1'};}
sub conservation2
{ $_[0]->{'conservation2'} = $_[1] if exists $_[1]; $_[0]->{'conservation2'};}
sub exclude_orf
{ $_[0]->{'exclude_orf'} = $_[1] if exists $_[1]; $_[0]->{'exclude_orf'}; }
sub start_at
{ $_[0]->{'start_at'} = $_[1] if exists $_[1]; $_[0]->{'start_at'}; }
sub end_at
{ $_[0]->{'end_at'} = $_[1] if exists $_[1]; $_[0]->{'end_at'}; }
1;
TFBS-0.7.1/TFBS/MatrixSet.pm 0000775 0000000 0000000 00000050577 13057522667 0015327 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::MatrixSet
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::Set - an agregate class representing a set of matrix patterns, containing methods for manipulating the set as a whole
=head1 SYNOPSIS
# creation of a TFBS::MatrixSet object
# let @list_of_matrix_objects be a list of TFBS::Matrix::* objects
###################################
# Create a TFBS::MatrixSet object:
my $matrixset = TFBS::MatrixSet->new(); # creates an empty set
$matrixset->add_Matrix(@list_of_matrix_objects); #add matrix objects to set
$matrixset->add_Matrix($matrixobj); # adds a single matrix object to set
# or, same as above:
my $matrixset = TFBS::MatrixSet->new(@list_of_matrix_objects, $matrixobj);
###################################
#
=head1 DESCRIPTION
TFBS::MatrixSet is an aggregate class storing a set of TFBS::Matrix::* subclass objects, and providing methods form manipulating those sets as a whole. TFBS::MatrixSet objects are created de novo or returned by some database (TFBS::DB::*) retrieval methods.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
Modified by Eivind Valen eivind.valen@gmail.com
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::MatrixSet;
use vars '@ISA';
use PDL;
use Bio::Seq;
use Bio::SeqIO;
use Bio::Root::Root;
use Bio::TreeIO;
use File::Temp qw/:POSIX/;
use TFBS::Matrix;
use TFBS::_Iterator::_MatrixSetIterator;
use TFBS::SiteSet;
use strict;
use constant TRUE => 1;
use constant FALSE => 0;
@ISA = qw(Bio::Root::Root);
# Hash of accepted options and their arguments for the program
# STAMP. Reference to empty list means the option take no arguments
# This test for legal arguments is maybe superfluous and can
# potentially be removed.
my %stamp_opt = (
-tf => [],
-sd => [],
-cc => [ "PCC", "ALLR", "ALLR_LL", "CS", "KL", "SSD" ],
-align => [ "NW", "SW", "SWA", "SWU" ],
-go => [],
-ge => [],
-out => [],
-overlapalign => [],
-nooverlapalign => [],
-extendedoverlap => [],
-printpairwise => [],
-tree => [ "UPGMA", "SOTA" ],
-ch => [],
-ma => [ "PPA", "IR" ],
-match => [],
-matchtop => [],
-prot => [],
-genrand => [],
-genscores => [],
-stampdir => [],
-tempdir => [],
-noclean => []
);
=head2 new
=cut
sub new {
my ($caller, @matrices) = shift;
my $self = bless {matrix_list =>[]}, ref($caller) || $caller;
$self->add_matrix(@matrices) if @matrices;
return $self;
}
=head2 new2
=cut
sub new2 {
my $class = shift;
my %args = @_;
my $self = bless {}, ref($class) || $class;
if (defined $args{'-matrices'}) {
$self->add_matrix( @{$args{'-matrices'}} ) if @{$args{'-matrices'}};
}
if (defined $args{'-matrixfile'}) {
my @matrices;
open (FILE, $args{-matrixfile})
or $self->throw("Could not open $args{-matrixfile}");
while () {
/^\s*$/ && next;
if (/^>/) {
}
}
close(FILE);
}
return $self;
}
=head2 add_matrix
Title : add_matrix
Usage : $matrixset->add_matrix(@list_of_matrix_objects);
Function: Adds matrix objects to matrixset
Returns : object reference (usually ignored)
Args : one or more TFBS::Matrix::* objects
=cut
sub add_matrix {
my ($self, @matrices) = @_;
foreach my $matrix (@matrices) {
$self->throw("Argument to add_matrix_set not a TFBS::Matrix object")
unless $matrix->isa("TFBS::Matrix");
}
push @{$self->{matrix_list}}, @matrices;
return $self;
}
sub add_Matrix {
my $self = shift;
return $self->add_matrix(@_);
}
=head2 add_matrix_set
Title : add_matrix
Usage : $matrixset->add_matrix(@list_of_matrixset_objects);
Function: Adds to the matrixset matrix objects contained in one or
more other matrixsets
Returns : object reference (usually ignored)
Args : one or more TFBS::MatrixSet objects
=cut
sub add_matrix_set {
my ($self, @sets) = @_;
foreach my $matrixset (@sets) {
$self->throw("Argument to add_matrix_set not a TFBS::Matrixset object")
unless $matrixset->isa("TFBS::MatrixSet");
push @{$self->{matrix_list}}, @{$matrixset->{matrix_list}};
}
}
sub reset {
my ($self) = @_;
$self->warn("reset: Deprecated method use Iterator instead.");
@{$self->{_iterator_list}} = @{$self->{matrix_list}};
}
sub sort_by_name {
my ($self) = @_;
$self->warn("sort_by_name: Deprecated method use Iterator instead.");
@{$self->{matrix_list}} = sort { uc($a->{name}) cmp uc ($b->{name}) }
@{$self->{matrix_list}};
$self->reset();
}
sub next {
my ($self) = @_;
$self->warn("next: Deprecated method use Iterator instead.");
if (my $next_matrix = shift (@{$self->{_iterator_list}})) {
return $next_matrix;
}
else {
$self->reset;
return undef;
}
}
=head2 search_seq
Title : search_seq
Usage : my $siteset = $matrixset->search_seq(%args)
Function: scans a nucleotide sequence with all patterns represented
stored in $matrixset;
It works only if all matrix objects in $matrixset understand
search_seq method (currently only TFBS::Matrix::PWM objects do)
Returns : a TFBS::SiteSet object
Args : # you must specify either one of the following three:
-file, # the name od a fasta file (single sequence)
#or
-seqobj # a Bio::Seq object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-seqstring # a string containing the sequence
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
=cut
sub search_seq {
my ($self, %args) = @_;
$self->_search(%args);
}
=head2 search_aln
Title : search_aln
Usage : my $site_pair_set = $matrixset->search_aln(%args)
Function: Scans a pairwise alignment of nucleotide sequences
with the pattern represented by the PWM: it reports only
those hits that are present in equivalent positions of both
sequences and exceed a specified threshold score in both, AND
are found in regions of the alignment above the specified
conservation cutoff value.
It works only if all matrix object in $matrixset understand
search_aln method (currently only TFBS::Matrix::PWM objects do)
Returns : a TFBS::SitePairSet object
Args : # you must specify either one of the following three:
-file, # the name of the alignment file in Clustal
format
#or
-alignobj # a Bio::SimpleAlign object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-alignstring # a multi-line string containing the alignment
# in clustal format
#############
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
-window, # size of the sliding window (inn nucleotides)
# for calculating local conservation in the
# alignment
# OPTIONAL: default 50
-cutoff # conservation cutoff (%) for including the
# region in the results of the pattern search
# OPTIONAL: default "70%"
-subpart # subpart of the alignment to search, given as e.g.
# -subpart => { relative_to => 1,
# start => 140,
# end => 180 }
# where start and end are coordinates in the
# sequence indicated by relative_to (1 for the
# 1st sequence in the alignment, 2 for the 2nd)
# OPTIONAL: by default searches entire alignment
-conservation
# conservation profile, a TFBS::ConservationProfile
# OPTIONAL: by default the conservation profile is
# computed internally on the fly (less efficient)
=cut
sub search_aln {
my ($self, %args) = @_;
my $mxit = $self->Iterator();
my $sitepairset = TFBS::SitePairSet->new;
my $aln = TFBS::Matrix::_Alignment->new(%args);
while (my $mx = $mxit->next) {
my $singleset = $mx->search_aln(%args,
-alignment_setup => $aln);
$sitepairset->add_site_pair_set($singleset);
}
return $sitepairset;
}
=head2 size
Title : size
Usage : my $number_of_matrices = $matrixset->size;
Function: gets the number of matrix objects in the $matrixset
(i.e. the size of the set)
Returns : a number
Args : none
=cut
sub size {
scalar @{ $_[0]->{matrix_list} };
}
=head2 Iterator
Title : Iterator
Usage : my $matrixset_iterator =
$matrixset->Iterator(-sort_by =>'total_ic');
while (my $matrix_object = $matrix_iterator->next) {
# do whatever you want with individual matrix objects
}
Function: Returns an iterator object that can be used to go through
all members of the set
Returns : an iterator object (currently undocumentened in TFBS -
but understands the 'next' method)
Args : -sort_by # optional - currently it accepts
# 'ID' (alphabetically)
# 'name' (alphabetically)
# 'class' (alphabetically)
# 'total_ic' (numerically, decreasing order)
-reverse # optional - reverses the default sorting order if true
=cut
sub Iterator {
my ($self, %args) = @_;
return TFBS::_Iterator::_MatrixSetIterator->new($self->{matrix_list},
$args{'-sort_by'},
$args{'-reverse'}
);
}
=head2 randomize_columns
Title : randomize_columns
Usage : $matrixset->randomize_columns();
Function: Randomizes the columns between all the matrices in the set (in place).
Returns : nothing
Args : none
=cut
sub randomize_columns {
my $self = shift;
my (@lengths, @concat);
my ($length, $i) = (-1, 0);
# Concatenate to one big matrix
for my $matrix (@{$self->{matrix_list}}) {
$length += $matrix->length();
push @lengths, $matrix->length();
push @{$concat[$_]}, @{${$matrix->matrix()}[$_]} for (0..3);
}
# Schwartzian transform to get random permutation
map { ( undef, $concat[0][$i], $concat[1][$i], $concat[2][$i], $concat[3][$i] ) = @$_; $i++; }
sort { $a->[0] <=> $b->[0] }
map { [ rand(), $concat[0][$_], $concat[1][$_], $concat[2][$_], $concat[3][$_] ] } ( 0 .. $length );
# Split it up again
my $start = 0;
for my $matrix (@{$self->{matrix_list}}) {
my $length = shift(@lengths);
my $end = $start + $length - 1;
$matrix->matrix( [
[ @{$concat[0]}[$start..$end] ],
[ @{$concat[1]}[$start..$end] ],
[ @{$concat[2]}[$start..$end] ],
[ @{$concat[3]}[$start..$end] ]
]
);
$start += $length;
}
}
sub _search {
my ($self, %args) = @_;
# DIRTY - stick tmp file name to seq object
my $seqobj = $self->_to_seqobj(%args);
($seqobj->{_fastaFH}, $seqobj->{_fastafile}) = tmpnam();
# we need $fastafile below
my $outstream = Bio::SeqIO->new(-file=>">".$seqobj->{_fastafile}, -format=>"Fasta");
my $subseqobj;
if(my $subpart = $args{-subpart}) {
my $subseq_start = $subpart->{-start};
my $subseq_end = $subpart->{-end};
unless($subseq_start and $subseq_end) {
$self->throw("Option -subpart missing suboption -relative_to, -start or -end");
}
$subseqobj = Bio::Seq->new(-seq => $seqobj->subseq($subseq_start, $subseq_end),
-id => $seqobj->id);
}
$outstream->write_seq($subseqobj or $seqobj);
$outstream->close;
# iterate through pwms
my @PWMs;
my $mxit = $self->Iterator();
while (my $pwm = $mxit->next() ) {
push @PWMs,$pwm;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm (@PWMs) {
my $threshold = ($args{-threshold} or $pwm->{minscore});
$hitlist->add_siteset($pwm->search_seq(-seqobj=>$seqobj,
-threshold =>$threshold,
-subpart=>$args{-subpart}));
}
delete $seqobj->{_fastaFH};
unlink $seqobj->{_fastafile};
delete $seqobj->{_fastafile};
return $hitlist;
}
sub _csearch {
my ($self, %args) = @_;
my $PWM_SEARCH = '/home/httpd/cgi-bin/CONSITE/bin/pwm_searchPFF';
# DIRTY - stick tmp file name to seq object
my $seqobj = $self->_to_seqobj(%args);
($seqobj->{_fastaFH}, $seqobj->{_fastafile}) = tmpnam();
# we need $fastafile below
my $seqFH = Bio::SeqIO->newFh(-fh=>$seqobj->{_fastaFH}, -format=>"Fasta");
print $seqFH $seqobj;
# iterate through pwms
my @PWMs;
$self->reset();
while (my $pwm = $self->next() ) {
push @PWMs,$pwm;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm (@PWMs) {
my $threshold = ($args{-threshold} or $pwm->{minscore});
$hitlist->add_siteset($pwm->search_seq(-seqobj=>$seqobj,
-threshold =>$threshold ));
}
delete $seqobj->{_fastaFH};
delete $seqobj->{_fastafile};
return $hitlist;
}
sub _bsearch {
my ($self,%args) = @_; #the rest of @_ goes to _to_seqob;
my @PWMs;
# prepare the sequence
my $seqobj = $self->_to_seqobj(%args);
$seqobj->{_pdl_matrix} = _seq_to_pdlmatrix($seqobj);
# prepare the PWMs
$self->reset();
while (my $pwm = $self->next() ) {
push @PWMs,$pwm;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm (@PWMs) {
my $threshold = ($args{-threshold} or $pwm->{minscore});
$hitlist->add_siteset($pwm->bsearch(-seqobj=>$seqobj,
-threshold =>$threshold ));
}
delete $seqobj->{_pdl_matrix};
return $hitlist;
}
sub _seq_to_pdlmatrix {
# not OO - help function for search
my $seqobj = shift;
my $seqstring = uc($seqobj->seq());
my @perlarray;
foreach (qw(A C G T)) {
my $seqtobits = $seqstring;
eval "\$seqtobits =~ tr/$_/1/"; # curr. letter $_ to 1
eval "\$seqtobits =~ tr/1/0/c"; # non-1s to 0
push @perlarray, [split("", $seqtobits)];
}
return byte (\@perlarray);
}
sub _to_seqobj {
my ($self, %args) = @_;
my $seq;
if ($args{-file}) { # not a Bio::Seq
return Bio::SeqIO->new(-file => $args{-file},
-format => 'fasta',
-moltype => 'dna')->next_seq();
}
elsif ($args{-seqstring}
or $args{-seq})
{ # I guess it's a string then
return Bio::Seq->new(-seq => ($args{-seqstring} or $args{-seq}),
-id => ($args{-seq_id} or "undefined"),
-moltype => 'dna');
}
elsif ($args{'-seqobj'} and ref($args{'-seqobj'}) =~ /Bio\:\:Seq/) {
# do nothing (maybe check later)
return $args{'-seqobj'};
}
#elsif (ref($format) =~ /Bio\:\:Seq/ and !defined $seq) {
# if only one parameter passed and it's a Bio::Seq
#return $format;
#}
else {
$self->throw ("Wrong parameters passed to search method: ".%args);
}
# CONTINUE HERE TOMORROW
}
=head2 remove_Matrix_by_ID
Title : remove_Matrix_by_ID
Usage : $matrixset->remove_Matrix_by_ID($id);
Function: Removes a matrix from the set
Returns : Nothing
Args : None
=cut
sub remove_Matrix_by_ID {
my ($self, $id) = @_;
my @list = grep { $_->ID() ne $id } @{$self->{matrix_list}};
$self->{matrix_list} = \@list;
}
my $error;
sub _check_opt {
my ($self, $opt, $arg, $list) = @_;
# Invalid argument
if (not defined($list)) {
$error = "Invalid argument: $opt\n";
return FALSE;
}
# Valid flag or switch.
return TRUE if (not scalar(@$list));
# Valid switch, check the argument
for (@$list) {
return TRUE if ($arg eq $_) ;
}
# Valid switch, invalid argument
$error = "$arg is invalid argument to $opt";
return FALSE;
}
sub _find_optimal {
my ($self, $output) = @_;
my ($optimal, $score_best, $in) = (undef, undef, 0);
for (@$output) {
if (/NumClust/) {
$in = 1;
next;
}
last if (/Tree Built/);
if ($in) {
my (undef, $clusters, $score) = split(/\t/);
if ((not defined($score_best)) || $score < $score_best) {
$score_best = $score;
$optimal = $clusters;
}
}
}
return $optimal;
}
sub _run_STAMP {
my ($self, %args) = @_;
my $fh;
for (keys(%args)) {
die $error unless ($self->_check_opt($_, $args{$_}, $stamp_opt{$_}));
}
# Write matrices to temporary file
if (not exists($args{-tf})) {
$fh = new File::Temp( TEMPLATE => 'STAMP-XXXXX',
DIR => $args{-tempdir} || '/tmp',
SUFFIX => '.set');
print $fh $_->STAMPprint() for (@{$self->{matrix_list}});
$args{-tf} = $fh->filename();
}
# Set some default options
$args{-tree} ||= "UPGMA";
$args{-ma} ||= "IR";
$args{-cc} ||= "PCC";
$args{-align} ||= "SWU";
# Make sure we find all files
my $path;
if ($args{-stampdir}) {
$path = $args{-stampdir};
die "Could not find STAMP at $path\n" if (not -e "$path/STAMP");
} else {
$path = (grep {-e "$_/STAMP"} split(/:+/, $ENV{PATH}))[0];
$path || die "Could not find STAMP in path\n";
}
$args{-sd} ||= $path."/ScoreDists/JaspRand_".$args{-cc}."_".$args{-align}.".scores";
die "No score distribution file found or not readable at '$args{-sd}'.\n Use -sd.\n" unless (-r $args{-sd});
# Execute STAMP
my $args = "";
$args .= "$_ $args{$_} " for (keys(%args));
my @output = `$path/STAMP -ch $args -out $fh`;
# Get tree
my $treeio = new Bio::TreeIO(-format => 'newick', -file => $fh->filename().".tree");
my $tree = $treeio->next_tree;
# Get FBP
my $fbp = TFBS::Matrix::PFM->new(-matrixfile => $fh->filename()."FBP.txt");
$fbp->{'filename'} = $fh->filename()."FBP.txt";
print STDERR "::: $fbp->{'filename'} \n";
if (not $args{-noclean}) {
my $deleted = unlink($fh->filename()."FBP.txt", $fh->filename().".tree");
warn("Couldn't remove temporary files") if ($deleted != 2);
}
return ($fh, \@output, $tree, $fbp);
}
sub _build_cluster {
my ($self, $cluster, $node) = @_;
if ($node->is_Leaf()) {
for (@{$self->{matrix_list}}) {
if ($_->ID() eq $node->id()) {
$cluster->add_matrix($_);
return;
}
}
} else {
$self->_build_cluster($cluster, $_) for ($node->each_Descendent());
}
}
=head2 cluster
Title : cluster
Usage : $matrixset->cluster(%args)
Function: Clusters the matrices in the set
Returns : The root node of the hierachical clustering tree.
An integer specifying the optimal number of clusters.
An array of TFBS::MatrixSets, one for each cluster.
Args : Many:
-stampdir Directory where stamp is located. Not necessary if it is in the PATH.
-tempdir Directory to put temporary files. Defaults to "/tmp"
-noclean 0 to clean up temporary files, 1 otherwise
-tree Method for constructing tree (UPGMA/SOTA). Def:UPGMA
=cut
sub cluster {
my ($self, %args) = @_;
if ($self->size() <= 1) {
warn("Can't cluster MatrixSet of size less than 2");
return;
}
my ($fh, $output, $tree, $fbp) = $self->_run_STAMP(%args);
# Find optimal cluster number
my $optimal = $args{-optimal} || $self->_find_optimal($output);
my $root = $tree->get_root_node();
my @nodes = ($root);
my @leaves;
# Descend the tree until the optimal cluster number is reached
while (scalar(@nodes) && (scalar(@nodes) + scalar(@leaves)) < $optimal) {
my $node = pop @nodes;
if ($node->is_Leaf()) {
push @leaves, $node;
} else {
@nodes = sort {$a->height() <=> $b->height()} (@nodes, $node->each_Descendent());
}
}
# Build the clusters
my @clusters;
for (@leaves, @nodes) {
my $cluster = $self->new();
$self->_build_cluster($cluster, $_);
push @clusters, $cluster;
}
return ($tree, $optimal, \@clusters);
}
=head2 fbp
Title : fbp
Usage : $matrixset->fbp(%args);
Function: Creates a familial binding profile (FBP) for the set
Returns : A familial binding profile represented as a TFBS::Matrix::PFM
Args : Many
-stampdir Directory where stamp is located. Not necessary if it is in the PATH.
-tempdir Directory to put temporary files. Defaults to "/tmp"
-noclean 0 to clean up temporary files, 1 otherwise
-align Alignment method
=cut
sub fbp {
my ($self, %args) = @_;
if ($self->size() == 0) {
warn("Can't create FBP for MatrixSet of size 0");
return;
} elsif ($self->size() == 1) {
return @{$self->{'matrix_list'}}[0];
}
my ($fh, $output, $tree, $fbp) = $self->_run_STAMP(%args);
return $fbp;
}
1;
TFBS-0.7.1/TFBS/PatternGen.pm 0000775 0000000 0000000 00000011303 13057522667 0015436 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen - a base class for pattern generators
=head1 DESCRIPTION
TFBS::PatternGen is a base class providing methods common to all pattern generating
modules. It is meant to be inherited by a concrete pattern generator, which must have its own
constructor.
=cut
package TFBS::PatternGen;
# Object preamble - inherits from TFBS::PatternGenI;
use vars qw(@ISA);
use strict;
use TFBS::PatternGenI;
# use TFBS::PatternGen::_Motif_;
use Bio::Seq;
use Bio::SeqIO;
use Carp;
@ISA = qw(TFBS::PatternGenI);
sub new {
confess("TFBS::PatterGen is a base class for particular pattern generators".
"and cannot be instantiated itself.");
}
=head2 pattern
Title : pattern
Usage : my $pattern_obj = $patterngen->pattern()
Function: retrieves a pattern object produced by the pattern generator
Returns : a pattern object (currently available pattern generators
return a TFBS::Matrix::PFM object)
Args : none
Warning : If a pattern generator produces more than one pattern,
this method call returns only the first one and prints
a warning on STDERR, In those cases you should use
I or I methods.
=cut
sub pattern {
my ($self, %args) =@_;
my @PFMs = $self->_motifs_to_patterns(%args);
if (scalar(@PFMs) > 1) {
$self->warn("The pattern generator produced multiple patterns. ".
"Please use patternSet method to retrieve a set object, ".
"or all_patterns method to retrieve an array of patterns");
}
return $PFMs[0];
}
=head2 patternSet
Title : patternSet
Usage : my $patternSet = $patterngen->patternSet()
Function: retrieves a pattern set object containing all the patterns
produced by the pattern generator
Returns : a pattern set object (currently available pattern generators
return a TFBS::MatrixSet object)
Args : none
=cut
sub patternSet {
my ($self, %args) = @_;
my @PFMs = $self->_motifs_to_patterns(%args);
my $set = TFBS::MatrixSet->new();
$set->add_matrix(@PFMs);
return $set;
}
=head2 all_patterns
Title : all_patterns
Usage : my @patterns = $patterngen->all_patterns()
Function: retrieves an array of pattern objects
produced by the pattern generator
Returns : an array of pattern set objects (currently available
pattern generators return an array of
TFBS::Matrix::PFM objects)
Args : none
=cut
sub all_patterns {
my ($self, %args) = @_;
my @patterns = $self->_motifs_to_patterns(%args);
return @patterns;
}
sub _create_seq_set {
my ($self, %args) = @_;
my (@raw_set, @final_set);
if ($args{-seq_list}) {
@raw_set = @{$args{-seq_list}};
}
elsif ($args{-seq_stream} ) {
while (my $seqobj = $args{-seq_stream}->next_seq()) {
push @raw_set, $seqobj;
}
}
elsif ($args{-seq_file} ) {
my $seqstream = Bio::SeqIO->new(-file=>$args{-seq_file},
-format=>"fasta");
while (my $seqobj = $seqstream->next_seq()) {
push @raw_set, $seqobj;
}
}
foreach my $seqobj (@raw_set) {
my $i = 1; #for unnamed sequences
if (ref($seqobj)) {
my $seqstring;
eval { $seqstring = $seqobj->seq() };
if ($@) {
$self->throw("Invalid sequence object passed in -seq_set.");
}
else {
_validate_seq(uc $seqstring)
or $self->throw("Illegal character(s) in sequence: $seqstring");
}
push @final_set, $seqobj;
}
else {
my $seqstring = $seqobj;
_validate_seq(uc $seqstring)
or $self->throw("Illegal character(s) in sequence: $seqstring");
push @final_set, Bio::Seq->new(-seq=>$seqstring,
-ID=>"unnamed".$i++,
-type=>"dna");
}
}
$self->{'seq_set'} = \@final_set;
return 1;
}
sub _motifs_to_patterns {
my ($self, %args) = @_;
my $i = 1;
my @patterns;
my %params = ( -name => "motif",
-ID => "motif",
-class => "unknown",
%args);
foreach my $motif (@{ $self->{'motifs'} }) {
push @patterns, $motif->pattern(-name => $params{-name}.$i,
-ID => $params{-ID}."#".$i,
-class => $params{-class});
$i++;
}
return @patterns;
}
sub _validate_seq {
# a utility function
my $sequence = uc $_[0];
$sequence=~ s/[ACGTN]//g;
return ($sequence eq "" ? 1 : 0);
}
sub _check_seqs_for_uniform_length {
my $self = shift;
my $reflength = $self->{'seq_set'}->[-1]->length();
foreach my $seqobj ( @{ $self->{'seq_set'} } ) {
if ($seqobj->length() != $reflength) {
$self->throw(ref($self). "object has received sequences of unequal length");
}
}
}
sub all_motifs {
return @{$_[0]->{'motifs'}} if $_[0]->{'motifs'};
}
TFBS-0.7.1/TFBS/PatternGen/ 0000775 0000000 0000000 00000000000 13057522667 0015077 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0015763 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/.svn/all-wcprops 0000775 0000000 0000000 00000001303 13057522667 0020151 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 44
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen
END
Gibbs.pm
K 25
svn:wc:ra_dav:version-url
V 53
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Gibbs.pm
END
AnnSpec.pm
K 25
svn:wc:ra_dav:version-url
V 55
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/AnnSpec.pm
END
Elph.pm
K 25
svn:wc:ra_dav:version-url
V 52
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Elph.pm
END
YMF.pm
K 25
svn:wc:ra_dav:version-url
V 51
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/YMF.pm
END
SimplePFM.pm
K 25
svn:wc:ra_dav:version-url
V 57
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/SimplePFM.pm
END
MEME.pm
K 25
svn:wc:ra_dav:version-url
V 52
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/MEME.pm
END
TFBS-0.7.1/TFBS/PatternGen/.svn/entries 0000775 0000000 0000000 00000001745 13057522667 0017371 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/PatternGen
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
Gibbs.pm
file
2009-08-07T13:10:58.000000Z
5dfe55dc5e474abf13353d6371bfb056
2008-01-24T20:21:25.772223Z
8
chrb
AnnSpec.pm
file
2009-08-07T13:10:58.000000Z
c12e1394e2c7ed39608ad57960adf7f1
2008-01-24T20:21:25.772223Z
8
chrb
MEME
dir
Elph.pm
file
2009-08-07T13:10:58.000000Z
b28cb34f5e5efeef3e20b026b5e03f71
2008-01-24T20:21:25.772223Z
8
chrb
Gibbs
dir
YMF.pm
file
2009-08-07T13:10:58.000000Z
7531fcf49cc6018822dc6b1c94bf18c3
2008-01-24T20:21:25.772223Z
8
chrb
AnnSpec
dir
SimplePFM.pm
file
2009-08-07T13:10:59.000000Z
8b2431fd45966d310acbea1d31f85fd7
2008-01-24T20:21:25.772223Z
8
chrb
Elph
dir
YMF
dir
Motif
dir
MEME.pm
file
2009-08-07T13:10:59.000000Z
69957d56c278eb8223d648e07f70f27f
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/PatternGen/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0017171 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/PatternGen/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0017657 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/.svn/text-base/AnnSpec.pm.svn-base 0000775 0000000 0000000 00000014516 13057522667 0023273 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::AnnSpec
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec - a pattern factory that uses the AnnSpec program (version 2.1)
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::AnnSpec->new(-seq_file=>'sequences.fa',
-binary => 'ann-spec '
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::AnnSpec builds position frequency matrices
using an external program AnnSpec (Workman, C. and Stormo, G.D. (2000) ANN-Spec: A method for discovering transcription factor binding sites with improved specificity. Proc. Pacific Symposium on Biocomputing 2000).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.se
=cut
package TFBS::PatternGen::AnnSpec;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::AnnSpec::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $pattrengen = TFBS::PatternGen::AnnSpec->new(%args);
Function: the constructor for the TFBS::PatternGen::AnnSpec object
Returns : a TFBS::PatternGen::AnnSpec object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to the 'meme' executable
# OPTIONAL: default 'ann-spec'
-additional_params # a string containing additional
# command-line switches for the
# ann-spec program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'filename'} =$args{'-seq_file'};
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'annspec';
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_AnnSpec() or $self->throw("Error running AnnSpec.");
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _run_AnnSpec{
my ($self)=shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $command_line =
$self->{'binary'}." ".
"-f ".$tmp_file." ".
# $self->{'motif_length_string'}." ".
# $self->{'nr_hits_string'}." ".
$self->{'additional_params'}.
"";
# print STDERR "$command_line\n";
my $resultstring = `$command_line`;
print "$resultstring\n";
# open(TEST, "test.out"); # this sentense is the one I add
# my @lines = ;# this sentense is the one I add
# my $resultstring = join '', @lines;# this sentense is the one I add
# print STDERR $resultstring;
$self->_parse_AnnSpec_output($resultstring,$command_line);
unlink $tmp_file;
return 1
}
sub _parse_AnnSpec_output{
my ($self,$resultstring,$command_line)=@_;
if ($resultstring eq''){
# warn "Error running AnnSpec\nNo patterns produced";
$self->throw ("Error running AnnSpec using command:\n $command_line");
return;
}
my ($consensus,$matrix)=$self->_parse_raw_matrix($resultstring);
my ($score,$sites)=$self->_parse_sites($resultstring);
for(my $x = 0; $x < scalar(@$consensus); $x++){
my $motif =TFBS::PatternGen::AnnSpec::Motif->new
(
#-length => $length."",
# -bg_probabilities => [split /\s+/, $raw_bp],
-tags => {consensus => $consensus->[$x],
score=>$score->[$x]},
-nr_hits => 1,
-sites=>$sites->[$x],
-matrix => $matrix->[$x]
);
push @{ $self->{'motifs'} }, $motif;
}
return
}
sub _parse_sites{
my ($self,$string)=@_;
my (@hits, @scores);
foreach my $substring (split /REPORTING/, $string ){
my @sub_hits;
my ($sites)=$substring=~/STR\s+n.*seq\n(.*)RUN\s+ALIGNMENT.*/s;
my ($average)=$substring=~/RUN INFORMATION_CONTENT\s+(\d*\.*\d*)/;
my ($score)=$substring=~/RUN\s+SCORE\s+(\d*\.*\d*)/;
if($sites){
my @sites=split/\n/,$sites;
foreach my $site (@sites){
my @site_array=split(/\s+/,$site);
my ($seq_id)=$site_array[6]=~/>(.*)/;
my $strand=1;
$strand=-1 if $site_array[3]=~/\'/;#MEans we have a pattern in the reverse strand
my ($start)=$site_array[3]=~/(\d+)/;
my $site = Bio::SeqFeature::Generic->new ( -start => $start,
-end => $start+(length$site_array[4])-1,
-strand => $strand,
-source => 'AnnSpec',
-score => $site_array[2],
);
foreach my $seq(@{$self->{'seq_set'}}){
if ($seq->id eq $seq_id){
$site->attach_seq ($seq);
}
}
push (@sub_hits,$site);
}
push @scores, $score;
push @hits, \@sub_hits;
}
}
return \@scores,\@hits;
}
sub _parse_raw_matrix{
my ($self,$string)=@_;
my (@pfms, @consensus);
foreach my $sub_string (split /REPORTING/, $string){
my ($ma)=$sub_string=~/RUN\s+WEIGHTS_CONS.*ALR\s+\/.*ALR\s+\#.*(ALR.*\nALR.*\nALR.*\nALR.*\s+\d+\n)ALR\s+=+.*/s;
my ($con)=$sub_string=~/WEIGHTS_CONS\s+(.*)\n/;
if($ma){
my @matrix=split("\n",$ma);
my @pfm;
foreach my $row(@matrix){
# print $row;
my @row=split /\s+/, $row;
push @pfm, [@row[2..scalar@row-1]];
}
push @pfms, \@pfm;
push @consensus, $con;
}
}
return \@consensus, \@pfms;
}
1;
TFBS-0.7.1/TFBS/PatternGen/.svn/text-base/Elph.pm.svn-base 0000775 0000000 0000000 00000020216 13057522667 0022626 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::Elph
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::Elph - a pattern factory that uses the Elph program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::Elph->new(-seq_file=>'sequences.fa',
-binary => '/Elph/elph'
-motif_length => [8, 9, 10],
-additional_params => '-x -r -e');
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::Gibbs builds position frequency matrices
using an advanced Gibbs sampling algorithm implemented in external
I program by Chip Lawrence. The algorithm can produce
multiple patterns from a single set of sequences.
=cut
package TFBS::PatternGen::Elph;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::Elph::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $db = TFBS::PatternGen::Gibbs->new(%args);
Function: the constructor for the TFBS::PatternGen::Gibbs object
Returns : a TFBS::PatternGen::Gibbs object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to Gibbs executable
# OPTIONAL: default 'Gibbs'
-nr_hits # a presumed number of pattern occurences in the
# sequence set: it can be a single integer, e.g.
# -nr_hits => 24 , or a reference to an array of
# integers, e.g -nr_hits => [12, 24, 36]
-motif_length # an expected length of motif in nucleotides:
# it can be a single integer, e.g.
# -motif_length => 8 , or a reference to an
# array ofintegers, e.g -motif_length => [8..12]
-additional_params # a string containing additional
# command-line switches for the
# Gibbs program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'motif_length_string'} =
($args{'-motif_length'}
? (ref($args{'-motif_length'})
? join(',', @{$args{'-motif_length'}})
: $args{'-motif_length'})
: 8 );
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'elph';
$self->{'motifs'} = [];
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_elph() or $self->throw("Error running elph.");
return $self;
}
sub _run_elph {
my $self = shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
$self->{'additional_params'}=~s/-b//;
#This removes a -b switch. This enables long output containgin info about the sites
my $command_line =
$self->{'binary'}." ".
$tmp_file." ".
"LEN=".$self->{'motif_length_string'}." ".
$self->{'additional_params'}." 2>/dev/null";
my $resultstring = `$command_line`;
$self->_parse_elph_output($resultstring,$command_line);
#print STDERR "$command_line\n";
#print STDERR $resultstring;
# unlink $tmp_file;
return 1
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _parse_elph_output {
my ($self, $resultstring,$command_line) = @_;
#print $resultstring;
if ($resultstring=~/^error/){
$self->throw ("Error running elp command:\n $command_line");
return;
}
#Motif after optimizing
#MAP for motif: 46.735 InfoPar=0.098
#
#Motif found:
#
#Background probability model:
# a c g t
# 0.30 0.20 0.19 0.31
#
#Background counts:
#a: 1456
#c: 948
#g: 909
#t: 1487
#
#
#Motif probability model:
#Pos: 1 2 3 4 5 6
#a 1.00 0.00 1.00 0.83 0.00 0.00
#c 0.00 0.00 0.00 0.00 0.00 0.17
#g 0.00 1.00 0.00 0.17 1.00 0.83
#t 0.00 0.00 0.00 0.00 0.00 0.00
#------------------------------------------
#Info 1.73 2.42 1.73 1.19 2.42 1.75
#
#Motif counts:
#a: 6 0 6 5 0 0
#c: 0 0 0 0 0 1
#g: 0 6 0 1 6 5
#t: 0 0 0 0 0 0
#
#
(my $MAP)=$resultstring=~/MAP for motif: (.*) InfoPar=/;
($resultstring)=~s/.*Motif counts:\n//s;
#print STDERR $resultstring;
my @array=split "\n",$resultstring;
my @matrix;
#print $array[0],"\n";
foreach (0..3){
my (@line)=split(/\s+/,$array[$_]);
#print "@line\n";
shift @line;
push @matrix,\@line;
# print "@line\n";
}
# print @matrix;
#print $resultstring;
my $sites=$self->_site_props($resultstring);
my $motif =TFBS::PatternGen::Elph::Motif->new
(
-tags => {score=>$MAP},#The score in this case is the E-value given in the output
-sites=>$sites,
-matrix => \@matrix
);
# Seq.no Pos ***** Motif ***** Prob D Seq.Id
# 1 354 ggatt AGAAGC cgccg 0.1389 -1 GAL1
# 2 636 caaag AGAAGG ttttt 0.6942 -1 GAL10
# 3 456 aaggc AGAAGG cagta 0.6942 -1 GAL2
# 4 444 aaagt AGAGGG ggtaa 0.1388 -1 GAL7
# 5 324 tagag AGAAGG agcaa 0.6942 -1 GAL80
# 6 165 gttac AGAAGG gccgc 0.6942 -1 GCY1
#$resultstring =~ s/.*=== MAP MAXIMIZATION RESULTS ===//s;
#my @raw_motifs = split /\-+\n\s+MOTIF \w\n/s, $resultstring;
#shift @raw_motifs; # discard the first one
#foreach my $raw_motif (@raw_motifs) {
# #print $raw_motif;
# my $motif =$self->_parse_raw_motif($raw_motif) || next;
push @{ $self->{'motifs'} }, $motif;
#}
#return 1;
}
sub _site_props{
my ($self,$resultstring)=@_;
my @sites;
# print $resultstring;
#($resultstring)=~s/.*Motif counts:\n//s;
my @array=split(/Seq\.no/,$resultstring);
#print $array[1];
my @sites_array=split "\n", $array[1];
foreach my $line(@sites_array){
# print $line;
next if $line=~/Pos/;
last if $line eq'';
my @site=split(/\s+/,$line);
# print $site[1],"\n";
my $nr=0;
$nr = 1 if $site[2]==1;
#A special case when the site startsat the first base.
#Then no preceding quence is given and the site array =shorter by 1
my $motif_seq=$site[4-$nr];
# print $motif_seq,"\n";
my $site = Bio::SeqFeature::Generic->new ( -start => $site[2],
-end => $site[2]+(length$motif_seq)-1,
-strand => 1,
#Always 1 with elph
-source => 'Elph',
-score => $site[-3],
);
foreach my $seq(@{$self->{'seq_set'}}){
if ($seq->id eq $site[-1]){#last element of the array
$site->attach_seq ($seq);
}
}
push (@sites,$site);
}
return \@sites;
}
1;
TFBS-0.7.1/TFBS/PatternGen/.svn/text-base/Gibbs.pm.svn-base 0000775 0000000 0000000 00000020124 13057522667 0022762 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::Gibbs
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::Gibbs - a pattern factory that uses Chip Lawrences Gibbs program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::Gibbs->new(-seq_file=>'sequences.fa',
-binary => '/Programs/Gibbs-1.0/bin/Gibbs'
-nr_hits => 24,
-motif_length => [8, 9, 10],
-additional_params => '-x -r -e');
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::Gibbs builds position frequency matrices
using an advanced Gibbs sampling algorithm implemented in external
I program by Chip Lawrence. The algorithm can produce
multiple patterns from a single set of sequences.
=cut
package TFBS::PatternGen::Gibbs;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::Gibbs::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $db = TFBS::PatternGen::Gibbs->new(%args);
Function: the constructor for the TFBS::PatternGen::Gibbs object
Returns : a TFBS::PatternGen::Gibbs object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to Gibbs executable
# OPTIONAL: default 'Gibbs'
-nr_hits # a presumed number of pattern occurences in the
# sequence set: it can be a single integer, e.g.
# -nr_hits => 24 , or a reference to an array of
# integers, e.g -nr_hits => [12, 24, 36]
-motif_length # an expected length of motif in nucleotides:
# it can be a single integer, e.g.
# -motif_length => 8 , or a reference to an
# array ofintegers, e.g -motif_length => [8..12]
-additional_params # a string containing additional
# command-line switches for the
# Gibbs program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'motif_length_string'} =
($args{'-motif_length'}
? (ref($args{'-motif_length'})
? join(',', @{$args{'-motif_length'}})
: $args{'-motif_length'})
: 8 );
$self->{'nr_hits_string'} =
($args{'-nr_hits'}
? (ref($args{'-nr_hits'})
? join(',', @{$args{'-nr_hits'}})
: $args{'-nr_hits'})
: "" );
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'Gibbs';
$self->{'motifs'} = [];
$self->_create_seq_set(%args) or die ('Error creating sequence set');
#print $self->{'seq_set'}->[0]->seq;
#$self->_seq_props;
$self->_run_Gibbs() or $self->throw("Error running Gibbs.");
return $self;
}
sub _run_Gibbs {
my $self = shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $command_line =
$self->{'binary'}." ".
" -PBernoulli ".
$tmp_file." ".
$self->{'motif_length_string'}." ".
$self->{'nr_hits_string'}." ".
$self->{'additional_params'}." -n";
my $resultstring = `$command_line`;
$self->_parse_Gibbs_output($resultstring);
#print STDERR "$command_line\n";
#print STDERR $resultstring;
unlink $tmp_file;
return 1
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _parse_Gibbs_output {
my ($self, $resultstring) = @_;
#print $resultstring;
#print"===========END_RESULTSTRING===============================\n";
$resultstring =~ s/.*=== MAP MAXIMIZATION RESULTS ===//s;
my @raw_motifs = split /\-+\n\s+MOTIF \w\n/s, $resultstring;
shift @raw_motifs; # discard the first one
foreach my $raw_motif (@raw_motifs) {
#print $raw_motif;
my $motif =$self->_parse_raw_motif($raw_motif) || next;
push @{ $self->{'motifs'} }, $motif;
}
return 1;
}
sub _site_props{
my ($self,$raw_motif)=@_;
my @sites;
# print $raw_motif;
$raw_motif=~s/.*Num Motifs:\s+\d+\n//s;
# print $raw_motif;
#print "#####################################################\n";
$raw_motif=~s/\n\s+\*+.*//s;
#print $raw_motif,"\n";
my @site_lines=(split("\n", $raw_motif));
foreach my $site(@site_lines){
my $start_seq;
my $end_seq;
my ($seq_nr,$pattern_nr,$start,$seq,$end,$score,$strand,$desc)=$site=~/\s+(\d+),\s+(\d+)\s+(\d+)\s+([\w,\s]+)\s+(\d+)\s+(\d\.\d+)\s+([F,R])(.*)/;
# print $seq_nr,$pattern_nr,$start,$seq;
if ($strand eq "F"){
$strand=1;
$start_seq=$start;
$end_seq=$end;
}
else{
$strand=-1;
$start_seq=$end;
$end_seq=$start;
}
#print $site;
my $site = Bio::SeqFeature::Generic->new ( -start => $start_seq,
-end => $end_seq,
-strand => $strand,
-source => 'Gibbs sampler',
-score => $score,
);
$site->attach_seq ($self->{'seq_set'}->[$seq_nr-1]);
push (@sites,$site);
}
foreach my $site(@sites){
#print $site->start."\n";
}
return \@sites;
}
sub _parse_raw_motif {
# a utility function
my ($self,$raw_motif) = @_;
# print $raw_motif;
my ($raw_matrix, $raw_bp, $length, $nr_hits, $MAP_score) =
$raw_motif =~ /Motif model \(residue frequency x 100\)\n(.+)Motif probability model\n.+Background probability model\n\s+(.+?)\n.+\D(\d+) columns\nNum Motifs\: (\d+).+Difference of Logs of Maps = ([\-\.\d]+)\n/s;
#print $raw_matrix;
return undef unless $raw_matrix;
my $sites = $self->_site_props($raw_motif);
# print STDERR
# join ":", ($raw_matrix, $raw_bp, $length, $nr_hits); print "\n";
my $matrix = _parse_raw_matrix($raw_matrix);
#print $matrix;
return
TFBS::PatternGen::Gibbs::Motif->new
#This object does not contain a new method. Instead the new method is than searched in the first ISA package. Remember that the object is still a TFBS::PatternGen::Gibbs::Motif.
#The only ISA in the package is TFBS::PatternGen::Motif.pm. This package indeed contains the new method
(-length => $length."",
-bg_probabilities => [split /\s+/, $raw_bp],
-MAP_score => $MAP_score,
-tags => {MAP_score => $MAP_score},
-nr_hits => $nr_hits,
-sites=>$sites,
-matrix => $matrix );
}
sub _parse_raw_matrix {
# a utility function
my $raw_matrix = shift;
my @lines = split "\n", $raw_matrix;
my (@A, @C, @G, @T);
foreach my $line (@lines) {
my $value_string;
next unless ($value_string) = $line =~ /\s+\d+\s+\|\s+(.+)/;
$value_string =~ s/\./0/g;
my ($a, $t, $c, $g) = split /\s+/, $value_string;
push @A, $a;
push @C, $c;
push @G, $g;
push @T, $t;
}
# print STDERR join(" ",@A, "\n", @C, "\n", @G, "\n", @T, "\n");
return [\@A, \@C, \@G, \@T];
}
1;
TFBS-0.7.1/TFBS/PatternGen/.svn/text-base/MEME.pm.svn-base 0000775 0000000 0000000 00000014017 13057522667 0022463 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::MEME
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::MEME - a pattern factory that uses the MEME program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::MEME->new(-seq_file=>'sequences.fa',
-binary => 'meme'
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::MEME builds position frequency matrices
using an external program MEME written by Bailey and Elkan.
For information and source code of MEME see
http://www.sdsc.edu/MEME
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=cut
package TFBS::PatternGen::MEME;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::SimplePFM;
use TFBS::PatternGen::MEME::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $pattrengen = TFBS::PatternGen::MEME->new(%args);
Function: the constructor for the TFBS::PatternGen::MEME object
Returns : a TFBS::PatternGen::MEME object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to the 'meme' executable
# OPTIONAL: default 'meme'
-additional_params # a string containing additional
# command-line switches for the
# meme program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'filename'} =$args{'-seq_file'};
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'meme';
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_meme() or $self->throw("Error running MEME.");
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _run_meme{
my ($self)=shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $command_line =
$self->{'binary'}." ".
$tmp_file." ".
"-text ".
"-dna ".
$self->{'additional_params'}
." 2>/dev/null"
;
# print STDERR "$command_line\n";
my $resultstring = `$command_line`;
# print STDERR $resultstring;
$self->_parse_meme_output($resultstring,$command_line);
unlink $tmp_file;
return 1
}
sub _parse_meme_output{
my ($self,$resultstring,$command_line)=@_;
if ($resultstring=~/^error/){
# warn "Error running AnnSpec\nNo patterns produced";
$self->throw ("Error running MEME command:\n $command_line");
return;
}
my @motifs=split(/\*\nMOTIF/,$resultstring);
shift @motifs;#discard the first one
#print STDERR scalar @motifs,"\n";
foreach my $raw_motif(@motifs){
my ($matrix,$sites,$score)=$self->_parse_raw_matrix($raw_motif);
# print STDERR $matrix;
my $motif =TFBS::PatternGen::MEME::Motif->new
(
-tags => {score=>$score},#The score in this case is the E-value given in the output
-sites=>$sites,
-matrix => $matrix
);
push @{ $self->{'motifs'} }, $motif;
}
return
}
#
#
sub _parse_raw_matrix{
my ($self,$string)=@_;
my @sites;
my @matrix;
$string=~s/(Motif \d+ block diagrams.*)//s;
# print STDERR $string;
my ($width,$e_value)=$string=~/width =\s+(\d+)\s+sites.*E-value =(.*)\n/;
# print STDERR $e_value,"\n";
$string=~s/.*Motif \d+ sites sorted by position p-value//s;
#print STDERR $string;
my @array=split("\n",$string);
foreach my $line(@array){
my $nr=0;
my $strand=1;#if revcomp is not selected teh strand is always 1
next if $line=~/^-/;
next if $line=~/P-value\s+Site/;
my (@properties)=split(/\s+/,$line);
next if @properties<1;
# print STDERR "@properties\n";
#First determine whether -revcomp switch is used and thus strand info is given
if ($properties[1] eq "+" or $properties[1] eq "-"){
$strand=$properties[1];
$nr=1;
}
my $site = Bio::SeqFeature::Generic->new ( -start =>$properties[1+$nr],
-end =>$properties[1+$nr]+$width-1,
-strand=>$strand,
-source=>'MEME',
-score=>$properties[2+$nr]
);
foreach my $seq(@{$self->{'seq_set'}}){
if ($seq->id eq $properties[0]){
$site->attach_seq ($seq);
}
}
push @sites,$site;
}
foreach my $site(@sites){
push @matrix,$site->seq->seq;
}
my $patterngen=TFBS::PatternGen::SimplePFM->new(-seq_list=>\@matrix);
my $matrix=$patterngen->pattern->rawprint;
# print STDERR $matrix;
return ($matrix,\@sites,$e_value);
}
1; TFBS-0.7.1/TFBS/PatternGen/.svn/text-base/SimplePFM.pm.svn-base 0000775 0000000 0000000 00000006317 13057522667 0023540 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::SimplePFM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::SimplePFM - a simple position frequency matrix factory
=head1 SYNOPSIS
my @sequences = qw( AAGCCT AGGCAT AAGCCT
AAGCCT AGGCAT AGGCCT
AGGCAT AGGTTT AGGCAT
AGGCCT AGGCCT );
my $patterngen =
TFBS::PatternGen::SimplePFM->new(-seq_list=>\@sequences);
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::SimplePFM generates a position frequency matrix from a set
of nucleotide sequences of equal length, The sequences can be passed either
as strings, as Bio::Seq objects or as a fasta file.
This pattern generator always creates only one pattern from a given set
of sequences.
=cut
package TFBS::PatternGen::SimplePFM;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGenI;
use TFBS::PatternGen;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $db = TFBS::PatternGen::SimplePFM->new(%args);
Function: the constructor for the TFBS::PatternGen::SimplePFM
object
Returns : a TFBS::PatternGen::SimplePFM obkect
Args : This method takes named arguments;
you must specify one of the following
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_check_seqs_for_uniform_length();
$self->{'motifs'} = [$self->_create_motif()];
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three above methods are used fro the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _create_motif {
my $self = shift;
my $length = $self->{'seq_set'}->[-1]->length();
# initialize the matrix
my $matrixref = [];
for my $i (0..3) {
for my $j (0..$length-1) {
$matrixref->[$i][$j] = 0;
}
}
#fill the matrix
my @base = qw(A C G T);
foreach my $seqobj ( @{ $self->{seq_set} } ) {
for my $i (0..3) {
my $seqstring = $seqobj->seq;
my @seqbase = split "", uc $seqstring;
for my $j (0..$length-1) {
$matrixref->[$i][$j] += ($base[$i] eq $seqbase[$j])?1:0;
}
}
}
my $nrhits =0; for my $i (0..3) {$nrhits += $matrixref->[$i][0];}
my $motif =
TFBS::PatternGen::Motif::Matrix->new(-matrix => $matrixref,
-nr_hits=> $nrhits);
return $motif;
}
sub _validate_seq {
# a utility function
my ($sequence)=@_;
$sequence=~ s/[ACGT]//g;
return ($sequence eq "" ? 1 : 0);
}
1; TFBS-0.7.1/TFBS/PatternGen/.svn/text-base/YMF.pm.svn-base 0000775 0000000 0000000 00000012303 13057522667 0022367 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::YMF
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::MEME - a pattern factory that uses the MEME program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::MEME->new(-seq_file=>'sequences.fa',
-binary => 'meme'
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::MEME builds position frequency matrices
using an external program MEME written by Bailey and Elkan.
For information and source code of MEME see
http://www.sdsc.edu/MEME
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=cut
package TFBS::PatternGen::YMF;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::YMF::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
use File::Temp qw/ tempfile tempdir /;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $patterngen = TFBS::PatternGen::YMF->new(%args);
Function: the constructor for the TFBS::PatternGen::MEME object
Returns : a TFBS::PatternGen::MEME object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to the 'meme' executable
# OPTIONAL: default 'meme'
-additional_params # a string containing additional
# command-line switches for the
# meme program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'width'}=$args{'-length_oligo'};
$self->{'path_org'}=$args{'-pathoforganismtables'};
$self->{'len_region'}=$args{'-length_region'};
$self->{'config_file'}=$args{'-config_file'}||$args{'-stats_path'}."/stats.config";
#The latter is the example configfile that comes with the installation of YMF
$self->{'abs_stats_path'} = $args{'-abs_stats_path'} ;
#This is the directory where the executable and the results file is
#generated by the program are located
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_stats() or $self->throw("Error running stats.");
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _run_stats{
my ($self)=shift;
my $tmp_file = tmpnam();
my $dumpfile = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $dir = tempdir();
#print $dir;
#change directory to directory where the program is located
#system 'cd $dir.w;';
# my $command="cd $dir;";
# print $command;
# system $command;
# `$command`;
# system 'ls -ltr';
my $command_line =
$self->{'abs_stats_path'}."/stats ".
# "stats ".
$self->{'config_file'}." ".
$self->{'len_region'}." ".
$self->{'width'}." ".
$self->{'path_org'}." ".
"-sort ".#sorts on z-score
$tmp_file
." >$dumpfile"
;
# print STDERR "cd $dir;$command_line\n";
my $resultstring = `cd $dir;$command_line`;
# print STDERR $resultstring;
$self->_parse_stats_output($resultstring,$command_line,$dumpfile,$dir);
unlink $tmp_file;
#unlink $dumpfile;
return 1
}
#
sub _parse_stats_output{
my ($self,$resultstring,$command_line,$dumpfile,$temp_dir)=@_;
open DUMP,$dumpfile;
while(){
if ((/(^Error.*)/) or /(.*Aborting.*)/){
# warn "Error running AnnSpec\nNo patterns produced";
print "YMF Error message: \"$1\"\n";
unlink $dumpfile;
$self->throw ("Error running YMF using command:\n $command_line");
return;
}
}
unlink $dumpfile;
open RES,"$temp_dir/results";
my $skip=;
while (){
my ($word,$occ,$z_score,$expect,$var)=split;
#print $word;
my $motif =TFBS::PatternGen::YMF::Motif->new
(-word=>$word,
-tags => {z_score=>$z_score,
'occurences'=>$occ,
'expectation value'=>$expect,
'variance'=>$var}
);
push @{ $self->{'motifs'} }, $motif;
}
my $command="rm -r $temp_dir";
#print $command;
`$command`;# or die "could not unlink $!";
# return
}
#
1; TFBS-0.7.1/TFBS/PatternGen/AnnSpec.pm 0000775 0000000 0000000 00000014516 13057522667 0016776 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::AnnSpec
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec - a pattern factory that uses the AnnSpec program (version 2.1)
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::AnnSpec->new(-seq_file=>'sequences.fa',
-binary => 'ann-spec '
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::AnnSpec builds position frequency matrices
using an external program AnnSpec (Workman, C. and Stormo, G.D. (2000) ANN-Spec: A method for discovering transcription factor binding sites with improved specificity. Proc. Pacific Symposium on Biocomputing 2000).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.se
=cut
package TFBS::PatternGen::AnnSpec;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::AnnSpec::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $pattrengen = TFBS::PatternGen::AnnSpec->new(%args);
Function: the constructor for the TFBS::PatternGen::AnnSpec object
Returns : a TFBS::PatternGen::AnnSpec object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to the 'meme' executable
# OPTIONAL: default 'ann-spec'
-additional_params # a string containing additional
# command-line switches for the
# ann-spec program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'filename'} =$args{'-seq_file'};
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'annspec';
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_AnnSpec() or $self->throw("Error running AnnSpec.");
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _run_AnnSpec{
my ($self)=shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $command_line =
$self->{'binary'}." ".
"-f ".$tmp_file." ".
# $self->{'motif_length_string'}." ".
# $self->{'nr_hits_string'}." ".
$self->{'additional_params'}.
"";
# print STDERR "$command_line\n";
my $resultstring = `$command_line`;
print "$resultstring\n";
# open(TEST, "test.out"); # this sentense is the one I add
# my @lines = ;# this sentense is the one I add
# my $resultstring = join '', @lines;# this sentense is the one I add
# print STDERR $resultstring;
$self->_parse_AnnSpec_output($resultstring,$command_line);
unlink $tmp_file;
return 1
}
sub _parse_AnnSpec_output{
my ($self,$resultstring,$command_line)=@_;
if ($resultstring eq''){
# warn "Error running AnnSpec\nNo patterns produced";
$self->throw ("Error running AnnSpec using command:\n $command_line");
return;
}
my ($consensus,$matrix)=$self->_parse_raw_matrix($resultstring);
my ($score,$sites)=$self->_parse_sites($resultstring);
for(my $x = 0; $x < scalar(@$consensus); $x++){
my $motif =TFBS::PatternGen::AnnSpec::Motif->new
(
#-length => $length."",
# -bg_probabilities => [split /\s+/, $raw_bp],
-tags => {consensus => $consensus->[$x],
score=>$score->[$x]},
-nr_hits => 1,
-sites=>$sites->[$x],
-matrix => $matrix->[$x]
);
push @{ $self->{'motifs'} }, $motif;
}
return
}
sub _parse_sites{
my ($self,$string)=@_;
my (@hits, @scores);
foreach my $substring (split /REPORTING/, $string ){
my @sub_hits;
my ($sites)=$substring=~/STR\s+n.*seq\n(.*)RUN\s+ALIGNMENT.*/s;
my ($average)=$substring=~/RUN INFORMATION_CONTENT\s+(\d*\.*\d*)/;
my ($score)=$substring=~/RUN\s+SCORE\s+(\d*\.*\d*)/;
if($sites){
my @sites=split/\n/,$sites;
foreach my $site (@sites){
my @site_array=split(/\s+/,$site);
my ($seq_id)=$site_array[6]=~/>(.*)/;
my $strand=1;
$strand=-1 if $site_array[3]=~/\'/;#MEans we have a pattern in the reverse strand
my ($start)=$site_array[3]=~/(\d+)/;
my $site = Bio::SeqFeature::Generic->new ( -start => $start,
-end => $start+(length$site_array[4])-1,
-strand => $strand,
-source => 'AnnSpec',
-score => $site_array[2],
);
foreach my $seq(@{$self->{'seq_set'}}){
if ($seq->id eq $seq_id){
$site->attach_seq ($seq);
}
}
push (@sub_hits,$site);
}
push @scores, $score;
push @hits, \@sub_hits;
}
}
return \@scores,\@hits;
}
sub _parse_raw_matrix{
my ($self,$string)=@_;
my (@pfms, @consensus);
foreach my $sub_string (split /REPORTING/, $string){
my ($ma)=$sub_string=~/RUN\s+WEIGHTS_CONS.*ALR\s+\/.*ALR\s+\#.*(ALR.*\nALR.*\nALR.*\nALR.*\s+\d+\n)ALR\s+=+.*/s;
my ($con)=$sub_string=~/WEIGHTS_CONS\s+(.*)\n/;
if($ma){
my @matrix=split("\n",$ma);
my @pfm;
foreach my $row(@matrix){
# print $row;
my @row=split /\s+/, $row;
push @pfm, [@row[2..scalar@row-1]];
}
push @pfms, \@pfm;
push @consensus, $con;
}
}
return \@consensus, \@pfms;
}
1;
TFBS-0.7.1/TFBS/PatternGen/AnnSpec/ 0000775 0000000 0000000 00000000000 13057522667 0016426 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/AnnSpec/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0017312 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/AnnSpec/.svn/all-wcprops 0000775 0000000 0000000 00000000314 13057522667 0021501 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 52
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/AnnSpec
END
Motif.pm
K 25
svn:wc:ra_dav:version-url
V 61
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/AnnSpec/Motif.pm
END
TFBS-0.7.1/TFBS/PatternGen/AnnSpec/.svn/entries 0000775 0000000 0000000 00000000541 13057522667 0020711 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/PatternGen/AnnSpec
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
Motif.pm
file
2009-08-07T13:10:53.000000Z
0f5af59c814a45843af3a0954ee4aca7
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/PatternGen/AnnSpec/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0020520 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/PatternGen/AnnSpec/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0021206 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/AnnSpec/.svn/text-base/Motif.pm.svn-base 0000775 0000000 0000000 00000002311 13057522667 0024337 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::AnnSpec::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::AnnSpec::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the AnnSpec program. You do not
normally want to create a TFBS::PatternGen::AnnSpec::Motif yourself. They are created
by running TFBS::PatternGen::AnnSpec
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard and Wynand Alkema
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::AnnSpec::Motif;
use vars qw(@ISA);
use strict;
use TFBS::Matrix::PFM;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen::Motif::Matrix);
TFBS-0.7.1/TFBS/PatternGen/AnnSpec/Motif.pm 0000775 0000000 0000000 00000002311 13057522667 0020042 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::AnnSpec::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::AnnSpec::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the AnnSpec program. You do not
normally want to create a TFBS::PatternGen::AnnSpec::Motif yourself. They are created
by running TFBS::PatternGen::AnnSpec
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard and Wynand Alkema
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::AnnSpec::Motif;
use vars qw(@ISA);
use strict;
use TFBS::Matrix::PFM;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen::Motif::Matrix);
TFBS-0.7.1/TFBS/PatternGen/Elph.pm 0000775 0000000 0000000 00000020217 13057522667 0016332 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::Elph
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::Elph - a pattern factory that uses the Elph program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::Elph->new(-seq_file=>'sequences.fa',
-binary => '/Elph/elph'
-motif_length => [8, 9, 10],
-additional_params => '-x -r -e');
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::Gibbs builds position frequency matrices
using an advanced Gibbs sampling algorithm implemented in external
I program by Chip Lawrence. The algorithm can produce
multiple patterns from a single set of sequences.
=cut
package TFBS::PatternGen::Elph;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::Elph::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $db = TFBS::PatternGen::Gibbs->new(%args);
Function: the constructor for the TFBS::PatternGen::Gibbs object
Returns : a TFBS::PatternGen::Gibbs object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to Gibbs executable
# OPTIONAL: default 'Gibbs'
-nr_hits # a presumed number of pattern occurrences in the
# sequence set: it can be a single integer, e.g.
# -nr_hits => 24 , or a reference to an array of
# integers, e.g -nr_hits => [12, 24, 36]
-motif_length # an expected length of motif in nucleotides:
# it can be a single integer, e.g.
# -motif_length => 8 , or a reference to an
# array ofintegers, e.g -motif_length => [8..12]
-additional_params # a string containing additional
# command-line switches for the
# Gibbs program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'motif_length_string'} =
($args{'-motif_length'}
? (ref($args{'-motif_length'})
? join(',', @{$args{'-motif_length'}})
: $args{'-motif_length'})
: 8 );
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'elph';
$self->{'motifs'} = [];
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_elph() or $self->throw("Error running elph.");
return $self;
}
sub _run_elph {
my $self = shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
$self->{'additional_params'}=~s/-b//;
#This removes a -b switch. This enables long output containgin info about the sites
my $command_line =
$self->{'binary'}." ".
$tmp_file." ".
"LEN=".$self->{'motif_length_string'}." ".
$self->{'additional_params'}." 2>/dev/null";
my $resultstring = `$command_line`;
$self->_parse_elph_output($resultstring,$command_line);
#print STDERR "$command_line\n";
#print STDERR $resultstring;
# unlink $tmp_file;
return 1
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _parse_elph_output {
my ($self, $resultstring,$command_line) = @_;
#print $resultstring;
if ($resultstring=~/^error/){
$self->throw ("Error running elp command:\n $command_line");
return;
}
#Motif after optimizing
#MAP for motif: 46.735 InfoPar=0.098
#
#Motif found:
#
#Background probability model:
# a c g t
# 0.30 0.20 0.19 0.31
#
#Background counts:
#a: 1456
#c: 948
#g: 909
#t: 1487
#
#
#Motif probability model:
#Pos: 1 2 3 4 5 6
#a 1.00 0.00 1.00 0.83 0.00 0.00
#c 0.00 0.00 0.00 0.00 0.00 0.17
#g 0.00 1.00 0.00 0.17 1.00 0.83
#t 0.00 0.00 0.00 0.00 0.00 0.00
#------------------------------------------
#Info 1.73 2.42 1.73 1.19 2.42 1.75
#
#Motif counts:
#a: 6 0 6 5 0 0
#c: 0 0 0 0 0 1
#g: 0 6 0 1 6 5
#t: 0 0 0 0 0 0
#
#
(my $MAP)=$resultstring=~/MAP for motif: (.*) InfoPar=/;
($resultstring)=~s/.*Motif counts:\n//s;
#print STDERR $resultstring;
my @array=split "\n",$resultstring;
my @matrix;
#print $array[0],"\n";
foreach (0..3){
my (@line)=split(/\s+/,$array[$_]);
#print "@line\n";
shift @line;
push @matrix,\@line;
# print "@line\n";
}
# print @matrix;
#print $resultstring;
my $sites=$self->_site_props($resultstring);
my $motif =TFBS::PatternGen::Elph::Motif->new
(
-tags => {score=>$MAP},#The score in this case is the E-value given in the output
-sites=>$sites,
-matrix => \@matrix
);
# Seq.no Pos ***** Motif ***** Prob D Seq.Id
# 1 354 ggatt AGAAGC cgccg 0.1389 -1 GAL1
# 2 636 caaag AGAAGG ttttt 0.6942 -1 GAL10
# 3 456 aaggc AGAAGG cagta 0.6942 -1 GAL2
# 4 444 aaagt AGAGGG ggtaa 0.1388 -1 GAL7
# 5 324 tagag AGAAGG agcaa 0.6942 -1 GAL80
# 6 165 gttac AGAAGG gccgc 0.6942 -1 GCY1
#$resultstring =~ s/.*=== MAP MAXIMIZATION RESULTS ===//s;
#my @raw_motifs = split /\-+\n\s+MOTIF \w\n/s, $resultstring;
#shift @raw_motifs; # discard the first one
#foreach my $raw_motif (@raw_motifs) {
# #print $raw_motif;
# my $motif =$self->_parse_raw_motif($raw_motif) || next;
push @{ $self->{'motifs'} }, $motif;
#}
#return 1;
}
sub _site_props{
my ($self,$resultstring)=@_;
my @sites;
# print $resultstring;
#($resultstring)=~s/.*Motif counts:\n//s;
my @array=split(/Seq\.no/,$resultstring);
#print $array[1];
my @sites_array=split "\n", $array[1];
foreach my $line(@sites_array){
# print $line;
next if $line=~/Pos/;
last if $line eq'';
my @site=split(/\s+/,$line);
# print $site[1],"\n";
my $nr=0;
$nr = 1 if $site[2]==1;
#A special case when the site startsat the first base.
#Then no preceding quence is given and the site array =shorter by 1
my $motif_seq=$site[4-$nr];
# print $motif_seq,"\n";
my $site = Bio::SeqFeature::Generic->new ( -start => $site[2],
-end => $site[2]+(length$motif_seq)-1,
-strand => 1,
#Always 1 with elph
-source => 'Elph',
-score => $site[-3],
);
foreach my $seq(@{$self->{'seq_set'}}){
if ($seq->id eq $site[-1]){#last element of the array
$site->attach_seq ($seq);
}
}
push (@sites,$site);
}
return \@sites;
}
1;
TFBS-0.7.1/TFBS/PatternGen/Elph/ 0000775 0000000 0000000 00000000000 13057522667 0015767 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Elph/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0016653 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Elph/.svn/all-wcprops 0000775 0000000 0000000 00000000306 13057522667 0021043 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 49
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Elph
END
Motif.pm
K 25
svn:wc:ra_dav:version-url
V 58
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Elph/Motif.pm
END
TFBS-0.7.1/TFBS/PatternGen/Elph/.svn/entries 0000775 0000000 0000000 00000000536 13057522667 0020256 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/PatternGen/Elph
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
Motif.pm
file
2009-08-07T13:10:54.000000Z
9b0c26fe4c28452e8eaa4ff54d4d47cd
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/PatternGen/Elph/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0020061 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/PatternGen/Elph/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0020547 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Elph/.svn/text-base/Motif.pm.svn-base 0000775 0000000 0000000 00000002173 13057522667 0023706 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::AnnSpec::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::MEME::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the meme program. You do not
normally want to create a TFBS::PatternGen::MEME::Motif yourself. They are created
by running TFBS::PatternGen::MEME
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::Elph::Motif;
use vars qw(@ISA);
use strict;
use TFBS::Matrix::PFM;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen::Motif::Matrix);
TFBS-0.7.1/TFBS/PatternGen/Elph/Motif.pm 0000775 0000000 0000000 00000002173 13057522667 0017411 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::AnnSpec::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::MEME::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the meme program. You do not
normally want to create a TFBS::PatternGen::MEME::Motif yourself. They are created
by running TFBS::PatternGen::MEME
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::Elph::Motif;
use vars qw(@ISA);
use strict;
use TFBS::Matrix::PFM;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen::Motif::Matrix);
TFBS-0.7.1/TFBS/PatternGen/Gibbs.pm 0000775 0000000 0000000 00000020125 13057522667 0016466 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::Gibbs
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::Gibbs - a pattern factory that uses Chip Lawrences Gibbs program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::Gibbs->new(-seq_file=>'sequences.fa',
-binary => '/Programs/Gibbs-1.0/bin/Gibbs'
-nr_hits => 24,
-motif_length => [8, 9, 10],
-additional_params => '-x -r -e');
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::Gibbs builds position frequency matrices
using an advanced Gibbs sampling algorithm implemented in external
I program by Chip Lawrence. The algorithm can produce
multiple patterns from a single set of sequences.
=cut
package TFBS::PatternGen::Gibbs;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::Gibbs::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $db = TFBS::PatternGen::Gibbs->new(%args);
Function: the constructor for the TFBS::PatternGen::Gibbs object
Returns : a TFBS::PatternGen::Gibbs object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to Gibbs executable
# OPTIONAL: default 'Gibbs'
-nr_hits # a presumed number of pattern occurrences in the
# sequence set: it can be a single integer, e.g.
# -nr_hits => 24 , or a reference to an array of
# integers, e.g -nr_hits => [12, 24, 36]
-motif_length # an expected length of motif in nucleotides:
# it can be a single integer, e.g.
# -motif_length => 8 , or a reference to an
# array ofintegers, e.g -motif_length => [8..12]
-additional_params # a string containing additional
# command-line switches for the
# Gibbs program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'motif_length_string'} =
($args{'-motif_length'}
? (ref($args{'-motif_length'})
? join(',', @{$args{'-motif_length'}})
: $args{'-motif_length'})
: 8 );
$self->{'nr_hits_string'} =
($args{'-nr_hits'}
? (ref($args{'-nr_hits'})
? join(',', @{$args{'-nr_hits'}})
: $args{'-nr_hits'})
: "" );
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'Gibbs';
$self->{'motifs'} = [];
$self->_create_seq_set(%args) or die ('Error creating sequence set');
#print $self->{'seq_set'}->[0]->seq;
#$self->_seq_props;
$self->_run_Gibbs() or $self->throw("Error running Gibbs.");
return $self;
}
sub _run_Gibbs {
my $self = shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $command_line =
$self->{'binary'}." ".
" -PBernoulli ".
$tmp_file." ".
$self->{'motif_length_string'}." ".
$self->{'nr_hits_string'}." ".
$self->{'additional_params'}." -n";
my $resultstring = `$command_line`;
$self->_parse_Gibbs_output($resultstring);
#print STDERR "$command_line\n";
#print STDERR $resultstring;
unlink $tmp_file;
return 1
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _parse_Gibbs_output {
my ($self, $resultstring) = @_;
#print $resultstring;
#print"===========END_RESULTSTRING===============================\n";
$resultstring =~ s/.*=== MAP MAXIMIZATION RESULTS ===//s;
my @raw_motifs = split /\-+\n\s+MOTIF \w\n/s, $resultstring;
shift @raw_motifs; # discard the first one
foreach my $raw_motif (@raw_motifs) {
#print $raw_motif;
my $motif =$self->_parse_raw_motif($raw_motif) || next;
push @{ $self->{'motifs'} }, $motif;
}
return 1;
}
sub _site_props{
my ($self,$raw_motif)=@_;
my @sites;
# print $raw_motif;
$raw_motif=~s/.*Num Motifs:\s+\d+\n//s;
# print $raw_motif;
#print "#####################################################\n";
$raw_motif=~s/\n\s+\*+.*//s;
#print $raw_motif,"\n";
my @site_lines=(split("\n", $raw_motif));
foreach my $site(@site_lines){
my $start_seq;
my $end_seq;
my ($seq_nr,$pattern_nr,$start,$seq,$end,$score,$strand,$desc)=$site=~/\s+(\d+),\s+(\d+)\s+(\d+)\s+([\w,\s]+)\s+(\d+)\s+(\d\.\d+)\s+([F,R])(.*)/;
# print $seq_nr,$pattern_nr,$start,$seq;
if ($strand eq "F"){
$strand=1;
$start_seq=$start;
$end_seq=$end;
}
else{
$strand=-1;
$start_seq=$end;
$end_seq=$start;
}
#print $site;
my $site = Bio::SeqFeature::Generic->new ( -start => $start_seq,
-end => $end_seq,
-strand => $strand,
-source => 'Gibbs sampler',
-score => $score,
);
$site->attach_seq ($self->{'seq_set'}->[$seq_nr-1]);
push (@sites,$site);
}
foreach my $site(@sites){
#print $site->start."\n";
}
return \@sites;
}
sub _parse_raw_motif {
# a utility function
my ($self,$raw_motif) = @_;
# print $raw_motif;
my ($raw_matrix, $raw_bp, $length, $nr_hits, $MAP_score) =
$raw_motif =~ /Motif model \(residue frequency x 100\)\n(.+)Motif probability model\n.+Background probability model\n\s+(.+?)\n.+\D(\d+) columns\nNum Motifs\: (\d+).+Difference of Logs of Maps = ([\-\.\d]+)\n/s;
#print $raw_matrix;
return undef unless $raw_matrix;
my $sites = $self->_site_props($raw_motif);
# print STDERR
# join ":", ($raw_matrix, $raw_bp, $length, $nr_hits); print "\n";
my $matrix = _parse_raw_matrix($raw_matrix);
#print $matrix;
return
TFBS::PatternGen::Gibbs::Motif->new
#This object does not contain a new method. Instead the new method is than searched in the first ISA package. Remember that the object is still a TFBS::PatternGen::Gibbs::Motif.
#The only ISA in the package is TFBS::PatternGen::Motif.pm. This package indeed contains the new method
(-length => $length."",
-bg_probabilities => [split /\s+/, $raw_bp],
-MAP_score => $MAP_score,
-tags => {MAP_score => $MAP_score},
-nr_hits => $nr_hits,
-sites=>$sites,
-matrix => $matrix );
}
sub _parse_raw_matrix {
# a utility function
my $raw_matrix = shift;
my @lines = split "\n", $raw_matrix;
my (@A, @C, @G, @T);
foreach my $line (@lines) {
my $value_string;
next unless ($value_string) = $line =~ /\s+\d+\s+\|\s+(.+)/;
$value_string =~ s/\./0/g;
my ($a, $t, $c, $g) = split /\s+/, $value_string;
push @A, $a;
push @C, $c;
push @G, $g;
push @T, $t;
}
# print STDERR join(" ",@A, "\n", @C, "\n", @G, "\n", @T, "\n");
return [\@A, \@C, \@G, \@T];
}
1;
TFBS-0.7.1/TFBS/PatternGen/Gibbs/ 0000775 0000000 0000000 00000000000 13057522667 0016125 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Gibbs/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0017011 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Gibbs/.svn/all-wcprops 0000775 0000000 0000000 00000000310 13057522667 0021174 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 50
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Gibbs
END
Motif.pm
K 25
svn:wc:ra_dav:version-url
V 59
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Gibbs/Motif.pm
END
TFBS-0.7.1/TFBS/PatternGen/Gibbs/.svn/entries 0000775 0000000 0000000 00000000537 13057522667 0020415 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/PatternGen/Gibbs
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
Motif.pm
file
2009-08-07T13:10:51.000000Z
cbaa7a312912e8cd8d3873ec0eeea71a
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/PatternGen/Gibbs/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0020217 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/PatternGen/Gibbs/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0020705 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Gibbs/.svn/text-base/Motif.pm.svn-base 0000775 0000000 0000000 00000004252 13057522667 0024044 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::Gibbs::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::Gibbs::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::Gibbs::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the Gibbs program. You do not
normally want to create a TFBS::PatternGen::Gibbs::Motif yourself. They are created
by running TFBS::PatternGen::Gibbs
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard and Wynand Alkema
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::Gibbs::Motif;
use vars qw(@ISA);
use strict;
use TFBS::Matrix::PFM;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen::Motif::Matrix);
=head2 MAP
Title : MAP
Usage : my $map_score = $motif->MAP;
Function: returns MAP score for the detected motif
(This is a backward compatibility method. For consistency,
you should use $motif->tag('MAP_score') instead
Returns : float (a scalar)
Args : none
=head2 Other methods
TFBS::PatterGen::Motif::Gibbs inherits from TFBS::PatternGen::Motif,
which inherits from TFBS::Matrix. Please consult the documentation of those modules
for additional available methods.
=cut
sub MAP{
my ($self) = @_;
return $self->tag("MAP_score");
}
sub _calculate_PFM {
my $self = shift;
unless ($self->{'nr_hits'}) {
$self->throw(ref($self).
" objects must be created with a (nonzero)".
" -nr_hits parameter in constructor"
);
}
my @PFM;
foreach my $rowref ( @{$self->{'matrix'}} ) {
my @PFMrow;
foreach my $element (@$rowref) {
push @PFMrow, int($self->{'nr_hits'}*$element/100 + 0.5);
}
push @PFM, [@PFMrow];
}
return \@PFM;
}
TFBS-0.7.1/TFBS/PatternGen/Gibbs/Motif.pm 0000775 0000000 0000000 00000004252 13057522667 0017547 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::Gibbs::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::Gibbs::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::Gibbs::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the Gibbs program. You do not
normally want to create a TFBS::PatternGen::Gibbs::Motif yourself. They are created
by running TFBS::PatternGen::Gibbs
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard and Wynand Alkema
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::Gibbs::Motif;
use vars qw(@ISA);
use strict;
use TFBS::Matrix::PFM;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen::Motif::Matrix);
=head2 MAP
Title : MAP
Usage : my $map_score = $motif->MAP;
Function: returns MAP score for the detected motif
(This is a backward compatibility method. For consistency,
you should use $motif->tag('MAP_score') instead
Returns : float (a scalar)
Args : none
=head2 Other methods
TFBS::PatterGen::Motif::Gibbs inherits from TFBS::PatternGen::Motif,
which inherits from TFBS::Matrix. Please consult the documentation of those modules
for additional available methods.
=cut
sub MAP{
my ($self) = @_;
return $self->tag("MAP_score");
}
sub _calculate_PFM {
my $self = shift;
unless ($self->{'nr_hits'}) {
$self->throw(ref($self).
" objects must be created with a (nonzero)".
" -nr_hits parameter in constructor"
);
}
my @PFM;
foreach my $rowref ( @{$self->{'matrix'}} ) {
my @PFMrow;
foreach my $element (@$rowref) {
push @PFMrow, int($self->{'nr_hits'}*$element/100 + 0.5);
}
push @PFM, [@PFMrow];
}
return \@PFM;
}
TFBS-0.7.1/TFBS/PatternGen/MEME.pm 0000775 0000000 0000000 00000014017 13057522667 0016166 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::MEME
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::MEME - a pattern factory that uses the MEME program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::MEME->new(-seq_file=>'sequences.fa',
-binary => 'meme'
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::MEME builds position frequency matrices
using an external program MEME written by Bailey and Elkan.
For information and source code of MEME see
http://www.sdsc.edu/MEME
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=cut
package TFBS::PatternGen::MEME;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::SimplePFM;
use TFBS::PatternGen::MEME::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $pattrengen = TFBS::PatternGen::MEME->new(%args);
Function: the constructor for the TFBS::PatternGen::MEME object
Returns : a TFBS::PatternGen::MEME object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to the 'meme' executable
# OPTIONAL: default 'meme'
-additional_params # a string containing additional
# command-line switches for the
# meme program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'filename'} =$args{'-seq_file'};
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'meme';
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_meme() or $self->throw("Error running MEME.");
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _run_meme{
my ($self)=shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $command_line =
$self->{'binary'}." ".
$tmp_file." ".
"-text ".
"-dna ".
$self->{'additional_params'}
." 2>/dev/null"
;
# print STDERR "$command_line\n";
my $resultstring = `$command_line`;
# print STDERR $resultstring;
$self->_parse_meme_output($resultstring,$command_line);
unlink $tmp_file;
return 1
}
sub _parse_meme_output{
my ($self,$resultstring,$command_line)=@_;
if ($resultstring=~/^error/){
# warn "Error running AnnSpec\nNo patterns produced";
$self->throw ("Error running MEME command:\n $command_line");
return;
}
my @motifs=split(/\*\nMOTIF/,$resultstring);
shift @motifs;#discard the first one
#print STDERR scalar @motifs,"\n";
foreach my $raw_motif(@motifs){
my ($matrix,$sites,$score)=$self->_parse_raw_matrix($raw_motif);
# print STDERR $matrix;
my $motif =TFBS::PatternGen::MEME::Motif->new
(
-tags => {score=>$score},#The score in this case is the E-value given in the output
-sites=>$sites,
-matrix => $matrix
);
push @{ $self->{'motifs'} }, $motif;
}
return
}
#
#
sub _parse_raw_matrix{
my ($self,$string)=@_;
my @sites;
my @matrix;
$string=~s/(Motif \d+ block diagrams.*)//s;
# print STDERR $string;
my ($width,$e_value)=$string=~/width =\s+(\d+)\s+sites.*E-value =(.*)\n/;
# print STDERR $e_value,"\n";
$string=~s/.*Motif \d+ sites sorted by position p-value//s;
#print STDERR $string;
my @array=split("\n",$string);
foreach my $line(@array){
my $nr=0;
my $strand=1;#if revcomp is not selected the strand is always 1
next if $line=~/^-/;
next if $line=~/P-value\s+Site/;
my (@properties)=split(/\s+/,$line);
next if @properties<1;
# print STDERR "@properties\n";
#First determine whether -revcomp switch is used and thus strand info is given
if ($properties[1] eq "+" or $properties[1] eq "-"){
$strand=$properties[1];
$nr=1;
}
my $site = Bio::SeqFeature::Generic->new ( -start =>$properties[1+$nr],
-end =>$properties[1+$nr]+$width-1,
-strand=>$strand,
-source=>'MEME',
-score=>$properties[2+$nr]
);
foreach my $seq(@{$self->{'seq_set'}}){
if ($seq->id eq $properties[0]){
$site->attach_seq ($seq);
}
}
push @sites,$site;
}
foreach my $site(@sites){
push @matrix,$site->seq->seq;
}
my $patterngen=TFBS::PatternGen::SimplePFM->new(-seq_list=>\@matrix);
my $matrix=$patterngen->pattern->rawprint;
# print STDERR $matrix;
return ($matrix,\@sites,$e_value);
}
1; TFBS-0.7.1/TFBS/PatternGen/MEME/ 0000775 0000000 0000000 00000000000 13057522667 0015622 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/MEME/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0016506 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/MEME/.svn/all-wcprops 0000775 0000000 0000000 00000000306 13057522667 0020676 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 49
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/MEME
END
Motif.pm
K 25
svn:wc:ra_dav:version-url
V 58
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/MEME/Motif.pm
END
TFBS-0.7.1/TFBS/PatternGen/MEME/.svn/entries 0000775 0000000 0000000 00000000536 13057522667 0020111 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/PatternGen/MEME
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
Motif.pm
file
2009-08-07T13:10:50.000000Z
f3616055bbabb9ac36d4491c9d6be735
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/PatternGen/MEME/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0017714 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/PatternGen/MEME/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0020402 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/MEME/.svn/text-base/Motif.pm.svn-base 0000775 0000000 0000000 00000002173 13057522667 0023541 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::AnnSpec::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::MEME::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the meme program. You do not
normally want to create a TFBS::PatternGen::MEME::Motif yourself. They are created
by running TFBS::PatternGen::MEME
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::MEME::Motif;
use vars qw(@ISA);
use strict;
use TFBS::Matrix::PFM;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen::Motif::Matrix);
TFBS-0.7.1/TFBS/PatternGen/MEME/Motif.pm 0000775 0000000 0000000 00000002173 13057522667 0017244 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::AnnSpec::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::MEME::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the meme program. You do not
normally want to create a TFBS::PatternGen::MEME::Motif yourself. They are created
by running TFBS::PatternGen::MEME
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::MEME::Motif;
use vars qw(@ISA);
use strict;
use TFBS::Matrix::PFM;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen::Motif::Matrix);
TFBS-0.7.1/TFBS/PatternGen/Motif/ 0000775 0000000 0000000 00000000000 13057522667 0016155 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Motif/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0017041 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Motif/.svn/all-wcprops 0000775 0000000 0000000 00000000465 13057522667 0021237 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 50
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Motif
END
Matrix.pm
K 25
svn:wc:ra_dav:version-url
V 60
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Motif/Matrix.pm
END
Word.pm
K 25
svn:wc:ra_dav:version-url
V 58
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/Motif/Word.pm
END
TFBS-0.7.1/TFBS/PatternGen/Motif/.svn/entries 0000775 0000000 0000000 00000000723 13057522667 0020442 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/PatternGen/Motif
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
Matrix.pm
file
2009-08-07T13:10:57.000000Z
5f311726eab66b4f40d922e770de5930
2008-01-24T20:21:25.772223Z
8
chrb
Word.pm
file
2009-08-07T13:10:57.000000Z
05996413e6ae07f300c9a6bae206d4bb
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/PatternGen/Motif/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0020247 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/PatternGen/Motif/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0020735 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/Motif/.svn/text-base/Matrix.pm.svn-base 0000775 0000000 0000000 00000002270 13057522667 0024260 0 ustar 00root root 0000000 0000000 package TFBS::PatternGen::Motif::Matrix;
use vars qw(@ISA);
use strict;
use TFBS::Matrix;
use TFBS::Matrix::PFM;
@ISA = qw(TFBS::Matrix);
sub new {
my ($caller, %args) = @_;
#my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"PFM");
#my $self = bless $matrix, ref($caller) || $caller;
my $self = $caller->SUPER::new(%args, -matrixtype=>"PFM");
$self->{'length'} = $args{'-length'} || scalar @{$self->{'matrix'}->[0]};
$self->{'nr_hits'} = ($args{'-nr_hits'} || undef);
# || $self->throw("No -nr_hits provided.");
# Why was nr_hits required ?? (Boris)
$self->{'sites'}=$args{'-sites'};
# $self->{'tags'} = ($args{'-tags'} || {});
return $self;
}
sub PFM {
my ($self, %args) = @_;
return TFBS::Matrix::PFM->new (-name => "unknown",
-ID => "unknown",
-class=> "unknown",
-tags => { %{$self->{'tags'} } },
%args,
-matrix => $self->_calculate_PFM()
);
}
sub pattern {
my ($self, %args ) = @_;
$self->PFM(%args);
}
sub _calculate_PFM { # simplest case: matrix already IS PFM
my $self = shift;
return [@{$self->{'matrix'}}];
}
sub get_sites{
return @{$_[0]->{'sites'}};
}
1;
TFBS-0.7.1/TFBS/PatternGen/Motif/.svn/text-base/Word.pm.svn-base 0000775 0000000 0000000 00000000533 13057522667 0023727 0 ustar 00root root 0000000 0000000 package TFBS::PatternGen::Motif::Word;
use vars qw(@ISA);
use strict;
use TFBS::Word::Consensus;
@ISA = qw(TFBS::Word::Consensus);
sub new {
my ($caller, %args) = @_;
my $word = TFBS::Word::Consensus->new(%args);
my $self = bless $word, ref($caller) || $caller;
return $self;
}
sub pattern {
return $_;
}
1;
TFBS-0.7.1/TFBS/PatternGen/Motif/Matrix.pm 0000775 0000000 0000000 00000002270 13057522667 0017763 0 ustar 00root root 0000000 0000000 package TFBS::PatternGen::Motif::Matrix;
use vars qw(@ISA);
use strict;
use TFBS::Matrix;
use TFBS::Matrix::PFM;
@ISA = qw(TFBS::Matrix);
sub new {
my ($caller, %args) = @_;
#my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"PFM");
#my $self = bless $matrix, ref($caller) || $caller;
my $self = $caller->SUPER::new(%args, -matrixtype=>"PFM");
$self->{'length'} = $args{'-length'} || scalar @{$self->{'matrix'}->[0]};
$self->{'nr_hits'} = ($args{'-nr_hits'} || undef);
# || $self->throw("No -nr_hits provided.");
# Why was nr_hits required ?? (Boris)
$self->{'sites'}=$args{'-sites'};
# $self->{'tags'} = ($args{'-tags'} || {});
return $self;
}
sub PFM {
my ($self, %args) = @_;
return TFBS::Matrix::PFM->new (-name => "unknown",
-ID => "unknown",
-class=> "unknown",
-tags => { %{$self->{'tags'} } },
%args,
-matrix => $self->_calculate_PFM()
);
}
sub pattern {
my ($self, %args ) = @_;
$self->PFM(%args);
}
sub _calculate_PFM { # simplest case: matrix already IS PFM
my $self = shift;
return [@{$self->{'matrix'}}];
}
sub get_sites{
return @{$_[0]->{'sites'}};
}
1;
TFBS-0.7.1/TFBS/PatternGen/Motif/Word.pm 0000775 0000000 0000000 00000000533 13057522667 0017432 0 ustar 00root root 0000000 0000000 package TFBS::PatternGen::Motif::Word;
use vars qw(@ISA);
use strict;
use TFBS::Word::Consensus;
@ISA = qw(TFBS::Word::Consensus);
sub new {
my ($caller, %args) = @_;
my $word = TFBS::Word::Consensus->new(%args);
my $self = bless $word, ref($caller) || $caller;
return $self;
}
sub pattern {
return $_;
}
1;
TFBS-0.7.1/TFBS/PatternGen/SimplePFM.pm 0000775 0000000 0000000 00000006317 13057522667 0017243 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::SimplePFM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::SimplePFM - a simple position frequency matrix factory
=head1 SYNOPSIS
my @sequences = qw( AAGCCT AGGCAT AAGCCT
AAGCCT AGGCAT AGGCCT
AGGCAT AGGTTT AGGCAT
AGGCCT AGGCCT );
my $patterngen =
TFBS::PatternGen::SimplePFM->new(-seq_list=>\@sequences);
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::SimplePFM generates a position frequency matrix from a set
of nucleotide sequences of equal length, The sequences can be passed either
as strings, as Bio::Seq objects or as a fasta file.
This pattern generator always creates only one pattern from a given set
of sequences.
=cut
package TFBS::PatternGen::SimplePFM;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGenI;
use TFBS::PatternGen;
use TFBS::PatternGen::Motif::Matrix;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $db = TFBS::PatternGen::SimplePFM->new(%args);
Function: the constructor for the TFBS::PatternGen::SimplePFM
object
Returns : a TFBS::PatternGen::SimplePFM obkect
Args : This method takes named arguments;
you must specify one of the following
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_check_seqs_for_uniform_length();
$self->{'motifs'} = [$self->_create_motif()];
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three above methods are used fro the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _create_motif {
my $self = shift;
my $length = $self->{'seq_set'}->[-1]->length();
# initialize the matrix
my $matrixref = [];
for my $i (0..3) {
for my $j (0..$length-1) {
$matrixref->[$i][$j] = 0;
}
}
#fill the matrix
my @base = qw(A C G T);
foreach my $seqobj ( @{ $self->{seq_set} } ) {
for my $i (0..3) {
my $seqstring = $seqobj->seq;
my @seqbase = split "", uc $seqstring;
for my $j (0..$length-1) {
$matrixref->[$i][$j] += ($base[$i] eq $seqbase[$j])?1:0;
}
}
}
my $nrhits =0; for my $i (0..3) {$nrhits += $matrixref->[$i][0];}
my $motif =
TFBS::PatternGen::Motif::Matrix->new(-matrix => $matrixref,
-nr_hits=> $nrhits);
return $motif;
}
sub _validate_seq {
# a utility function
my ($sequence)=@_;
$sequence=~ s/[ACGT]//g;
return ($sequence eq "" ? 1 : 0);
}
1; TFBS-0.7.1/TFBS/PatternGen/YMF.pm 0000775 0000000 0000000 00000012303 13057522667 0016072 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::YMF
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::MEME - a pattern factory that uses the MEME program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::MEME->new(-seq_file=>'sequences.fa',
-binary => 'meme'
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::MEME builds position frequency matrices
using an external program MEME written by Bailey and Elkan.
For information and source code of MEME see
http://www.sdsc.edu/MEME
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=cut
package TFBS::PatternGen::YMF;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::YMF::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
use File::Temp qw/ tempfile tempdir /;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $patterngen = TFBS::PatternGen::YMF->new(%args);
Function: the constructor for the TFBS::PatternGen::MEME object
Returns : a TFBS::PatternGen::MEME object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to the 'meme' executable
# OPTIONAL: default 'meme'
-additional_params # a string containing additional
# command-line switches for the
# meme program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'width'}=$args{'-length_oligo'};
$self->{'path_org'}=$args{'-pathoforganismtables'};
$self->{'len_region'}=$args{'-length_region'};
$self->{'config_file'}=$args{'-config_file'}||$args{'-stats_path'}."/stats.config";
#The latter is the example configfile that comes with the installation of YMF
$self->{'abs_stats_path'} = $args{'-abs_stats_path'} ;
#This is the directory where the executable and the results file is
#generated by the program are located
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_stats() or $self->throw("Error running stats.");
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _run_stats{
my ($self)=shift;
my $tmp_file = tmpnam();
my $dumpfile = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $dir = tempdir();
#print $dir;
#change directory to directory where the program is located
#system 'cd $dir.w;';
# my $command="cd $dir;";
# print $command;
# system $command;
# `$command`;
# system 'ls -ltr';
my $command_line =
$self->{'abs_stats_path'}."/stats ".
# "stats ".
$self->{'config_file'}." ".
$self->{'len_region'}." ".
$self->{'width'}." ".
$self->{'path_org'}." ".
"-sort ".#sorts on z-score
$tmp_file
." >$dumpfile"
;
# print STDERR "cd $dir;$command_line\n";
my $resultstring = `cd $dir;$command_line`;
# print STDERR $resultstring;
$self->_parse_stats_output($resultstring,$command_line,$dumpfile,$dir);
unlink $tmp_file;
#unlink $dumpfile;
return 1
}
#
sub _parse_stats_output{
my ($self,$resultstring,$command_line,$dumpfile,$temp_dir)=@_;
open DUMP,$dumpfile;
while(){
if ((/(^Error.*)/) or /(.*Aborting.*)/){
# warn "Error running AnnSpec\nNo patterns produced";
print "YMF Error message: \"$1\"\n";
unlink $dumpfile;
$self->throw ("Error running YMF using command:\n $command_line");
return;
}
}
unlink $dumpfile;
open RES,"$temp_dir/results";
my $skip=;
while (){
my ($word,$occ,$z_score,$expect,$var)=split;
#print $word;
my $motif =TFBS::PatternGen::YMF::Motif->new
(-word=>$word,
-tags => {z_score=>$z_score,
'occurences'=>$occ,
'expectation value'=>$expect,
'variance'=>$var}
);
push @{ $self->{'motifs'} }, $motif;
}
my $command="rm -r $temp_dir";
#print $command;
`$command`;# or die "could not unlink $!";
# return
}
#
1; TFBS-0.7.1/TFBS/PatternGen/YMF/ 0000775 0000000 0000000 00000000000 13057522667 0015532 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/YMF/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0016416 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/YMF/.svn/all-wcprops 0000775 0000000 0000000 00000000304 13057522667 0020604 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 48
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/YMF
END
Motif.pm
K 25
svn:wc:ra_dav:version-url
V 57
/svn/lenhard/!svn/ver/8/TFBS/TFBS/PatternGen/YMF/Motif.pm
END
TFBS-0.7.1/TFBS/PatternGen/YMF/.svn/entries 0000775 0000000 0000000 00000000535 13057522667 0020020 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/PatternGen/YMF
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
Motif.pm
file
2009-08-07T13:10:55.000000Z
8773ed93b0f146efb3841afff327db68
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/PatternGen/YMF/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0017624 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/PatternGen/YMF/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0020312 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/PatternGen/YMF/.svn/text-base/Motif.pm.svn-base 0000775 0000000 0000000 00000002200 13057522667 0023440 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::YMF::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::YMF::Motif - class for unprocessed motifs and associated
numerical scores created by the YMF program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::YMF::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the ymf program. You do not
normally want to create a TFBS::PatternGen::YMF::Motif yourself. They are created
by running TFBS::PatternGen::YMF
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::YMF::Motif;
use vars qw(@ISA);
use strict;
#use TFBS::Word;
#use TFBS::Word::Consensus;
use TFBS::PatternGen::Motif::Word;
@ISA = qw(TFBS::PatternGen::Motif::Word);
1;
TFBS-0.7.1/TFBS/PatternGen/YMF/Motif.pm 0000775 0000000 0000000 00000002200 13057522667 0017143 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::YMF::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::YMF::Motif - class for unprocessed motifs and associated
numerical scores created by the YMF program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::YMF::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the ymf program. You do not
normally want to create a TFBS::PatternGen::YMF::Motif yourself. They are created
by running TFBS::PatternGen::YMF
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# the code begins here:
package TFBS::PatternGen::YMF::Motif;
use vars qw(@ISA);
use strict;
#use TFBS::Word;
#use TFBS::Word::Consensus;
use TFBS::PatternGen::Motif::Word;
@ISA = qw(TFBS::PatternGen::Motif::Word);
1;
TFBS-0.7.1/TFBS/PatternGenI.pm 0000775 0000000 0000000 00000000775 13057522667 0015562 0 ustar 00root root 0000000 0000000 package TFBS::PatternGenI;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from Bio::RootI;
use Bio::Root::Root;
use Carp;
@ISA = qw(Bio::Root::Root);
sub pattern {
my $self = shift;
$self->_abstractDeath;
}
sub _abstractDeath {
# borrowed from BioPerl; with compliments :)
my $self = shift;
my $package = ref $self;
my $caller = (caller())[1];
confess "Abstract method '$caller' defined in interface TFBS::PatternGenI not implemented by package $package";
}
TFBS-0.7.1/TFBS/PatternI.pm 0000775 0000000 0000000 00000006020 13057522667 0015115 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternI
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternI - interface definition for all pattern objects (currently
includes matrices and word (consensus and regular expressions )
=head1 DESCRIPTION
TFBS::PatternI is a draft class that should contain general interface for matrix and other (future) pattern objects. It is not defined and not used yet, as I need to ponder over certain unresolved issues in general pattern definition. User feedback is more than welcome.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins here:
# The code begins HERE:
package TFBS::PatternI;
use vars '@ISA';
use Bio::Root::Root;
use strict;
@ISA = qw(Bio::Root::Root);
#sub new {
#}
=head2 ID
Title : ID
Usage : my $ID = $icm->ID()
$pfm->ID('M00119');
Function: Get/set on the ID of the pattern (unique in a DB or a set)
Returns : pattern ID (a string)
Args : none for get, string for set
=cut
sub ID {
my ($self, $ID) = @_;
$self->{'ID'} = $ID if $ID;
return $self->{'ID'};
}
=head2 name
Title : name
Usage : my $name = $pwm->name()
$pfm->name('PPARgamma');
Function: Get/set on the name of the pattern
Returns : pattern name (a string)
Args : none for get, string for set
=cut
sub name {
my ($self, $name) = @_;
$self->{'name'} = $name if $name;
return $self->{'name'};
}
=head2 class
Title : class
Usage : my $class = $pwm->class()
$pfm->class('forkhead');
Function: Get/set on the structural class of the pattern
Returns : class name (a string)
Args : none for get, string for set
=cut
sub class {
my ($self, $class) = @_;
$self->{'class'} = $class if $class;
return $self->{'class'};
}
=head2 tag
Title : tag
Usage : my $acc = $pwm->tag('acc')
$pfm->tag(source => "Gibbs");
Function: Get/set on the structural class of the pattern
Returns : tag value (a scalar/reference)
Args : tag name (string) for get,
tag name (string) and value (any scalar/reference) for set
=cut
sub tag {
my $self = shift;
my $tag = shift || return;
if (scalar @_) {
$self->{'tags'}->{$tag} =shift;
}
return $self->{'tags'}->{$tag};
}
=head2 all_tags
Title : all_tags
Usage : my %tag = $pfm->all_tags();
Function: get a hash of all tags for a matrix
Returns : a hash of all tag values keyed by tag name
Args : none
=cut
sub all_tags {
return %{$_[0]->{'tags'}};
}
=head2 delete_tag
Title : delete_tag
Usage : $pfm->delete_tag('score');
Function: get a hash of all tags for a matrix
Returns : nothing
Args : a string (tag name)
=cut
sub delete_tag {
my ($self, $tag) = @_;
delete $self->{'tags'}->{$tag};
}
1;
TFBS-0.7.1/TFBS/README.md 0000664 0000000 0000000 00000000034 13057522667 0014304 0 ustar 00root root 0000000 0000000 TFBS
====
TFBS perl module
TFBS-0.7.1/TFBS/Run/ 0000775 0000000 0000000 00000000000 13057522667 0013574 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Run/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0014460 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Run/.svn/all-wcprops 0000775 0000000 0000000 00000000334 13057522667 0016651 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 37
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Run
END
ConservationProfileGenerator.pm
K 25
svn:wc:ra_dav:version-url
V 69
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Run/ConservationProfileGenerator.pm
END
TFBS-0.7.1/TFBS/Run/.svn/entries 0000775 0000000 0000000 00000000551 13057522667 0016060 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/Run
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
ConservationProfileGenerator.pm
file
2009-08-07T13:10:48.000000Z
98de460766383395e70cefa0b313bdd0
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/Run/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0015666 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/Run/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0016354 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Run/.svn/text-base/ConservationProfileGenerator.pm.svn-base 0000775 0000000 0000000 00000012512 13057522667 0026275 0 ustar 00root root 0000000 0000000 package TFBS::Run::ConservationProfileGenerator;
use strict;
use Bio::Root::Root;
use TFBS::ConservationProfile;
use Bio::AlignIO;
use constant DEFAULT_WINDOW => 50;
use constant DEFAULT_CUTOFF => 0.7;
use vars qw'@ISA';
@ISA = qw'Bio::Root::Root';
sub new {
my ( $caller, %args ) = @_;
my $self = bless {
alignment => undef,
ref_sequence => undef,
method => undef,
window => DEFAULT_WINDOW,
cutoff => DEFAULT_CUTOFF,
%args
},
ref $caller || $caller;
if ( !defined( $self->alignment )
or !$self->alignment->isa("Bio::SimpleAlign") )
{
$self->throw( "alignment: argument missing or wrong object type: "
. ref( $self->alignment ) );
}
return $self;
}
sub run {
my ( $self, %args ) = @_;
my $method = ( $args{method} or $self->method or "simple" );
my %method_subref = (
simple => \&_run_simple,
malin => \&_run_Malins,
align_cons => \&_run_align_cons
);
if ( !defined( $method_subref{$method} ) ) {
$self->throw("method $method not supported");
}
$method_subref{$method}->( $self, %args );
}
sub alignment {
$_[0]->{'alignment'};
}
sub ref_sequence {
$_[0]->{'ref_sequence'};
}
sub method {
$_[0]->{'method'};
}
sub window {
$_[0]->{'window'};
}
sub cutoff {
$_[0]->{'cutoff'};
}
sub _run_simple {
my ( $self, %args ) = @_;
my ( $window_size, $cutoff, $ref_seq_nr, $other_seq_nr ) =
$self->_rearrange( [qw(WINDOW CUTOFF REF_SEQ_NR OTHER_SEQ_NR)], %args );
$window_size = $self->window unless $window_size;
$cutoff = $self->cutoff unless $cutoff;
$ref_seq_nr = 1 if !$ref_seq_nr;
$other_seq_nr = ( $other_seq_nr or 3 - $ref_seq_nr );
my @seq1 = split "", $self->alignment->get_seq_by_pos($ref_seq_nr)->seq;
my @seq2 = split "", $self->alignment->get_seq_by_pos($other_seq_nr)->seq;
my @CONSERVATION;
my @match;
while ( $seq1[0] eq "-" or $seq1[0] eq "." ) {
shift @seq1;
shift @seq2;
}
for my $i ( 0 .. $#seq1 ) {
push( @match, ( uc( $seq1[$i] ) eq uc( $seq2[$i] ) ? 1 : 0 ) )
unless ( $seq1[$i] eq "-" or $seq1[$i] eq "." );
}
my @graph = ( $match[0] );
for my $i ( 1 .. ( $#match + $window_size / 2 ) ) {
$graph[$i] = $graph[ $i - 1 ] + ( $i > $#match ? 0 : $match[$i] ) -
( $i < $window_size ? 0 : $match[ $i - $window_size ] );
}
# at this point, the graph values are shifted $window_size/2 to the right
# i.e. the score at a certain position is the score of the window
# UPSTREAM of it: To fix it, we shoud discard the first $window_size/2 scores:
#$self->conservation1 ([]);
foreach my $match_point ( @graph[ int( $window_size / 2 ) .. $#graph ] ) {
push @CONSERVATION, $match_point / $window_size;
}
return TFBS::ConservationProfile->new(
conservation => \@CONSERVATION,
parameters => {
window => $window_size,
cutoff => $cutoff,
ref_seq_nr => $ref_seq_nr,
other_seq_nr => $other_seq_nr,
method => "simple"
},
ref_sequence => $self->ref_sequence,
alignment => $self->alignment
);
}
sub _run_Malins {
shift->throw(
"Not implemeted, sorry. Pick another method for the time being");
}
sub _run_align_cons {
my ( $self, %args ) = @_;
my ( $window_size, $increment, $cutoff, $stringency, $format, $prog ) =
$self->_rearrange(
[qw(WINDOW INCREMENT CUTOFF STRINGENCY FORMAT PROGRAM)], %args );
my %params = (
-w => $window_size,
-n => $increment,
-t => $cutoff,
-s => $stringency,
-r => "p",
-f => ( $format or "c" ) # center by default
);
$prog = "align_cons" unless defined $prog;
my @cl_args;
while ( my ( $param, $value ) = each %params ) {
if ( defined $value ) {
push @cl_args, $param, $value;
}
}
my $alnstring = $self->_alignment_to_string("fasta");
$alnstring =~ s/[\"\$]/\\$1/gs; # escape things that might confuse echo
my $command = join " ", $prog, @cl_args;
my @output_lines = `echo "$alnstring" | $command`;
# add error checking here!!!
my @CONSERVATION;
foreach my $line (@output_lines) {
chomp $line;
$line =~ s/^\D+//;
my ( $pos, $value ) = split /\s+/, $line;
push @CONSERVATION, $value;
}
return TFBS::ConservationProfile->new(
conservation => \@CONSERVATION,
parameters => {
window => $window_size,
cutoff => $cutoff,
increment => $increment,
stringency => $stringency,
method => "align_cons"
},
alignment => $self->alignment,
ref_sequence => $self->ref_sequence
);
}
sub _alignment_to_string {
my ( $self, $format ) = ( @_, "fasta" );
my $alnstring;
my $fh = IO::String->new($alnstring);
my $outstream = Bio::AlignIO->new( -fh => $fh, -format => $format );
$outstream->write_aln( $self->alignment );
$outstream->close;
return $alnstring;
}
#sub _UNIT_TESTS {
# require Test;
# require CONSNP::Test::TestObjects;
# my $to = CONSNP::Test::TestObjects->new;
#
# plan(tests => 5);
#
# exit(0);
#
#
#}
1;
TFBS-0.7.1/TFBS/Run/ConservationProfileGenerator.pm 0000775 0000000 0000000 00000012514 13057522667 0022002 0 ustar 00root root 0000000 0000000 package TFBS::Run::ConservationProfileGenerator;
use strict;
use Bio::Root::Root;
use TFBS::ConservationProfile;
use Bio::AlignIO;
use constant DEFAULT_WINDOW => 50;
use constant DEFAULT_CUTOFF => 0.7;
use vars qw'@ISA';
@ISA = qw'Bio::Root::Root';
sub new {
my ( $caller, %args ) = @_;
my $self = bless {
alignment => undef,
ref_sequence => undef,
method => undef,
window => DEFAULT_WINDOW,
cutoff => DEFAULT_CUTOFF,
%args
},
ref $caller || $caller;
if ( !defined( $self->alignment )
or !$self->alignment->isa("Bio::SimpleAlign") )
{
$self->throw( "alignment: argument missing or wrong object type: "
. ref( $self->alignment ) );
}
return $self;
}
sub run {
my ( $self, %args ) = @_;
my $method = ( $args{method} or $self->method or "simple" );
my %method_subref = (
simple => \&_run_simple,
malin => \&_run_Malins,
align_cons => \&_run_align_cons
);
if ( !defined( $method_subref{$method} ) ) {
$self->throw("method $method not supported");
}
$method_subref{$method}->( $self, %args );
}
sub alignment {
$_[0]->{'alignment'};
}
sub ref_sequence {
$_[0]->{'ref_sequence'};
}
sub method {
$_[0]->{'method'};
}
sub window {
$_[0]->{'window'};
}
sub cutoff {
$_[0]->{'cutoff'};
}
sub _run_simple {
my ( $self, %args ) = @_;
my ( $window_size, $cutoff, $ref_seq_nr, $other_seq_nr ) =
$self->_rearrange( [qw(WINDOW CUTOFF REF_SEQ_NR OTHER_SEQ_NR)], %args );
$window_size = $self->window unless $window_size;
$cutoff = $self->cutoff unless $cutoff;
$ref_seq_nr = 1 if !$ref_seq_nr;
$other_seq_nr = ( $other_seq_nr or 3 - $ref_seq_nr );
my @seq1 = split "", $self->alignment->get_seq_by_pos($ref_seq_nr)->seq;
my @seq2 = split "", $self->alignment->get_seq_by_pos($other_seq_nr)->seq;
my @CONSERVATION;
my @match;
while ( $seq1[0] eq "-" or $seq1[0] eq "." ) {
shift @seq1;
shift @seq2;
}
for my $i ( 0 .. $#seq1 ) {
push( @match, ( uc( $seq1[$i] ) eq uc( $seq2[$i] ) ? 1 : 0 ) )
unless ( $seq1[$i] eq "-" or $seq1[$i] eq "." );
}
my @graph = ( $match[0] );
for my $i ( 1 .. ( $#match + $window_size / 2 ) ) {
$graph[$i] = $graph[ $i - 1 ] + ( $i > $#match ? 0 : $match[$i] ) -
( $i < $window_size ? 0 : $match[ $i - $window_size ] );
}
# at this point, the graph values are shifted $window_size/2 to the right
# i.e. the score at a certain position is the score of the window
# UPSTREAM of it: To fix it, we should discard the first $window_size/2 scores:
#$self->conservation1 ([]);
foreach my $match_point ( @graph[ int( $window_size / 2 ) .. $#graph ] ) {
push @CONSERVATION, $match_point / $window_size;
}
return TFBS::ConservationProfile->new(
conservation => \@CONSERVATION,
parameters => {
window => $window_size,
cutoff => $cutoff,
ref_seq_nr => $ref_seq_nr,
other_seq_nr => $other_seq_nr,
method => "simple"
},
ref_sequence => $self->ref_sequence,
alignment => $self->alignment
);
}
sub _run_Malins {
shift->throw(
"Not implemented, sorry. Pick another method for the time being");
}
sub _run_align_cons {
my ( $self, %args ) = @_;
my ( $window_size, $increment, $cutoff, $stringency, $format, $prog ) =
$self->_rearrange(
[qw(WINDOW INCREMENT CUTOFF STRINGENCY FORMAT PROGRAM)], %args );
my %params = (
-w => $window_size,
-n => $increment,
-t => $cutoff,
-s => $stringency,
-r => "p",
-f => ( $format or "c" ) # center by default
);
$prog = "align_cons" unless defined $prog;
my @cl_args;
while ( my ( $param, $value ) = each %params ) {
if ( defined $value ) {
push @cl_args, $param, $value;
}
}
my $alnstring = $self->_alignment_to_string("fasta");
$alnstring =~ s/[\"\$]/\\$1/gs; # escape things that might confuse echo
my $command = join " ", $prog, @cl_args;
my @output_lines = `echo "$alnstring" | $command`;
# add error checking here!!!
my @CONSERVATION;
foreach my $line (@output_lines) {
chomp $line;
$line =~ s/^\D+//;
my ( $pos, $value ) = split /\s+/, $line;
push @CONSERVATION, $value;
}
return TFBS::ConservationProfile->new(
conservation => \@CONSERVATION,
parameters => {
window => $window_size,
cutoff => $cutoff,
increment => $increment,
stringency => $stringency,
method => "align_cons"
},
alignment => $self->alignment,
ref_sequence => $self->ref_sequence
);
}
sub _alignment_to_string {
my ( $self, $format ) = ( @_, "fasta" );
my $alnstring;
my $fh = IO::String->new($alnstring);
my $outstream = Bio::AlignIO->new( -fh => $fh, -format => $format );
$outstream->write_aln( $self->alignment );
$outstream->close;
return $alnstring;
}
#sub _UNIT_TESTS {
# require Test;
# require CONSNP::Test::TestObjects;
# my $to = CONSNP::Test::TestObjects->new;
#
# plan(tests => 5);
#
# exit(0);
#
#
#}
1;
TFBS-0.7.1/TFBS/Site.pm 0000775 0000000 0000000 00000017030 13057522667 0014276 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Site
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Site - a nucleotide sequence feature object representing (possibly putative) transcription factor binding site.
=head1 SYNOPSIS
# manual creation of site object;
# for details, see documentation of Bio::SeqFeature::Generic;
my $site = TFBS::Site
(-start => $start_pos, # integer
-end => $end_pos, # integer
-score => $score, # float
-source => "TFBS", # string
-primary => "TF binding site", # primary tag
-strand => $strand, # -1, 0 or 1
-seqobj => $seqobj, # a Bio::Seq object whose sequence
# contains the site
-pattern => $pattern_obj # usu. TFBS::Matrix:PWM obj.
-);
# Searching sequence with a pattern (PWM) and retrieving individual sites:
#
# The following objects should be defined for this example:
# $pwm - a TFBS::Matrix::PWM object
# $seqobj - a Bio::Seq object
# Consult the documentation for the above modules if you do not know
# how to create them.
# Scanning sequence with $pwm returns a TFBS::SiteSet object:
my $site_set = $pwm->search_seq(-seqobj => $seqobj,
-threshold => "80%");
# To retrieve individual sites from $site_set, create an iterator obj:
my $site_iterator = $site_set->Iterator(-sort_by => "score");
while (my $site = $site_iterator->next()) {
# do something with $site
}
=head1 DESCRIPTION
TFBS::Site object holds data for a (possibly predicted) transcription factor binding site on a nucleotide sequence (start, end, strand, score, tags, as well as references to the corresponding sequence and pattern objects). TFBS::Site is a subclass of Bio::SeqFeature::Generic and has acces to all of its method. Additionally, it contains the pattern() method, an accessor for pattern object associated with the site object.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
TFBS::Site is a class that extends Bio::SeqFeature::Generic. Please consult Bio::SeqFeature::Generic documentation for other available methods.
=cut
# The code begins HERE:
package TFBS::Site;
use vars qw(@ISA);
use strict;
use Bio::SeqFeature::Generic;
@ISA = qw(Bio::SeqFeature::Generic);
=head2 new
Title : new
Usage : my $site = TFBS::Site->new(%args)
Function: constructor for the TFBS::Site object
Returns : TFBS::Site object
Args : -start, # integer
-end, # integer
-strand, # -1, 0 or 1
-score, # float
-source, # string (method used to detect it)
-primary, # string (primary tag)
-seqobj, # a Bio::Seq object
-pattern # a pattern object, usu. TFBS::Matrix::PWM
=cut
sub new {
my $class = shift;
my %args = (-seq_id => undef,
-siteseq => undef,
-seqobj => undef,
-strand => "0",
-source => "TFBS",
-primary => "TF binding site",
-pattern => undef,
-score => undef,
-start => undef,
-end => undef,
-frame => 0,
@_);
my $obj = Bio::SeqFeature::Generic->new(%args);
my $self = bless $obj, ref($class) || $class;
if ($args{-seqobj}) {
$self->attach_seq($args{-seqobj}) ;
$self->add_tag_value('sequence', $self->seq->seq);
}
# this is only for GFF printing really, and will be moved there soon
if (defined $args{'-pattern'}) {
$self->pattern($args{'-pattern'});
$self->add_tag_value('TF' => $self->pattern->name());
$self->add_tag_value('class' => $self->pattern->class)
if $self->pattern->class;
}
return $self;
}
=head2 pattern
Title : pattern
Usage : my $pattern = $site->pattern(); # gets the pattern
$site->pattern($pwm); # sets the pattern to $pwm
Function: gets/sets the pattern object associated with the site
Returns : pattern object, here TFBS::Matrix::PWM object
Args : pattern object (optional, for setting the pattern only)
=cut
sub pattern {
my ($self, $pattern) = @_;
if (defined $pattern) {
$self->{'pattern'} = $pattern;
}
return $self->{'pattern'};
}
=head2 rel_score
Title : rel_score
Usage : my $percent_score = $site->rel_score() * 100; # gets the pattern
Function: gets relative score (between 0.0 to 1.0) with respect of the score
range of the associated pattern (matrix)
Returns : floating point number between 0 and 1,
or undef if pattern not defined
Args : none
=cut
sub rel_score {
my ($self) = @_;
return undef unless $self->pattern();
return ($self->score - $self->pattern->min_score)/
($self->pattern->max_score - $self->pattern->min_score);
}
=head2 GFF
Title : GFF
Usage : print $site->GFF();
: print $site->GFF($gff_formatter)
Function: returns a "standard" GFF string - the "generic" gff_string
method is left untouched for possible customizations
Returns : a string (NOT newline terminated! )
Args : a $gff_formatter function reference (optional)
=cut
sub GFF {
# due to popular demand, GFF is again a legal method, this time
# not requiring GFF modules
return $_[0]->gff_string($_[1]);
}
=head2 location
=head2 start
=head2 end
=head2 length
=head2 score
=head2 frame
=head2 sub_SeqFeature
=head2 add_sub_SeqFeature
=head2 flush_sub_SeqFeature
=head2 primary_tag
=head2 source_tag
=head2 has_tag
=head2 add_tag_value
=head2 each_tag_value
=head2 all_tags
=head2 remove_tag
=head2 attach_seq
=head2 seq
=head2 entire_seq
=head2 seq_id
=head2 annotation
=head2 gff_format
=head2 gff_string
The above methods are inherited from Bio::SeqFeature::Generic.
Please see L for details on their usage.
=cut
##################################################################
# BACKWARD COMPATIBILITY METHODS
sub Matrix {
my ($self, %args) = @_;
$self->pattern(%args);
}
sub seqobj {
}
sub siteseq {
$_[0]->seq->seq();
}
sub site_length {
my ($self) = @_;
$self->warn("site_length method is present for backward compatibility only. In new code please use the length() method");
return $self->length();
}
sub old_GFF {
eval "require GFF::GeneFeature;";
if ($@) { print STDERR "Failed to load GFF modules, stopped"; return; }
my ($self, %tags) =@_;
$self->warn("GFF method is for backward compatibility only, and its use in new code is not recommended. Please use Bio::SeqFeature::Generic gff methods if possible.");
my $GFFgf = GFF::GeneFeature->new(2);
$GFFgf->seqname ( $self->seqname() or "Unknown" );
$GFFgf->source ("TFBS");
$GFFgf->feature ("TFBS");
$GFFgf->start ($self->start());
$GFFgf->end ($self->end());
$GFFgf->score ($self->score());
$GFFgf->strand (("-",".","+")[$self->strand()+1]);
# $GFFgf->strand ($self->strand());
%tags = (TF => $self->pattern->{name},
class => $self->pattern->{class},
sequence => $self->seq->seq(),
%tags);
while (my ($tag, $value) = each %tags) {
my @values;
if (ref($value) eq "ARRAY") {
@values = @$value;
}
else {
@values = ($value);
}
$GFFgf->attribute($tag, @values);
}
return $GFFgf;
}
1;
TFBS-0.7.1/TFBS/SitePair.pm 0000775 0000000 0000000 00000003173 13057522667 0015115 0 ustar 00root root 0000000 0000000 package TFBS::SitePair;
use vars qw(@ISA);
use strict;
use Bio::SeqFeature::FeaturePair;
@ISA = qw(Bio::SeqFeature::FeaturePair);
# 'new' used to be inherited, but we need it now
sub new {
my ($caller, $site1, $site2) = @_;
#if ($Bio::Root::Root::VERSION < 1.4) {
#return $caller->SUPER::new($site1, $site2);
#}
#else {
return $caller->SUPER::new(-feature1 => $site1,
-feature2 => $site2);
#}
# ^ Version check commented out because from BioPerl 1.5.2
# version nrs are represented differently. // PE 2007-7-11
}
=head2 pattern
Title : pattern
Usage : my $pattern = $sitepair->pattern(); # gets the pattern
# sets the pattern to $pwm
Function: gets the pattern object associated with the site pair
Returns : pattern object, here TFBS::Matrix::PWM object
Args : none (get-only method)
=cut
sub pattern {
$_[0]->feature1->pattern();
}
=head2 GFF
Title : GFF
Usage : print $site->GFF();
: print $site->GFF($gff_formatter)
Function: returns a "standard" multiline GFF string
Returns : a string (multiline, newline terminated)
Args : a $gff_formatter function reference (optional)
=cut
sub GFF {
return join "\n", $_[0]->site1->GFF, $_[0]->site2->GFF;
}
=head2 site1
=head2 site2
Title : site1
site2
Usage : my $site1 = $sitepair->site1();
Function: Returns individual TFBS::Site objects, from the site pair
Returns : a TFBS::Site
Args : none
=cut
sub site1 {
$_[0]->feature1();
}
sub site2 {
$_[0]->feature2();
}
TFBS-0.7.1/TFBS/SitePairSet.pm 0000775 0000000 0000000 00000014244 13057522667 0015572 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::SitePairSet
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::SitePairSet - a set of TFBS::SitePair objects
=head1 SYNOPSIS
my $site_pair_set = TFBS::SitePairSet->new(@list_of_site_pair_objects);
# add a TFBS::SitePair object to set:
$site_pair_set->add_site_pair($site_pair_obj);
# append another TFBS::SitePairSet contents:
$site_pair_set->add_site_pair_set($site_pair_obj);
# create an iterator:
my $it = $site_pair_set->Iterator(-sort_by => 'start');
=head1 DESCRIPTION
TFBS::SitePairSet is an aggregate class that contains a collection
of TFBS::SitePair objects. It can be created anew and filled with
TFBS::Site::Pair object. It is also returned by search_aln() method call
of TFBS::PatternI subclasses (e.g. TFBS::Matrix::PWM).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::SitePairSet;
use vars qw(@ISA $AUTOLOAD);
use strict;
use TFBS::SitePair;
use TFBS::_Iterator::_SiteSetIterator;
@ISA = qw(Bio::Root::Root);
sub new {
my ($class, @data) = @_;
my $self = bless {}, ref($class) || $class;
$self->{_site_array_ref} = [];
@data = @{$class->{_site_array_ref}} if !@data && ref($class);
$self->add_site_pair(@data);
return $self;
}
=head2 size
Title : size
Usage : my $size = $sitepairset->size()
Function: returns a number of TFBS::SitePair objects contained in the set
Returns : a scalar (integer)
Args : none
=cut
sub size {
scalar @{ $_[0]->{_site_array_ref} };
}
=head2 add_site_pair
Title : add_site_pair
Usage : $sitepairset->add_site_pair($site_pair_object)
$sitepairset->add_site_pair(@list_of_site_pair_objects)
Function: adds TFBS::SitePair objects to an existing TFBS::SitePairSet object
Returns : $sitepairset object (usually ignored)
Args : A list of TFBS::SitePair objects to add
=cut
sub add_site_pair {
my ($self, @site_list) = @_;
foreach my $site (@site_list) {
$site->isa("TFBS::SitePair")
or $self->throw("Attempted to add an element ".
"of a wrong type.");
push @{$self->{_site_array_ref}}, $site;
}
return 1;
}
=head2 add_site_pair_set
Title : add_site_pair_set
Usage : $sitepairset->add_site_pair_set($site_pair_set_object)
$sitepairset->add_site_pair(@list_of_site_pair_set_objects)
Function: adds the contents of other TFBS::SitePairSet objects
to an existing TFBS::SitePairSet object
Returns : $sitepairset object (usually ignored)
Args : A list of TFBS::SitePairSet objects whose contents should be
added to $sitepairset
=cut
sub add_site_pair_set {
my ($self, @sitesets) = @_;
foreach my $siteset (@sitesets) {
$siteset->isa("TFBS::SitePairSet")
or $self->throw("Attempted to add an element ".
"that is not a TFBS::SiteSet object.");
push @{$self->{_site_array_ref}},
@{ $siteset->{_site_array_ref} };
}
return $self;
}
=head2 Iterator
Title : Iterator
Usage : my $it = $sitepairset->Iterator(-sort_by=>'start');
while (my $site_pair = $it->next()) { #...
Function: Returns an iterator object, used to iterate thorugh elements
(TFBS::SitePair objects)
Returns : a TFBS::_Iterator object
Args : -sort_by # optional - currently it accepts
# (default sort order in parenthetse)
# 'name' (pattern name, alphabetically)
# 'ID' (pattern/matrix ID, alphabetically)
# 'start' (site start in sequence,
# numerically,increasing order)
# 'end' (site end in sequence,
# numerically, increasing order)
# 'score' (1st site in pair,
# numerically, decreasing order)
-reverse # optional - reverses the default sorting order if true
=cut
sub Iterator {
my ($self, %args) = @_;
return TFBS::_Iterator::_SiteSetIterator->new($self->{_site_array_ref},
$args{'-sort_by'},
$args{'-reverse'}
);
}
=head2 set1
=head2 set2
Title : set1
set2
Usage : my $siteset1 = $sitepairset->set1();
: my $siteset2 = $sitepairset->set2()
Function: Returns individual TFBS::SiteSet objects, from the site set pair
Returns : A TFBS::SiteSet object
Args : none
=cut
sub set1 {
$_[0]->_get_set(1);
}
sub set2 {
$_[0]->_get_set(2);
}
=head2 GFF
Title : GFF
Usage : print $site->GFF();
: print $site->GFF($gff_formatter)
Function: returns a "standard" multiline GFF string
Returns : a string (multiline, newline terminated)
Args : a $gff_formatter function reference (optional)
=cut
sub GFF {
my ($self, %args) = @_;
my $iterator = $self->Iterator(-sort_by=>'start');
my $gff_string = "";
while (my $sitepair = $iterator->next()) {
$gff_string .= $sitepair->GFF(%args)."\n";
}
return $gff_string;
}
##############################################################
# PRIVATE AND AUTOMATIC METHODS
##############################################################
sub _get_set {
my ($self, $set_nr) = @_;
my $feature = "feature$set_nr";
my $it = $self->Iterator();
my $siteset = TFBS::SiteSet->new();
no strict 'refs';
while (my $site_pair = $it->next()) {
eval "$siteset->add_site(\$site_pair->$feature())";
}
return $siteset;
}
sub AUTOLOAD {
my ($self) = @_;
my %discontinued = (sort => 1,
sort_by_name => 1,
sort_reversed => 1,
reverse => 1,
next_site => 1,
reset => 1
);
$AUTOLOAD =~ /.+::(\w+)/;
if ($discontinued{$1}) {
$self->_no_more($1);
}
else {
$self->throw("$1: no such method");
}
}
sub _no_more {
$_[0]->throw("Method '$_[1]' is no longer available in ".
ref($_[0]).". Use the 'Iterator' method instead.");
}
1;
TFBS-0.7.1/TFBS/SiteSet.pm 0000775 0000000 0000000 00000014101 13057522667 0014746 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::SiteSet
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::SiteSet - a set of TFBS::Site objects
=head1 SYNOPSIS
my $site_set = TFBS::SiteSet->new(@list_of_site_objects);
# add a TFBS::Site object to set:
$site_set->add_site($site_obj);
# append another TFBS::SiteSet contents:
$site_pair_set->add_site_set($site_obj);
# create an iterator:
my $it = $site_set->Iterator(-sort_by => 'start');
=head1 DESCRIPTION
TFBS::SiteSet is an aggregate class that contains a collection
of TFBS::Site objects. It can be created anew and filled with
TFBS::Site object. It is also returned by search_seq() method call
of some TFBS::PatternI subclasses (e.g. TFBS::Matrix::PWM).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::SiteSet;
use vars qw(@ISA $AUTOLOAD);
use TFBS::Site;
use TFBS::_Iterator::_SiteSetIterator;
use strict;
@ISA = qw(Bio::Root::Root);
sub new {
my ($class, @data) = @_;
my $self = bless {}, ref($class) || $class;
$self->{_site_array_ref} = [];
@data = @{$class->{site_list}} if !@data && ref($class);
$self->add_site(@data);
return $self;
}
=head2 add_site
Title : add_site
Usage : $siteset->add_site($site_object)
$siteset->add_site(@list_of_site_objects)
Function: adds TFBS::Site objects to an existing TFBS::SiteSet object
Returns : $sitepair object (usually ignored)
Args : A list of TFBS::Site objects to add
=cut
sub add_site {
my ($self, @site_list) = @_;
foreach my $site (@site_list) {
ref($site) =~ /TFBS::Site*/
or $self->throw("Attempted to add an element ".
"of a wrong type.");
push @{$self->{_site_array_ref}}, $site;
}
return 1;
}
=head2 add_site_set
Title : add_site_set
Usage : $siteset->add_site_set($site_set_object)
$siteset->add_site(@list_of_site_set_objects)
Function: adds the contents of other TFBS::SiteSet objects
to an existing TFBS::SiteSet object
Returns : $siteset object (usually ignored)
Args : A list of TFBS::SiteSet objects whose contents should be
added to $siteset
=cut
sub add_siteset {
my ($self, @sitesets) = @_;
foreach my $siteset (@sitesets) {
ref($siteset) =~ /TFBS::Site.*Set/
or $self->throw("Attempted to add an element ".
"that is not a TFBS::SiteSet object.");
push @{$self->{_site_array_ref}},
@{ $siteset->{_site_array_ref} };
}
return $self;
}
=head2 size
Title : size
Usage : my $size = $siteset->size()
Function: returns a number of TFBS::Site objects contained in the set
Returns : a scalar (integer)
Args : none
=cut
sub size {
scalar @{ $_[0]->{_site_array_ref} };
}
=head2 Iterator
Title : Iterator
Usage : my $siteset_iterator =
$siteset->Iterator(-sort_by =>'start');
while (my $site = $siteset_iterator->next) {
# do whatever you want with individual matrix objects
}
Function: Returns an iterator object that can be used to go through
all members of the set (TFBS::Site objects)
Returns : an iterator object (currently undocumentened in TFBS -
but understands the 'next' method)
Args : -sort_by # optional - currently it accepts
# (default sort order in parenthetse)
# 'name' (pattern name, alphabetically)
# 'ID' (pattern/matrix ID, alphabetically)
# 'start' (site start in sequence,
# numerically,increasing order)
# 'end' (site end in sequence,
# numerically, increasing order)
# 'score' (numerically, decreasing order)
-reverse # optional - reverses the default sorting order if true
=cut
sub Iterator {
my ($self, %args) = @_;
return TFBS::_Iterator::_SiteSetIterator->new($self->{_site_array_ref},
$args{'-sort_by'},
$args{'-reverse'}
);
}
sub all_sites {
my ($self,%args) = @_;
return @{$self->{_site_array_ref}} if @{$self->{_site_array_ref}};
}
=head2 GFF
Title : GFF
Usage : print $siteset->GFF();
: print $siteset->GFF($gff_formatter)
Function: returns a "standard" multiline GFF string
Returns : a string (multiline, newline terminated)
Args : a $gff_formatter function reference (optional)
=cut
sub GFF {
my ($self, %args) = @_;
my $site_iterator = $self->Iterator(-sort_by=>'start');
my $gff_string = "";
while (my $site = $site_iterator->next()) {
$gff_string .= $site->GFF(%args)."\n";
}
return $gff_string;
}
########################################################
# OBSOLETE METHODS
########################################################
sub old_GFF {
eval "require GFF::GeneFeatureSet;";
if ($@) { print STDERR "Failed to load GFF modules, stopped"; return; }
my ($self) = @_;
my $site_iterator = $self->Iterator(-sort_by=>'start');
my $GFFset = GFF::GeneFeatureSet->new(2);
while (my $site = $site_iterator->next()) {
$GFFset->addGeneFeature($site->GFF());
}
return $GFFset;
}
##############################################################
# PRIVATE AND AUTOMATIC METHODS
##############################################################
sub AUTOLOAD {
my ($self) = @_;
my %discontinued = (sort => 1,
sort_by_name => 1,
sort_reversed => 1,
reverse => 1,
next_site => 1,
reset => 1
);
$AUTOLOAD =~ /.+::(\w+)/;
if ($discontinued{$1}) {
$self->_no_more($1);
}
else {
$self->throw("$1: no such method");
}
}
sub _no_more {
$_[0]->throw("Method '$_[1]' is no longer available in ".
ref($_[0]).". Use the 'Iterator' method instead.");
}
1;
TFBS-0.7.1/TFBS/TFFM.pm 0000775 0000000 0000000 00000012320 13057522667 0014123 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::TFFM
#
# You may distribute this module under the same terms as perl itself
#
# Date: 2015/10/06
#
# POD
=head1 NAME
TFBS::TFFM - class for Transcription Factor Flexible Models (TFFMs)
=head1 DESCRIPTION
TFBS::TFFM is a class to hold basic information about a TFFM. It was
mainly designed to store the information about a TFFM stored in the
TFFM table of the JASPAR DB newly introduced in the JASPAR 2016 version.
It does NOT (currently) store the actual XML describing the the model but
this would be simple to add. At the time of this writing the relationship
between JASPAR matrices as stored in the MATRIX table and TFFMs was not
completely clear and the matrix IDs related to a TFFM are stored in the
TFFM table. The relationship could be 1:n, m:1 or m:n in the future so
this may well be changed and a joining table created to facilitate this.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - David Arenillas
David Arenillas: dave@cmmt.ubc.ca
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::TFFM;
use strict;
sub new
{
my $class = shift;
my %args = @_;
my $self = bless {}, ref($class) || $class;
$self->{'ID'} = $args{-ID} || "Unknown";
$self->{'name'} = $args{-name} || "Unknown";
$self->{'matrix_ID'} = $args{-matrix_ID};
$self->{'log_p_1st_order'} = $args{-log_p_1st_order};
$self->{'log_p_detailed'} = $args{-log_p_detailed};
$self->{'experiment_name'} = $args{-experiment_name};
# The JASPAR matrix related to this TFFM
my $matrix = $args{-matrix};
if ($matrix) {
if ($matrix->ISA('TFBS::Matrix')) {
$self->{'matrix'} = $matrix;
} else {
$self->throw(
"Provided -matrix argument does not refer to a TFBS::Matrix"
. " object"
);
}
}
return $self;
}
=head2 ID
Title : ID
Usage : my $id = $tffm->ID();
Function: Get/set the ID of this TFFM.
Returns : The ID of this TFFM.
Args : None for get or a new string ID.
=cut
sub ID
{
my ($self, $id) = @_;
if ($id) {
$self->{ID} = $id;
}
return $self->{ID};
}
=head2 name
Title : name
Usage : my $name = $tffm->name();
Function: Get/set the name of the transcription factor for which this TFFM
was modelled.
Returns : Name of the TF modelled by this TFFM.
Args : None for get or a new string TF name.
=cut
sub name
{
my ($self, $name) = @_;
if ($name) {
$self->{name} = $name;
}
return $self->{name};
}
=head2 experiment_name
Title : experiment_name
Usage : my $filename = $tffm->experiment_name();
Function: Get/set the name of the experimental data on which this TFFM
(generally ChIP-seq peak data) TFFM was trained. Often this
is base file name of ChIP-seq peaks file.
Returns : Name of the experiment/datafile.
Args : None for get or a new experiment/datafile name.
=cut
sub experiment_name
{
my ($self, $exp_name) = @_;
if ($exp_name) {
$self->{experiment_name} = $exp_name;
}
return $self->{experiment_name};
}
=head2 log_p_1st_order
Title : log_p_1st_order
Usage : my $log_p_val = $tffm->log_p_1st_order();
Function: Get/set the log(p) value for the 1st order model of this TFFM.
Returns : Log(p) value of the 1st-order model.
Args : None for get or a new 1st-order log(p) value.
=cut
sub log_p_1st_order
{
my ($self, $log_p_val) = @_;
if ($log_p_val) {
$self->{log_p_1st_order} = $log_p_val;
}
return $self->{log_p_1st_order};
}
=head2 log_p_detailed
Title : log_p_detailed
Usage : my $log_p_val = $tffm->log_p_detailed();
Function: Get/set the log(p) value for the detailed model of this TFFM.
Returns : Log(p) value of the detailed model.
Args : None for get or a new detailed log(p) value.
=cut
sub log_p_detailed
{
my ($self, $log_p_val) = @_;
if ($log_p_val) {
$self->{log_p_detailed} = $log_p_val;
}
return $self->{log_p_detailed};
}
=head2 matrix_ID
Title : matrix_ID
Usage : my $matrix_id = $tffm->matrix_ID();
Function: Get/set the ID of the matrix associated to this TFFM.
Returns : ID of the matrix associated to this TFFM.
Args : None for get or a JASPAR matrix ID.
=cut
sub matrix_ID
{
my ($self, $matrix_id) = @_;
if ($matrix_id) {
$self->{matrix_ID} = $matrix_id;
}
return $self->{matrix_ID};
}
=head2 matrix
Title : matrix
Usage : my $matrix = $tffm->matrix();
Function: Get/set the matrix object related to this TFFM
Returns : A reference to TFBS::Matrix object which was used to train the
TFFM.
Args : None for get or a new TFBS::Matrix object reference.
=cut
sub matrix
{
my ($self, $matrix) = @_;
if ($matrix) {
if ($matrix->ISA("TFBS::Matrix")) {
$self->{matrix} = $matrix;
} else {
$self->throw(
"Provided matrix argument does not refer to a TFBS::Matrix"
. " object"
);
}
}
return $self->{'matrix'};
}
1;
TFBS-0.7.1/TFBS/Tools/ 0000775 0000000 0000000 00000000000 13057522667 0014130 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Tools/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0015014 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Tools/.svn/all-wcprops 0000775 0000000 0000000 00000000302 13057522667 0017200 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 39
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Tools
END
SetOperations.pm
K 25
svn:wc:ra_dav:version-url
V 56
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Tools/SetOperations.pm
END
TFBS-0.7.1/TFBS/Tools/.svn/entries 0000775 0000000 0000000 00000000534 13057522667 0016415 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/Tools
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
SetOperations.pm
file
2009-08-07T13:10:43.000000Z
de714ffa79e6ed4e3c997e3dfce58183
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/Tools/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0016222 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/Tools/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0016710 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Tools/.svn/text-base/SetOperations.pm.svn-base 0000775 0000000 0000000 00000013451 13057522667 0023571 0 ustar 00root root 0000000 0000000 package TFBS::Tools::SetOperations;
use strict;
use Bio::Root::Root;
use vars qw'@ISA';
@ISA = qw'Bio::Root::Root';
sub new {
my ($caller, @args) = @_;
my $self = bless {}, ref $caller || $caller;
my ($index_by, $strict, $output_type, $pairs) =
$self->_rearrange([qw'INDEX_BY STRICT OUTPUT_TYPE PAIRS'], @args);
$self->index_by($index_by);
$self->strict($strict);
$self->output_type($output_type);
$self->pairs($pairs);
return $self;
}
sub union {
my ($self, @sets) = @_;
my %union_index =
map {$self->_index($_)} $self->_sets_to_arrayrefs(@sets);
$self->_output(\%union_index);
}
sub intersection {
my ($self, @sets) = @_;
my @set_arrayrefs = $self->_sets_to_arrayrefs(@sets);
#this would be faster, but we might want to retain the exact objects
# that were present in
#my @set_arrayrefs = sort {@$a <=> @$b} $self->_sets_to_arrayrefs(@sets);
my %intersection_index = $self->_index(shift @set_arrayrefs);
foreach my $set_arrayref (@set_arrayrefs) {
my %curr_set_index = $self->_index($set_arrayref);
my @help_array = %curr_set_index;
foreach my $key (keys %intersection_index) {
if (!exists $curr_set_index{$key}) {
delete $intersection_index{$key} ;
}
}
}
$self->_output(\%intersection_index);
}
sub difference {
# pairs only for now
my ($self, @sets) = @_;
my ($set1, $set2) = $self->_sets_to_arrayrefs(@sets);
if (!defined $set2) {
$self->throw ("'difference' needs exactly two sets as arguments");
}
my %diff_index1 = $self->_index($set1);
my %diff_index2 = $self->_index($set2);
foreach my $key (keys %diff_index1) {
if (exists $diff_index2{$key}) {
delete $diff_index1{$key};
delete $diff_index2{$key};
}
}
wantarray ? ($self->_output(\%diff_index1), $self->_output(\%diff_index2))
: $self->_output(\%diff_index1);
}
sub index_by {
my $self = shift;
# By default, we are dealing with Bio::SeqFeatureI objects
my @DEFAULTS = qw(primary_tag source_tag start end score strand);
if (@_) {
if(!defined $_[0]) {
$self->{_index_by} = \@DEFAULTS;
}
elsif (ref($_[0]) eq "ARRAY") {
$self->{_index_by} = $_[0];
}
else {
$self->{_index_by} = [@_];
}
}
return @{$self->{_index_by}};
}
sub strict {
my $self = shift;
if (@_) {
if ($self->{_strict} = shift) {
$self->{_index_fn} = \&_index_strict;
}
else {
$self->{_index_fn} = \&_index_by_annotation;
}
}
return $self->{_strict};
}
sub output_type {
my $self = shift;
if (@_) {
unless ($self->{_output_type} = shift) {
$self->{_output_type} = "arrayref"
}
}
return $self->{_output_type};
}
sub pairs {
my $self = shift;
if (@_) {
if ($self->{_pairs} = shift and !$self->strict) {
$self->{_index_fn} = \&_index_by_pair_annotation;
}
}
return $self->{_pairs};
}
sub _index {
my ($self) = @_;
$self->{_index_fn}->(@_);
}
sub _index_strict {
my ($self, $set_arrayref) = @_;
my %index_hash = (map {$_, $_} @$set_arrayref);
return %index_hash;
}
sub _index_by_pair_annotation {
my ($self, $set_arrayref) = @_;
my %index_hash;
foreach my $member (@$set_arrayref) {
my @index_elements = ($self->_get_index_elements($member->feature1),
$self->_get_index_elements($member->feature2));
$index_hash{join("::", @index_elements)} = $member;
}
return %index_hash;
}
sub _index_by_annotation {
my ($self, $set_arrayref) = @_;
my %index_hash;
foreach my $member (@$set_arrayref) {
my @index_elements = $self->_get_index_elements($member);
$index_hash{join("::", @index_elements)} = $member;
}
return %index_hash;
}
sub _get_index_elements {
my ($self, $set_member) = @_;
my @index_elements;
foreach my $method ($self->index_by) {
if (ref($method) eq 'CODE') {
push @index_elements, $method->($set_member);
}
else {
eval { push @index_elements, $set_member->$method; };
if ($@) {
$self->throw(sprintf("Could not use '%s' for indexing a %s object. The original error was:\n",
$method, ref($set_member)).$@)
}
}
}
return @index_elements;
}
sub _sets_to_arrayrefs {
my ($self, @sets) = @_;
my @set_arrayrefs;
foreach my $set (@sets) {
if (ref($set) eq "ARRAY") {
push @set_arrayrefs, $set;
}
elsif(ref($set) and $set->can("Iterator")) {
my @set_elements;
my $it = $set->Iterator;
while (my $set_el = $it->next) { push @set_elements, $set_el }
push @set_arrayrefs, \@set_elements;
}
else {
$self->throw("Set must be an aray reference or have an ".
"Iterator method. Got ".(ref($set or $set)). "instead.");
}
}
return @set_arrayrefs;
}
sub _output {
my ($self, $hashref) = @_;
if ($self->output_type eq "arrayref") {
return [values %$hashref];
}
elsif ($self->output_type eq "array") {
return %$hashref;
}
elsif ($self->output_type eq "matrix_set") {
my $setobj = TFBS::MatrixSet->new;
$setobj->add_Matrix(values %$hashref);
return $setobj;
}
elsif ($self->output_type eq "site_set") {
my $setobj = TFBS::SiteSet->new;
$setobj->add_site(values %$hashref);
return $setobj;
}
else {
$self->throw($self->output_type." is not a supported output type");
}
}
1;
TFBS-0.7.1/TFBS/Tools/SetOperations.pm 0000775 0000000 0000000 00000013451 13057522667 0017274 0 ustar 00root root 0000000 0000000 package TFBS::Tools::SetOperations;
use strict;
use Bio::Root::Root;
use vars qw'@ISA';
@ISA = qw'Bio::Root::Root';
sub new {
my ($caller, @args) = @_;
my $self = bless {}, ref $caller || $caller;
my ($index_by, $strict, $output_type, $pairs) =
$self->_rearrange([qw'INDEX_BY STRICT OUTPUT_TYPE PAIRS'], @args);
$self->index_by($index_by);
$self->strict($strict);
$self->output_type($output_type);
$self->pairs($pairs);
return $self;
}
sub union {
my ($self, @sets) = @_;
my %union_index =
map {$self->_index($_)} $self->_sets_to_arrayrefs(@sets);
$self->_output(\%union_index);
}
sub intersection {
my ($self, @sets) = @_;
my @set_arrayrefs = $self->_sets_to_arrayrefs(@sets);
#this would be faster, but we might want to retain the exact objects
# that were present in
#my @set_arrayrefs = sort {@$a <=> @$b} $self->_sets_to_arrayrefs(@sets);
my %intersection_index = $self->_index(shift @set_arrayrefs);
foreach my $set_arrayref (@set_arrayrefs) {
my %curr_set_index = $self->_index($set_arrayref);
my @help_array = %curr_set_index;
foreach my $key (keys %intersection_index) {
if (!exists $curr_set_index{$key}) {
delete $intersection_index{$key} ;
}
}
}
$self->_output(\%intersection_index);
}
sub difference {
# pairs only for now
my ($self, @sets) = @_;
my ($set1, $set2) = $self->_sets_to_arrayrefs(@sets);
if (!defined $set2) {
$self->throw ("'difference' needs exactly two sets as arguments");
}
my %diff_index1 = $self->_index($set1);
my %diff_index2 = $self->_index($set2);
foreach my $key (keys %diff_index1) {
if (exists $diff_index2{$key}) {
delete $diff_index1{$key};
delete $diff_index2{$key};
}
}
wantarray ? ($self->_output(\%diff_index1), $self->_output(\%diff_index2))
: $self->_output(\%diff_index1);
}
sub index_by {
my $self = shift;
# By default, we are dealing with Bio::SeqFeatureI objects
my @DEFAULTS = qw(primary_tag source_tag start end score strand);
if (@_) {
if(!defined $_[0]) {
$self->{_index_by} = \@DEFAULTS;
}
elsif (ref($_[0]) eq "ARRAY") {
$self->{_index_by} = $_[0];
}
else {
$self->{_index_by} = [@_];
}
}
return @{$self->{_index_by}};
}
sub strict {
my $self = shift;
if (@_) {
if ($self->{_strict} = shift) {
$self->{_index_fn} = \&_index_strict;
}
else {
$self->{_index_fn} = \&_index_by_annotation;
}
}
return $self->{_strict};
}
sub output_type {
my $self = shift;
if (@_) {
unless ($self->{_output_type} = shift) {
$self->{_output_type} = "arrayref"
}
}
return $self->{_output_type};
}
sub pairs {
my $self = shift;
if (@_) {
if ($self->{_pairs} = shift and !$self->strict) {
$self->{_index_fn} = \&_index_by_pair_annotation;
}
}
return $self->{_pairs};
}
sub _index {
my ($self) = @_;
$self->{_index_fn}->(@_);
}
sub _index_strict {
my ($self, $set_arrayref) = @_;
my %index_hash = (map {$_, $_} @$set_arrayref);
return %index_hash;
}
sub _index_by_pair_annotation {
my ($self, $set_arrayref) = @_;
my %index_hash;
foreach my $member (@$set_arrayref) {
my @index_elements = ($self->_get_index_elements($member->feature1),
$self->_get_index_elements($member->feature2));
$index_hash{join("::", @index_elements)} = $member;
}
return %index_hash;
}
sub _index_by_annotation {
my ($self, $set_arrayref) = @_;
my %index_hash;
foreach my $member (@$set_arrayref) {
my @index_elements = $self->_get_index_elements($member);
$index_hash{join("::", @index_elements)} = $member;
}
return %index_hash;
}
sub _get_index_elements {
my ($self, $set_member) = @_;
my @index_elements;
foreach my $method ($self->index_by) {
if (ref($method) eq 'CODE') {
push @index_elements, $method->($set_member);
}
else {
eval { push @index_elements, $set_member->$method; };
if ($@) {
$self->throw(sprintf("Could not use '%s' for indexing a %s object. The original error was:\n",
$method, ref($set_member)).$@)
}
}
}
return @index_elements;
}
sub _sets_to_arrayrefs {
my ($self, @sets) = @_;
my @set_arrayrefs;
foreach my $set (@sets) {
if (ref($set) eq "ARRAY") {
push @set_arrayrefs, $set;
}
elsif(ref($set) and $set->can("Iterator")) {
my @set_elements;
my $it = $set->Iterator;
while (my $set_el = $it->next) { push @set_elements, $set_el }
push @set_arrayrefs, \@set_elements;
}
else {
$self->throw("Set must be an aray reference or have an ".
"Iterator method. Got ".(ref($set or $set)). "instead.");
}
}
return @set_arrayrefs;
}
sub _output {
my ($self, $hashref) = @_;
if ($self->output_type eq "arrayref") {
return [values %$hashref];
}
elsif ($self->output_type eq "array") {
return %$hashref;
}
elsif ($self->output_type eq "matrix_set") {
my $setobj = TFBS::MatrixSet->new;
$setobj->add_Matrix(values %$hashref);
return $setobj;
}
elsif ($self->output_type eq "site_set") {
my $setobj = TFBS::SiteSet->new;
$setobj->add_site(values %$hashref);
return $setobj;
}
else {
$self->throw($self->output_type." is not a supported output type");
}
}
1;
TFBS-0.7.1/TFBS/Word.pm 0000775 0000000 0000000 00000004275 13057522667 0014314 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Word
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Word - base class for word-based patterns
=head1 DESCRIPTION
TFBS::Word is a base class consisting of universal constructor called by
its subclasses (TFBS::Matrix::*), and word pattern manipulation methods that
are independent of the word type. It is not meant to be instantiated itself.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Word;
use vars '@ISA';
use TFBS::PatternI;
use strict;
@ISA = qw(TFBS::PatternI);
=head2 new
=cut
sub new {
my ($caller, @args) = @_;
my $self = $caller->SUPER::new(@args);
my ($id, $name, $class, $word, $tagref) = $self->_rearrange([qw(ID NAME CLASS
WORD TAGS)], @args);
if (defined $word) { $self->word($word); }
else { $self->throw("Need a -word argument"); }
$self->name($name);
$self->ID($id);
$self->{'tags'} = ($tagref or {});
return $self;
}
=head2 word
=cut
sub word {
my ($self, @args) = @_;
if(scalar(@args) == 0) {
return $self->{'word'};
}
my ($word) = @args;
if (defined $word and ! $self->validate_word($word)) {
$self->throw("Trying to set the word to an invalid value: $word");
}
else {
return $self->{'word'} = $word;
}
}
=head2 validate_word
Required in all subclasses
=cut
sub validate_word {
shift->throw("Error: method 'validate_word' not implemented");
}
=head2 length
=cut
sub length {
# wird length does not have to be defined, but its subroutine does
shift->throw("Error: method 'length' not implemented");
}
=head2 search_seq
=cut
sub search_seq {
shift->throw("Error: method search_seq not implemented");
}
=head2 search_aln
=cut
sub search_aln {
shift->throw("Error: method search_aln not implemented");
}
1; TFBS-0.7.1/TFBS/Word/ 0000775 0000000 0000000 00000000000 13057522667 0013743 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Word/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0014627 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Word/.svn/all-wcprops 0000775 0000000 0000000 00000000270 13057522667 0017017 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 38
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Word
END
Consensus.pm
K 25
svn:wc:ra_dav:version-url
V 51
/svn/lenhard/!svn/ver/8/TFBS/TFBS/Word/Consensus.pm
END
TFBS-0.7.1/TFBS/Word/.svn/entries 0000775 0000000 0000000 00000000527 13057522667 0016232 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/Word
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
Consensus.pm
file
2009-08-07T13:11:00.000000Z
0b9f7fd3d406a1f03748bc19ea6e191c
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/Word/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0016035 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/Word/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0016523 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/Word/.svn/text-base/Consensus.pm.svn-base 0000775 0000000 0000000 00000015041 13057522667 0022562 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Word::Consensus
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Word - IUPAC DNA consensus word-based pattern class
=head1 DESCRIPTION
TFBS::Word is a base class consisting of universal constructor called by
its subclasses (TFBS::Matrix::*), and word pattern manipulation methods that
are independent of the word type. It is not meant to be instantiated itself.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
package TFBS::Word::Consensus;
use vars '@ISA';
use TFBS::Word;
use TFBS::Matrix::PWM;
use strict;
@ISA = qw(TFBS::Word);
=head2 new
Title : new
Usage : my $pwm = TFBS::Matrix::PWM->new(%args)
Function: constructor for the TFBS::Matrix::PWM object
Returns : a new TFBS::Matrix::PWM object
Args : # you must specify the -word argument:
-word, # a strig consisting of letters in
# IUPAC degenerate DNA alphabet
# (any of ACGTSWKMPYBDHVN)
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # a hash reference reference, OPTIONAL
=cut
# "new" is inherited from TFBS::Word
=head2 search_seq
Title : search_seq
Usage : my $siteset = $pwm->search_seq(%args)
Function: scans a nucleotide sequence with the pattern represented
by the PWM
Returns : a TFBS::SiteSet object
Args : # you must specify either one of the following three:
-file, # the name od a fasta file (single sequence)
#or
-seqobj # a Bio::Seq object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-seqstring # a string containing the sequence
-max_mismatches, # number of allowed positions in the site that do
# not match the consensus
# OPTIONAL: default 0
=cut
sub search_seq {
my ($self, @args) = @_;
my ($max_mismatch) = $self->_rearrange([qw(MAX_MISMATCHES)], @args) or 0;
$max_mismatch = 0 unless defined $max_mismatch;
my $pwm = $self->to_PWM;
my $siteset = $pwm->search_seq(@args,
-threshold => $self->length - $max_mismatch);
$self->_replace_patterns_in_siteset($siteset);
return $siteset;
}
=head2 search_aln
Title : search_aln
Usage : my $site_pair_set = $pwm->search_aln(%args)
Function: Scans a pairwise alignment of nucleotide sequences
with the pattern represented by the word: it reports only
those hits that are present in equivalent positions of both
sequences and exceed a specified threshold score in both, AND
are found in regions of the alignment above the specified
conservation cutoff value.
Returns : a TFBS::SitePairSet object
Args : # you must specify either one of the following three:
-file, # the name of the alignment file in Clustal
format
#or
-alignobj # a Bio::SimpleAlign object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-alignstring # a multi-line string containing the alignment
# in clustal format
#############
-max_mismatches, # number of allowed positions in the site that do
# not match the consensus
# OPTIONAL: default 0
-window, # size of the sliding window (inn nucleotides)
# for calculating local conservation in the
# alignment
# OPTIONAL: default 50
-cutoff # conservation cutoff (%) for including the
# region in the results of the pattern search
# OPTIONAL: default "70%"
=cut
sub search_aln {
my ($self, @args) = @_;
my ($max_mismatch) = $self->_rearrange([qw(MAX_MISMATCHES)], @args) or 0;
$max_mismatch = 0 unless defined $max_mismatch;
my $pwm = $self->to_PWM;
my $sitepairset = $pwm->search_aln(@args,
-threshold => $self->length - $max_mismatch);
$self->_replace_patterns_in_sitepairset($sitepairset);
return $sitepairset;
}
=head2 to_PWM
=cut
sub to_PWM {
my ($self, @args) = @_;
my $pwm = TFBS::Matrix::PWM->new(-ID => $self->ID,
-name => $self->name,
-class => $self->class,
-matrix => _consensus2matrixref($self->word),
-tags => {$self->all_tags}
);
return $pwm;
}
=head2 validate_word
=cut
sub validate_word {
my ($self, $word) = @_;
$word =~ s/[ACGTSWKMRYBDHVN]//gi;
return ($word eq "");
}
=head2 length
=cut
sub length {
return length $_[0]->word;
}
# private methods
sub _replace_patterns_in_siteset {
my ($self, $siteset) = @_;
my $iter = $siteset->Iterator;
while (my $site = $iter->next) {
$site->pattern($self);
}
}
sub _replace_patterns_in_sitepairset {
my ($self, $sitepairset) = @_;
my $iter = $sitepairset->Iterator;
while (my $sitepair = $iter->next) {
$sitepair->feature1->pattern($self);
$sitepair->feature2->pattern($self);
}
}
# utility functions
sub _consensus2matrixref {
my ($word) = @_;
my %iupac = ( T => [0,0,0,1],
G => [0,0,1,0],
K => [0,0,1,1],
C => [0,1,0,0],
Y => [0,1,0,1],
S => [0,1,1,0],
B => [0,1,1,1],
A => [1,0,0,0],
W => [1,0,0,1],
R => [1,0,1,0],
D => [1,0,1,1],
M => [1,1,0,0],
H => [1,1,0,1],
V => [1,1,1,0],
N => [1,1,1,1]
);
my @vert_array;
foreach my $letter (split '', $word) {
push @vert_array,
($iupac{uc($letter)}
or croak ("$letter is not a legal IUPAC DNA character"));
}
return _transpose_arrayref(\@vert_array);
}
sub _transpose_arrayref {
my $vert_arrayref = shift;
my $maxcol = scalar(@$vert_arrayref) - 1;
my @horiz_array;
foreach my $row (0..3) {
push @horiz_array, [ map { $vert_arrayref->[$_][$row] } 0..$maxcol ];
}
return \@horiz_array;
}
1;
TFBS-0.7.1/TFBS/Word/Consensus.pm 0000775 0000000 0000000 00000015041 13057522667 0016265 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Word::Consensus
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Word - IUPAC DNA consensus word-based pattern class
=head1 DESCRIPTION
TFBS::Word is a base class consisting of universal constructor called by
its subclasses (TFBS::Matrix::*), and word pattern manipulation methods that
are independent of the word type. It is not meant to be instantiated itself.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
package TFBS::Word::Consensus;
use vars '@ISA';
use TFBS::Word;
use TFBS::Matrix::PWM;
use strict;
@ISA = qw(TFBS::Word);
=head2 new
Title : new
Usage : my $pwm = TFBS::Matrix::PWM->new(%args)
Function: constructor for the TFBS::Matrix::PWM object
Returns : a new TFBS::Matrix::PWM object
Args : # you must specify the -word argument:
-word, # a strig consisting of letters in
# IUPAC degenerate DNA alphabet
# (any of ACGTSWKMPYBDHVN)
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # a hash reference reference, OPTIONAL
=cut
# "new" is inherited from TFBS::Word
=head2 search_seq
Title : search_seq
Usage : my $siteset = $pwm->search_seq(%args)
Function: scans a nucleotide sequence with the pattern represented
by the PWM
Returns : a TFBS::SiteSet object
Args : # you must specify either one of the following three:
-file, # the name od a fasta file (single sequence)
#or
-seqobj # a Bio::Seq object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-seqstring # a string containing the sequence
-max_mismatches, # number of allowed positions in the site that do
# not match the consensus
# OPTIONAL: default 0
=cut
sub search_seq {
my ($self, @args) = @_;
my ($max_mismatch) = $self->_rearrange([qw(MAX_MISMATCHES)], @args) or 0;
$max_mismatch = 0 unless defined $max_mismatch;
my $pwm = $self->to_PWM;
my $siteset = $pwm->search_seq(@args,
-threshold => $self->length - $max_mismatch);
$self->_replace_patterns_in_siteset($siteset);
return $siteset;
}
=head2 search_aln
Title : search_aln
Usage : my $site_pair_set = $pwm->search_aln(%args)
Function: Scans a pairwise alignment of nucleotide sequences
with the pattern represented by the word: it reports only
those hits that are present in equivalent positions of both
sequences and exceed a specified threshold score in both, AND
are found in regions of the alignment above the specified
conservation cutoff value.
Returns : a TFBS::SitePairSet object
Args : # you must specify either one of the following three:
-file, # the name of the alignment file in Clustal
format
#or
-alignobj # a Bio::SimpleAlign object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-alignstring # a multi-line string containing the alignment
# in clustal format
#############
-max_mismatches, # number of allowed positions in the site that do
# not match the consensus
# OPTIONAL: default 0
-window, # size of the sliding window (inn nucleotides)
# for calculating local conservation in the
# alignment
# OPTIONAL: default 50
-cutoff # conservation cutoff (%) for including the
# region in the results of the pattern search
# OPTIONAL: default "70%"
=cut
sub search_aln {
my ($self, @args) = @_;
my ($max_mismatch) = $self->_rearrange([qw(MAX_MISMATCHES)], @args) or 0;
$max_mismatch = 0 unless defined $max_mismatch;
my $pwm = $self->to_PWM;
my $sitepairset = $pwm->search_aln(@args,
-threshold => $self->length - $max_mismatch);
$self->_replace_patterns_in_sitepairset($sitepairset);
return $sitepairset;
}
=head2 to_PWM
=cut
sub to_PWM {
my ($self, @args) = @_;
my $pwm = TFBS::Matrix::PWM->new(-ID => $self->ID,
-name => $self->name,
-class => $self->class,
-matrix => _consensus2matrixref($self->word),
-tags => {$self->all_tags}
);
return $pwm;
}
=head2 validate_word
=cut
sub validate_word {
my ($self, $word) = @_;
$word =~ s/[ACGTSWKMRYBDHVN]//gi;
return ($word eq "");
}
=head2 length
=cut
sub length {
return length $_[0]->word;
}
# private methods
sub _replace_patterns_in_siteset {
my ($self, $siteset) = @_;
my $iter = $siteset->Iterator;
while (my $site = $iter->next) {
$site->pattern($self);
}
}
sub _replace_patterns_in_sitepairset {
my ($self, $sitepairset) = @_;
my $iter = $sitepairset->Iterator;
while (my $sitepair = $iter->next) {
$sitepair->feature1->pattern($self);
$sitepair->feature2->pattern($self);
}
}
# utility functions
sub _consensus2matrixref {
my ($word) = @_;
my %iupac = ( T => [0,0,0,1],
G => [0,0,1,0],
K => [0,0,1,1],
C => [0,1,0,0],
Y => [0,1,0,1],
S => [0,1,1,0],
B => [0,1,1,1],
A => [1,0,0,0],
W => [1,0,0,1],
R => [1,0,1,0],
D => [1,0,1,1],
M => [1,1,0,0],
H => [1,1,0,1],
V => [1,1,1,0],
N => [1,1,1,1]
);
my @vert_array;
foreach my $letter (split '', $word) {
push @vert_array,
($iupac{uc($letter)}
or croak ("$letter is not a legal IUPAC DNA character"));
}
return _transpose_arrayref(\@vert_array);
}
sub _transpose_arrayref {
my $vert_arrayref = shift;
my $maxcol = scalar(@$vert_arrayref) - 1;
my @horiz_array;
foreach my $row (0..3) {
push @horiz_array, [ map { $vert_arrayref->[$_][$row] } 0..$maxcol ];
}
return \@horiz_array;
}
1;
TFBS-0.7.1/TFBS/_Iterator.pm 0000775 0000000 0000000 00000003007 13057522667 0015321 0 ustar 00root root 0000000 0000000 package TFBS::_Iterator;
use vars '@ISA';
use strict;
use Carp;
@ISA = qw(Bio::Root::Root);
#############################################################
# PUBLIC METHODS
#############################################################
sub new {
my ($caller, $arrayref, $sort_by, $reverse) = @_;
my $class = ref $caller || $caller;
my $self;
if ($arrayref) {
$self = bless { _orig_array_ref => [ @$arrayref ],
_iterator_array_ref => [ @$arrayref ],
_sort_by => ($sort_by || undef),
_reverse => ($reverse || 0)
},
$class;
}
else {
croak("No valid array ref for Iterator of ".
(ref($class) || $class)." provided:");
}
$self->_sort() if $sort_by;
$self->_reverse() if $reverse;
return $self;
}
sub current {
}
sub reset {
my ($self) = @_;
@{$self->{_iterator_array_ref}} = @{$self->{_orig_array_ref}};
$self->_sort() if $self->{'_sort_by'};
$self->_reverse() if $self->{'reverse'};
return $self;
}
sub next {
my $self = shift;
return shift @{$self->{_iterator_array_ref}};
}
#################################################################
# PRIVATE METHODS
#################################################################
sub _sort {
my ($self, $sort_by) = @_;
$self->throw("Generic iterator cannot sort ".ref($self).
" object by '$sort_by'.");
}
sub _reverse {
my $self = shift;
$self->{'_iterator_array_ref'} =
[ reverse @{ $self->{'_iterator_array_ref'} } ];
}
TFBS-0.7.1/TFBS/_Iterator/ 0000775 0000000 0000000 00000000000 13057522667 0014760 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/_Iterator/.svn/ 0000775 0000000 0000000 00000000000 13057522667 0015644 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/_Iterator/.svn/all-wcprops 0000775 0000000 0000000 00000000520 13057522667 0020032 0 ustar 00root root 0000000 0000000 K 25
svn:wc:ra_dav:version-url
V 43
/svn/lenhard/!svn/ver/8/TFBS/TFBS/_Iterator
END
_MatrixSetIterator.pm
K 25
svn:wc:ra_dav:version-url
V 65
/svn/lenhard/!svn/ver/8/TFBS/TFBS/_Iterator/_MatrixSetIterator.pm
END
_SiteSetIterator.pm
K 25
svn:wc:ra_dav:version-url
V 63
/svn/lenhard/!svn/ver/8/TFBS/TFBS/_Iterator/_SiteSetIterator.pm
END
TFBS-0.7.1/TFBS/_Iterator/.svn/entries 0000775 0000000 0000000 00000000744 13057522667 0017250 0 ustar 00root root 0000000 0000000 8
dir
435
http://www.ii.uib.no/svn/lenhard/TFBS/TFBS/_Iterator
http://www.ii.uib.no/svn/lenhard
2008-01-24T20:21:25.772223Z
8
chrb
svn:special svn:externals svn:needs-lock
92b4b857-2e4f-4894-b4a8-5712848ce9df
_MatrixSetIterator.pm
file
2009-08-07T13:10:38.000000Z
d4d3720758267cb683a5840b30e49bdc
2008-01-24T20:21:25.772223Z
8
chrb
_SiteSetIterator.pm
file
2009-08-07T13:10:38.000000Z
03a4a343868d81822e866344ae82ee13
2008-01-24T20:21:25.772223Z
8
chrb
TFBS-0.7.1/TFBS/_Iterator/.svn/format 0000775 0000000 0000000 00000000002 13057522667 0017052 0 ustar 00root root 0000000 0000000 8
TFBS-0.7.1/TFBS/_Iterator/.svn/text-base/ 0000775 0000000 0000000 00000000000 13057522667 0017540 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/TFBS/_Iterator/.svn/text-base/_MatrixSetIterator.pm.svn-base 0000775 0000000 0000000 00000002752 13057522667 0025415 0 ustar 00root root 0000000 0000000 package TFBS::_Iterator::_MatrixSetIterator;
use vars '@ISA';
use strict;
use Carp;
use TFBS::_Iterator;
@ISA = qw(TFBS::_Iterator);
sub _sort {
my ($self, $sort_by) = @_;
$sort_by or $sort_by = $self->{_sort_by} or $sort_by = 'name';
# we can sort by name, start, end, score
my %sort_fn =
(class => sub { $a->class() cmp $b->class()
||
$a->name() cmp $b->name()
||
$a->ID() cmp $b->ID()
},
id => sub { $a->ID() cmp $b->ID()
},
ID => sub { $a->ID() cmp $b->ID()
},
name => sub { $a->name() cmp $b->name() ||
$a->class() cmp $b->class() ||
$a->ID() cmp $b->ID()
},
species => sub { $a->tag('species') cmp $b->tag('species') ||
$a->class() cmp $b->class() ||
$a->ID() cmp $b->ID()
},
total_ic => sub { $b->total_ic() <=> $a->total_ic()
||
$a->name() cmp $b->name()
}
);
if (defined (my $sort_function = $sort_fn{lc $sort_by})) {
$self->{'_iterator_array_ref'} =
[ sort $sort_function @{$self->{'_orig_array_ref'}} ];
}
else {
#order by tag derived value
$self->{'_iterator_array_ref'}= [ sort { $a->tag($self->{_sort_by}) cmp $b->tag( $self->{_sort_by}) ||
$a->class() cmp $b->class() ||
$a->ID() cmp $b->ID()
} @{$self->{'_orig_array_ref'}} ] || $self->throw("Cannot sort ".ref($self)." object by '$sort_by'.");
}
}
TFBS-0.7.1/TFBS/_Iterator/.svn/text-base/_SiteSetIterator.pm.svn-base 0000775 0000000 0000000 00000002533 13057522667 0025052 0 ustar 00root root 0000000 0000000 package TFBS::_Iterator::_SiteSetIterator;
use vars '@ISA';
use strict;
use Carp;
use TFBS::_Iterator;
@ISA = qw(TFBS::_Iterator);
sub _sort {
my ($self, $sort_by) = @_;
$sort_by or $sort_by = $self->{_sort_by} or $sort_by = 'name';
# we can sort by name, start, end, score
my %sort_fn =
(start => sub { $a->start() <=> $b->start()
|| $a->pattern->name() cmp $b->pattern->name()
|| $a->strand() <=> $b->strand()
},
end => sub { $a->end() <=> $b->end()
|| $a->pattern->name() cmp $b->pattern->name()
|| $a->strand() <=> $b->strand()
},
ID => sub { $a->pattern->ID() cmp $b->pattern->ID()
|| $a->start() <=> $b->start()
|| $a->end() <=> $b->end()
|| $a->strand() <=> $b->strand()
},
name => sub { $a->pattern->name() cmp $b->pattern->name()
|| $a->start() <=> $b->start()
|| $a->end() <=> $b->end()
|| $a->strand() <=> $b->strand()
},
score => sub { $b->score() <=> $a->score()
|| $a->pattern->name() cmp $b->pattern->name()
|| $a->strand() <=> $b->strand()
}
);
if (defined (my $sort_function = $sort_fn{lc $sort_by})) {
$self->{'_iterator_array_ref'} =
[ sort $sort_function @{$self->{'_orig_array_ref'}} ];
}
else {
$self->throw("Cannot sort ".ref($self)." object by '$sort_by'.");
}
}
TFBS-0.7.1/TFBS/_Iterator/_MatrixSetIterator.pm 0000775 0000000 0000000 00000004043 13057522667 0021113 0 ustar 00root root 0000000 0000000 package TFBS::_Iterator::_MatrixSetIterator;
use vars '@ISA';
use strict;
use Carp;
use TFBS::_Iterator;
@ISA = qw(TFBS::_Iterator);
#
# Changed name field sorts to case insensitive which results in a more
# intuitive name sort order, at least for the JASPAR Web site
# DJA 2015/09/16
#
sub _sort {
my ($self, $sort_by) = @_;
$sort_by or $sort_by = $self->{_sort_by} or $sort_by = 'name';
# we can sort by name, start, end, score
my %sort_fn =
(class => sub {
$a->class() cmp $b->class()
|| uc $a->name() cmp uc $b->name()
|| $a->ID() cmp $b->ID()
},
id => sub {
$a->ID() cmp $b->ID()
},
ID => sub {
$a->ID() cmp $b->ID()
},
name => sub {
uc $a->name() cmp uc $b->name()
|| $a->class() cmp $b->class()
|| $a->ID() cmp $b->ID()
},
species => sub {
$a->tag('species') cmp $b->tag('species')
|| $a->class() cmp $b->class()
|| $a->ID() cmp $b->ID()
},
total_ic => sub {
$b->total_ic() <=> $a->total_ic()
|| uc $a->name() cmp uc $b->name()
}
);
if (defined (my $sort_function = $sort_fn{lc $sort_by})) {
$self->{'_iterator_array_ref'} =
[ sort $sort_function @{$self->{'_orig_array_ref'}} ];
}
else {
#order by tag derived value
$self->{'_iterator_array_ref'}= [ sort { $a->tag($self->{_sort_by}) cmp $b->tag( $self->{_sort_by}) ||
$a->class() cmp $b->class() ||
$a->ID() cmp $b->ID()
} @{$self->{'_orig_array_ref'}} ] || $self->throw("Cannot sort ".ref($self)." object by '$sort_by'.");
}
}
TFBS-0.7.1/TFBS/_Iterator/_SiteSetIterator.pm 0000775 0000000 0000000 00000002753 13057522667 0020561 0 ustar 00root root 0000000 0000000 package TFBS::_Iterator::_SiteSetIterator;
use vars '@ISA';
use strict;
use Carp;
use TFBS::_Iterator;
@ISA = qw(TFBS::_Iterator);
#
# Changed name field sorts to case insensitive which results in a more
# intuitive name sort order.
# DJA 2015/09/16
#
sub _sort {
my ($self, $sort_by) = @_;
$sort_by or $sort_by = $self->{_sort_by} or $sort_by = 'name';
# we can sort by name, start, end, score
my %sort_fn =
(start => sub { $a->start() <=> $b->start()
|| uc $a->pattern->name() cmp uc $b->pattern->name()
|| $a->strand() <=> $b->strand()
},
end => sub { $a->end() <=> $b->end()
|| uc $a->pattern->name() cmp uc $b->pattern->name()
|| $a->strand() <=> $b->strand()
},
ID => sub { $a->pattern->ID() cmp $b->pattern->ID()
|| $a->start() <=> $b->start()
|| $a->end() <=> $b->end()
|| $a->strand() <=> $b->strand()
},
name => sub { uc $a->pattern->name() cmp uc $b->pattern->name()
|| $a->start() <=> $b->start()
|| $a->end() <=> $b->end()
|| $a->strand() <=> $b->strand()
},
score => sub { $b->score() <=> $a->score()
|| uc $a->pattern->name() cmp uc $b->pattern->name()
|| $a->strand() <=> $b->strand()
}
);
if (defined (my $sort_function = $sort_fn{lc $sort_by})) {
$self->{'_iterator_array_ref'} =
[ sort $sort_function @{$self->{'_orig_array_ref'}} ];
}
else {
$self->throw("Cannot sort ".ref($self)." object by '$sort_by'.");
}
}
TFBS-0.7.1/blib/ 0000775 0000000 0000000 00000000000 13057522667 0013202 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/ 0000775 0000000 0000000 00000000000 13057522667 0014117 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/.exists 0000664 0000000 0000000 00000000000 13057522667 0015425 0 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/auto/ 0000775 0000000 0000000 00000000000 13057522667 0015067 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/auto/TFBS/ 0000775 0000000 0000000 00000000000 13057522667 0015625 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/auto/TFBS/.exists 0000664 0000000 0000000 00000000000 13057522667 0017133 0 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/auto/TFBS/Ext/ 0000775 0000000 0000000 00000000000 13057522667 0016365 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/auto/TFBS/Ext/pwmsearch/ 0000775 0000000 0000000 00000000000 13057522667 0020356 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/auto/TFBS/Ext/pwmsearch/.exists 0000664 0000000 0000000 00000000000 13057522667 0021664 0 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/auto/TFBS/Ext/pwmsearch/pwmsearch.bs 0000664 0000000 0000000 00000000000 13057522667 0022663 0 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/arch/auto/TFBS/Ext/pwmsearch/pwmsearch.bundle 0000775 0000000 0000000 00000142734 13057522667 0023560 0 ustar 00root root 0000000 0000000 Ęţşľ S¬ p UÜ Îúíţ
„ … Đ __TEXT 0 0 __text __TEXT { § { € __symbol_stub __TEXT "( "( € __stub_helper __TEXT 0) Î 0) € __const __TEXT + + __cstring __TEXT - • - __unwind_info __TEXT µ/ H µ/ H __DATA 0 0 __nl_symbol_ptr __DATA 0 0 - __la_symbol_ptr __DATA 0 ´ 0 2 __data __DATA Č0 Č0 __bss __DATA ä0 ” 8 __LINKEDIT @ @ ¬ " €0 @ @ \ p@ Ľ ,D < đE ‘ 8N t P P P ` 1 ĽL _ -Ó+®Ô%6™µ˙?ŹŠéöÓ$
* 4 © /usr/lib/libSystem.B.dylib & hE ) „E + „E l U‰ĺSWVělR č ^‹†€# ‰… ˙˙‹ ‰EđdžX$ ‹E‰D$Ť˝¨˙˙‰<$ÇD$Ä č ‹E ‰D$Ť…zµ˙˙‰$ÇD$ň čô óZEň…`Á˙˙‹E‰D$Ť…cą˙˙‰$ÇD$ čĘ ‹E‰D$Ť…L˝˙˙‰$ÇD$ č Ç…8Á˙˙ Ç…@Á˙˙ Ť…pÁ˙˙‰D$‰<$‰űčH …ŔtŤ†” ‰$č! »˙˙˙˙é¤ Ť† ‰D$Ť…zµ˙˙‰$či …Ŕt\‰Ç‹E ŤŽË ‰L$‰$čN …ŔtX‰D$ ‰…¤˙˙‰|$Ť…pÁ˙˙‰D$‰ $čÍ 1Ű…ŔtŤ†č ‰$č¬ »˙˙˙˙‹µ¤˙˙ë,Ť†Ż ‰$č‘ 1˙»˙˙˙˙ëŤ†Í ‰$čz 1ö»˙˙˙˙čÎ ‰<$čÄ ‰4$čĽ ‹… ˙˙‹ ;Eđu
‰ŘÄlR ^_[]Ăč‹ U‰ĺěč X‹€Ŕ! ‹ ‹M‰L$‰$čŚ 1ŔÄ]ĂU‰ĺňE‹E¸” x
f.€ś v‹M‹U ‰” ň€ś ‰¤ 1Ŕ]ĂU‰ĺ‹E‹” ‹U ‰
¸” x‹U‹Mň€ś ň‹€¤ ‰1Ŕ]ĂU‰ĺSWVěě> č X‰…`Á˙˙‹€! ‰…4Á˙˙‹ ‰Eđ‹}‹·Ŕ ‹]…ö~V1Éş ‰đ‰Î€<3 DĘF9Ć|ô‰ĆLJ” ˙˙˙˙Ť‡” ‰…TÁ˙˙…É‹•`Á˙˙t9Ť‡ ‰…PÁ˙˙Ç…8Á˙˙ 1Ŕél LJ” ˙˙˙˙Ť‡” ‰…TÁ˙˙‹•`Á˙˙Ť‡ ‰…PÁ˙˙1ŔŤŠĹ ‰ŤLÁ˙˙ŤŠś ‰Ť<Á˙˙‰ÁÇ…8Á˙˙ Ç…XÁ˙˙ ë‹·Ŕ A‰µhÁ˙˙Ť1€|˙ „ë ‰Ť\Á˙˙fWŔ…öfWÉ‹M ~e‹E‹•\Á˙˙Ť‰…dÁ˙˙ŤT¶űfWŔ1˙‰űfWÉ‹…dÁ˙˙ľ‹µ`Á˙˙‹´†, ¸ )đţDĆĐňXÁţňX ń‹…hÁ˙˙ÇÂűC9Ă|˝‹}f.Ź¸ vdň…hÁ˙˙‹…PÁ˙˙8 ‹]u`Ç…dÁ˙˙ ż ‹Ť\Á˙˙…Ô ‹E‰D$ ňL$‰\$ ‰L$‹E‰D$‰<$ÇD$ č˛ é™ Ç…dÁ˙˙ ‹]éĆ ňŤ@Á˙˙Ç…dÁ˙˙ °˝XÁ˙˙č u‹…LÁ˙˙‰$čr 0Ŕ‹•XÁ˙˙‰ŃÁድ\Á˙˙‰´
pÁ˙˙Ç„
tÁ˙˙ ň…@Á˙˙ň„
xÁ˙˙B‰•XÁ˙˙„Ŕu‹…<Á˙˙‰$č# Ç…dÁ˙˙˙˙˙˙ň…hÁ˙˙ë5‹…TÁ˙˙8 ň…hÁ˙˙x
f.Źś v‰Ź” ňŹś LJ¤ f.‡¸ †µ ‹…PÁ˙˙8 uEż ‹Ť\Á˙˙… ‹E‰D$ ňD$‰\$ ‰L$‹E‰D$‰<$ÇD$ ‰Îč{ ‰ńëkň…hÁ˙˙°˝XÁ˙˙č u‹…LÁ˙˙‰$čX 0Ŕ‹•XÁ˙˙‰ŃÁድ\Á˙˙‰´
pÁ˙˙Ç„
tÁ˙˙ ň…hÁ˙˙ň„
xÁ˙˙B‰•XÁ˙˙„ŔtM‹Ť\Á˙˙‹…dÁ˙˙…Ŕ„Ký˙˙ë/‹…TÁ˙˙8 x
f.‡ś vۉŹ” ň‡ś LJ¤ ëÁ‰…8Á˙˙ë‹…<Á˙˙‰$čĽ Ç…8Á˙˙˙˙˙˙‹•`Á˙˙‹…XÁ˙˙‹ŤPÁ˙˙9 t6…Ŕ~tŤ˝xÁ˙˙Ťšµ ‰Ć‹GřňňD$@‰D$‰ $č÷ ‰đÇHuÜëB‹…TÁ˙˙‹ …Ŕx6‹Ź¤ ň‡ś ‹U‰T$ ňD$‰L$‰\$ ‰D$‹E‰D$‰<$č ‹…4Á˙˙‹ ;Eđu‹…8Á˙˙Äě> ^_[]ĂčL U‰ĺSWVě č ^‹ľR ŤG‰†R ‹]‰ $č} @‰$čP ‰„ľV …Ŕt‰\$‰$čW ë
Ť†6 ‰„ľV Ä ^_[]ĂU‰ĺSWVě č ^ľň ~:1˙Ťžö ‹† ‰Eđ‹Eđ‹ ‹ ‰L$ŤŽÁ ‰L$‰$čÇ ĂG;ľň |×Ä ^_[]ĂU‰ĺSWVě č X‹}˙Ť€h ‰$č ˙˙˙¸˙˙˙˙é! ‹]‹u ‹F‰D$‰ $čź ‹F‰D$ŤŇ ‰$čŠ ‹F ‰$č7 Ý›¸ Ç Ç Ćé 1Ŕ˙ŚŔ Ťé ‰E𫤠‰E썻 ‰EčŤG˙‰Eäż ë&‰L$‹Eđë‰L$‹Ečë‰D$‹Eě‰$č
Çëk‹ľŠ€ů-u$€xbu Ç ëN€xau Ç ë<€ů-•Á;}ä}1„Éu-€xmu ‹Lľ€9 uŽ€xnu ‹Lľ€9 u€xcu ‹Dľ€8 u‚G;}|1ŔÄ ^_[]ĂU‰ĺSWVěl č [‹b ‰…ŕ˙˙‹ ‰E𫬠‰D$‹E‰$č ‰…¤ŕ˙˙…Ŕ„ 1˙Ťµ¨ŕ˙˙ŤZ ‰… ŕ˙˙‰ťśŕ˙˙‰ű‰t$‹… ŕ˙˙‰D$‹…¤ŕ˙˙‰$čă ř˙¸ DŘ…Ű”ŔG˙ç Ć„ŔuÄ…Ű„® ‹…¤ŕ˙˙‰$‰ţÁţ Áî ţÁţč ‹E‰°Ŕ ˙Ś 1Ŕ‹Ťśŕ˙˙ňV ‹} ‰ůŤ€1˙‰Ëë
GĂ‹u‹¶Ŕ Ż÷ĆňŚő¨ŕ˙˙ň ˙uÜ‹} ň ×ňXL×ňXL×ňXL×ňYČňL× Á(@‹U‹˛Ŕ 9đ|žë7Ť. ë ‹…śŕ˙˙Ť€b ‰$čü˙˙‹…¤ŕ˙˙‰$čÓ ¸˙˙˙˙é— ‹} ‹EÇ€¬ Ç€¨ Ç€´ Ç€° ‰Ă1Ŕ…ö~aWŔ‹…śŕ˙˙ň^ ňf WŰ1Éş ‰ř(ę(áň7ň]ćň_îÇJuîňXÝň›¨ ňXÄň° ‰ÇÇ(A9ń|ż1Ŕ‹Ťŕ˙˙‹ ;Mđu Äl ^_[]Ăč U‰ĺSWVěě č X‰… ˙˙˙‹€. ‰…˙˙˙‹ ‰Eđ‹E‰D$Ť…(˙˙˙‰$ÇD$Č čŐ …Ŕ”ĂtT‹u Ť…)˙˙˙‰D$‰4$čő ‰4$čó ĆD0˙ ‰4$čć …Ŕt&ż ·€|>˙ uĆD>˙ 0˙‰4$čĹ 9ÇsG„˙u߶ó1É‹… ˙˙˙Ť€L ‰…˙˙˙‰Č‰…$˙˙˙ë‰ů‰Ď‰ř đ…Č ‹E‰D$Ť…(˙˙˙‰$ÇD$Č č. ą Šť(˙˙˙…ŔtČ€ű>tĂ…ö‰ůu˝Ť…)˙˙˙ë ‹… ˙˙˙Š@‰… ˙˙˙ľË1ö„Űt›x ‹… ˙˙˙‹€* ‹D4öÄuŃ„Űx% @ ë‰ $ÇD$ @ č¤ ‹Ť$˙˙˙…Ŕuů?B ‹E A‰Ť$˙˙˙땉Ť$˙˙˙‹…˙˙˙‰$č)ú˙˙ľ˙˙˙˙é*˙˙˙‹E‹Ť$˙˙˙Ć ‹…˙˙˙‹ ;Eđu
‰đÄě ^_[]Ăč? U‰ĺSWVě,C č X‰…ŕĽđ˙‹€j ‰…ÜĽđ˙‹ ‰Eđ‹}ŤťŻ˝đ˙ŤµćĽđ˙‰\$‰t$‹E‰$čńý˙˙…Ŕu0‹E‰D$‰\$ ‰t$‹E ‰D$‰<$čĺô˙˙…ŔtÇ‹…ŕĽđ˙Ť€Î ëř˙ą u‹…ŕĽđ˙Ť€Ş ‰$čVů˙˙ą˙˙˙˙‹…ÜĽđ˙‹ ;Eđu
‰ČÄ,C ^_[]Ăč~ U‰ĺVP‹u…ö~Ç$- č´ NuńÇ$
čĄ Ä^]ĂU‰ĺSWVě č [‹MŤ¤ ‰D$Ť» ‰D$ ‹E ‰D$Ť ‰D$‹}$‰<$č3 } t ‰|$ Ť ë
‰|$ Ť ‰$ÇD$ ÇD$ č ‹uň†¨ ňŽ° ňU ňT$Ť ‰D$‰<$ň\ŃňY“‹ ň\Áň^ĐňT$čµ
‹†Ŕ ‰Ů‰ű‹}ř‰D$ ŤG‰D$Ť# ‰D$‰ $č‰
‰đ¸Ŕ ‰Ú‹M~(ů1öľ1‰T$‰$‰Ë‰×č…
‰ú‰Ů‹EF;°Ŕ |܉T$Ç$
če
1ŔÄ ^_[]ĂU‰ĺSWVě č X‹u ‹‹}‹]ůč uŤ€î ‰$č—÷˙˙‹¸˙˙˙˙ë1ŔÁበ‹Áá‹U ‰T‹ÁáňEňD˙Ä ^_[]ĂU‰ĺSWVěLč X‰EäÇ$ čŕ ‹ ‰$čĆ ‰$čň ‹8Ç$ čŔ ‹ ‰$č¦ ‰$čş ‹ŤQü‰‹1Ç$ č™ ‹ ‰$č ‰$čĄ ‹Ç$ čy ‹ ‰$Ťł)ÇčZ ˙…w ‰÷ŤO‰M̉$čo ‹ ‹D¸‹XÇ$ č< ‹ ‰$č" ‰ĆöÇt‰4$čA ‹ ‹D¸‹@ ë@Ç$ č ‹ ‰$čň ‰$č ‹ ‹D¸‰D$‰4$ÇD$ ÇD$ čP ‰EäÇ$ čÉ
‹ ‰$čŻ ‰$čŐ
‹ ‹D¸‹XÇ$ č˘
‹ ‰$č ‰ĆöÇt‰4$č§
‹ ‹D¸‹@ ë@Ç$ čr
‹ ‰$čX ‰$č~
‹ ‹D¸‰D$‰4$ÇD$ ÇD$ č¶
‰EŕÇ$ č/
‹ ‰$č ‰$č;
‹ ‹D¸ ‹XÇ$ č
‹ ‰$čî
‰ĆöÇt‰4$č
‹ ‹D¸ ‹ ň ë8Ç$ čŐ ‹ ‰$č»
‰$čá ‹ ‹D¸ ‰D$‰4$č#
Ý]čňEčňEŘÇ$ č ‹ ‰$č~
‰$č¤ ‹ ‹D¸‹XÇ$ čq ‹ ‰$čW
‰ĆöÇt‰4$čv ‹ ‹D¸‹@ ë@Ç$ čA ‹ ‰$č'
‰$čM ‹ ‹D¸‰D$‰4$ÇD$ ÇD$ č… ‰EÔÇ$ čţ ‹ ‰$čä ‰$č
‹ ‹D¸‹XÇ$ č× ‹ ‰$č˝ ‰ĆöÇt‰4$čÜ ‹ ‹D¸‹@ ë@Ç$ č§ ‹ ‰$čŤ ‰$čł ‹ ‹D¸‰D$‰4$ÇD$ ÇD$ čë ‰EĐÇ$ čd ‹ ‰$čJ ‰$čp ‹ ‹D¸‰ţ‹XÇ$ č; ‹ ‰$č! ‰ÇöÇt‰<$č@ ‹ ‹D°‹x ëBÇ$ č ‹ ‰$čń ‰$č ‹ ‹D°‰D$‰<$ÇD$ ÇD$ čO ‰ÇÇ$ čÉ ‹ ‰$čŻ ‰$čÉ ‹ ŠXÇ$ č¦ ‹ ‰$čŚ öĂ t(‰$čˇ Ç$ č ‹ ‰$či ‰$čw ë‰$č÷ ‰|$‹EЉD$‹EÔ‰D$ ňZEŘóD$‹Eŕ‰D$‹Eä‰$č‘ë˙˙Ç$ č, ‹ ‰$č ‰$č8 ‹0Ç$ č ‹ ‰$čň ‰$‹EĚŤ4†č ‰0ÄL^_[]Ă‹M ‹U䍒© ‰T$‰L$‰$č U‰ĺSWVěLč X‰EđÇ$ č° ‹ ‰$č– ‰$č ‹0Ç$ č ‹ ‰$čv ‰$čŠ ‹ŤQü‰‹Ç$ či ‹ ‰$čO ‰$ču ‹ ‰EěÇ$ čF ‹ ‰$č, ‰$čR ‹ ‹D‹xÇ$ č ‹ ‰$‹EěŤ)ƉučŤC‰Eŕčô ‰Ć‰řöÄt‰4$č ‹ ‹D‹@ ë@Ç$ čÜ ‹ ‰$č ‰$čč ‹ ‹D‰D$‰4$ÇD$ " ÇD$ č ‰Eě}č|0Ç$ č“ ‹ ‰$čy ‰$čź ‹ ‹tÇEč éű Ç$ čc ‹ ‰$čI ‰ĆÇ$ čK ‹ ‰$č1 ‹MđŤ‘Ĺ
‰Uč‰T$ ‹Uě‰T$Ťąľ
‰|$‰$č` ‰D$‰4$ÇD$ čR ‰Ć…öt#‹F<u‹F €x t‹EđŤ€Ĺ
‰EčëlöÄ˙uoÇ$ čĎ ‹ ‰$čµ ‰ĆÇ$ č· ‹ ‰$čť ‹MđŤ‰Đ
‰Mč‰L$ ‹Mě‰L$‰|$‰$čŇ ‰D$‰4$ÇD$ čÄ ‰Ć…ö„Ţ Ç$ č` ‹ ‰$čF ‹}đŤŹŘ
‰L$‰$ÇD$ č“ ‰EÜÇ$ č* ‹ ‰$č ŤŹÜ
‰L$‰t$‰$č „Ŕt‰]ä˙Fë'‰]äÇ$ čď ‹ ‰$čŐ ‰t$‰$č? ‰ĆÇ$ čË ‹ ‰$č± ‹M܉L$‰$ÇD$ č@ ‰ĂÇ$ čś ‹ ‰$č‚ ‰\$‰t$‰$1˙č …Ŕ„1 Ç$ čl ‹ ‰$čR ‰EÜÇ$ čS ‹ ‰$č9 ‰ÇÇ$ č; ‹ ‰$č! ‰\$‰$čÇ ‰D$‰<$č… ‰EŘÇ$ č
‹ ‰$čđ ‰ÇÇ$ čň ‹ ‰$čŘ ‰t$‰$č~ ‰D$‰<$č< ‰D$ ‹UđŤ‚ ‹Mč…ÉEÁ‰D$ ŤŠ Ť‚ DȉL$‰Á‹}ěEωL$ŤŠ DȉL$‹E؉D$ ‰|$Ť‚ä
‰D$‹E܉$čż ‰ÇÇ$ č] ‹ ‰$čC ‰|$‰$čł …ŰtS‹C…Ŕt*H‰CuFÇ$ č* ‹ ‰$č ‰\$‰$čž ë"Ç$ č ‹ ‰$čě ‰\$‰$čt …ö‹]ätS‹F…Ŕt*H‰FuFÇ$ čĐ ‹ ‰$č¶ ‰t$‰$čD ë"Ç$ č¬ ‹ ‰$č’ ‰t$‰$č …˙…\ Ç$ č‚ ‹ ‰$čh ‹U𫩲
‰L$ ŤŠÂú˙˙‰L$ŤŠ3 ‰L$‰$čŻ Ç$ čC ‹ ‰$č) ‰$ča 8 thÇ$ č ‹ ‰$č ‰ĆÇ$ č ‹ ‰$čî ‰$č ‹8Ç$ čč ‹ ‰$čÎ ‰$č ‹ ‰D$‰|$‰4$čú Ç$ č¸ ‹ ‰$čž ‰$čĐ ‰ĆÇ$ č ‹ ‰$č~ ‰$č¤ ‹ ‰tÇ$ čt ‹ ‰$čZ ‰$č€ ‹0Ç$ čT ‹ ‰$č: ‰$‹EŕŤ4†č` ‰0ÄL^_[]ĂÇ$ č& ‹ ‰$č ‹O ‰L$‹MđŤ‰0 ‰L$‰$č< ˙%0 ˙%0 ˙% 0 ˙% 0 ˙%$0 ˙%(0 ˙%,0 ˙%00 ˙%40 ˙%80 ˙%<0 ˙%@0 ˙%D0 ˙%H0 ˙%L0 ˙%P0 ˙%T0 ˙%X0 ˙%\0 ˙%`0 ˙%d0 ˙%h0 ˙%l0 ˙%p0 ˙%t0 ˙%x0 ˙%|0 ˙%€0 ˙%„0 ˙%0 ˙%Ś0 ˙%0 ˙%”0 ˙%0 ˙%ś0 ˙% 0 ˙%¤0 ˙%¨0 ˙%¬0 ˙%°0 ˙%´0 ˙%¸0 ˙%Ľ0 ˙%Ŕ0 ˙%Ä0 h é h é h1 éú hP éđ hd éć h éÜ hź éŇ hą éČ hŃ éľ hî é´ h éŞ h é h1 é– hB éŚ hU é‚ hj éx h én h‘ éd h© éZ hŔ éP hÓ éF hě é< h é2 h é( h1 é hJ é hb é
hs é h0 ˙% 0 h‹ éę˙˙˙hž éŕ˙˙˙h· éÖ˙˙˙hĚ éĚ˙˙˙hŮ éÂ˙˙˙hč é¸˙˙˙hö é®˙˙˙h
é¤˙˙˙h éš˙˙˙h, é˙˙˙hD é†˙˙˙hS é|˙˙˙hb ér˙˙˙h~ éh˙˙˙h‹ é^˙˙˙h› éT˙˙˙hŞ éJ˙˙˙ Đ? $@ $Ŕ Y@ MAIN: get_matrix failed. r MAIN: open_seq_file failed. w MAIN: open_outfile failed. MAIN: loop_on_seqs failed. DO_SEQ: save_hit failed %ld %.3f
%s
GET_CMD_ARGS: Too few arguments. GET_MATRIX: could not open specified file. %lf,%*c GET_MATRIX: too many counts. GET_SEQUENCE: Sequence too long. LOOP_ON_SEQS: get_sequence failed. LOOP_ON_SEQS: do_seq failed. %s TFBS %s %s - + %6.3f %6.1f %ld %ld SAVE_HIT: MAXHITS limit reached. matrixfile, seqfile, threshold, tfname, tfclass, outfile pwmsearch.c %s::%s XS_VERSION VERSION 0.2 version %s object version %-p does not match %s%s%s%s %-p $ :: bootstrap parameter %s TFBS::Ext::pwmsearch::search_xs { 4 4 #( 4 0) :) D) N) X) b) l) v) €) Š) ”) ž) ¨) ˛) Ľ) Ć) Đ) Ú) ä) î) ř) * * * * ** 4* >* T* ^* h* r* |* †* * š* ¤* ®* ¸* Â* Ě* Ö* ŕ* ę* ô* err_log function failure !`- ¤P€,p™pQ @__DefaultRuneLocale Qq@___stack_chk_guard @___stderrp @dyld_stub_binder €ě˙˙˙˙˙˙˙˙ q>@_Perl_Gthr_key_ptr q>@_Perl_Icurpad_ptr q >@_Perl_Imarkstack_ptr_ptr q >@_Perl_Iop_ptr q$>@_Perl_Iscopestack_ix_ptr q(>@_Perl_Istack_base_ptr q,>@_Perl_Istack_sp_ptr q0>@_Perl_Isv_yes_ptr q4>@_Perl_Iunitcheckav_ptr q8>@_Perl_call_list q<>@_Perl_croak q@>@_Perl_croak_xs_usage qD>@_Perl_form qH>@_Perl_get_sv qL>@_Perl_newSVpvf qP>@_Perl_newSVpvn qT>@_Perl_newXS qX>@_Perl_new_version q\>@_Perl_sv_2mortal q`>@_Perl_sv_2nv qd>@_Perl_sv_2pv_flags qh>@_Perl_sv_derived_from ql>@_Perl_sv_free qp>@_Perl_sv_free2 qt>@_Perl_sv_newmortal qx>@_Perl_upg_version q|>@_Perl_vcmp q€>@_Perl_vstringify q„@___maskrune q@___stack_chk_fail qŚ@___strcpy_chk q@_atof q”@_fclose q@_fgets qś@_fopen$UNIX2003 q @_fprintf q¤@_fscanf q¨@_fwrite$UNIX2003 q¬@_malloc q°@_printf q´@_pthread_getspecific q¸@_putc qĽ@_putchar qŔ@_strcpy qÄ@_strlen _
do_se yannounce ‹b err_ Óget_ ěloop_on_seqs śmark ˇoutput ¦save_hit «XS_TFBS__Ext__pwmsearch_search_xs ° arch †q Î ű Ĺ est_ ´oot_TFBS__Ext__pwmsearch µ save Äpull É ď « ă log âshow ç „' ä' cmd_args Ťmatrix ’sequence — Á( ™+ Í/ ‘3 Ň4 ˙4 ˝7 ¤8 ÔB űĘ*<8ˇ `]Ř´ÄÁ-ľg°
úŢ l DúŢ ( libSystem.B úŢ ( libSystem.B d " d . f :# R . { Y $ { d „ $ Ę N Ę . E z $ E $ * N * . o „ $ o $ < N < . « Ź $ « $ 8 N 8 . ă š $ ă $ ˇ N ˇ . „ ˘ $ „ « „ $ ` N ` . ä É $ ä $ ] N ] . A Ó $ A $ X N X . ™ á $ ™ $ 4 N 4 . Í í $ Í ű „ $ Ä N Ä . ‘ $ ‘ $ Á N Á . R $ R $ - N - . $ $ $ > N > . ˝ , $ ˝ $ g N g . $ 6 $ $ Y „ $ 0 N 0 . T! f $ T! $ Î N Î & + & Č0 Ź &
ä0 ™ &
č0 d ˘ + © Č0 °
ä0 ş
č0 Ă $ ć E đ « ű o T! ! { , ă 4 „ = ä G A U ™ a Í o ‘ } R ‹ ˝ • ţ ¨ ţ ş ţ Ó ţ á ţ ú ţ ţ $ ţ 6 ţ M ţ ] ţ i ţ ~ ţ ‰ ţ – ţ Ą ţ ´ ţ Ŕ ţ Ň ţ ă ţ đ ţ ţ ţ ' ţ 6 ţ I ţ [ ţ f ţ w ‹ — © Ľ Ç Ő Ű ă ę ú $ , A G P X ` ` a b c d e f g h i j k l m n o p q r s t u v w x y z { } ~ ‚ „ … † ‡ ‰ Š ‹ Ś Ť Ž Ź @| € ` a b c d e f g h i j k l m n o p q r s t u v w x y z { } ~ ‚ „ … † ‡ ‰ Š ‹ Ś Ť Ž Ź /Users/gtan/src/TFBS-0.5.0/Ext/ pwmsearch.c /Users/gtan/src/TFBS-0.5.0/Ext/pwmsearch.o _do_search ./lib/pwm_searchPFF.c _announce _best_save _best_pull _do_seq _err_log /usr/include/secure/_string.h _err_show _get_cmd_args _get_matrix _get_sequence /usr/include/ctype.h _loop_on_seqs _mark _output _save_hit _XS_TFBS__Ext__pwmsearch_search_xs pwmsearch.xs _boot_TFBS__Ext__pwmsearch _TRANS _PANIC _NUM_ERRS ___ERR__ _TRANS _PANIC _NUM_ERRS ___ERR__ _XS_TFBS__Ext__pwmsearch_search_xs _announce _best_pull _best_save _boot_TFBS__Ext__pwmsearch _do_search _do_seq _err_log _err_show _get_cmd_args _get_matrix _get_sequence _loop_on_seqs _mark _output _save_hit _Perl_Gthr_key_ptr _Perl_Icurpad_ptr _Perl_Imarkstack_ptr_ptr _Perl_Iop_ptr _Perl_Iscopestack_ix_ptr _Perl_Istack_base_ptr _Perl_Istack_sp_ptr _Perl_Isv_yes_ptr _Perl_Iunitcheckav_ptr _Perl_call_list _Perl_croak _Perl_croak_xs_usage _Perl_form _Perl_get_sv _Perl_newSVpvf _Perl_newSVpvn _Perl_newXS _Perl_new_version _Perl_sv_2mortal _Perl_sv_2nv _Perl_sv_2pv_flags _Perl_sv_derived_from _Perl_sv_free _Perl_sv_free2 _Perl_sv_newmortal _Perl_upg_version _Perl_vcmp _Perl_vstringify __DefaultRuneLocale ___maskrune ___stack_chk_fail ___stack_chk_guard ___stderrp ___strcpy_chk _atof _fclose _fgets _fopen$UNIX2003 _fprintf _fscanf _fwrite$UNIX2003 _malloc _printf _pthread_getspecific _putc _putchar _strcpy _strlen dyld_stub_binder Ďúíţ
Đ … x __TEXT 0 0 __text __TEXT ó
ë ó
€ __stubs __TEXT Ţ$ Ţ$ € __stub_helper __TEXT ě% Ň ě% € __const __TEXT Ŕ' Ŕ' __cstring __TEXT ŕ) ¬ ŕ) __unwind_info __TEXT Ś, | Ś, __eh_frame __TEXT - đ - Ř __DATA 0 0 __nl_symbol_ptr __DATA 0 0 - __got __DATA 0 0 / __la_symbol_ptr __DATA (0 h (0 2 __data __DATA 1 1 __bss __DATA °1 0 H __LINKEDIT @ @ Ü " €0 @ @ ` h@ ¸ D @ đE ‘ |P ` P P P ` 1 O _ ťô€fë?˝ůeć5żl$
* 8 © /usr/lib/libSystem.B.dylib & `E ) €E + €E p UH‰ĺAWAVAUATSHěxR L‰…p˙˙I‰ÍH‰Óó…l˙˙I‰öH‰řH‹
ď$ H‹ H‰MĐÇv& LŤĄx˙˙L‰çH‰ĆşŘ čA LŤ˝Jµ˙˙L‰˙L‰öş č* óZ…l˙˙HŤ˝3ą˙˙ň…@Á˙˙H‰Ţş č HŤ˝ ˝˙˙L‰îş4 čň HŤµPÁ˙˙Ç…Á˙˙ Ç…Á˙˙ L‰çčk …ŔtHŤ= č. »˙˙˙˙é‰ HŤ5 L‰˙čľ I‰ÇM…˙tHHŤ5 H‹˝p˙˙čŁ I‰ĆM…ötCHŤ˝x˙˙HŤµPÁ˙˙L‰úL‰ńčđ 1Ű…Ŕt8HŤ=˙ čÇ ë%HŤ=¸ čą E1˙»˙˙˙˙ëHŤ=Ŕ čŁ E1ö»˙˙˙˙čë L‰˙č+ L‰÷č# H‹–# H‹ H;EĐu‰ŘHÄxR [A\A]A^A_]Ăčč UH‰ĺH‰řH‹
n# H‹9H‰Ć0Ŕčń 1Ŕ]ĂUH‰ĺHż x
f.‡¨ vH‰· ň‡¨ ‰—° 1Ŕ]ĂUH‰ĺH‹‡ H‰Hż xň‡¨ ň‹‡° ‰1Ŕ]ĂUH‰ĺAWAVAUATSHě^ L‰…ء˙˙H‰•ŕˇ˙˙I‰öI‰űH‹Ĺ" H‹ H‰EĐMcĐ M…Ŕ~R1Ň1Ŕľ €< DĆH˙ÂL9Â|ńIÇ ˙˙˙˙IŤ“ H‰•đˇ˙˙…Ŕt?H‰Ťřˇ˙˙IŤ H‰…čˇ˙˙E1˙éP H‰Ťřˇ˙˙IÇ ˙˙˙˙IŤ H‰…đˇ˙˙ëH‰Ťřˇ˙˙IŤ H‰…čˇ˙˙1ŇLŤ
č AĽ I‰×ë
E‹Đ H˙ÂIcŔHĐH‹Ťřˇ˙˙€|˙ „ă fWŔE…ŔfWÉ~TH‹…řˇ˙˙LŤCŤL€űfWŔ1ö1˙fWÉIľ2A‹D‰ă)ĂřDŘËřHcŔHcŰňAX ĆÇÁűH˙ĆňAXŢD9Ć|ČÇ…˘˙˙ fA.‹Č †M ň…˘˙˙H‹…čˇ˙˙8 ujA» …ę M‰ĚÇ…˘˙˙ L‰ßL‰ŰH‹µŕˇ˙˙I‰ŐH‹Ťřˇ˙˙E1Ŕf(ÁL‹ŤŘˇ˙˙č
…ŔtHŤ=f čů Ç…˘˙˙˙˙˙˙M‰áL‰ęI‰Űë~ňŤĐˇ˙˙M‰ÝH‰ÓM‰Ě°I˙č uHŤ=P čĽ 0ŔKŤ H‰ÚH‰”͢˙˙DŽ͢˙˙ ň…С˙˙ň„Í ˘˙˙I˙Ç„Ŕu HŤ=Đ H‰Óčy H‰ÚÇ…˘˙˙˙˙˙˙M‰áM‰ëAĽ ň…˘˙˙ëAH‹…đˇ˙˙H8 ň…˘˙˙x fA.‹¨ vI‰“ ňA‹¨ AÇ° AĽ fA.Č †ú H‹…čˇ˙˙8 uMA» … M‰ĚL‰ßL‰ŰH‹µŕˇ˙˙I‰ŐH‹Ťřˇ˙˙A¸ L‹ŤŘˇ˙˙čĽ …Ŕ…™ M‰áL‰ęI‰Űëfň…˘˙˙L‰ŰI‰ŐM‰Ě°I˙č uHŤ= č… 0ŔKŤ L‰ęH‰”͢˙˙DŽ͢˙˙ ň…˘˙˙ň„Í ˘˙˙I˙Ç„ŔM‰áI‰Ű„ AĽ ë3H‹…đˇ˙˙H8 x fA.¨ vI‰“ ňA¨ AÇ° ‹ť˘˙˙…Ű„ ý˙˙A‰ŢëE1öH‹…čˇ˙˙8 t7M…˙Ž€ HŤť ˘˙˙LŤ%R ňH‹sđH˙ĆL‰ç°č… HĂI˙ĎuâëRH‹…đˇ˙˙H‹H…ŇH‹Ťřˇ˙˙x u€xnuAŤL$HcÉH‹4Ë€> …s˙˙˙€xcuAŤD$HcŔH‹4Ă€> …]˙˙˙A˙ÄE9üŚc˙˙˙1ŔHÄ[A\A]A^A_]ĂUH‰ĺAWAVAUATSHěh I‰öI‰üH‹É H‹ H‰EĐHŤ5ś čH H‰…xŕ˙˙H…Ŕ„Ş E1˙HŤť€ŕ˙˙A˝ H‹˝xŕ˙˙HŤ5K H‰Ú0Ŕč ř˙¸ DDřE…˙”ŔAýç EŤmHĂ„ŔuÁE…˙„[ A˙ÍH‹˝xŕ˙˙čĹ D‰éÁů Áé DéÁůA‰Ś$Đ AýŚ“ 1Ŕ1Ňňş HcňIŤ<öŤ4€Hcö1Űë H˙ĂA‹Ś$Đ ŻËÁHcÉňŚÍ€ŕ˙˙ň ßűuÚňA öŤNHcÉňAX ÎŤNHcÉňAX ÎŤNHcÉňAX ÎÂĆH˙ŔHcÎňYČňA ÎA‹Ś$Đ 9ČŚy˙˙˙1ŔIÇ„$Ŕ IÇ„$¸ …ÉŽ“ 1ŇWŔň
ň WŰH‰ÖHÁć HŤ4¶HÁţ IŤ4ö1˙(ę(áň4ţň]ćň_îH˙Ç˙uëňXÝňAś$¸ ňXÄH˙ÂňA„$Ŕ 9Ę|ë&HŤ=Ś ëHŤ=· čĐű˙˙H‹˝xŕ˙˙ča ¸˙˙˙˙H‹
Ď H‹ H;MĐuHÄh [A\A]A^A_]Ăč# UH‰ĺAWAVAUATSHěč H‰•řţ˙˙I‰÷I‰ýL‰đţ˙˙H‹€ H‹ H‰EĐHŤ˝ ˙˙˙ľČ L‰ęčń H…ŔA”ĆtXHŤµ˙˙˙L‰˙č L‰˙č BĆD8˙ L‰˙č H…Ŕt.» A´A€| ˙ u AĆD ˙ E0äL‰˙čß H9ĂsH˙ĂE„äu×A¶ŢE1ä1Éë
D‰ůL‹đţ˙˙A‰ĎD‰ř Ř…¬ HŤ˝ ˙˙˙ľČ L‰ęčY ą DŠµ ˙˙˙H…ŔtÍA€ţ>tÇ…ŰD‰ůuŔLŤ˙˙˙ëEŠu I˙ĹAľţ1Ű@„˙t›x IľĆH‹
‹D<öÄuŘE„öx% @ ë
ľ @ čÖ
…ŔuľIü?B H‹…řţ˙˙F4 I˙ÄëĄHŤ=- č(ú˙˙»˙˙˙˙é<˙˙˙H‹…řţ˙˙BĆ H‹" H‹ H;EĐu‰ŘHÄč [A\A]A^A_]Ăčt
UH‰ĺAWAVAUATSHě8C H‰Ť¨Ľđ˙I‰×I‰ôI‰ýH‹Ő H‹ H‰EĐHŤť°Ľđ˙LŤµ€˝đ˙L‰˙H‰ŢL‰ňčţ˙˙…Ŕu%L‰ďL‰ćH‰ÚL‰ńL‹…¨Ľđ˙č˘ô˙˙…ŔtŇHŤ=ş ëř˙ą uHŤ= č\ů˙˙ą˙˙˙˙H‹g H‹ H;EĐu‰ČHÄ8C [A\A]A^A_]Ăčą UH‰ĺSP‰ű…Ű~ż- čń ˙Ëuňż
HÄ[]éÝ UH‰ĺAWAVAUATSPM‰ĎňEĐE‰ĹI‰ÎH‰ÓH‰đI‰üIŤŚ$» MŤ„$¤ HŤ5, L‰˙H‰Â0Ŕčj E…ít HŤ=" ëHŤ= ľ ş L‰ůčO ňAś$¸ ňA”$Ŕ ňEĐ(Čň\ĘňY
C ň\Úň^ËHŤ5Ö L‰˙°č HŤSHŤ5Î IcŚ$Đ HŮL‰˙0Ŕčâ AĽ$Đ ~ IŢ1ŰAľ< L‰ţčé H˙ĂA;ś$Đ |ćż
L‰ţčĎ 1ŔHÄ[A\A]A^A_]ĂUH‰ĺAWAVATSHěH‰ËI‰ÖňEŘA‰÷I‰üH‹ Hůč uHŤ=G čł÷˙˙H‹ ¸˙˙˙˙ë1ŔHŤ IM‰$ÎH‹ HŤ IE‰|ÎH‹ HŤ IňEŘňADÎH˙HÄ[A\A^A_]ĂUH‰ĺAWAVAUATSHě(I‰ö1˙č2
H‹8č H‰ÇčF
H‹1˙č
H‹8č H‰Çč
H‹HŤQüH‰D‹91˙čô H‹8čÜ
H‰Çč
Hąř˙˙˙ JŤý HH)ÓH!Ë1˙Hű0…ń č¸ H‹8č
AŤOLcńH‰Çčż H‹ J‹đD‹` 1˙čŹ H‹8čw
H‰ĂD‰ŕöÄtH‰ßč’ H‹ J‹đH‹@ë-1˙č` H‹8čH
H‰Çčn H‹ J‹4đH‰ß1Ňą č˛ H‰E¸1˙č/ H‹8č
AŤOLcáH‰Çč6 H‹ J‹ŕD‹h 1˙č H‹8čî H‰ĂD‰čöÄtH‰ßč H‹ J‹ŕH‹@ë-1˙č× H‹8čż H‰Çčĺ H‹ J‹4ŕH‰ß1Ňą č) H‰E°1˙č¦ H‹8čŽ AŤOLcáH‰Çč H‹ J‹ŕD‹h 1˙č} H‹8če H‰ĂD‰čöÄtH‰ßč€ H‹ J‹ŕH‹ ň ë&1˙čK H‹8č3 H‰ÇčY H‹ J‹4ŕH‰ßčž ňEĐL‰uČ1˙č H‹8č AŤOLcáH‰Çč# H‹ J‹ŕD‹h 1˙čó H‹8čŰ H‰ĂD‰čöÄtH‰ßčö H‹ J‹ŕH‹@ë-1˙čÄ H‹8č¬ H‰ÇčŇ H‹ J‹4ŕH‰ß1Ňą č H‰EŔ1˙č“ H‹8č{ AŤOLcéH‰Çčš H‹ J‹čD‹p 1˙čj H‹8čR H‰ĂD‰đöÄtH‰ßčm H‹ J‹čL‹hë01˙č; H‹8č# H‰ÇčI H‹ J‹4čH‰ß1Ňą čŤ I‰ĹL‹uČ1˙č H‹8čď AÇMc˙H‰Çč H‹ J‹řD‹` 1˙čŢ H‹8čĆ H‰ĂD‰ŕöÄtH‰ßčá H‹ J‹řL‹xë01˙čŻ H‹8č— H‰Çč˝ H‹ J‹4řH‰ß1Ňą č I‰Ç1˙č H‹8čg H‰Çč H‹ ŠX#1˙čb H‹8čJ H‰ÇöĂ t č_ 1˙čF H‹8č. H‰Çč< ëčż ňZEĐH‹}¸H‹u°H‹UŔL‰éM‰řč(ě˙˙1˙č H‹8čô H‰Çč H‹ JŤ đ1˙čî H‹8čÖ H‰Çč H‰HÄ([A\A]A^A_]ĂčÇ H‹8čŻ HŤŚ H‰ÇL‰öčď UH‰ĺAWAVAUATSHěH1˙č• H‹8č} H‰Çč© L‹01˙č{ H‹8čc H‰Çčw H‹HŤQüH‰D‹91˙čW H‹8č? H‰Çče AŤOLcáH‹ JŤřI)ĆIÁî1˙č+ H‹8č H‰Çč9 H‹ J‹ŕD‹h 1˙č H‹8čń H‰ĂD‰čöÄtH‰ßč H‹ J‹ŕL‹hë01˙čÚ H‹8č H‰Çčč H‹ J‹4ŕH‰ß1Ňą" č, I‰ĹL‰eŔAţ|-E1ö1˙čť H‹8č… AŤOHcŮH‰Çč¤ H‹ L‹<ŘéĂ 1˙čs H‹8č[ H‰Ă1˙ča H‹8čI HŤ5k LŤ5k H‰ÇL‰ęL‰ń0Ŕč H‰ßH‰Ć1Ňč| I‰ÇM…˙t A‹G <uI‹G€x
tLŤ5- ëTöÄ˙uX1˙č˙ H‹8čç H‰Ă1˙čí H‹8čŐ HŤ5÷
LŤ5 H‰ÇL‰ęL‰ń0Ŕč H‰ßH‰Ć1Ňč I‰ÇM…˙„o L‰u¸L‰mĐ1˙čź H‹8č‡ HŤ5Ă
H‰Çş čÝ I‰Ć1˙čy H‹8ča HŤˇ
H‰ÇL‰ţčÝ „ŔtA˙Gë 1˙čN H‹8č6 H‰ÇL‰ţčˇ I‰ÇE1í1˙č. H‹8č H‰ÇL‰ö1ŇčŻ H‰ĂH‰]Č1˙č H‹8čó H‰ÇL‰ţH‰Úč‘ …Ŕ„
1˙čć H‹8čÎ H‰E°1˙čÓ LŤ%@
HŤ6
HŤ
1
H‹8H‹]¸H…ŰHDŃH‰U¨I‰ÍLEmĐLDáLŤ5
LEóč€ H‰Ă1˙č† H‹8čn H‰ÇH‹uČč H‰ßH‰ĆčÓ H‰E¸1˙č\ H‹8čD H‰Ă1˙čJ H‹8č2 H‰ÇL‰ţčŮ H‰ßH‰Ćč HŤ5d H‰D$L‰t$L‰$$H‹}°H‹UĐH‹M¸L‹E¨M‰é0ŔčQ I‰Ĺ1˙čó H‹8čŰ H‰ÇL‰îčL H‹]ČH…ŰtD‹C…Ŕt#˙ȉCu61˙č H‹8čŞ H‰ÇH‰Ţč9 ë1˙č¦ H‹8čŽ H‰ÇH‰Ţč M…˙tFA‹G…Ŕt$˙ČA‰Gu61˙čw H‹8č_ H‰ÇL‰ţčî ë1˙č[ H‹8čC H‰ÇL‰ţčĚ M…í… 1˙č8 H‹8č HŤ5· HŤŐö˙˙HŤ
( H‰Çčs 1˙č H‹8čô H‰Çč, H8 tO1˙čď H‹8č× I‰Ć1˙čÝ H‹8čĹ H‰Çčĺ ‹1˙čÄ H‹8č¬ H‰Çčä H‹L‰÷‰ŢčÝ 1˙č H‹8č H‰Çčş I‰Ć1˙č† H‹8čn H‰Çč” H‹ H‹]ŔL‰4Ř1˙čd H‹8čL H‰Çčr H‹ HŤ Ř1˙čF H‹8č. H‰ÇčZ H‰HÄH[A\A]A^A_]Ă1˙č H‹8č I‹UHŤ5• H‰Ç0Ŕč< ˙%D ˙%F ˙%H ˙%J ˙%L ˙%N ˙%P ˙%R ˙%T ˙%V ˙%X ˙%Z ˙%\ ˙%^ ˙%` ˙%b ˙%d ˙%f ˙%h ˙%j ˙%l ˙%n ˙%p ˙%r ˙%t ˙%v ˙%x ˙%z ˙%| ˙%~ ˙%€ ˙%‚ ˙%„ ˙%† ˙% ˙%Š ˙%Ś ˙%Ž ˙% ˙%’ ˙%” ˙%– ˙% ˙%š ˙%ś h é h é h1 éú hP éđ hd éć h éÜ hź éŇ hą éČ hŃ éľ hî é´ h éŞ h é h2 é– hD éŚ hX é‚ hn éx h„ én h— éd h° éZ hČ éP hÜ éF hö é< h é2 h( é( h> é hX é hq é
h é LŤ ý AS˙%í h› éć˙˙˙h® éÜ˙˙˙hÇ éŇ˙˙˙hÜ éČ˙˙˙hé éľ˙˙˙hř é´˙˙˙h éŞ˙˙˙h é ˙˙˙h$ é–˙˙˙h3 éŚ˙˙˙hB é‚˙˙˙hQ éx˙˙˙h` én˙˙˙h| éd˙˙˙h‰ éZ˙˙˙h™ éP˙˙˙h¨ éF˙˙˙ Đ? $@ $Ŕ Y@ MAIN: get_matrix failed. r MAIN: open_seq_file failed. w MAIN: open_outfile failed. MAIN: loop_on_seqs failed. DO_SEQ: save_hit failed DO_SEQ: output failed %ld %.3f
%s
GET_CMD_ARGS: Too few arguments. GET_MATRIX: could not open specified file. %lf,%*c GET_MATRIX: too many counts. GET_SEQUENCE: Sequence too long. LOOP_ON_SEQS: get_sequence failed. LOOP_ON_SEQS: do_seq failed. %s TFBS %s %s - + %6.3f %6.1f %ld %ld SAVE_HIT: MAXHITS limit reached. matrixfile, seqfile, threshold, tfname, tfclass, outfile pwmsearch.c %s::%s XS_VERSION VERSION 0.2 version %s object version %-p does not match %s%s%s%s %-p $ :: bootstrap parameter %s TFBS::Ext::pwmsearch::search_xs $ $ ŃX ó
< < ß$ <
4 ± 1 c ¶ ŕ
# ž ! zR x , ËÝ˙˙˙˙˙˙± A†C
PŚŤŽŹ $ L Lß˙˙˙˙˙˙ A†C
$ t Cß˙˙˙˙˙˙1 A†C
$ ś Lß˙˙˙˙˙˙0 A†C
, Ä Tß˙˙˙˙˙˙Ý A†C
PŚŤŽŹ $ ô ä˙˙˙˙˙˙U A†C
CŽ , .ä˙˙˙˙˙˙S A†C
GŚŽŹ , L Qä˙˙˙˙˙˙… A†C
MŚŤŽŹ , | ¦ĺ˙˙˙˙˙˙; A†C
PŚŤŽŹ , ¬ ±ç˙˙˙˙˙˙Ż A†C
PŚŤŽŹ , Ü 0é˙˙˙˙˙˙» A†C
PŚŤŽŹ $ »é˙˙˙˙˙˙* A†C
B , 4 ˝é˙˙˙˙˙˙ A†C
JŚŤŽŹ , d ¦ę˙˙˙˙˙˙{ A†C
KŚŽŹ , ” ńę˙˙˙˙˙˙ A†C
MŚŤŽŹ , Ä aď˙˙˙˙˙˙ A†C
MŚŤŽŹ ě% ö% &
& & & (& 2& <& F& P& Z& d& n& x& ‚& Ś& –& & Ş& ´& ľ& Č& Ň& Ü& ć& đ& ú& ' ' (' 2' <' F' P' Z' d' n' x' ‚' Ś' –' ' Ş' ´' err_log function failure !(`- @__DefaultRuneLocale Qq@___stack_chk_guard @___stderrp @dyld_stub_binder €Ř˙˙˙˙˙˙˙˙ q(>@_Perl_Gthr_key_ptr q0>@_Perl_Icurpad_ptr q8>@_Perl_Imarkstack_ptr_ptr q@>@_Perl_Iop_ptr qH>@_Perl_Iscopestack_ix_ptr qP>@_Perl_Istack_base_ptr qX>@_Perl_Istack_sp_ptr q`>@_Perl_Isv_yes_ptr qh>@_Perl_Iunitcheckav_ptr qp>@_Perl_call_list qx>@_Perl_croak q€>@_Perl_croak_xs_usage q>@_Perl_form q>@_Perl_get_sv q>@_Perl_newSVpvf q >@_Perl_newSVpvn q¨>@_Perl_newXS q°>@_Perl_new_version q¸>@_Perl_sv_2mortal qŔ>@_Perl_sv_2nv qČ>@_Perl_sv_2pv_flags qĐ>@_Perl_sv_derived_from qŘ>@_Perl_sv_free qŕ>@_Perl_sv_free2 qč>@_Perl_sv_newmortal qđ>@_Perl_upg_version qř>@_Perl_vcmp q€>@_Perl_vstringify q@___maskrune q@___stack_chk_fail q@___strcpy_chk q @_atof q¨@_fclose q°@_fgets q¸@_fopen qŔ@_fprintf qČ@_fscanf qĐ@_fwrite qŘ@_malloc qŕ@_printf qč@_pthread_getspecific qđ@_putc qř@_putchar q€@_strcpy q@_strlen _
do_se yannounce ‹b err_ Óget_ ěloop_on_seqs śmark ˇoutput ¦save_hit «XS_TFBS__Ext__pwmsearch_search_xs ° arch †q Î ó ¤ est_ ´oot_TFBS__Ext__pwmsearch µ save Äpull É Ă ô ¤ log âshow ç $ Ö$ cmd_args Ťmatrix ’sequence — ©% ®( é, 0 Ó1 ý1 –4 ‘5 ±> ó± 10Ý US…»Ż»*™{ úŢ l DúŢ ( libSystem.B úŢ ( libSystem.B d " d . f :# R . ó
Y $ ó
d „ $ ± N ± . ¤ z $ ¤ $ N . Ă „ $ Ă $ 1 N 1 . ô Ź $ ô $ 0 N 0 . $
š $ $
$ Ý N Ý . ˘ $ « „ $ U N U . V É $ V $ S N S . © Ó $ © $ … N … . . á $ . $ ; N ; . i í $ i ű „ $ Ż N Ż . $ $ » N » . Ó $ Ó $ * N * . ý $ $ ý $ N . , $ $ { N { . ‘ 6 $ ‘ Y „ $ N . 1 f $ 1 $ N & ŕ' & 1 Ź & °1 ™ & Ŕ1 d ˘ ŕ' © 1 ° °1 ş Ŕ1 Ă ‘ ć ¤ đ ô ű Ă 1 ! ó
, $
4 = V G © U . a i o } Ó ý ‹ • ţ ¨ ţ ş ţ Ó ţ á ţ ú ţ ţ $ ţ 6 ţ M ţ ] ţ i ţ ~ ţ ‰ ţ – ţ Ą ţ ´ ţ Ŕ ţ Ň ţ ă ţ đ ţ ţ ţ ' ţ 6 ţ I ţ [ ţ f ţ w ‹ — © Ľ Ç Ő Ű ă ę ń ú
/ 5 > F N ` a b c d e f g h i j k l m n o p q r s t u v w x y z { } ~ ‚ „ … † ‡ ‰ Š ‹ Ś Ť Ž Ź @| € ` a b c d e f g h i j k l m n o p q r s t u v w x y z { } ~ ‚ „ … † ‡ ‰ Š ‹ Ś Ť Ž Ź /Users/gtan/src/TFBS-0.5.0/Ext/ pwmsearch.c /Users/gtan/src/TFBS-0.5.0/Ext/pwmsearch.o _do_search ./lib/pwm_searchPFF.c _announce _best_save _best_pull _do_seq _err_log /usr/include/secure/_string.h _err_show _get_cmd_args _get_matrix _get_sequence /usr/include/ctype.h _loop_on_seqs _mark _output _save_hit _XS_TFBS__Ext__pwmsearch_search_xs pwmsearch.xs _boot_TFBS__Ext__pwmsearch _TRANS _PANIC _NUM_ERRS ___ERR__ _TRANS _PANIC _NUM_ERRS ___ERR__ _XS_TFBS__Ext__pwmsearch_search_xs _announce _best_pull _best_save _boot_TFBS__Ext__pwmsearch _do_search _do_seq _err_log _err_show _get_cmd_args _get_matrix _get_sequence _loop_on_seqs _mark _output _save_hit _Perl_Gthr_key_ptr _Perl_Icurpad_ptr _Perl_Imarkstack_ptr_ptr _Perl_Iop_ptr _Perl_Iscopestack_ix_ptr _Perl_Istack_base_ptr _Perl_Istack_sp_ptr _Perl_Isv_yes_ptr _Perl_Iunitcheckav_ptr _Perl_call_list _Perl_croak _Perl_croak_xs_usage _Perl_form _Perl_get_sv _Perl_newSVpvf _Perl_newSVpvn _Perl_newXS _Perl_new_version _Perl_sv_2mortal _Perl_sv_2nv _Perl_sv_2pv_flags _Perl_sv_derived_from _Perl_sv_free _Perl_sv_free2 _Perl_sv_newmortal _Perl_upg_version _Perl_vcmp _Perl_vstringify __DefaultRuneLocale ___maskrune ___stack_chk_fail ___stack_chk_guard ___stderrp ___strcpy_chk _atof _fclose _fgets _fopen _fprintf _fscanf _fwrite _malloc _printf _pthread_getspecific _putc _putchar _strcpy _strlen dyld_stub_binder TFBS-0.7.1/blib/bin/ 0000775 0000000 0000000 00000000000 13057522667 0013752 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/bin/.exists 0000664 0000000 0000000 00000000000 13057522667 0015260 0 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/ 0000775 0000000 0000000 00000000000 13057522667 0013750 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/.exists 0000664 0000000 0000000 00000000000 13057522667 0015256 0 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/TFBS/ 0000775 0000000 0000000 00000000000 13057522667 0014506 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/TFBS/DB.pm 0000664 0000000 0000000 00000000506 13057522667 0015332 0 ustar 00root root 0000000 0000000 # This package should hold interface and common database manipulation
# methods, if we decide there are any
package TFBS::DB;
use vars qw(@ISA);
use strict;
use Bio::Root::Root;
use TFBS::Matrix;
@ISA = qw(Bio::Root::Root);
sub new {
}
sub get_MatrixSet {
}
sub get_Matrix_by_ID {
}
# not finished (apparently)
TFBS-0.7.1/blib/lib/TFBS/DB/ 0000775 0000000 0000000 00000000000 13057522667 0014773 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/TFBS/DB/FlatFileDir.pm 0000664 0000000 0000000 00000032600 13057522667 0017457 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::DB::FlatFileDir
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::DB::FlatFileDir - interface to a database of pattern matrices
stored as a collection of flat files in a dedicated directory
=head1 SYNOPSIS
=over 4
=item * creating a database object by connecting to the existing directory
my $db = TFBS::DB::FlatFileDir->connect("/home/boris/MatrixDir");
=item * retrieving a TFBS::Matrix::* object from the database
# retrieving a PFM by ID
my $pfm = $db->get_Matrix_by_ID('M00079','PFM');
#retrieving a PWM by name
my $pwm = $db->get_Matrix_by_name('NF-kappaB', 'PWM');
=item * retrieving a set of matrices as a TFBS::MatrixSet object according to various criteria
# retrieving a set of PWMs from a list of IDs:
my @IDlist = ('M0019', 'M0045', 'M0073', 'M0101');
my $matrixset = $db->get_MatrixSet(-IDs => \@IDlist,
-matrixtype => "PWM");
# retrieving a set of ICMs from a list of names:
my @namelist = ('p50', 'p53', 'HNF-1'. 'GATA-1', 'GATA-2', 'GATA-3');
my $matrixset = $db->get_MatrixSet(-names => \@namelist,
-matrixtype => "ICM");
# retrieving a set of all PFMs in the database
my $matrixset = $db->get_MatrixSet(-matrixtype => "PFM");
=item * creating a new FlatFileDir database in a new directory:
my $db = TFBS::DB::JASPAR2->create("/home/boris/NewMatrixDir");
=item * storing a matrix in the database:
#let $pfm is a TFBS::Matrix::PFM object
$db->store_Matrix($pfm);
=back
=head1 DESCRIPTION
TFBS::DB::FlatFileDir is a read/write database interface module that
retrieves and stores TFBS::Matrix::* and TFBS::MatrixSet
objects in a set of flat files in a dedicated directory. It has a
very simple structure and can be easily set up manually if desired.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::DB::FlatFileDir;
use vars qw(@ISA);
use strict;
use Bio::Root::Root;
use TFBS::Matrix::PFM;
use TFBS::Matrix::ICM;
use TFBS::Matrix::PWM;
use TFBS::MatrixSet;
@ISA = qw(TFBS::DB Bio::Root::Root);
=head2 new
Title : new
Usage : my $db = TFBS::DB::FlatFileDir->new(%args);
Function: the formal constructor for the TFBS::DB::FlatFileDir object;
most users will not use it - they will use specialized
I or I constructors to create a
database object
Returns : a TFBS::DB::FlatFileDir object
Args : -dir # the directory containing flat files
=cut
sub new {
my $caller = shift;
my $self = bless {_item => {},
_idlist_of_name=>{} ,
_idlist_of_class=>{}
},
ref ($caller) || $caller;
if (-d $_[0]) {
$self->{dir} = $_[0];
}
elsif ($_[0] eq '-dir' and -d $_[1]) {
$self->{dir} = $_[1];
}
else {
$self->throw("Error initializing FlatFileDir database dir: ",
($_[1] or $_[0] or "No directory parameter passed."));
}
$self->_load_db_index();
return $self;
}
=head2 connect
Title : connect
Usage : my $db = TFBS::DB::FlatFileDir->connect($directory);
Function: Creates a database object that retrieves TFBS::Matrix::*
object data from or stores it in an existing directory
Returns : a TFBS::DB::FlatFileDir object
Args : ($directory)
The name of the directory (possibly with fully qualified
path).
=cut
sub connect {
my ($caller, $dir) = @_;
$caller->new(-dir=>$dir);
}
=head2 create
Title : create
Usage : my $newdb = TFBS::DB::FlatFileDir->create($new_directory);
Function: connects to the database server, creates a new directory,
sets up a FlatFileDir database and returns a database
object that interfaces the database
Returns : a TFBS::DB::FlatFileDir object
Args : ($new_directory)
The name of the directory to create
(possibly with fully qualified path).
=cut
sub create {
my ($caller, $dir) = @_;
if (-d $dir) { die ("Directory $dir exists") ; }
mkdir ($dir) or die("Error creating directory $dir, stopped");
open FILE, ">$dir/matrix_list.txt"
or die ("Error creating matrix_list.txt");
close FILE;
$caller->new(-dir=>$dir);
}
=head2 get_Matrix_by_ID
Title : get_Matrix_by_ID
Usage : my $pfm = $db->get_Matrix_by_ID('M00034', 'PFM');
Function: fetches matrix data under the given ID from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on the second argument (allowed
values are 'PFM', 'ICM', and 'PWM'); returns undef if
matrix with the given ID is not found
Args : (Matrix_ID, Matrix_type)
Matrix_ID is a string; Matrix_type is one of the
following: 'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or 'PWM' (position
weight matrix)
If Matrix_type is omitted, a PWM is retrieved by default.
=cut
sub get_Matrix_by_ID {
my ($self, $ID, $mt) = @_;
$self->throw("No ID passed to get_Matrix_by_ID.") unless defined $ID;
$mt = defined $mt ? $self->_check_matrixtype($mt) : "PWM";
my $matrixobj;
{
no strict 'refs';
my $working_mt = $mt = uc $mt;
my $matrixstring = $self->_read_file($ID,$mt)
# if no desired $mt, is there a PFM?
|| $self->_read_file($ID,$working_mt="PFM")
|| return undef;
eval("\$matrixobj= TFBS::Matrix::$working_mt->new".'
( -ID => $ID,
-name => $self->{_item}->{$ID}->{name} || "",
-class => $self->{_item}->{$ID}->{class}|| "",
-matrix=> $matrixstring,
-tags=> $self->{_item}->{$ID}->{tags}
);'.
"if (\$working_mt ne \$mt) {\$matrixobj = \$matrixobj->to_$mt;}");
if ($@) {$self->throw($@); }
}
# print "MATRIXOBJ: $matrixobj\n";
return $matrixobj;
}
=head2 get_Matrix_by_name
Title : get_Matrix_by_name
Usage : my $pfm = $db->get_Matrix_by_name('HNF-1', 'PWM');
Function: fetches matrix data under the given name from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the object
depending on the second argument (allowed values are
'PFM', 'ICM', and 'PWM')
Args : (Matrix_name, Matrix_type)
Matrix_name is a string; Matrix_type is one of the
following:
'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or
'PWM' (position weight matrix)
If Matrix_type is omitted, a PWM is retrieved by default.
Warning : According to the current JASPAR2 data model, name is
not necessarily a unique identifier. In the case where
there are several matrices with the same name in the
database, the function fetches the first one and prints
a warning on STDERR. You have been warned.
=cut
sub get_Matrix_by_name {
my ($self, $name, $mt) = @_;
my $ID=$self->{_idlist_of_name}->{$name}->[0]
or return undef;
if ((my $L= scalar @{ $self->{_idlist_of_name}->{$name} }) > 1) {
$self->warn("There are $L matrices with name '$name'");
}
return $self->get_Matrix_by_ID($ID, $mt);
}
sub get_matrix {
# an obsolete method - kept for the time being for backward compatibility
my ($self, %args) = @_;
my $DIR = $self->{dir};
my $ID;
# retrieval from .pwm files in a directory
my $mt = ($self->_get_matrixtype_from_args(%args)
or $self->throw("No -matrixtype provided."));
if ($args{-ID}) {
$ID = $args{-ID};
}
elsif (my $name = $args{-name}) {
$ID=$self->{_idlist_of_name}->{$name}->[0]
or $self->warn("No matrix with name $name found.");
if ((my $L= scalar @{ $self->{_idlist_of_name}->{$name} }) > 1) {
$self->warn("There are $L matrices with name '$name'");
}
}
else {
$self->throw("No -ID or -name passed to ".ref($self));
}
my $matrixobj;
{
no strict 'refs';
my $ucmt = uc $mt;
my $matrixstring =`cat $DIR/$ID.$mt`;
eval("\$matrixobj= TFBS::Matrix::$ucmt->new".'
( -ID => $ID,
-name => $self->{_item}->{$ID}->{name},
-class => $self->{_item}->{$ID}->{class},
-matrix=> $matrixstring # FIXME - temporary
);');
if ($@) {$self->throw($@); }
}
# print "MATRIXOBJ: $matrixobj\n";
return $matrixobj;
}
=head2 store_Matrix
Title : store_Matrix
Usage : $db->store_Matrix($matrixobj);
Function: Stores the contents of a TFBS::Matrix::DB object in the database
Returns : 0 on success; $@ contents on failure
(this is too C-like and may change in future versions)
Args : ($matrixobj) # a TFBS::Matrix::* object
=cut
sub store_Matrix {
my ($self, $matrixobj) = @_;
my ($mt) = ($matrixobj =~ /TFBS::Matrix::(\w+)/)
or $self->throw("Wrong type of object passed to store_Matrix.");
if (defined $self->{_item}->{$matrixobj->ID()}) {
$self->throw("ID ".$matrixobj->ID()." exists in the database.");
}
else {
my $matrixfile = $self->{dir}."/".$matrixobj->ID().".".lc($mt);
open FILE, ">$matrixfile"
or $self->throw("Could not write file $matrixfile.");
print FILE $matrixobj->rawprint;
close FILE;
my $ic = ($mt eq "ICM") ? $matrixobj->total_ic :
($mt eq "PFM") ? $matrixobj->to_ICM->total_ic : "";
$self->{_item}->{$matrixobj->ID()} = { 'name' => $matrixobj->name || "",
'ic' => $ic,
'class'=> $matrixobj->class || "" };
my %tags= $matrixobj->all_tags();
foreach my $named_tag (keys %tags){
$self->{_item}->{$matrixobj->ID()}{'tag'}{$named_tag}=$tags{$named_tag};
# print $named_tag , " ", $self->{_item}->{$matrixobj->ID()}{'tag'}{$named_tag}, "\n";
}
$self->_update_db_index();
}
return 0;
}
=head2 delete_Matrix_having_ID
Title : delete_Matrix_having_ID
Usage : $db->delete_Matrix_with_ID('M00045');
Function: Deletes the matrix having the given ID from the database
Returns : 0 on success; $@ contents on failure
(this is too C-like and may change in future versions)
Args : (ID)
A string
Comment : Yeah, yeah, 'delete_Matrix_having_ID' is a stupid name
for a method, but at least it should be obviuos what it does.
=cut
sub delete_Matrix_having_ID {
my ($self, $ID) = @_;
my $DIR = $self->{dir};
unlink <$DIR/$ID.*>;
delete $self->{_item}->{$ID};
$self->_update_db_index();
}
sub _update_db_index {
my $self = shift;
rename $self->{dir}."/matrix_list.txt", $self->{dir}."/~matrix_list.txt";
open FILE, ">".$self->{dir}."/matrix_list.txt";
foreach my $ID ( keys %{$self->{_item}} ) {
print FILE join("\t", $ID,
$self->{_item}->{$ID}->{ic},
$self->{_item}->{$ID}->{name},
$self->{_item}->{$ID}->{class}
)."\t";
# add tagged annotation
# my %tag = $self->{_item}->{$ID}->{'all_tags'};
foreach my $name(sort keys %{$self->{'_item'}->{$ID}{'tag'}}){
print FILE "; ", $name, " \"", $self->{'_item'}->{$ID}{'tag'}{$name}, "\"\ ";
}
print FILE "\n";
}
close FILE;
}
sub _load_db_index {
my ($self, $field, $value) = @_;
my $DIR = $self->{dir};
open (MATRIXLIST, "$DIR/matrix_list.txt")
or $self->throw("Could not read matrix list $DIR/matrix_list.txt");
while (my $line = ) {
chomp $line;
my ($ID, $ic, $name, $class) = split /\s+/, $line ;
if ($ID =~ /(\w+)\.(\w+)$/) {
$ID = $1;
}
defined($self->{_item}->{$ID})
and $self->warn("Duplicate entries for ID $ID");
$self->{_item}->{$ID} = {name=>$name, ic=>$ic, class=>$class};
push @{ $self->{_idlist_of_name}->{$name} }, $ID;
push @{ $self->{_idlist_of_class}->{$class} }, $ID;
# annoatation
my @anno= split(/\s?;\s?/, $line);
my %tags;
shift @anno;
foreach (@anno){
my ($name, $val)=split(/\s?\"/, $_);
# print "$name $val\n";
$self->{_item}->{$ID}->{'tags'}->{$name}=$val;
}
}
close MATRIXLIST;
return scalar keys %{ $self->{_item} }; # false if list empty
}
sub get_MatrixSet {
my ($self, %args) = @_;
my $DIR = $self->{db};
my $arrayref;
my $mt = $self->_check_matrixtype($args{-matrixtype})
|| $self->throw("No matrix type provided.");
delete $args{'-matrixtype'};
my ($field, $value) = %args;
unless (defined $field) {
$field="-IDs";
$arrayref = [ keys %{ $self->{_item}} ];
}
my @IDlist;
if ($field eq "-IDs") {
@IDlist = @$arrayref;
}
elsif ($field eq "-names") {
foreach (@$arrayref) {
push @IDlist, @{ $self->{_idlist_of_name}->{$_} };
}
}
elsif ($field eq "-classes") {
foreach (@$arrayref) {
push @IDlist, @{ $self->{_idlist_of_class}->{$_} };
}
}
else {
$self->throw("Unknown matrixset selector: $field.");
}
my $matrixset = TFBS::MatrixSet->new();
foreach my $ID(@IDlist) {
$matrixset->add_matrix($self->get_Matrix_by_ID($ID, $mt));
}
close MATRIXLIST;
return $matrixset;
}
sub _check_matrixtype {
my ($self, $mt) = @_;
$mt = uc $mt;
return undef unless $mt;
unless ( $mt eq "PFM"
or $mt eq "ICM"
or $mt eq "PWM") {
$self->throw("Unsupported matrix type: ".$mt);
}
return $mt;
}
sub _read_file {
my ($self, $id, $mt) = @_;
local $/ = undef;
open FILE, $self->{dir}."/$id.".lc($mt) or return undef;
my $matrixstring = ; #slurp;
close FILE;
return $matrixstring;
}
1;
TFBS-0.7.1/blib/lib/TFBS/DB/JASPAR2.pm 0000664 0000000 0000000 00000061514 13057522667 0016402 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::DB::JASPAR2
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::DB::JASPAR2 - interface to MySQL relational database of pattern matrices
=head1 SYNOPSIS
=over 4
=item * creating a database object by connecting to the existing JASPAR2-type database
my $db = TFBS::DB::JASPAR2->connect("dbi:mysql:JASPAR2:myhost",
"myusername",
"mypassword");
=item * retrieving a TFBS::Matrix::* object from the database
# retrieving a PFM by ID
my $pfm = $db->get_Matrix_by_ID('M0079','PFM');
#retrieving a PWM by name
my $pwm = $db->get_Matrix_by_name('NF-kappaB', 'PWM');
=item * retrieving a set of matrices as a TFBS::MatrixSet object according to various criteria
# retrieving a set of PWMs from a list of IDs:
my @IDlist = ('M0019', 'M0045', 'M0073', 'M0101');
my $matrixset = $db->get_MatrixSet(-IDs => \@IDlist,
-matrixtype => "PWM");
# retrieving a set of ICMs from a list of names:
my @namelist = ('p50', 'p53', 'HNF-1'. 'GATA-1', 'GATA-2', 'GATA-3');
my $matrixset = $db->get_MatrixSet(-names => \@namelist,
-matrixtype => "ICM");
# retrieving a set of all PFMs in the database
# derived from human genes:
my $matrixset = $db->get_MatrixSet(-species => ['Homo sapiens'],
-matrixtype => "PFM");
=item * creating a new JASPAR2-type database named MYJASPAR2:
my $db = TFBS::DB::JASPAR2->create("dbi:mysql:MYJASPAR2:myhost",
"myusername",
"mypassword");
=item * storing a matrix in the database (currently only PFMs):
#let $pfm is a TFBS::Matrix::PFM object
$db->store_Matrix($pfm);
=back
=head1 DESCRIPTION
TFBS::DB::JASPAR2 is a read/write database interface module that
retrieves and stores TFBS::Matrix::* and TFBS::MatrixSet
objects in a relational database.
=head1 JASPAR2 DATA MODEL
JASPAR2 is working name for a relational database model used
for storing transcriptional factor pattern matrices in a MySQL database.
It was initially designed to store matrices for the JASPAR database of
high quality eukaryotic transcription factor specificity profiles by
Albin Sandelin and Wyeth W. Wasserman. Besides the profile matrix itself,
this data model stores profile ID (unique), name, structural class,
basic taxonomic and bibliographic information
as well as some additional optional tags.
Due to its data model, which precedeed the design of the
module, TFBS::DB::JASPAR2 cannot store arbitrary tags for a matrix.
The supported tags are
'acc' # (accession number;
# originally for transcription factor protein seq)
'seqdb' # sequence database where 'acc' comes from
'medline' # PubMed ID
'species' # Species name
'sysgroup'
'total_ic' # total information content - redundant, present
# for historical
"medline" => ($self->_get_medline($ID) or ""),
"species" => ($self->_get_species($ID) or ""),
"sysgroup"=> ($self->_get_sysgroup($ID) or ""),
"type" => ($self->_get_type($ID) or ""),
"seqdb" => ($self->_get_seqdb($ID) or ""),
"acc" => ($self->_get_acc($ID) or ""),
"total_ic"=
----------------------- ADVANCED ---------------------------------
For the developers and the curious, here is the JASPAR2 data model:
CREATE TABLE matrix_data (
ID varchar(16) DEFAULT '' NOT NULL,
pos_ID varchar(24) DEFAULT '' NOT NULL,
base enum('A','C','G','T'),
position tinyint(3) unsigned,
raw int(3) unsigned,
info float(7,5) unsigned, -- calculated
pwm float(7,5) unsigned, -- calculated
normalized float(7,5) unsigned,
PRIMARY KEY (pos_ID),
KEY id_index (ID)
);
CREATE TABLE matrix_info (
ID varchar(16) DEFAULT '' NOT NULL,
name varchar(15) DEFAULT '' NOT NULL,
type varchar(8) DEFAULT '' NOT NULL,
class varchar(20),
phylum varchar (32), -- maps to 'sysgroup' tag
litt varchar(40), -- not used by this module
medline int(12),
information varchar(20), -- not used by this module
iterations varchar(6),
width int(2), -- calculated
consensus varchar(25), -- calculated
IC float(6,4), -- maps to 'total_ic' tag
sites int(3) unsigned, -- not used by this module
PRIMARY KEY (ID)
)
CREATE TABLE matrix_seqs (
ID varchar(16) DEFAULT '' NOT NULL,
internal varchar(8) DEFAULT '' NOT NULL,
seq_db varchar(15) NOT NULL,
seq varchar(10) NOT NULL,
PRIMARY KEY (ID, seq_db, seq)
)
CREATE TABLE matrix_species (
ID varchar(16) DEFAULT '' NOT NULL,
internal varchar(8) DEFAULT '' NOT NULL,
species varchar(24) NOT NULL,
PRIMARY KEY (ID, species)
)
It is our best intention to hide the details of this data model, which we
are using on a daily basis in our work, from most TFBS users, simply
because for historical reasons some table column names are confusing
at best. Most users should only know the methods to store the data and
which tags are supported.
-------------------------------------------------------------------------
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::DB::JASPAR2;
use vars qw(@ISA $AUTOLOAD);
# we need all three matrices due to the redundancy in JASPAR2 data model
# which will hopefully be removed in JASPAR3
use TFBS::Matrix::PWM;
use TFBS::Matrix::PFM;
use TFBS::Matrix::ICM;
use TFBS::MatrixSet;
use Bio::Root::Root;
use DBI;
# use TFBS::DB; # eventually
use strict;
@ISA = qw(TFBS::DB Bio::Root::Root);
#########################################################################
# CONSTANTS
#########################################################################
use constant DEFAULT_CONNECTSTRING => "dbi:mysql:JASPAR_DEMO"; # on localhost
use constant DEFAULT_USER => "";
use constant DEFAULT_PASSWORD => "";
#########################################################################
# PUBLIC METHODS
#########################################################################
=head2 new
Title : new
Usage : DEPRECATED - for backward compatibility only
Use connect() or create() instead
=cut
sub new {
_new (@_);
}
=head2 connect
Title : connect
Usage : my $db =
TFBS::DB::JASPAR2->connect("dbi:mysql:DATABASENAME:HOSTNAME",
"USERNAME",
"PASSWORD");
Function: connects to the existing JASPAR2-type database and
returns a database object that interfaces the database
Returns : a TFBS::DB::JASPAR2 object
Args : a standard database connection triplet
("dbi:mysql:DATABASENAME:HOSTNAME", "USERNAME", "PASSWORD")
In place of DATABASENAME, HOSTNAME, USERNAME and PASSWORD,
use the actual values. PASSWORD and USERNAME might be
optional, depending on the user acces permissions for
the database server.
=cut
sub connect {
# a more intuitive syntax for the constructor
my ($caller, @connection_args) = @_;
$caller->new(-connect => \@connection_args);
}
=head2 create
Title : create
Usage : my $newdb =
TFBS::DB::JASPAR2->create("dbi:mysql:NEWDATABASENAME:HOSTNAME",
"USERNAME",
"PASSWORD");
Function: connects to the database server, creates a new JASPAR2-type database and returns a database
object that interfaces the database
Returns : a TFBS::DB::JASPAR2 object
Args : a standard database connection triplet
("dbi:mysql:NEWDATABASENAME:HOSTNAME", "USERNAME", "PASSWORD")
In place of NEWDATABASENAME, HOSTNAME, USERNAME and
PASSWORD use the actual values. PASSWORD and USERNAME
might be optional, depending on the users acces permissions
for the database server.
=cut
sub create {
my ($caller, $connectstring, $user, $password) = @_;
if ($connectstring
and $connectstring =~ /dbi:mysql:(\w+)(.*)/)
{
# connect to the server;
my $dbh=DBI->connect("dbi:mysql:mysql".$2,
$user,$password)
or die("Error connecting to the database");
# create database and open it
$dbh->do("create database $1")
or die("Error creating database.");
$dbh->do("use $1");
# create tables
_create_tables($dbh);
$dbh->disconnect;
# run "new" with new database
return $caller->new(-connect=>[$connectstring, $user, $password]);
}
else {
die("Missing or malformed connect string for ".
"TFBS::DB::JASPAR2 connection.");
}
}
=head2 dbh
Title : dbh
Usage : my $dbh = $db->dbh();
$dbh->do("UPDATE matrix_data SET name='ADD1' WHERE NAME='SREBP2'");
Function: returns the DBI database handle of the MySQL database
interfaced by $db; THIS IS USED FOR WRITING NEW METHODS
FOR DIRECT RELATIONAL DATABASE MANIPULATION - if you
have write access AND do not know what you are doing,
you can severely corrupt the data
For documentation about database handle methods, see L
Returns : the database (DBI) handle of the MySQL JASPAR2-type
relational database associated with the TFBS::DB::JASPAR2
object
Args : none
=cut
sub dbh {
my ($self, $dbh) = @_;
$self->{'dbh'} = $dbh if $dbh;
return $self->{'dbh'};
}
=head2 get_Matrix_by_ID
Title : get_Matrix_by_ID
Usage : my $pfm = $db->get_Matrix_by_ID('M00034', 'PFM');
Function: fetches matrix data under the given ID from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on the second argument (allowed
values are 'PFM', 'ICM', and 'PWM'); returns undef if
matrix with the given ID is not found
Args : (Matrix_ID, Matrix_type)
Matrix_ID is a string; Matrix_type is one of the
following: 'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or 'PWM' (position
weight matrix)
If Matrix_type is omitted, a PWM is retrieved by default.
=cut
sub get_Matrix_by_ID {
my ($self, $ID, $mt) = @_;
$mt = (uc($mt) or "PWM");
unless (defined $ID) {
$self->throw("No ID passed to get_Matrix_by_ID");
}
my $matrixobj;
{
no strict 'refs';
my $ucmt = uc $mt;
my $matrixstring = $self->_get_matrixstring($ID, $mt) || return undef;
eval("\$matrixobj= TFBS::Matrix::$ucmt->new".'
( -ID => $ID,
-name => $self->_get_name($ID)."",
-class => $self->_get_class($ID)."",
-tags => { "medline" => ($self->_get_medline($ID) or ""),
"species" => ($self->_get_species($ID) or ""),
"sysgroup"=> ($self->_get_sysgroup($ID) or ""),
"type" => ($self->_get_type($ID) or ""),
"seqdb" => ($self->_get_seqdb($ID) or ""),
"acc" => ($self->_get_acc($ID) or ""),
"total_ic"=> ($self->_get_total_ic($ID) or "")
},
-matrix=> $matrixstring # FIXME - temporary
);');
if ($@) {$self->throw($@); }
}
return $matrixobj;
}
=head2 get_Matrix_by_name
Title : get_Matrix_by_name
Usage : my $pfm = $db->get_Matrix_by_name('HNF-1', 'PWM');
Function: fetches matrix data under the given name from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the object
depending on the second argument (allowed values are
'PFM', 'ICM', and 'PWM')
Args : (Matrix_name, Matrix_type)
Matrix_name is a string; Matrix_type is one of the
following:
'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or
'PWM' (position weight matrix)
If Matrix_type is omitted, a PWM is retrieved by default.
Warning : According to the current JASPAR2 data model, name is
not necessarily a unique identifier. In the case where
there are several matrices with the same name in the
database, the function fetches the first one and prints
a warning on STDERR. You have been warned.
=cut
sub get_Matrix_by_name {
my ($self, $name, $mt) = @_;
unless(defined $name) {
$self->throw("No name passed to get_Matrix_by_name."); }
my @IDlist = $self->_get_IDlist_by_query(-names=>[$name]);
my $ID= ($IDlist[0]
or $self->warn("No matrix with name $name found."));
if ((my $L= scalar @IDlist) > 1) {
$self->warn("There are $L matrices with name '$name'");
}
return $self->get_Matrix_by_ID($ID, $mt);
}
=head2 get_MatrixSet
Title : get_MatrixSet
Usage : my $matrixset = $db->get_MatrixSet(%args);
Function: fetches matrix data under for all matrices in the database
matching criteria defined by the named arguments
and returns a TFBS::MatrixSet object
Returns : a TFBS::MatrixSet object
Args : This method accepts named arguments:
-IDs # a reference to an array of IDs (strings)
-names # a reference to an array of
# transcription factor names (string)
-classes # a reference to an array of
# structural class names (strings)
-species # a reference to an array of
# Latin species names (strings)
-sysgroups # a reference to an array of
# higher taxonomic categories (strings)
-matrixtype # a string, 'PFM', 'ICM' or 'PWM'
-min_ic # float, minimum total information content
# of the matrix
The five arguments that expect list references are used in database
query formulation: elements within lists are combined with 'OR'
operators, and the lists of different types with 'AND'. For example,
my $matrixset = $db->(-classes => ['TRP_CLUSTER', 'FORKHEAD'],
-species => ['Homo sapiens', 'Mus musculus'],
-matrixtype => 'PWM');
gives a set of PWMs whose (structural clas is 'TRP_CLUSTER' OR
'FORKHEAD') AND (the species they are derived from is 'Homo sapiens'
OR 'Mus musculus').
The -min_ic filter is applied after the query in the sense that the
matrices profiles with total information content less than specified
are not included in the set.
=cut
sub get_MatrixSet {
my ($self, %args) = @_;
my @IDlist = $self->_get_IDlist_by_query(%args);
my $mt = ($args{'-matrixtype'} or "PWM");
my $matrixset = TFBS::MatrixSet->new();
foreach (@IDlist) {
next if (defined $args{'-min_ic'}
and $self->_get_total_ic($_) < $args{'-min_ic'});
$matrixset->add_Matrix($self->get_Matrix_by_ID($_, $mt));
}
return $matrixset;
}
=head2 store_Matrix
Title : store_Matrix
Usage : $db->store_Matrix($pfm);
Function: Stores the contents of a TFBS::Matrix::DB object in the database
Returns : 0 on success; $@ contents on failure
(this is too C-like and may change in future versions)
Args : (PFM_object)
A TFBS::Matrix::PFM object
Comment : this is an experimental method that is not 100% bulletproof;
use at your own risk
=cut
sub store_Matrix {
my ($self, @PFMs) = @_;
my $err;
foreach my $pfm (@PFMs) {
eval {
$self->_store_matrix_data($pfm);
$self->_store_matrix_info($pfm);
$self->_store_matrix_seqs($pfm);
$self->_store_matrix_species($pfm);
};
}
return $@;
}
=head2 store_MatrixSet
Title : store_MatrixSet
Usage : $db->store_Matrix($matrixset);
Function: Stores the TFBS::DB::PFM object that are part of a
TFBS::MatrixSet object into the database
Returns : 0 on success; $@ contents on failure
(this is too C-like and may change in future versions)
Args : (MatrixSet_object)
A TFBS::MatrixSet object
Comment : THIS METHOD IS NOT YET IMPLEMENTED
=cut
sub store_MatrixSet {
$_[0]->throw ("Method store_MtrixSet not yet implemented.");
}
=head2 delete_Matrix_having_ID
Title : delete_Matrix_having_ID
Usage : $db->delete_Matrix_with_ID('M00045');
Function: Deletes the matrix having the given ID from the database
Returns : 0 on success; $@ contents on failure
(this is too C-like and may change in future versions)
Args : (ID)
A string
Comment : Yeah, yeah, 'delete_Matrix_having_ID' is a stupid name
for a method, but at least it should be obviuos what it does.
=cut
sub delete_Matrix_having_ID {
my ($self, @IDs) = @_;
eval {
foreach my $ID (@IDs) {
my $q_ID = $self->dbh->quote($ID);
foreach my $table (qw (matrix_data
matrix_info
matrix_seqs
matrix_species)
)
{
$self->dbh->do("DELETE from $table where ID=$q_ID");
}
}
};
return $@;
}
#########################################################################
# PRIVATE METHODS
#########################################################################
sub _new {
my ($caller, %args) = @_;
my $class = ref $caller || $caller;
my $self = bless {}, $class;
my ($connectstring, $user, $password);
if ($args{'-connect'} and (ref($args{'-connect'}) eq "ARRAY")) {
($connectstring, $user, $password) = @{$args{'-connect'}};
}
elsif ($args{'-create'} and (ref($args{'-create'}) eq "ARRAY")) {
return $caller->create(@{-args{'create'}});
}
else {
($connectstring, $user, $password) =
(DEFAULT_CONNECTSTRING, DEFAULT_USER, DEFAULT_PASSWORD);
}
$self->dbh( DBI->connect($connectstring, $user, $password) );
return $self;
}
sub _get_IDlist_by_query {
# called by get_MatrixSet
my ($self, %args) = @_;
my ($TABLES, %arrayref);
$args{-names} and $arrayref{name} = $args{-names} ;
$args{-classes} and $arrayref{class} = $args{-classes} ;
$args{-sysgroups} and $arrayref{phylum} = $args{-sysgroups};
$args{-IDs} and $arrayref{ID} = $args{-IDs};
my @andconditions;
if ($args{-species}) {
$TABLES = ' matrix_info, matrix_species ';
push @andconditions,
'matrix_info.ID = matrix_species.ID',
" (".
join(" OR ",
(map {"matrix_species.species=".
$self->dbh->quote($_)
}
@{$args{-species}}
)).
") ";
}
else {
$TABLES = 'matrix_info ';
}
foreach my $key (keys %arrayref) {
if (scalar @{$arrayref{$key}}) {
push @andconditions,
"(".
join(" OR ",
(map {"matrix_info.$key=".
$self->dbh->quote($_)
}
@{$arrayref{$key}}
)).
")";
}
else {
push @andconditions, "(1=0)";
}
}
my $WHERE = ((scalar @andconditions) == 0) ? "" : " WHERE ";
my $query =
"SELECT DISTINCTROW matrix_info.id FROM $TABLES $WHERE".
join(" AND ", @andconditions);
my $sth = $self->dbh->prepare($query);
$sth->execute() or $self->throw("Query failed:\n$query\n");
# collect IDs and return
my @IDlist = ();
while (my ($id) = $sth->fetchrow_array()) {
push @IDlist, $id;
}
$sth->finish;
return @IDlist;
}
sub _get_matrixstring {
my ($self, $ID, $mt) = @_;
my %dbname = (PWM => 'pwm', PFM => 'raw', ICM => 'info');
unless (defined $dbname{$mt}) {
$self->throw("Unsupported matrix type: ".$mt);
}
my $sth;
my $qID = $self->dbh->quote($ID);
my $matrixstring = "";
foreach my $base (qw(A C G T)) {
$sth=$self->dbh->prepare
("SELECT $dbname{$mt} FROM matrix_data
WHERE ID=$qID AND base='$base' ORDER BY position");
$sth->execute;
$matrixstring .=
join (" ", (map {$_->[0]} @{$sth->fetchall_arrayref()}))."\n";
}
$sth->finish;
return undef if $matrixstring eq "\n"x4;
return $matrixstring;
}
sub _simple_query {
my ($self, $table, $retr_field, $search_field, $search_value) = @_;
my $q_value = $self->dbh->quote($search_value);
my $sth = $self->dbh->prepare
("SELECT DISTINCT $retr_field from $table WHERE $search_field = $q_value and $retr_field <> \"\" ORDER BY $retr_field");
$sth->execute;
return (map {$_->[0]} @{$sth->fetchall_arrayref});
}
sub _store_matrix_data {
my ($self, $pfm, $ACTION) = @_;
my @base = qw(A C G T);
my $pfmatrix = $pfm->matrix();
my $icmatrix = $pfm->to_ICM()->matrix();
my $pwmatrix = $pfm->to_PWM->matrix();
my $sth = $self->dbh->prepare
(q! INSERT INTO matrix_data VALUES(?,?,?,?,?,?,?,?) !);
for my $i (0..3) {
for my $j (0..($pfm->length-1)) {
$sth->execute( $pfm->ID,
$pfm->ID.".".$base[$i].".".($j+1),
$base[$i],
$j+1,
$pfmatrix->[$i][$j],
$icmatrix->[$i][$j],
$pwmatrix->[$i][$j],
$pfmatrix->[$i][$j] / $pfm->column_sum())
or $self->throw("Error executing query.");
}
}
}
sub _store_matrix_info {
my ($self, $pfm, $ACTION) = @_;
my $sth = $self->dbh->prepare
(q! INSERT INTO matrix_info
(ID, name, type, class, phylum, width, IC, sites)
VALUES(?,?,?,?,?,?,?,?) !);
$sth->execute($pfm->ID,
($pfm->name or $pfm->ID),
($pfm->{'tags'}->{'type'} or ""),
($pfm->class() or undef),
($pfm->{'tags'}->{'sysgroup'} or undef),
$pfm->length(),
$pfm->to_ICM->total_ic(),
$pfm->column_sum()
)
or $self->throw("Error executing query");
}
sub _store_matrix_seqs {
my ($self, $pfm, $ACTION) = @_;
return unless ($pfm->{'tags'}->{'seqdb'} or $pfm->{'tags'}->{'acc'});
my $sth = $self->dbh->prepare
(q! INSERT INTO matrix_seqs
(ID, seq_db, seq)
VALUES(?,?,?) !);
$sth->execute($pfm->ID,
($pfm->{'tags'}->{'seqdb'} or ""),
($pfm->{'tags'}->{'acc'} or "")
)
or $self->throw("Error executing query");
}
sub _store_matrix_species {
my ($self, $pfm, $ACTION) = @_;
return unless $pfm->{'tags'}->{'species'};
my $sp = $pfm->{'tags'}->{'species'};
my @splist = (ref($sp) ? @$sp : $sp);
foreach my $species (@splist) {
my $sth = $self->dbh->prepare
(q! INSERT INTO matrix_species
(ID, species)
VALUES(?,?) !);
$sth->execute($pfm->ID,
$species
)
or $self->throw("Error executing query");
}
}
sub _create_tables {
# utility function
# If you want to change the databse schema,
# this is the right place to do it
my $dbh = shift;
my @queries =
(
q!
CREATE TABLE matrix_data (
ID varchar(16) DEFAULT '' NOT NULL,
pos_ID varchar(24) DEFAULT '' NOT NULL,
base enum('A','C','G','T'),
position tinyint(3) unsigned,
raw int(3) unsigned,
info float(7,5) unsigned,
pwm float(7,5),
normalized float(7,5) unsigned,
PRIMARY KEY (pos_ID),
KEY id_index (ID)
)
!,
q!
CREATE TABLE matrix_info (
ID varchar(16) DEFAULT '' NOT NULL,
name varchar(15) DEFAULT '' NOT NULL,
type varchar(8) DEFAULT '' NOT NULL,
class varchar(20),
phylum varchar(32),
litt varchar(40),
medline int(12),
information varchar(20),
iterations varchar(6),
width int(2),
consensus varchar(25),
IC float(6,4),
sites int(3) unsigned,
PRIMARY KEY (ID)
)
!,
q!
CREATE TABLE matrix_seqs (
ID varchar(16) DEFAULT '' NOT NULL,
internal varchar(8) DEFAULT '' NOT NULL,
seq_db varchar(15) NOT NULL,
seq varchar(10) NOT NULL,
PRIMARY KEY (ID, seq_db, seq)
)
!,
q!
CREATE TABLE matrix_species (
ID varchar(16) DEFAULT '' NOT NULL,
internal varchar(8) DEFAULT '' NOT NULL,
species varchar(24) NOT NULL,
PRIMARY KEY (ID, species)
)
!);
foreach my $query (@queries) {
$dbh->do($query)
or die("Error executing the query: $query\n");
}
}
sub AUTOLOAD {
my ($self, $ID) = @_;
no strict 'refs';
my $TABLE;
my %dbname_of = (ID => 'ID',
name => 'name',
class => 'class',
species => 'species',
sysgroup => 'phylum',
type => 'type',
seqdb => 'seq_db',
acc => 'seq',
total_ic => 'IC',
medline => 'medline'
);
my ($where_column, $where_value);
if ($AUTOLOAD =~ /.*::_{0,1}get_(\w+)_list/) {
defined $dbname_of{$1} or $self->throw("$AUTOLOAD: no such method!");
($where_column, $where_value) = (1,1);
}
elsif ($AUTOLOAD =~ /.*::_get_(\w+)/) {
defined $dbname_of{$1} or $self->throw("$AUTOLOAD: no such method!");
defined $ID or $self->throw("No ID provided for $AUTOLOAD");
($where_column, $where_value) = ('ID', $ID);
}
else {
$self->throw("$AUTOLOAD: no such method!");
}
defined $dbname_of{$1} or $self->throw("$AUTOLOAD: no such method!");
if ($1 eq 'species') { $TABLE = 'matrix_species'; }
elsif ($1 eq 'seqdb' or $1 eq 'acc') { $TABLE = 'matrix_seqs', }
else { $TABLE = 'matrix_info' ; }
my @results = $self->_simple_query ($TABLE, $dbname_of{$1},
$where_column => $where_value);
wantarray ? return @results : return $results[0];
}
sub DESTROY {
$_[0]->dbh->disconnect() if $_[0]->dbh;
}
1;
TFBS-0.7.1/blib/lib/TFBS/DB/JASPAR4.pm 0000664 0000000 0000000 00000053470 13057522667 0016406 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::DB::JASPAR4
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::DB::JASPAR4 - interface to MySQL relational database of pattern matrices
=head1 SYNOPSIS
=over 4
=item * creating a database object by connecting to the existing JASPAR2-type database
my $db = TFBS::DB::JASPAR4->connect("dbi:mysql:JASPAR4:myhost",
"myusername",
"mypassword");
=item * retrieving a TFBS::Matrix::* object from the database
# retrieving a PFM by ID
my $pfm = $db->get_Matrix_by_ID('M0079','PFM');
#retrieving a PWM by name
my $pwm = $db->get_Matrix_by_name('NF-kappaB', 'PWM');
=item * retrieving a set of matrices as a TFBS::MatrixSet object according to various criteria
# retrieving a set of PWMs from a list of IDs:
my @IDlist = ('M0019', 'M0045', 'M0073', 'M0101');
my $matrixset = $db->get_MatrixSet(-IDs => \@IDlist,
-matrixtype => "PWM");
# retrieving a set of ICMs from a list of names:
my @namelist = ('p50', 'p53', 'HNF-1'. 'GATA-1', 'GATA-2', 'GATA-3');
my $matrixset = $db->get_MatrixSet(-names => \@namelist,
-matrixtype => "ICM");
# retrieving a set of all PFMs in the database
# derived from human genes:
my $matrixset = $db->get_MatrixSet(-species => ['Homo sapiens'],
-matrixtype => "PFM");
=item * creating a new JASPAR4-type database named MYJASPAR4:
my $db = TFBS::DB::JASPAR4->create("dbi:mysql:MYJASPAR4:myhost",
"myusername",
"mypassword");
=item * storing a matrix in the database (currently only PFMs):
#let $pfm is a TFBS::Matrix::PFM object
$db->store_Matrix($pfm);
=back
=head1 DESCRIPTION
TFBS::DB::JASPAR4 is a read/write database interface module that
retrieves and stores TFBS::Matrix::* and TFBS::MatrixSet
objects in a relational database. The interface is nearly identical
to the JASPAR2interface, while the underlying data model is different
=head1 JASPAR2 DATA MODEL
JASPAR4 is working name for a relational database model used
for storing transcriptional factor pattern matrices in a MySQL database.
It was initially designed (JASPAR2) to store matrices for the JASPAR database of
high quality eukaryotic transcription factor specificity profiles by
Albin Sandelin and Wyeth W. Wasserman. Besides the profile matrix itself,
this data model stores profile ID (unique), name, structural class,
basic taxonomic and bibliographic information
as well as some additional opseqdbtional tags.
Tags that are commonly used in the actual JASPAR database include
'medline' # PubMed ID
'species' # Species name
'superclass' #Species supergroup, eg 'vertebrate', 'plant' etc
'total_ic' # total information content - redundant, present
# for historical
'type' #experimental nethod
'acc' #accession number for TF protein sequence
'seqdb' #corresponding database name
but any tag is storable and searchable.
----------------------- ADVANCED ---------------------------------
For the developers and the curious, here is the JASPAR4 data model:
It is our best intention to hide the details of this data model, which we
are using on a daily basis in our work, from most TFBS users.
Most users should only know the methods to store the data and
which tags are supported.
-------------------------------------------------------------------------
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::DB::JASPAR4;
use vars qw(@ISA $AUTOLOAD);
# we need all three matrices due to the redundancy in JASPAR2 data model
# which will hopefully be removed in JASPAR3
use TFBS::Matrix::PWM;
use TFBS::Matrix::PFM;
use TFBS::Matrix::ICM;
use TFBS::MatrixSet;
use Bio::Root::Root;
use DBI;
# use TFBS::DB; # eventually
use strict;
@ISA = qw(TFBS::DB Bio::Root::Root);
#########################################################################
# CONSTANTS
#########################################################################
use constant DEFAULT_CONNECTSTRING => "dbi:mysql:JASPAR_DEMO"; # on localhost
use constant DEFAULT_USER => "";
use constant DEFAULT_PASSWORD => "";
#########################################################################
# PUBLIC METHODS
#########################################################################
=head2 new
Title : new
Usage : DEPRECATED - for backward compatibility only
Use connect() or create() instead
=cut
sub new {
_new (@_);
}
=head2 connect
Title : connect
Usage : my $db =
TFBS::DB::JASPAR4->connect("dbi:mysql:DATABASENAME:HOSTNAME",
"USERNAME",
"PASSWORD");
Function: connects to the existing JASPAR4-type database and
returns a database object that interfaces the database
Returns : a TFBS::DB::JASPAR4 object
Args : a standard database connection triplet
("dbi:mysql:DATABASENAME:HOSTNAME", "USERNAME", "PASSWORD")
In place of DATABASENAME, HOSTNAME, USERNAME and PASSWORD,
use the actual values. PASSWORD and USERNAME might be
optional, depending on the user's acces permissions for
the database server.
=cut
sub connect {
# a more intuitive syntax for the constructor
my ($caller, @connection_args) = @_;
$caller->new(-connect => \@connection_args);
}
=head2 dbh
Title : dbh
Usage : my $dbh = $db->dbh();
$dbh->do("UPDATE matrix_data SET name='ADD1' WHERE NAME='SREBP2'");
Function: returns the DBI database handle of the MySQL database
interfaced by $db; THIS IS USED FOR WRITING NEW METHODS
FOR DIRECT RELATIONAL DATABASE MANIPULATION - if you
have write access AND do not know what you are doing,
you can severely corrupt the data
For documentation about database handle methods, see L
Returns : the database (DBI) handle of the MySQL JASPAR2-type
relational database associated with the TFBS::DB::JASPAR2
object
Args : none
=cut
sub dbh {
my ($self, $dbh) = @_;
$self->{'dbh'} = $dbh if $dbh;
return $self->{'dbh'};
}
=head2 store_Matrix
Title : store_Matrix
Usage : $db->store_Matrix($matrixobject);
Function: Stores the contents of a TFBS::Matrix::DB object in the database
Returns : 0 on success; $@ contents on failure
(this is too C-like and may change in future versions)
Args : (PFM_object)
A TFBS::Matrix::PFM, FBS::Matrix::PWM or FBS::Matrix::ICM object.
PFM object are recommended to use, as they are eaily converted to
other formats
Comment : this is an experimental method that is not 100% bulletproof;
use at your own risk
=cut
sub store_Matrix {
my ($self, @PFMs) = @_;
my $err;
foreach my $pfm (@PFMs) {
eval {
$self->_store_matrix_data($pfm);
$self->_store_matrix_info($pfm);
$self->_store_matrix_annotation($pfm);
#$self->_store_matrix_species($pfm);
};
}
return $@;
}
sub create {
my ($caller, $connectstring, $user, $password) = @_;
if ($connectstring
and $connectstring =~ /dbi:mysql:(\w+)(.*)/)
{
# connect to the server;
my $dbh=DBI->connect("dbi:mysql:mysql".$2,
$user,$password)
or die("Error connecting to the database");
# create database and open it
$dbh->do("create database $1")
or die("Error creating database.");
$dbh->do("use $1");
# create tables
_create_tables($dbh);
$dbh->disconnect;
# run "new" with new database
return $caller->new(-connect=>[$connectstring, $user, $password]);
}
else {
die("Missing or malformed connect string for ".
"TFBS::DB::JASPAR2 connection.");
}
}
=head2 get_Matrix_by_ID
Title : get_Matrix_by_ID
Usage : my $pfm = $db->get_Matrix_by_ID('M00034', 'PFM');
Function: fetches matrix data under the given ID from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on what form the matrix is stored
in the database (PFM is default)
Args : (Matrix_ID)
Matrix_ID is a string;
=cut
sub get_Matrix_by_ID {
my ($self, $ID, $mt) = @_;
$mt = (uc($mt) or "PWM");
unless (defined $ID) {
$self->throw("No ID passed to get_Matrix_by_ID");
}
my $matrixobj;
{
no strict 'refs';
my $ucmt = uc $mt;
my $matrixstring = $self->_get_matrixstring($ID) || return undef;
# get type of matrix
my $sth=$self->dbh->prepare(qq{SELECT type FROM MATRIX_INFO WHERE ID = '$ID'});
$sth->execute();
my $type=$sth->fetchrow_array();
# get reast of annotation as tags
$sth=$self->dbh->prepare(qq{SELECT tag, val FROM MATRIX_ANNOTATION WHERE ID = '$ID' });
$sth->execute();
my %tags;
while ( my($tag, $val)= $sth->fetchrow_array()){
$tags{$tag}=$val;
}
my $name= $tags{'name'};
my $class= $tags{'class'};
delete ($tags{'name'});
delete ($tags{'class'});
eval ("\$matrixobj= TFBS::Matrix::$type->new".'
( -ID => $ID."",
-name =>$name,
-class => $class,
-tags => \%tags,
-matrixstring=> $matrixstring # FIXME - temporary
);');
#if ($@) {$self->throw($@); }
#print "ref:",ref ($matrixobj);
}
# print $matrixobj->ID();
# print "here\n";print $matrixobj->prettyprint();
return ($matrixobj);
}
=head2 get_Matrix_by_name
Title : get_Matrix_by_name
Usage : my $pfm = $db->get_Matrix_by_name('HNF-1');
Function: fetches matrix data under the given name from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the object
depending on what form the matrix object was stored in
the database (default PFM))
Args : (Matrix_name)
Warning : According to the current JASPAR4 data model, name is
not necessarily a unique identifier. In the case where
there are several matrices with the same name in the
database, the function fetches the first one and prints
a warning on STDERR. You've been warned.
=cut
sub get_Matrix_by_name {
my ($self, $name, $mt) = @_;
unless(defined $name) {
$self->throw("No name passed to get_Matrix_by_name."); }
my @IDlist = $self->_get_IDlist_by_query(-name=>[$name]);
my $ID= ($IDlist[0]
or $self->warn("No matrix with name $name found."));
if ((my $L= scalar @IDlist) > 1) {
$self->warn("There are $L matrices with name '$name'");
}
return $self->get_Matrix_by_ID($ID);
}
=head2 get_MatrixSet
Title : get_MatrixSet
Usage : my $matrixset = $db->get_MatrixSet(%args);
Function: fetches matrix data under for all matrices in the database
matching criteria defined by the named arguments
and returns a TFBS::MatrixSet object
Returns : a TFBS::MatrixSet object
Args : This method accepts named arguments, corresponding to arbitrary tags.
Note that this is different from JASPAR2. As any tag is supported for
database storage, any tag can be used for information retrieval.
Additionally, arguments as 'name' and 'class' can be used (even though
they are not tags.
As with get_Matrix methods, it is important to realize that any matrix
format can be stored in the database: the TFBS::MatrixSet might therefore
consist of PFMs, ICMs and PWMS, depending on how matrices are stored,
Examples include
-ID # a reference to an array of IDs (strings)
-name # a reference to an array of
# transcription factor names (string)
-class # a reference to an array of
# structural class names (strings)
-species # a reference to an array of
# Latin species names (strings)
-sysgroup # a reference to an array of
# higher taxonomic categories (strings)
-min_ic # float, minimum total information content
# of the matrix. IMPORTANT:if retrieved matrices are in PWM
format there is no way to measureinformation content.
-matrixtype #string describing type of matrix to retrieve. If left out, the format
will revert to the database format. Note that this option only works
if the database format is pfm
The arguments that expect list references are used in database
query formulation: elements within lists are combined with 'OR'
operators, and the lists of different types with 'AND'. For example,
my $matrixset = $db->(-class => ['TRP_CLUSTER', 'FORKHEAD'],
-species => ['Homo sapiens', 'Mus musculus'],
);
gives a set of TFBS::Matrix::PFM objects (given that the matrix models are stored as such)
whose (structural clas is 'TRP_CLUSTER' OR'FORKHEAD') AND (the species they are derived
from is 'Homo sapiens'OR 'Mus musculus').
The -min_ic filter is applied after the query in the sense that the
matrices profiles with total information content less than specified
are not included in the set.
=cut
sub get_MatrixSet {
my ($self, %args) = @_;
my @IDlist = $self->_get_IDlist_by_query(%args);
my $type;
my $matrixset = TFBS::MatrixSet->new();
foreach (@IDlist) {
# print "$_\n";
}
foreach (@IDlist) {
#next if (defined $args{'-min_ic'}
# and $_->_get_total_ic($_) < $args{'-min_ic'});
#evaluate total information content: ivolves actually retrieving matrix
# is actually a problem if matrix is stored PWM: thro an error if so
my $matrix=$self->get_Matrix_by_ID($_);
#evaluate
#ugly code:
if (defined $args{'-min_ic'} ){
if ($matrix->isa("TFBS::Matrix::PFM")){
next if ( $matrix->to_ICM->total_ic() < $args{'-min_ic'});
}
if ($matrix->isa("TFBS::Matrix::ICM")){
next if ($matrix->total_ic() < $args{'-min_ic'});
}
if ($matrix->isa("TFBS::Matrix::PWM")){
$self->throw("Cannot evaluate information constent from PWM matrices");
}
}
#ugly code:
if ($args{'-matrixtype'} && $matrix->isa("TFBS::Matrix::PFM")){
if ( $args{'-matrixtype'} eq ('PWM')) {
# warn "change";
$matrix= $matrix->to_PWM();
}
if ( $args{'-matrixtype'} eq ('ICM')) {
#warn "change";
$matrix= $matrix->to_PWM();
}
}
$matrixset->add_Matrix($matrix);
}
return $matrixset;
}
sub store_MatrixSet {
$_[0]->throw ("Method store_MtrixSet not yet implemented.");
}
=head2 delete_Matrix_having_ID
Title : delete_Matrix_having_ID
Usage : $db->delete_Matrix_with_ID('M00045');
Function: Deletes the matrix having the given ID from the database
Returns : 0 on success; $@ contents on failure
(this is too C-like and may change in future versions)
Args : (ID)
A string
Comment : Yeah, yeah, 'delete_Matrix_having_ID' is a stupid name
for a method, but at least it should be obviuos what it does.
=cut
sub delete_Matrix_having_ID {
my ($self, @IDs) = @_;
eval {
foreach my $ID (@IDs) {
my $q_ID = $self->dbh->quote($ID);
foreach my $table (qw (MATRIX_DATA
MATRIX_INFO
MATRIX_ANNOTATION
)
)
{
$self->dbh->do("DELETE from $table where ID=$q_ID");
}
}
};
return $@;
}
#########################################################################
# PRIVATE METHODS
#########################################################################
sub _new {
my ($caller, %args) = @_;
my $class = ref $caller || $caller;
my $self = bless {}, $class;
my ($connectstring, $user, $password);
if ($args{'-connect'} and (ref($args{'-connect'}) eq "ARRAY")) {
($connectstring, $user, $password) = @{$args{'-connect'}};
}
elsif ($args{'-create'} and (ref($args{'-create'}) eq "ARRAY")) {
return $caller->create(@{-args{'create'}});
}
else {
($connectstring, $user, $password) =
(DEFAULT_CONNECTSTRING, DEFAULT_USER, DEFAULT_PASSWORD);
}
$self->dbh( DBI->connect($connectstring, $user, $password) );
return $self;
}
sub _store_matrix_data {
my ($self, $pfm, $ACTION) = @_;
my @base = qw(A C G T);
my $matrix = $pfm->matrix();
my $type;
my $sth = $self->dbh->prepare
(q! INSERT INTO MATRIX_DATA VALUES(?,?,?,?) !);
for my $i (0..3) {
for my $j (0..($pfm->length-1)) {
$sth->execute( $pfm->ID,
$base[$i],
$j+1,
$matrix->[$i][$j]
)
or $self->throw("Error executing query.");
}
}
}
sub _store_matrix_info {
my ($self, $pfm, $ACTION) = @_;
my $type;
$type= 'PFM' if $pfm->isa("TFBS::Matrix::PFM");
$type= 'PWM' if $pfm->isa("TFBS::Matrix::PWM");
$type= 'ICM' if $pfm->isa("TFBS::Matrix::ICM");
my $sth = $self->dbh->prepare
(q! INSERT INTO MATRIX_INFO
(ID, type)
VALUES(?,?) !);
$sth->execute($pfm->ID,
$type,
)
or $self->throw("Error executing query");
}
sub _store_matrix_annotation {
my ($self, $pfm, $ACTION) = @_;
my $sth = $self->dbh->prepare
(q! INSERT INTO MATRIX_ANNOTATION
(ID, tag, val)
VALUES(?,?,?) !);
$sth->execute($pfm->ID,
'name',
($pfm->name() or ""),
);
$sth->execute($pfm->ID,
'class',
($pfm->class() or ""),
);
# get all tags
my %tags= $pfm->all_tags();
foreach my $tag( keys %tags){
$sth->execute($pfm->ID,
$tag,
($tags{$tag} or ""),
)
or $self->throw("Error executing query");
}
}
#when creating: try to support arbitrary tags
sub _create_tables {
# utility function
# If you want to change the databse schema,
# this is the right place to do it
my $dbh = shift;
my @queries =
(
q!
CREATE TABLE MATRIX_DATA(
ID VARCHAR (16) DEFAULT '' NOT NULL,
row VARCHAR(1) NOT NULL,
col TINYINT(3) UNSIGNED NOT NULL,
val float(7,4),
PRIMARY KEY (ID, row, col)
)
!,
q!
CREATE TABLE MATRIX_INFO(
ID VARCHAR (16) DEFAULT '' NOT NULL PRIMARY KEY ,
type ENUM ('PFM', 'ICM','PWM') DEFAULT 'PFM' NOT NULL
)
!,
q!
CREATE TABLE MATRIX_ANNOTATION(
ID VARCHAR (16) DEFAULT '' NOT NULL,
tag VARCHAR(255)DEFAULT '' NOT NULL,
val varchar(255) DEFAULT '',
PRIMARY KEY (ID, tag)
)
!,
);
foreach my $query (@queries) {
$dbh->do($query)
or die("Error executing the query: $query\n");
}
}
sub _get_matrixstring {
my ($self, $ID) = @_;
#my %dbname = (PWM => 'pwm', PFM => 'raw', ICM => 'info');
#unless (defined $dbname{$mt}) {
#$self->throw("Unsupported matrix type: ".$mt);
#}
my $sth;
my $qID = $self->dbh->quote($ID);
my $matrixstring = "";
foreach my $base (qw(A C G T)) {
$sth=$self->dbh->prepare
("SELECT val FROM MATRIX_DATA
WHERE ID=$qID AND row='$base' ORDER BY col");
$sth->execute;
$matrixstring .=
join (" ", (map {$_->[0]} @{$sth->fetchall_arrayref()}))."\n";
}
$sth->finish;
return undef if $matrixstring eq "\n"x4;
return $matrixstring;
}
sub _get_IDlist_by_query {
# called by get_MatrixSet
# should be able to search for arbitrary tags...hmmm
my ($self, %args) = @_;
my ($TABLES, %arrayref);
my (%intersected_set);
foreach my $key(keys %args){
unless ( $key eq "-min_ic" or $key eq "-matrixtype"){
my $oldkey=$key;
$key=~s/-//;
$arrayref{$key}= $args{$oldkey};
}
}
my @andconditions;
$TABLES = 'MATRIX_ANNOTATION ';
#special case: get all matrices
unless (keys %arrayref){
my $query = "SELECT DISTINCT ID FROM $TABLES ";
my $sth = $self->dbh->prepare($query);
$sth->execute() or $self->throw("Query failed:\n$query\n");
my @ary;
while (my ($id) = $sth->fetchrow_array()) {
push (@ary, $id);
}
return(@ary);
}
foreach my $key (keys %arrayref) {
#print "key: $key\n";
if ($key eq 'ID'){
push @andconditions,
"(".
join(" OR ",
(map {"MATRIX_ANNOTATION.ID=".
$self->dbh->quote($_)
}
@{$arrayref{$key}}
)).
")";
}
else{
push @andconditions,
"(".
join(" OR ",
(map {"MATRIX_ANNOTATION.tag=". $self->dbh->quote($key)." AND val=".
$self->dbh->quote($_)
}
@{$arrayref{$key}}
)).
")";
}
push (@andconditions, 1) unless(@andconditions);
my $WHERE = ((scalar @andconditions) == 0) ? "" : " WHERE ";
my $query =
"SELECT DISTINCT ID FROM $TABLES $WHERE".
join(" AND ", @andconditions);
# warn $query;
undef @andconditions;
my $sth = $self->dbh->prepare($query);
$sth->execute() or $self->throw("Query failed:\n$query\n");
# collect IDs and return
my %current_query;
while (my ($id) = $sth->fetchrow_array()) {
$current_query{$id}=1;
}
unless (%intersected_set){
%intersected_set= %current_query;
next;
}
# do intersect
foreach my $key (keys %intersected_set){
delete $intersected_set{ $key} unless $current_query{$key};
}
}
my @ary;
foreach my $key (keys %intersected_set){
push (@ary, $key);
# warn "$key\n";
}
return (@ary);
}
sub DESTROY {
$_[0]->dbh->disconnect() if $_[0]->dbh;
}
TFBS-0.7.1/blib/lib/TFBS/DB/LocalTRANSFAC.pm 0000664 0000000 0000000 00000016724 13057522667 0017517 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::DB::LocalTRANSFAC
#
# Copyright Stephen Montgomery smontgom@bcgsc.bc.ca
#
# Contributors: Boris Lenhard, Leonardo Marino-Ramirez
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::DB::LocalTRANSFAC - interface to local transfac database
position frequency matrices (matrix.dat)
-------------------------------- NOTICE ----------------------------------
The TRANSFAC database is free for non-commercial use. For commercial use
the TRANSFAC databases and programs have to be licensed. Please read
the DISCLAIMER at http://transfac.gbf.de/TRANSFAC/disclaimer.htm.
-------------------------------------------------------------------------
=head1 SYNOPSIS
=over 4
=item * creating a database object by connecting to TRANSFAC data
my $db = TFBS::DB::LocalTRANSFAC->connect(-localdir => '/home/someusr');
localdir is the location of the matrix.dat TRANSFAC datafile
=item * retrieving a TFBS::Matrix::* object from the database
# retrieving a PFM by ID
my $pfm = $db->get_Matrix_by_ID('V$CEBPA_01','PFM');
#retrieving a PWM by TRANSFAC accession number
my $pwm = $db->get_Matrix_by_acc('M00116', 'PWM');
=back
=head1 DESCRIPTION
TFBS::DB::LocalTRANSFAC is a read only database interface that fetches
TRANSFAC matrix data from a local TRANSFAC install (matrix.dat)
=cut
package TFBS::DB::LocalTRANSFAC;
use vars qw(@ISA);
use strict;
use TFBS::DB::TRANSFAC;
use TFBS::Matrix::PFM;
@ISA = qw(TFBS::DB::TRANSFAC);
=head2 connect
Title : connect
Usage : my $db = TFBS::DB::TRANSFAC->connect(%args);
Function: Creates a TRANSFAC database connection object, which can be used
to retrieve matrices from a locally installed TRANSFAC database
Returns : a TFBS::DB::TRANSFAC object
Args : -localdir # REQUIRED: the directory of the matrix.dat TRANSFAC
# datafile. matrix.dat must have read access.
-accept_conditions # OPTIONAL: by setting this to a true
# value, you confirm that you
# have read and accepted the terms
# of use of TRANSFAC at
# http://transfac.gbf.de/TRANSFAC/disclaimer.htm;
# this also suppresses the annoying
# message that is printed to STDERR
# upon invoking the method
=cut
sub connect {
my ($caller, %args) = @_;
my $self = bless { 'loc' => $args{'-localdir'}}, ref $caller || $caller;
unless (defined ($args{-accept_conditions}) and $args{-accept_conditions}) {
print STDERR <connect(-accept_conditions => 1);
--------------------------------------------------------------------------
ENDNOTICE
;
}
unless (defined $args{-localdir}) {
$self->throw("Need directory of TRANSFAC database");
}
return $self;
}
=head2 get_Matrix_by_acc
Title : get_Matrix_by_acc
Usage : my $pfm = $db->get_Matrix_by_acc('V$CREB_01', 'PFM');
Function: fetches matrix data under the given TRANSFAC aaccession number
from database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on the second argument (allowed
values are 'PFM', 'ICM', and 'PWM'); returns undef if
matrix with the given ID is not found
Args : (Matrix_ID, Matrix_type)
Matrix_ID is a string; Matrix_type is one of the
following: 'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or 'PWM' (position
weight matrix)
If Matrix_type is omitted, a PFM is retrieved by default.
=cut
sub get_Matrix_by_acc {
my ($self, $acc, $mt) = @_;
unless (defined $acc) {
$self->throw("No parameters passed to get_Matrix_by_ID.");
}
my $datablock = _get_Matrix_Block ( 'acc' => $acc,
'loc' => $self->{'loc'});
return $self->_get_Matrix_by_Block($datablock, $mt);
}
=head2 get_Matrix_by_ID
Title : get_Matrix_by_ID
Usage : my $pfm = $db->get_Matrix_by_ID('V$CREB_01', 'PFM');
Function: fetches matrix data under the given TRANSFAC ID from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on the second argument (allowed
values are 'PFM', 'ICM', and 'PWM'); returns undef if
matrix with the given ID is not found
Args : (Matrix_ID, Matrix_type)
Matrix_ID is a string; Matrix_type is one of the
following: 'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or 'PWM' (position
weight matrix)
If Matrix_type is omitted, a PFM is retrieved by default.
=cut
sub get_Matrix_by_ID {
my ($self, $ID, $mt) = @_;
unless (defined $ID) {
$self->throw("No parameters passed to get_Matrix_by_ID.");
}
my $datablock = _get_Matrix_Block ( 'ID' => $ID,
'loc' => $self->{'loc'});
return $self->_get_Matrix_by_Block($datablock, $mt);
}
sub _get_Matrix_Block {
my %params = @_;
my $loc = $params{'loc'};
my $acc = $params{'acc'};
my $ID = $params{'ID'};
$loc = $loc . "/matrix.dat";
open(HANDLE, $loc) || die ("File opening failed for matrix.dat: Check file permissions");
my @raw_data=;
my @block = ();
my $hit = 0;
foreach my $line (@raw_data)
{
if ($line eq "//\n")
{
foreach my $lineinblock (@block)
{
if (defined $ID) {
if ($lineinblock eq "ID $ID\n") { $hit = 1 };
}
if (defined $acc) {
if ($lineinblock eq "AC $acc\n") { $hit = 1 };
}
}
if ($hit == 0) { @block = (); }
}
if ($hit == 0) { push @block, $line; }
}
close(HANDLE);
return \@block;
}
sub _get_Matrix_by_Block {
my ($self, $datablock, $mt) = @_;
my @datalines = @$datablock;
my (@As, @Cs, @Gs, @Ts, $name, $ID, $acc);
foreach my $line (@datalines)
{
if ($line =~ /NA\s+(\S+)\n/) {
$name = $1;
}
if ($line =~ /ID\s+(\S+)\n/) {
$ID = $1;
}
if ($line =~ /AC\s+(\S+)\n/) {
$acc = $1;
}
#if ($line =~ /\d{2}\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\n/) {
# change to allow for both older and newer file format
# contributed by Leonardo Marino-Ramirez:
# Updated 2003-09-05 to enable parsing of non-integer entries
if ($line =~ /^\d{2}\s+(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*).*$/) {
push @As, $1;
push @Cs, $2;
push @Gs, $3;
push @Ts, $4;
}
}
return undef unless @As;
my $pfm = TFBS::Matrix::PFM-> new ( -ID => $ID,
-name => $name,
-tags => {acc=>$acc},
-matrix => [ \@As, \@Cs, \@Gs, \@Ts]
);
if (!defined($mt) or uc($mt) eq "PFM") {return $pfm;}
elsif (uc($mt) eq "ICM") {return $pfm->to_ICM;}
elsif (uc($mt) eq "PWM") {return $pfm->to_PWM;}
else { $self->throw("Unrecognized matrix format: $mt"); }
}
1;
TFBS-0.7.1/blib/lib/TFBS/DB/TRANSFAC.pm 0000664 0000000 0000000 00000016531 13057522667 0016540 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::DB::TRANSFAC
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::DB::TRANSFAC - interface to database of TRANSFAC public
position frequency matrices at TESS (http://www.cbil.upenn.edu/tess)
-------------------------------- NOTICE ----------------------------------
The TRANSFAC database is free for non-commercial use. For commercial use
the TRANSFAC databases and programs have to be licensed. Please read
the DISCLAIMER at http://transfac.gbf.de/TRANSFAC/disclaimer.htm.
-------------------------------------------------------------------------
=head1 SYNOPSIS
=over 4
=item * creating a database object by connecting to TRANSFAC data
my $db = TFBS::DB::TRANSFAC->connect();
=item * retrieving a TFBS::Matrix::* object from the database
# retrieving a PFM by ID
my $pfm = $db->get_Matrix_by_ID('V$CEBPA_01','PFM');
#retrieving a PWM by TRANSFAC accession number
my $pwm = $db->get_Matrix_by_acc('M00116', 'PWM');
=back
=head1 DESCRIPTION
TFBS::DB::TRANSFAC is a read only database interface that fetches
TRANSFAC matrix data from TESS web interface
(http://www.cbil.upen.edu/TESS) and returns TFBS::Matrix::* objects.
=cut
package TFBS::DB::TRANSFAC;
use vars qw(@ISA $ua);
use strict;
use Bio::Root::Root;
use TFBS::Matrix::PFM;
use LWP::Simple qw($ua get);
@ISA = qw(TFBS::DB Bio::Root::Root);
=head2 connect
Title : connect
Usage : my $db = TFBS::DB::TRANSFAC->connect(%args);
Function: Creates a TRANSFAC database connection object, which can be used
to retrieve matrices from public TRANSFAC databases via the web
Returns : a TFBS::DB::TRANSFAC object
Args : -proxy # OPTIONAL: a http proxy server name,
# usually required for accessing TRANSFAC from behind
# a firewall
-accept_conditions # OPTIONAL: by setting this to a true
# value, you confirm that you
# have read and accepted the terms
# of use of TRANSFAC at
# http://transfac.gbf.de/TRANSFAC/disclaimer.htm;
# this also suppresses the annoying
# message that is printed to STDERR
# upon invoking the method
=cut
sub connect {
my ($caller, %args) = @_;
my $self = bless {}, ref $caller || $caller;
unless (defined ($args{-accept_conditions}) and $args{-accept_conditions}) {
print STDERR <connect(-accept_conditions => 1);
--------------------------------------------------------------------------
ENDNOTICE
;
}
if (defined $args{'-proxy'}) {
$ua->proxy('http',$args{'-proxy'});
}
return $self;
}
=head2 new
Title : connect
Usage : my $db = TFBS::DB::TRANSFAC->connect(%args);
Function: Here, I is just a synonim for I
(to make the interface consistent with other
bioperl read-obly Bio::DB::* objects)
Returns : a TFBS::DB::TRANSFAC object
Args : -accept_conditions # see explanation at I
=cut
sub new {
my ($caller, %args) = @_;
$caller->connect(%args);
}
=head2 get_Matrix_by_ID
Title : get_Matrix_by_ID
Usage : my $pfm = $db->get_Matrix_by_ID('V$CREB_01', 'PFM');
Function: fetches matrix data under the given TRANSFAC ID from the
database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on the second argument (allowed
values are 'PFM', 'ICM', and 'PWM'); returns undef if
matrix with the given ID is not found
Args : (Matrix_ID, Matrix_type)
Matrix_ID is a string; Matrix_type is one of the
following: 'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or 'PWM' (position
weight matrix)
If Matrix_type is omitted, a PFM is retrieved by default.
=cut
sub get_Matrix_by_ID {
my ($self, $ID, $mt) = @_;
unless (defined $ID) {
$self->throw("No parameters passed to get_Matrix_by_ID.");
}
my $url = "http://www.cbil.upenn.edu/cgi-bin/tess/tess33?request=MTX-DBRTRV-Id&key=$ID";
# my $url = "http://www.cbil.upenn.edu/cgi-bin/tess/tess33?request=MTX-DBRTRV-Id&key=$ID";
return $self->_get_Matrix_by_URL($url, $mt);
}
=head2 get_Matrix_by_acc
Title : get_Matrix_by_acc
Usage : my $pfm = $db->get_Matrix_by_acc('V$CREB_01', 'PFM');
Function: fetches matrix data under the given TRANSFAC aaccession number
from database and returns a TFBS::Matrix::* object
Returns : a TFBS::Matrix::* object; the exact type of the
object depending on the second argument (allowed
values are 'PFM', 'ICM', and 'PWM'); returns undef if
matrix with the given ID is not found
Args : (Matrix_ID, Matrix_type)
Matrix_ID is a string; Matrix_type is one of the
following: 'PFM' (raw position frequency matrix),
'ICM' (information content matrix) or 'PWM' (position
weight matrix)
If Matrix_type is omitted, a PFM is retrieved by default.
=cut
sub get_Matrix_by_acc {
my ($self, $acc, $mt) = @_;
unless (defined $acc) {
$self->throw("No parameters passed to get_Matrix_by_ID.");
}
my $url = "http://www.cbil.upenn.edu/cgi-bin/tess/tess33?request=MTX-DBRTRV-Accno&key=$acc";
return $self->_get_Matrix_by_URL($url, $mt);
}
sub get_MatrixSet {
my ($self, %args) = @_;
# not yet implemented
}
sub _get_Matrix_by_URL {
my ($self, $url, $mt) = @_;
my $HTMLpage = get $url || return undef;
my (@As, @Cs, @Gs, @Ts, $name, $ID, $acc);
my @lines = split "\n", $HTMLpage;
foreach my $line (@lines) {
$line =~ s/\r//;
$line =~ s/<\/{0,1}b>//gi;
$line =~ s/ //gi;
if ($line =~ /Name<\/td>| ([^<]+) | ([^<]+) | ([^<]+) new ( -ID => $ID,
-name => $name,
-tags => {acc=>$acc},
-matrix => [ \@As, \@Cs, \@Gs, \@Ts]
);
if (!defined($mt) or uc($mt) eq "PFM") {return $pfm;}
elsif (uc($mt) eq "ICM") {return $pfm->to_ICM;}
elsif (uc($mt) eq "PWM") {return $pfm->to_PWM;}
else { $self->throw("Unrecognized matrix format: $mt"); }
}
1;
TFBS-0.7.1/blib/lib/TFBS/Ext/ 0000775 0000000 0000000 00000000000 13057522667 0015246 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/TFBS/Ext/.exists 0000664 0000000 0000000 00000000000 13057522667 0016554 0 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/TFBS/Ext/pwmsearch.pm 0000664 0000000 0000000 00000007330 13057522667 0017600 0 ustar 00root root 0000000 0000000 package TFBS::Ext::pwmsearch;
require 5.005_62;
use strict;
use warnings;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
use Bio::SeqIO;
use File::Temp qw (:POSIX);
require Exporter;
require DynaLoader;
our @ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
# This allows declaration use TFBS::Ext::pwmsearch ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
%EXPORT_TAGS = ( 'all' => [ qw(
) ] );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
@EXPORT = qw(
);
$VERSION = '0.2';
bootstrap TFBS::Ext::pwmsearch $VERSION;
# Preloaded methods go here.
sub pwmsearch {
my ($matrixobj, $seqobj, $threshold, $start, $end) = @_;
$start = 1 if !defined($start);
$end = $seqobj->length if !defined($end);
my $matrixfile = tmpnam();
open (MATRIX, ">$matrixfile") or die ("Error opening temporary file.");
print MATRIX $matrixobj->rawprint();
close MATRIX;
my $outfile = tmpnam();
# pwm_search is confused by long descriptions - we delete desc temporarily:
my $save_desc = $seqobj->desc();
$seqobj->desc("");
my $seqfile;
if ($seqobj->{_fastafile}) {
$seqfile = $seqobj->{_fastafile};
}
else {
$seqfile = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$seqfile", -format=>"fasta");
$outstream->write_seq(Bio::Seq->new(-seq =>$seqobj->subseq($start, $end),
-id =>$seqobj->id));
$outstream->close();
}
$seqobj->desc($save_desc);
# calculate threshold
if ($threshold) {
if ($threshold =~ /(.+)%/) {
# percentage
$threshold = $matrixobj->{min_score} +
($matrixobj->{max_score} - $matrixobj->{min_score})* $1/100;
}
else {
# absolute value
# $threshold = $args{-threshold};
}
}
else {
# no threshold given
$threshold = $matrixobj->{min_score} -1;
}
search_xs($matrixfile, $seqfile,
$threshold, $matrixobj->name()."",
$matrixobj->{'class'}."", $outfile);
unlink $seqfile unless $seqobj->{'_fastafile'};
unlink $matrixfile;
my $hitlist = TFBS::SiteSet->new();
my ($TFname, $TFclass) = ($matrixobj->{name}, $matrixobj->{class});
my $save_delim = $/; # bugfix submitted
local $/ = "\n"; # by Michal Lapidot
open (OUTFILE, $outfile)
or die("Could not read temporary outfile");
while (my $line = ) {
# print STDERR $line;
chomp $line;
$line =~ s/^\s+//;
$line =~ s/ *\t */\t/g;
my ($seq_id, $factor, $class, $strand, $score, $pos, $siteseq) =
(split /\t/, $line)[0, 2, 3, 4, 5, 7, 9];
my $num_strand = ($strand eq "-")? "-1" : "1";
my $site = TFBS::Site->new ( -seq_id => $seqobj->display_id()."",
-seqobj => $seqobj,
-strand => $num_strand."",
-pattern => $matrixobj,
-siteseq => $siteseq."",
-score => $score."",
-start => $pos +$start -1,
-end => $pos +$start
+length($siteseq) -2
);
$hitlist->add_site($site);
}
close OUTFILE;
$/ = $save_delim;
unlink $outfile;
return $hitlist;
}
1;
__END__
=head1 NAME
TFBS::Ext::pwmsearch - Perl extension for scanning a DNA sequence object with a position weight matrix
=head1 SYNOPSIS
use TFBS::Ext::pwmsearch;
pwmsearch
=head1 DESCRIPTION
Stub documentation for TFBS::Ext::pwmsearch, created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.
Blah blah blah.
=head2 EXPORT
None by default.
=head1 AUTHOR
A. U. Thor, a.u.thor@a.galaxy.far.far.away
=head1 SEE ALSO
perl(1).
=cut
TFBS-0.7.1/blib/lib/TFBS/Matrix.pm 0000664 0000000 0000000 00000017440 13057522667 0016316 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix - base class for matrix patterns, containing methods common
to all
=head1 DESCRIPTION
TFBS::Matrix is a base class consisting of universal constructor called by
its subclasses (TFBS::Matrix::*), and matrix manipulation methods that are
independent of the matrix type. It is not meant to be instantiated itself.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Matrix;
use vars '@ISA';
use PDL; # this dependency has to be eliminated in the future versions
use TFBS::PatternI;
use strict;
@ISA = qw(TFBS::PatternI);
sub new {
my $class = shift;
my %args = @_;
my $self = bless {}, ref($class) || $class;
# first figure out how it was called
# we need (-dbh and (-ID or -name) for fetching it from a database
# or -matrix for direct matrix input
if (defined $args{'-matrix'}) {
$self->set_matrix($args{'-matrix'});
}
elsif (defined $args{'-matrixstring'}) {
$self->set_matrix($args{'-matrixstring'});
}
elsif (defined $args{-matrixfile}) {
my $matrixstring;
open (FILE, $args{-matrixfile})
or $self->throw("Could not open $args{-matrixfile}");
{
local $/ = undef;
$matrixstring = ;
}
$self->set_matrix($matrixstring);
}
else {
$self->throw("No matrix or db object provided.");
}
# Set the object data.
# Parameters specified in constructor call override those
# fetched from the database.
$self->{'ID'} = ($args{-ID} or
$self->{ID} or
"Unknown");
$self->{'name'} = ($args{-name} or
$self->{name} or
"Unknown");
$self->{'class'} = ($args{-class} or
$self->{class} or
"Unknown");
$self->{'strand'} = ($args{-strand} or
$self->{strand} or
"+");
$self->{'bg_probabilities'} =
($args{'-bg_probabilities'} || {A => 0.25,
C => 0.25,
G => 0.25,
T => 0.25});
$self->{'tags'} = $args{-tags} ? ((ref($args{-tags}) eq "HASH") ? $args{-tags} : {} ) :{};
return $self;
}
=head2 matrix
Title : matrix
Usage : my $matrix = $pwm->matrix();
$pwm->matrix( [ [12, 3, 0, 0, 4, 0],
[ 0, 0, 0,11, 7, 0],
[ 0, 9,12, 0, 0, 0],
[ 0, 0, 0, 1, 1,12]
]);
Function: get/set for the matrix data
Returns : a reference to 2D array of integers(PFM) or floats (ICM, PWM)
Args : none for get;
a four line string, reference to 2D array, or a 2D piddle for set
=cut
sub matrix {
my ($self, $matrixdata) = @_;
$self->set_matrix($matrixdata) if $matrixdata;
return $self->{'matrix'};
}
=head2 pdl_matrix
Title : pdl_matrix
Usage : my $pdl = $pwm->pdl_matrix();
Function: access the PDL matrix used to store the actual
matrix data directly
Returns : a PDL object, aka a piddle
Args : none
=cut
sub pdl_matrix {
pdl $_[0]->{'matrix'};
}
sub set_matrix {
my ($self, $matrixdata) = @_;
# The input matrix (specified as -array=> in the constructir call
# can either be
# * a 2D regular perl array with 4 rows,
# * a piddle (FIXME - check for 4 rows), or
# * a four-line string of numbers
# print STDERR "MATRIX>>>".$matrixdata;
if (ref($matrixdata) eq "ARRAY"
and ref($matrixdata->[0]) eq "ARRAY"
and scalar(@{$matrixdata}) == 4)
{
# it is a perl array
$self->{'matrix'} = $matrixdata;
}
elsif (ref($matrixdata) eq "PDL")
{
# it's a piddle
$self->{matrix} = _pdl_to_matrixref($matrixdata);
}
elsif (!ref($matrixdata))
#and (scalar split "\n",$matrixdata) == 4)
{
# it's a string then
$self->{matrix} = $self->_matrix_from_string($matrixdata);
}
else {
$self->throw("Wrong data type/format for -matrix.\n".
"Acceptable formats are Array of Arrays (4 rows),\n".
"PDL Array, (4 rows),\n".
"or plain string (4 lines).");
}
# $self->_set_min_max_score();
return 1;
}
sub _matrix_from_string {
my ($self, $matrixstring) = @_;
my @array = ();
foreach ((split "\n", $matrixstring)[0..3]) {
s/^\s+//;
s/\s+$//;
push @array, [split];
}
return \@array;
}
sub _set_min_max_score {
my ($self) = @_;
my $transpose = $self->pdl_matrix->xchg(0,1);
$self->{min_score} = sum(minimum $transpose);
$self->{max_score} = sum(maximum $transpose);
}
sub _load {
my ($self, $field, $value) = @_;
if (substr(ref($self->{db}),0,5) eq "DBI::") {
# database retrieval
}
elsif (-d $self->{dbh}) {
# retrieval from .pwm files in a directory
$self->_lookup_in_matrixlist($field, $value)
or do {
warn ("Matrix with $field=>$value not found.");
return undef;
};
my $ID = $self->{ID};
my $DIR = $self->{dbh};
$self->set_matrix(scalar `cat $DIR/$ID.pwm`); # FIXME - temporary
}
else {
$self->throw("-dbh is not a valid database handle or a directory.");
}
}
=head2 revcom
Title : revcom
Usage : my $revcom_pfm = $pfm->revcom();
Function: create a matrix pattern object which is reverse complement
of the current one
Returns : a TFBS::Matrix::* object of the same type as the one
the method acted upon
Args : none
=cut
sub revcom {
my ($self) = @_;
my $revcom_matrix =
$self->new(-matrix => $self->pdl_matrix->slice('-1:0,-1:0'),
# the above line rotates the original matrix 180 deg,
-ID => ($self->{ID} or ""),
-name => ($self->{name} or ""),
-class => ($self->{class} or ""),
-strand => ($self->{strand} and $self->{strand} eq "-") ? "+" : "-",
-tags => ($self->{tags} or {}) );
return $revcom_matrix;
}
=head2 rawprint
Title : rawprint
Usage : my $rawstring = $pfm->rawprint);
Function: convert matrix data to a simple tab-separated format
Returns : a four-line string of tab-separated integers or floats
Args : none
=cut
sub rawprint {
my $self = shift;
my $pwmstring = sprintf ( $self->pdl_matrix );
$pwmstring =~ s/\[|\]//g; # lose []
$pwmstring =~ s/\n /\n/g; # lose leading spaces
my @pwmlines = split("\n", $pwmstring); # f
$pwmstring = join ("\n", @pwmlines[2..5])."\n";
return $pwmstring;
}
=head2 prettyprint
Title : prettyprint
Usage : my $prettystring = $pfm->prettyprint();
Function: convert matrix data to a human-readable string format
Returns : a four-line string with nucleotides and aligned numbers
Args : none
=cut
sub prettyprint {
my $self = shift;
my $pwmstring = sprintf ( $self->pdl_matrix );
$pwmstring =~ s/\[|\]//g; # lose []
$pwmstring =~ s/\n /\n/g; # lose leading spaces
my @pwmlines = split("\n", $pwmstring); #
@pwmlines = ("A [$pwmlines[2] ]",
"C [$pwmlines[3] ]",
"G [$pwmlines[4] ]",
"T [$pwmlines[5] ]");
$pwmstring = join ("\n", @pwmlines)."\n";
return $pwmstring;
}
=head2 length
Title : length
Usage : my $pattern_length = $pfm->length;
Function: gets the pattern length in nucleotides
(i.e. number of columns in the matrix)
Returns : an integer
Args : none
=cut
sub length {
my $self = shift;
return $self->pdl_matrix->getdim(0);
}
sub _pdl_to_matrixref {
my ($matrixdata) = @_;
unless ($matrixdata->isa("PDL")) {
die "A non-PDL object passed to _pdl_to_matrixref";
}
my @list = list $matrixdata;
my @array;
my $matrix_width = scalar(@list) / 4;
for (0..3) {
push @array, [splice(@list, 0, $matrix_width)];
}
return \@array;
}
sub DESTROY {
# nothing
}
1;
TFBS-0.7.1/blib/lib/TFBS/Matrix/ 0000775 0000000 0000000 00000000000 13057522667 0015752 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/TFBS/Matrix/ICM.pm 0000664 0000000 0000000 00000052770 13057522667 0016733 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::ICM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::ICM - class for information content matrices of nucleotide
patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::ICM object manually:
my $matrixref = [ [ 0.00, 0.30, 0.00, 0.00, 0.24, 0.00 ],
[ 0.00, 0.00, 0.00, 1.45, 0.42, 0.00 ],
[ 0.00, 0.89, 2.00, 0.00, 0.00, 0.00 ],
[ 0.00, 0.00, 0.00, 0.13, 0.06, 2.00 ]
];
my $icm = TFBS::Matrix::ICM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring = <new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::ICM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and retrieve
TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pfm = $db_obj->get_Matrix_by_ID("M0001", "ICM");
# or
my $pfm = $db_obj->get_Matrix_by_name("MyProfile", "ICM");
=item * retrieving list of individual TFBS::Matrix::ICM objects
from a TFBS::MatrixSet object
(see decumentation of TFBS::MatrixSet to learn how to create
objects for storage and manipulation of multiple matrices)
my @icm_list = $matrixset->all_patterns(-sort_by=>"name");
* drawing a sequence logo
$icm->draw_logo(-file=>"logo.png",
-full_scale =>2.25,
-xsize=>500,
-ysize =>250,
-graph_title=>"C/EBPalpha binding site logo",
-x_title=>"position",
-y_title=>"bits");
=back
=head1 DESCRIPTION
TFBS::Matrix::ICM is a class whose instances are objects representing
position weight matrices (PFMs). An ICM is normally calculated from a
raw position frequency matrix (see L
for the explanation of position frequency matrices). For example, given
the following position frequency matrix,
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
the standard computational procedure is applied to convert it into the
following information content matrix:
A:[2.00 0.30 0.00 0.00 0.24 0.00]
C:[0.00 0.00 0.00 1.45 0.42 0.00]
G:[0.00 0.89 2.00 0.00 0.00 0.00]
T:[0.00 0.00 0.00 0.13 0.06 2.00]
which contains the "weights" associated with the occurrence of each
nucleotide at the given position in a pattern.
A TFBS::Matrix::PWM object is equipped with methods to search nucleotide
sequences and pairwise alignments of nucleotide sequences with the
pattern they represent, and return a set of sites in nucleotide
sequence (a TFBS::SiteSet object for single sequence search, and a
TFBS::SitePairSet for the alignment search).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code starts HERE:
package TFBS::Matrix::ICM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::SeqIO;
use TFBS::Matrix;
#use GD;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
#################################################################
# PUBLIC METHODS
#################################################################
=head2 new
Title : new
Usage : my $icm = TFBS::Matrix::ICM->new(%args)
Function: constructor for the TFBS::Matrix::ICM object
Returns : a new TFBS::Matrix::ICM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"ICM");
my $self = bless $matrix, ref($class) || $class;
$self->_check_ic_validity();
return $self;
}
=head2 to_PWM
Title : to_PWM
Usage : my $pwm = $icm->to_PWM()
Function: converts an information content matrix (a TFBS::Matrix::ICM object)
to position weight matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::PWM object
Args : none; in the future releases, it should be able to accept
a user defined background probability of the four
nucleotides
=cut
sub to_PWM {
my ($self) = @_;
$self->throw ("Method to_PWM not yet implemented.");
}
=head2 draw_logo
Title : draw_logo
Usage : my $gdImageObj = $icm->draw_logo(%args)
Function: Draws a "sequence logo", a graphical representation
of a possibly degenerate fixed-width nucleotide
sequence pattern, from the information content matrix
Returns : a GD::Image object;
if you only need the image file you can ignore it
Args : -file, # the name of the output PNG image file
# OPTIONAL: default none
-xsize # width of the image in pixels
# OPTIONAL: default 600
-ysize # height of the image in pixels
# OPTIONAL: default 5/8 of -x_size
-margin # size of image margins in pixels
# OPTIONAL: default 15% of -y_size
-full_scale # the maximum value on the y-axis, in bits
# OPTIONAL: default 2.25
-graph_title,# the graph title
# OPTIONAL: default none
-x_title, # x-axis title; OPTIONAL: default none
-y_title # y-axis title; OPTIONAL: default none
-error_bars # reference to an array of S.D. values for each column; OPTIONAL
-ps # if true, produces a postscript string instead of a GD::Image object
-pdf # if true AND the -file argumant is used, produces an output pdf file
=cut
sub draw_logo {
no strict;
my $self = shift;
my %args = (-xsize => 600,
-full_scale => 2.25,
-graph_title=> "",
-x_title => "",
-y_title => "",
@_);
# Other parameters that can be specified:
# -ysize -line_width -margin
# do not have a fixed default value
# - they are calculated from xsize if not specified
# draw postscript logo if asked for
if ($args{'-ps'} || $args{'-pdf'}){
return _draw_ps_logo($self, @_);
}
require GD;
my ($xsize,$FULL_SCALE, $x_title, $y_title)
= @args{qw(-xsize -full_scale -x_title y_title)} ;
my $PER_PIXEL_LINE = 300;
# calculate other parameters if not specified
my $line_width = ($args{-line_width} or int ($xsize/$PER_PIXEL_LINE) or 1);
my $ysize = ($args{-ysize} or $xsize/1.6);
# remark (the line above): 1.6 is a standard screen x:y ratio
my $margin = ($args{-margin} or $ysize*0.15);
my $image = GD::Image->new($xsize, $ysize);
my $white = $image->colorAllocate(255,255,255);
my $black = $image->colorAllocate(0,0,0);
my $motif_size = $self->pdl_matrix->getdim(0);
my $font = ((&GD::gdTinyFont(), &GD::gdSmallFont(), &GD::gdMediumBoldFont(),
&GD::gdLargeFont(), &GD::gdGiantFont())[int(($ysize-50)/100)]
or &GD::gdGiantFont());
my $title_font = ((&GD::gdSmallFont(), &GD::gdMediumBoldFont(),
&GD::gdLargeFont(), &GD::gdGiantFont())[int(($ysize-50)/100)]
or &GD::gdGiantFont());
# WRITE LABELS AND TITLE
# graph title #&GD::Font::MediumBold
$image->string($title_font,
$xsize/2-length($args{-graph_title})* $title_font->width() /2,
$margin/2 - $title_font->height()/2,
$args{-graph_title}, $black);
# x_title
$image->string($font,
$xsize/2-length($args{-x_title})*$font->width()/2,
$ysize-( $margin - $font->height()*0 - 5*$line_width)/2
- $font->height()/2*0,
$args{-x_title},
$black);
# y_title
$image->stringUp($font,
($margin -$font->width()- 5*$line_width)/2
- $font->height()/2 ,
$ysize/2+length($args{'-y_title'})*$font->width()/2,
$args{'-y_title'}, $black);
# DRAW AXES
# vertical: (top left to bottom right)
$image->filledRectangle($margin-$line_width, $margin-$line_width,
$margin-1, $ysize-$margin+$line_width,
$black);
# horizontal: (ditto)
$image->filledRectangle($margin-$line_width, $ysize-$margin+1,
$xsize-$margin+$line_width,$ysize-$margin+$line_width,
$black);
# DRAW VERTICAL TICKS AND LABELS
# vertical axis (IC 1 and 2)
my $ic_1 = ($ysize - 2* $margin) / $FULL_SCALE;
foreach my $i (1..$FULL_SCALE) {
$image->filledRectangle($margin-3*$line_width,
$ysize-$margin - $i*$ic_1,
$margin-1,
$ysize-$margin+$line_width - $i*$ic_1,
$black);
$image->string($font,
$margin-5*$line_width - $font->width,
$ysize - $margin - $i*$ic_1 - $font->height()/2,
$i,
$black);
}
# DRAW HORIZONTAL TICKS AND LABELS, AND THE LOGO ITSELF
# define function refs as hash elements
my %draw_letter = ( A => \&draw_A,
C => \&draw_C,
G => \&draw_G,
T => \&draw_T );
my $horiz_step = ($xsize -2*$margin) / $motif_size;
foreach my $i (0..$motif_size) {
$image->filledRectangle($margin + $i*$horiz_step,
$ysize-$margin+1,
$margin + $i*$horiz_step+ $line_width,
$ysize-$margin+3*$line_width,
$black);
last if $i==$motif_size;
# get the $i-th column of matrix
my %ic;
($ic{A}, $ic{C}, $ic{G}, $ic{T}) = list $self->pdl_matrix->slice($i);
# sort nucleotides by increasing information content
my @draw_order = sort {$ic{$a}<=>$ic{$b}} qw(A C G T);
# draw logo column
my $xlettersize = $horiz_step /1.1;
my $ybottom = $ysize - $margin;
foreach my $base (@draw_order) {
my $ylettersize = int($ic{$base}*$ic_1 +0.5);
next if $ylettersize ==0;
# draw letter
$draw_letter{$base}->($image,
$margin + $i*$horiz_step,
$ybottom - $ylettersize,
$xlettersize, $ylettersize, $white);
$ybottom = $ybottom - $ylettersize-1;
}
if ($args{'-error_bars'} and ref($args{'-error_bars'}) eq "ARRAY") {
my $sd_pix = int($args{'-error_bars'}->[$i]*$ic_1);
my $yt = $ybottom - $sd_pix+1;
my $yb = $ybottom + $sd_pix-1;
my $xpos = $margin + ($i+0.45)*$horiz_step;
my $half_width;
if ($yb > $ysize-$margin+$line_width) {
$yb = $ysize-$margin+$line_width
}
else {
$image->line($xpos - $xlettersize/8, $yb,
$xpos + $xlettersize/8, $yb,
$black);
}
$image->line($xpos, $yt, $xpos, $yb, $black);
$image->line($xpos - 1 , $ybottom, $xpos+1, $ybottom, $black);
$image->line($xpos - $xlettersize/8, $yt,
$xpos + $xlettersize/8, $yt,
$black);
}
# print position number on x axis
$image->string($font,
$margin + ($i+0.5)*$horiz_step - $font->width()/2,
$ysize - $margin +5*$line_width,
$i+1,
$black);
}
# print $args{-file};
if ($args{-file}) {
open (PNGFILE, ">".$args{-file})
or $self->throw("Could not write to ".$args{-file});
print PNGFILE $image->png;
close PNGFILE;
}
return $image;
}
sub total_ic {
return $_[0]->pdl_matrix->sum();
}
=head2 _draw_ps_logo
Title : _draw_ps_logo
Usage : my $postscript_string = $icm->_draw_ps_logo(%args)
Internal method, should be accessed using draw_logo()
Function: Draws a "sequence logo", a graphical representation
of a possibly degenerate fixed-width nucleotide
sequence pattern, from the information content matrix
Returns : a postscript string;
if you only need the image file you can ignore it
Args : -file, # the name of the output PNG image file
# OPTIONAL: default none
-xsize # width of the image in pixels
# OPTIONAL: default 600
-ysize # height of the image in pixels
# OPTIONAL: default 5/8 of -x_size
-full_scale # the maximum value on the y-axis, in bits
# OPTIONAL: default 2.25
-graph_title,# the graph title
# OPTIONAL: default none
-x_title, # x-axis title; OPTIONAL: default none
-y_title # y-axis title; OPTIONAL: default none
=cut
sub _draw_ps_logo{
my $self = shift;
my %args = (-xsize => 600,
-full_scale => 2.25,
-graph_title=> "",
-x_title => "",
-y_title => "",
@_);
my $xsize= $args{'-xsize'};
my $max_ysize= $args{'-ysize'} ||int 5* $args{'-xsize'}/8;
my $ysize= $max_ysize*($args{'-full_scale'}-($args{'-full_scale'}-2))/$args{'-full_scale'};
my $x=100; # nternal, for placement on 'paper'
my $y=100;
my $out= "%!PS-Adobe-2.0
%%Orientation: Portrait
%%Pages: 1
%%BoundingBox: 0 0 ".($args{'-xsize'}*1.2)." ".( $max_ysize*1.5)."
%%BeginSetup
%%EndSetup
%%Magnification: 1.0000
%%EndProlog
%%end
%%save
gsave\n";
#colors and correction definitions
my %color;
$color{'black'}="0.000 0.000 0.000 setrgbcolor";
$color{'A'}="0.000 1.000 0.000 setrgbcolor";
$color{'C'}="0.000 0.000 1.000 setrgbcolor";
$color{'G'}="1.000 0.860 0.000 setrgbcolor";
$color{'T'}="1.000 0.000 0.000 setrgbcolor";
my $fontsize= int $ysize*0.68;
my $fontwidth=1.5*($xsize/$self->length());
my %w_correct; # correction of font widths
$w_correct{'A'}=0.95;
$w_correct{'T'}=1.05;
$w_correct{'C'}=0.90;
$w_correct{'G'}=0.90;
my %y_next;#correction of font heights
$y_next{'A'}=1;
$y_next{'T'}=1;
$y_next{'C'}=0.94;
$y_next{'G'}=0.94;
my %y_correct; #correction of font bounding boxes
$y_correct{'A'}=0;
$y_correct{'C'}=0.035*$fontsize;
$y_correct{'G'}=0.035*$fontsize;
$y_correct{'T'}=0;
#define y axis,tickmarks and scaling
my $font= $fontwidth/5;
$out.="newpath\n ". ($x-10)." ". ($y+2*$ysize/4 )." moveto\n". "$x ". ($y+2*$ysize/4 ) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-20). " ".( $y+$ysize/2)." moveto\n";
$out.=" (1) show\n grestore\n" ;
$out.="newpath\n ". ($x-10)." ". ($y+$ysize )." moveto\n". "$x ". ($y+$ysize) ." lineto\n stroke\n";
$out.="newpath\n ". ($x-10)." ". ($y+$max_ysize )." moveto\n". "$x ". ($y+$max_ysize) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-20). " ".( $y+$ysize)." moveto\n";
$out.=" (2) show\n grestore\n" ;
$out.="newpath\n $x $y moveto\n". ($x). " ".($y+$max_ysize) ." lineto\n stroke\n";
$out.="newpath\n $x $y moveto\n". ($x+$xsize). " ".($y) ." lineto\n stroke\n";
# draw titles if requested
if ($args{'-y_title'}){
$out.= "gsave\n/Times-Italic findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x-40). " ".( $y+$ysize/2)." moveto\n";
$out.=" 90 rotate ($args{'-y_title'}) show\n grestore\n" ;
}
if ($args{'-x_title'}){
$out.= "gsave\n/Times-Italic findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x+$xsize/2.5). " ".( $y*(0.60))." moveto\n";
$out.=" ($args{'-x_title'}) show\n grestore\n" ;
}
if ($args{'-title'}){
$out.= "gsave\n/Times-Roman findfont $color{black} [".($font*2)." 0 0 $font 0 0] makefont setfont\n".($x+$xsize/3). " ".( $y+$max_ysize*1.1)." moveto\n";
$out.=" ($args{'-title'}) show\n grestore\n" ;
}
# define x axis and x tickmarks
my $col_width=($xsize/$self->length()) -0.006*$xsize;
my $x_now;
for(my $i=1; $i<=$self->length(); $i++){
$x_now=$x+$col_width*$i;
$out.="newpath\n ". ($x_now)." ". ($y)." moveto\n". ($x_now)." ". ($y-$ysize/20 ) ." lineto\n stroke\n";
$out.= "gsave\n/Times-Bold findfont $color{black} [$font 0 0 $font 0 0] makefont setfont\n".($x_now-$col_width/2). " ".( $y-20)." moveto\n";
$out.=" ($i) show\n grestore\n" ;
}
# draw the logo
foreach my $i (0..$self->length()-1 ) { # get the $i-th column of matrix
my %ic;
($ic{A}, $ic{C}, $ic{G}, $ic{T}) = list $self->pdl_matrix->slice($i);
my @draw_order = sort {$ic{$a}<=>$ic{$b}} qw(A C G T);
#draw this position
foreach my $letter (@draw_order){
$ic{$letter}=0.0000001 if ( $ic{$letter}==0); # some interpretors do not uderstand size 0
$out.= "gsave\n/Helvetica-Bold findfont $color{$letter} [".$fontwidth*$w_correct{$letter}." 0 0 ";
$out.= $ic{$letter}*$fontsize*$y_next{$letter} ;
$y+=$y_correct{$letter}*$ic{$letter}; #movement that isletter specific, due to bounding boxes
$out.= " 0 0] makefont setfont\n$x $y moveto\n";
$out.= " ($letter) show\n grestore\n" ;
$y+=$fontsize*$ic{$letter}*0.75; #ic content move
}
$x+=$fontwidth/1.6;
$y=100;
}
# save as file if requested
if ($args{-file}) {
open (PSFILE, ">".$args{-file})
or $self->throw("Could not write to ".$args{-file});
print PSFILE $out;
close PSFILE;
}
if ($args{-pdf}){
system "ps2pdf $args{-file} ".$args{-file}.".pdf ";
system " mv $args{-file}.pdf $args{-file}";
}
return $out;
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
#################################################################
# INTERNAL METHODS
#################################################################
sub _check_ic_validity {
my ($self) = @_;
# to do
}
sub DESTROY {
# nothing
}
#################################################################
# UTILITY FUNCTIONS
#################################################################
# letter drawing routines
sub draw_A {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $green = $im->colorAllocate(0,255,0);
my $outPoly = GD::Polygon->new();
$outPoly->addPt($x, $y+$ysize);
$outPoly->addPt($x+$xsize*.42, $y);
$outPoly->addPt($x+$xsize*.58, $y);
$outPoly->addPt($x+$xsize, $y+$ysize);
$outPoly->addPt($x+0.85*$xsize, $y+$ysize);
$outPoly->addPt($x+0.725*$xsize, $y+0.75*$ysize);
$outPoly->addPt($x+0.275*$xsize, $y+0.75*$ysize);
$outPoly->addPt($x+0.15*$xsize, $y+$ysize);
$im->filledPolygon($outPoly, $green);
if ($ysize>8) {
my $inPoly = GD::Polygon->new();
$inPoly->addPt($x+$xsize*.5, $y+0.2*$ysize);
$inPoly->addPt($x+$xsize*.34, $y+0.6*$ysize-1);
$inPoly->addPt($x+$xsize*.64, $y+0.6*$ysize-1);
$im->filledPolygon($inPoly, $white);
}
return 1;
}
sub draw_C {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $blue = $im->colorAllocate(0,0,255);
$im->arc($x+$xsize*0.54, $y+$ysize/2,1.08*$xsize,$ysize,0,360,$blue);
$im->fill($x+$xsize/2, $y+$ysize/2, $blue);
if ($ysize>12) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
0.75*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize/2, $y+$ysize/4+1,
$x+$xsize*1.1, $y+(3*$ysize/4)-1,
$white);
}
elsif ($ysize>3) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
(0.75-0.75/$ysize)*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize*0.25, $y+$ysize/2,
$x+$xsize*1.1, $y+$ysize/2,
$white);
}
return 1;
}
sub draw_G {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $yellow = $im->colorAllocate(200,200,0);
$im->arc($x+$xsize*0.54, $y+$ysize/2,1.08*$xsize,$ysize,0,360,$yellow);
$im->fill($x+$xsize/2, $y+$ysize/2, $yellow);
if ($ysize>20) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
0.75*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize/2, $y+$ysize/4+1,
$x+$xsize*1.1, $y+$ysize/2-1,
$white);
}
elsif($ysize>3) {
$im->arc($x+$xsize*0.53, $y+$ysize/2,
(0.75-0.75/$ysize)*$xsize, (0.725-0.725/$ysize)*$ysize,
0,360,$white);
$im->fill($x+$xsize/2, $y+$ysize/2, $white);
$im->filledRectangle($x+$xsize*0.25, $y+$ysize/2,
$x+$xsize*1.1, $y+$ysize/2,
$white);
}
$im->filledRectangle($x+0.85*$xsize, $y+$ysize/2,
$x+$xsize,$y+(3*$ysize/4)-1,
$yellow);
$im->filledRectangle($x+0.6*$xsize, $y+$ysize/2,
$x+$xsize,$y+(5*$ysize/8)-1,
$yellow);
return 1;
}
sub draw_T {
my ($im, $x, $y, $xsize, $ysize, $white) = @_;
my $red = $im->colorAllocate(255,0,0);
$im->filledRectangle($x, $y, $x+$xsize, $y+0.16*$ysize, $red);
$im->filledRectangle($x+0.42*$xsize, $y, $x+0.58*$xsize, $y+$ysize, $red);
return 1;
}
1;
TFBS-0.7.1/blib/lib/TFBS/Matrix/PFM.pm 0000664 0000000 0000000 00000037334 13057522667 0016744 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::PFM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::PFM - class for raw position frequency matrix patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::PFM object manually:
my $matrixref = [ [ 12, 3, 0, 0, 4, 0 ],
[ 0, 0, 0, 11, 7, 0 ],
[ 0, 9, 12, 0, 0, 0 ],
[ 0, 0, 0, 1, 1, 12 ]
];
my $pfm = TFBS::Matrix::PFM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring =
"12 3 0 0 4 0\n0 0 0 11 7 0\n0 9 12 0 0 0\n0 0 0 1 1 12";
my $pfm = TFBS::Matrix::PFM->new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::PFM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and
retrieve TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pfm = $db_obj->get_Matrix_by_ID("M0001", "PFM");
# or
my $pfm = $db_obj->get_Matrix_by_name("MyProfile", "PFM");
=item * retrieving list of individual TFBS::Matrix::PFM objects
from a TFBS::MatrixSet object
(See the L to learn how to create
objects for storage and manipulation of multiple matrices.)
my @pfm_list = $matrixset->all_patterns(-sort_by=>"name");
=item * convert a raw frequency matrix to other matrix types:
my $pwm = $pfm->to_PWM(); # convert to position weight matrix
my $icm = $icm->to_ICM(); # convert to information con
=back
=head1 DESCRIPTION
TFBS::Matrix::PFM is a class whose instances are objects representing
raw position frequency matrices (PFMs). A PFM is derived from N
nucleotide patterns of fixed size, e.g. the set of sequences
AGGCCT
AAGCCT
AGGCAT
AAGCCT
AAGCCT
AGGCAT
AGGCCT
AGGCAT
AGGTTT
AGGCAT
AGGCCT
AGGCCT
will give the matrix:
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
which contains the count of each nucleotide at each position in the
sequence. (If you have a set of sequences as above and want to
create a TFBS::Matrix::PFM object out of them, have a look at
TFBS::PatternGen::SimplePFM module.)
PFMs are easily converted to other types of matrices, namely
information content matrices and position weight matrices. A
TFBS::Matrix::PFM object has the methods to_ICM and to_PWM which
do just that, returning a TFBS::Matrix::ICM and TFBS::Matrix::PWM
objects, respectively.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Matrix::PFM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::SeqIO;
use TFBS::Matrix;
use TFBS::Matrix::ICM;
use TFBS::Matrix::PWM;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
use constant EXACT_SCHNEIDER_MAX => 30;
#######################################################
# PUBLIC METHODS
#######################################################
=head2 new
Title : new
Usage : my $pfm = TFBS::Matrix::PFM->new(%args)
Function: constructor for the TFBS::Matrix::PFM object
Returns : a new TFBS::Matrix::PFM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
Warnings : Warns if the matrix provided has columns with different
sums. Columns with different sums contradict the usual
origin of matrix data and, unless you are absolutely sure
that column sums _should_ be different, it would be wise to
check your matrices.
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"PFM");
my $self = bless $matrix, ref($class) || $class;
$self->_check_column_sums();
return $self;
}
=head2 column_sum
Title : column_sum
Usage : my $nr_sequences = $pfm->column_sum()
Function: calculates the sum of elements of one column
(the first one by default) which normally equals the
number of sequences used to derive the PFM.
Returns : the sum of elements of one column (an integer)
Args : columnn number (starting from 1), OPTIONAL - you DO NOT
need to specify it unless you are dealing with a matrix
=cut
sub column_sum {
my ($self, $column) = (@_,1);
return $self->pdl_matrix->slice($column-1)->sum;
}
=head2 to_PWM
Title : to_PWM
Usage : my $pwm = $pfm->to_PWM()
Function: converts a raw frequency matrix (a TFBS::Matrix::PFM object)
to position weight matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::PWM object
Args : none; in the future releases, it should be able to accept
a user defined background probability of the four
nucleotides
=cut
sub to_PWM {
my ($self, %args) = @_;
my $bg = ($args{'-bg_probabilities' } || $self->{'bg_probabilities'});
my $bg_pdl =
transpose pdl ($bg->{'A'}, $bg->{'C'}, $bg->{'G'}, $bg->{'T'});
my $nseqs = $self->pdl_matrix->sum / $self->length;
my $q_pdl = ($self->pdl_matrix +$bg_pdl*sqrt($nseqs))
/
($nseqs + sqrt($nseqs));
my $pwm_pdl = log2(4*$q_pdl);
my $PWM = TFBS::Matrix::PWM->new
( (map {("-$_", $self->{$_}) } keys %$self),
# do not want tags to point to the same arrayref as in $self:
-tags => \%{ $self->{'tags'}},
-bg_probabilities => \%{ $self->{'bg_probabilities'}},
-matrix => $pwm_pdl
);
return $PWM;
}
=head2 to_ICM
Title : to_ICM
Usage : my $icm = $pfm->to_ICM()
Function: converts a raw frequency matrix (a TFBS::Matrix::PFM object)
to information content matrix. At present it assumes uniform
background distribution of nucleotide frequencies.
Returns : a new TFBS::Matrix::ICM object
Args : -small_sample_correction # undef (default), 'schneider' or 'pseudocounts'
How a PFM is converted to ICM:
For a PFM element PFM[i,k], the probability without
pseudocounts is estimated to be simply
p[i,k] = PFM[i,k] / Z
where
- Z equals the column sum of the matrix i.e. the number of motifs used
to construct the PFM.
- i is the column index (position in the motif)
- k is the row index (a letter in the alphacer, here k is one of
(A,C,G,T)
Here is how one normally calculates the pseudocount-corrected positional
probability p'[i,j]:
p'[i,k] = (PFM[i,k] + 0.25*sqrt(Z)) / (Z + sqrt(Z))
0.25 is for the flat distribution of nucleotides, and sqrt(Z) is the
recommended pseudocount weight. In the general case,
p'[i,k] = (PFM[i,k] + q[k]*B) / (Z + B)
where q[k] is the background distribution of the letter (nucleotide) k,
and B an arbitrary pseudocount value or expression (for no pseudocounts
B=0).
For a given position i, the deviation from random distribution in bits
is calculated as (Baldi and Brunak eq. 1.9 (2ed) or 1.8 (1ed)):
- for an arbitrary alphabet of A letters:
D[i] = log2(A) + sum_for_all_k(p[i,k]*log2(p[i,k]))
- special case for nucleotides (A=4)
D[i] = 2 + sum_for_all_k(p[i,k]*log2(p[i,k]))
D[i] equals the information content of the position i in the motif. To
calculate the entire ICM, you have to calculate the contrubution of each
nucleotide at a position i to D[i], i.e.
ICM[i,k] = p'[i,k] * D[i]
=cut
sub to_ICM {
my ($self, %args) = @_;
my $bg = ($args{'-bg_probabilities' } || $self->{'bg_probabilities'});
# compute ICM
my $bg_pdl =
transpose pdl ($bg->{'A'}, $bg->{'C'}, $bg->{'G'}, $bg->{'T'});
my $Z_pdl = $self->pdl_matrix->xchg(0,1)->sumover;
# pseudocount calculation
my $B = 0;
if (lc($args{'-small_sample_correction'} or "") eq "pseudocounts") {
$B = sqrt($Z_pdl);
}
else {
$B = 0; # do not add pseudocounts
}
my $p_pdl = ($self->pdl_matrix +$bg_pdl*$B)/ ($Z_pdl + $B);
my $plog_pdl = $p_pdl*log2($p_pdl);
$plog_pdl = $plog_pdl->badmask(0);
my $D_pdl = 2 + $plog_pdl->xchg(0,1)->sumover;
my $ic_pdl = $p_pdl * $D_pdl;
# apply Schneider correction if requested
if (lc($args{'-small_sample_correction'} or "") eq "schneider") {
my $columnsum_pdl = $ic_pdl->transpose->sumover;
my $corrected_columnsum_pdl =
$columnsum_pdl
+ _schneider_correction ($self->pdl_matrix, $bg_pdl);
$ic_pdl *= $corrected_columnsum_pdl/$columnsum_pdl;
}
# construct and return an ICM object
my $ICM = TFBS::Matrix::ICM->new
( (map {("-$_" => $self->{$_})} keys %$self),
-tags => \%{ $self->{'tags'}},
-bg_probabilities => \%{ $self->{'bg_probabilities'}},
-matrix => $ic_pdl
);
return $ICM;
}
=head2 draw_logo
Title : draw_logo
Usage : my $gd_image = $pfm->draw_logo()
Function: draws a sequence logo; similar to the
method in TFBS::Matrix::ICM, but can automatically calculate
error bars for drawing
Returns : a GD image object (see documentation of GD module)
Args : many; PFM-specific options are:
-small_sample_correction # One of
# "Schneider" (uses correction
# described by Schneider et al.
# (Schneider t et al. (1986) J.Biol.Chem.
# "pseudocounts" - standard pseudocount
# correction, more suitable for
# PFMs with large r column sums
# If the parameter is ommited, small
# sample correction is not applied
-draw_error_bars # if true, adds error bars to each position
# in the logo. To calculate the error bars,
# it uses the -small_sample_connection
# argument if explicitly set,
# or "Schneider" by default
For other args, see draw_logo entry in TFBS::Matrix::ICM documentation
=cut
sub draw_logo {
my ($self, %args) = @_;
if ($args{'-draw_error_bars'}) {
$args{'-small_sample_correction'} ||= "Schneider"; # default Schneider
my $pdl_no_correction =
$self->to_ICM()
->pdl_matrix->transpose->sumover;
my $pdl_with_correction =
$self->to_ICM(-small_sample_correction
=> $args{'-small_sample_correction'})
->pdl_matrix->transpose->sumover;
$args{'-error_bars'} =
[list ($pdl_no_correction - $pdl_with_correction)];
}
$self->to_ICM(%args)->draw_logo(%args);
}
=head2 add_PFM
Title : add_PFM
Usage : $pfm->add_PFM($another_pfm)
Function: adds the values of $pnother_pfm matrix to $pfm
Returns : reference to the updated $pfm object
Args : a TFBS::Matrix::PFM object
=cut
sub add_PFM {
my ($self, $pfm) = @_;
$pfm->isa("TFBS::Matrix::PFM")
or $self->throw("Wrong or no argument passed to add_PFM");
my $sum = $self->pdl_matrix + $pfm->pdl_matrix;
$self->set_matrix($sum);
return $self;
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
###############################################
# PRIVATE METHODS
###############################################
sub _check_column_sums {
my ($self) = @_;
my $pdl = $self->pdl_matrix->sever();
my $rowsums = $pdl->xchg(0,1)->sumover();
if ($rowsums->where($rowsums != $rowsums->slice(0))->getdim(0) > 0) {
$self->warn("PFM for ".$self->{ID}." has unequal column sums");
}
}
sub DESTROY {
# does nothing
}
###############################################
# UTILITY FUNCTIONS
###############################################
sub log2 { log($_[0]) / log(2); }
sub _schneider_correction {
my ($pdl, $bg_pdl) = @_;
my $Hg = -sum ($bg_pdl*log2($bg_pdl));
my (@Hnbs, %saved_Hnb);
my $is_flat = _is_bg_flat(list $bg_pdl);
my @factorials = (1);
if (min($pdl->transpose->sumover) <= EXACT_SCHNEIDER_MAX) {
foreach my $i (1..max($pdl->transpose->sumover)) {
$factorials[$i] =$factorials[$i-1] * $i;
}
}
my @column_sums = list $pdl->transpose->sumover;
foreach my $colsum (@column_sums) {
if (defined($saved_Hnb{$colsum})) {
push @Hnbs, $saved_Hnb{$colsum};
}
else {
my $Hnb;
if ($colsum <= EXACT_SCHNEIDER_MAX) {
if ($is_flat) {
$Hnb = _schneider_Hnb_precomputed($colsum);
}
else {
$Hnb = _schneider_Hnb_exact($colsum, $bg_pdl,
\@factorials);
}
}
else {
$Hnb = _schneider_Hnb_approx($colsum, $Hg);
}
$saved_Hnb{$colsum} = $Hnb;
push @Hnbs, $Hnb;
}
}
return -$Hg + pdl(@Hnbs);
}
sub _schneider_Hnb_exact {
my ($n, $bg_pdl, $rFactorial) = @_;
my $is_flat = _is_bg_flat(list $bg_pdl);
return 0 if $n==1;
# my @fctrl = (1);
# foreach my $i (1..max($pdl->transpose->sumover)) {
# $rFactorial->[$i] =$rFactorial->[$i-1] * $i;
# }
# my @colsum = list $pdl->transpose->sumover;
my ($na, $nc, $ng, $nt) = ($n, 0,0,0);
# my $n = $colsum[0];
my $E_Hnb=0;
while (1) {
my $ns_pdl = pdl [$na, $nc, $ng, $nt];
my $Pnb = ($rFactorial->[$n]
/
($rFactorial->[$na]
*$rFactorial->[$nc]
*$rFactorial->[$ng]
*$rFactorial->[$nt])
)*prod($bg_pdl->transpose**pdl($na, $nc, $ng, $nt));
my $Hnb = -1 * sum(($ns_pdl/$n)*log2($ns_pdl/$n)->badmask(0));
$E_Hnb += $Pnb*$Hnb;
if ($nt) {
if ($ng) { $ng--; $nt++, }
elsif ($nc) { $nc--; $ng = $nt+1; $nt = 0; }
elsif ($na) { $na--; $nc = $nt+1; $nt = 0; }
else { last; }
}
else {
if ($ng) { $ng--; $nt++, }
elsif ($nc) { $nc--; $ng++; }
else { $na--; $nc++; $nt = 0; }
}
}
return $E_Hnb;
}
sub _schneider_Hnb_approx {
my ($colsum, $Hg) = @_;
return $Hg -3/(2*log(2)*$colsum);
}
sub _schneider_Hnb_precomputed {
my $i = shift;
if ($i<1 or $i>30) {
die "Precomputed params only available for colsums 1 to 30)";
}
my @precomputed =
(
0, # 1
0.75, # 2
1.11090234442608, # 3
1.32398964833609, # 4
1.46290503577084, # 5
1.55922640783176, # 6
1.62900374746751, # 7
1.68128673969433, # 8
1.7215504663901, # 9
1.75328193031842, # 10
1.77879136615189, # 11
1.79965855531179, # 12
1.81699248819687, # 13
1.8315892710679, # 14
1.84403166371213, # 15
1.85475371994775, # 16
1.86408383599326, # 17
1.87227404728809, # 18
1.87952034817826, # 19
1.88597702438913, # 20
1.89176691659196, # 21
1.89698887214968, # 22
1.90172322434865, # 23
1.90603586889234, # 24
1.90998133028897, # 25
1.91360509239859, # 26
1.91694538711761, # 27
1.92003457997914, # 28
1.92290025302018, # 29
1.92556605820924, # 30
);
return $precomputed[$i-1];
}
sub _is_bg_flat {
my @bg = @_;
my $ref = shift;
foreach my $other (@bg) {
return 0 unless $ref==$other;
}
return 1;
}
1;
TFBS-0.7.1/blib/lib/TFBS/Matrix/PWM.pm 0000664 0000000 0000000 00000036222 13057522667 0016760 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::Matrix::PWM
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::PWM - class for position weight matrices of nucleotide
patterns
=head1 SYNOPSIS
=over 4
=item * creating a TFBS::Matrix::PWM object manually:
my $matrixref = [ [ 0.61, -3.16, 1.83, -3.16, 1.21, -0.06],
[-0.15, -2.57, -3.16, -3.16, -2.57, -1.83],
[-1.57, 1.85, -2.57, -1.34, -1.57, 1.14],
[ 0.31, -3.16, -2.57, 1.76, 0.24, -0.83]
];
my $pwm = TFBS::Matrix::PWM->new(-matrix => $matrixref,
-name => "MyProfile",
-ID => "M0001"
);
# or
my $matrixstring = <new(-matrixstring => $matrixstring,
-name => "MyProfile",
-ID => "M0001"
);
=item * retrieving a TFBS::Matix::PWM object from a database:
(See documentation of individual TFBS::DB::* modules to learn
how to connect to different types of pattern databases and retrieve
TFBS::Matrix::* objects from them.)
my $db_obj = TFBS::DB::JASPAR2->new
(-connect => ["dbi:mysql:JASPAR2:myhost",
"myusername", "mypassword"]);
my $pwm = $db_obj->get_Matrix_by_ID("M0001", "PWM");
# or
my $pwm = $db_obj->get_Matrix_by_name("MyProfile", "PWM");
=item * retrieving list of individual TFBS::Matrix::PWM objects
from a TFBS::MatrixSet object
(see decumentation of TFBS::MatrixSet to learn how to create
objects for storage and manipulation of multiple matrices)
my @pwm_list = $matrixset->all_patterns(-sort_by=>"name");
=item * scanning a nucleotide sequence with a matrix
my $siteset = $pwm->search_seq(-file =>"myseq.fa",
-threshold => "80%");
=item * scanning a pairwise alignment with a matrix
my $site_pair_set = $pwm->search_aln(-file =>"myalign.aln",
-threshold => "80%",
-cutoff => "70%",
-window => 50);
=back
=head1 DESCRIPTION
TFBS::Matrix::PWM is a class whose instances are objects representing
position weight matrices (PWMs). A PWM is normally calculated from a
raw position frequency matrix (see L
for the explanation of position frequency matrices). For example, given
the following position frequency matrix:
A:[ 12 3 0 0 4 0 ]
C:[ 0 0 0 11 7 0 ]
G:[ 0 9 12 0 0 0 ]
T:[ 0 0 0 1 1 12 ]
The standard computational procedure is applied to convert it into the
following position weight matrix:
A:[ 0.61 -3.16 1.83 -3.16 1.21 -0.06]
C:[-0.15 -2.57 -3.16 -3.16 -2.57 -1.83]
G:[-1.57 1.85 -2.57 -1.34 -1.57 1.14]
T:[ 0.31 -3.16 -2.57 1.76 0.24 -0.83]
which contains the "weights" associated with the occurrence of each
nucleotide at the given position in a pattern.
A TFBS::Matrix::PWM object is equipped with methods to search nucleotide
sequences and pairwise alignments of nucleotide sequences with the
pattern they represent, and return a set of sites in nucleotide
sequence (a TFBS::SiteSet object for single sequence search, and a
TFBS::SitePairSet for the alignment search).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::Matrix::PWM;
use vars '@ISA';
use PDL;
use strict;
use Bio::Root::Root;
use Bio::Seq;
use Bio::SeqIO;
use TFBS::Matrix;
use TFBS::SiteSet;
use TFBS::Matrix::_Alignment;
use TFBS::Ext::pwmsearch;
use File::Temp qw/:POSIX/;
@ISA = qw(TFBS::Matrix Bio::Root::Root);
#################################################################
# PUBLIC METHODS
#################################################################
=head2 new
Title : new
Usage : my $pwm = TFBS::Matrix::PWM->new(%args)
Function: constructor for the TFBS::Matrix::PWM object
Returns : a new TFBS::Matrix::PWM object
Args : # you must specify either one of the following three:
-matrix, # reference to an array of arrays of integers
#or
-matrixstring,# a string containing four lines
# of tab- or space-delimited integers
#or
-matrixfile, # the name of a file containing four lines
# of tab- or space-delimited integers
#######
-name, # string, OPTIONAL
-ID, # string, OPTIONAL
-class, # string, OPTIONAL
-tags # an array reference, OPTIONAL
=cut
sub new {
my ($class, %args) = @_;
my $matrix = TFBS::Matrix->new(%args, -matrixtype=>"PWM");
my $self = bless $matrix, ref($class) || $class;
$self->_set_min_max_score();
return $self;
}
=head2 search_seq
Title : search_seq
Usage : my $siteset = $pwm->search_seq(%args)
Function: scans a nucleotide sequence with the pattern represented
by the PWM
Returns : a TFBS::SiteSet object
Args : # you must specify either one of the following three:
-file, # the name od a fasta file (single sequence)
#or
-seqobj # a Bio::Seq object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-seqstring # a string containing the sequence
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
-subpart # subpart of the sequence to search, given as
# -subpart => { start => 140,
# end => 180 }
# where start and end are coordinates in the
# sequence; the coordinate range is interpreted
# in the BioPerl tradition (1-based, inclusive)
# OPTIONAL: by default searches entire alignment
=cut
sub search_seq {
my ($self, %args) = @_;
$self->_search(%args);
}
=head2 search_aln
Title : search_aln
Usage : my $site_pair_set = $pwm->search_aln(%args)
Function: Scans a pairwise alignment of nucleotide sequences
with the pattern represented by the PWM: it reports only
those hits that are present in equivalent positions of both
sequences and exceed a specified threshold score in both, AND
are found in regions of the alignment above the specified
conservation cutoff value.
Returns : a TFBS::SitePairSet object
Args : # you must specify either one of the following three:
-file, # the name of the alignment file in Clustal
format
#or
-alignobj # a Bio::SimpleAlign object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-alignstring # a multi-line string containing the alignment
# in clustal format
#############
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
-window, # size of the sliding window (inn nucleotides)
# for calculating local conservation in the
# alignment
# OPTIONAL: default 50
-cutoff # conservation cutoff (%) for including the
# region in the results of the pattern search
# OPTIONAL: default "70%"
-subpart # subpart of the alignment to search, given as e.g.
# -subpart => { relative_to => 1,
# start => 140,
# end => 180 }
# where start and end are coordinates in the
# sequence indicated by relative_to (1 for the
# 1st sequence in the alignment, 2 for the 2nd)
# OPTIONAL: by default searches entire alignment
-conservation
# conservation profile, a TFBS::ConservationProfile
# OPTIONAL: by default the conservation profile is
# computed internally on the fly (less efficient)
=cut
sub search_aln {
my ($self, %args) = @_;
unless ($args{-alignstring} or $args{-alignobj} or $args{-file}) {
$self->throw
("No alignment file, string or object passed to search_aln.");
}
$args{-pattern_set} = $self;
my $aln = ($args{-alignment_setup} or TFBS::Matrix::_Alignment->new(%args));
$aln->do_sitesearch(%args);
return $aln->site_pair_set;
}
sub max_score {
$_[0]->{max_score};
}
sub min_score {
$_[0]->{min_score};
}
=head2 name
=head2 ID
=head2 class
=head2 matrix
=head2 length
=head2 revcom
=head2 rawprint
=head2 prettyprint
The above methods are common to all matrix objects. Please consult
L to find out how to use them.
=cut
#################################################################
# PRIVATE METHODS
#################################################################
sub _set_min_max_score {
my ($self) = @_;
my $transpose = $self->pdl_matrix->xchg(0,1);
$self->{min_score} = sum(minimum $transpose);
$self->{max_score} = sum(maximum $transpose);
}
sub _search {
# this method runs the pwmsearch C extension and parses the data
# similarly to _csearch, which will eventually be discontinued
my ($self, %args) = @_;
my $seqobj = $self->_to_seqobj(%args);
my ($subseq_start, $subseq_end) = (1,$seqobj->length);
if(my $subpart = $args{-subpart}) {
$subseq_start = $subpart->{-start};
$subseq_end = $subpart->{-end};
unless($subseq_start and $subseq_end) {
$self->throw("Option -subpart missing suboption -start or -end");
}
}
return TFBS::Ext::pwmsearch::pwmsearch($self, $seqobj,
($args{-threshold} or 0),
$subseq_start, $subseq_end);
}
sub _csearch {
# this is a wrapper around Wyeth Wasserman's's pwm_searchPFF program
# until we do a proper extension
my ($self) = shift; #the rest of @_ goes to _to_seqob;
my %args = @_;
my $PWM_SEARCH = $args{'-binary'}
|| "pwm_searchPFF";
# dump the sequence into a tempfile
my $seqobj = $self->_to_seqobj(@_);
my ($fastaFH, $fastafile);
if (defined $seqobj->{_fastaFH} and defined $seqobj->{_fastafile}) {
($fastaFH, $fastafile) = ($seqobj->{_fastaFH}, $seqobj->{_fastafile});
}
else {
($fastaFH, $fastafile) = tmpnam();
my $seqFH = Bio::SeqIO->newFh(-fh =>$fastaFH, -format=>"Fasta");
print $seqFH $seqobj;
}
# we need $fastafile below
# calculate threshold
my $threshold;
if ($args{-threshold}) {
if ($args{-threshold} =~ /(.+)%/) {
# percentage
$threshold = $self->{min_score} +
($self->{max_score} - $self->{min_score})* $1/100;
}
else {
# absolute value
$threshold = $args{-threshold};
}
}
else {
# no threshold given
$threshold = $self->{min_score} -1;
}
# convert piddle to text (there MUST be a better way)
my $pwmstring = sprintf ( $self->pdl_matrix );
$pwmstring =~ s/\[|\]//g; # lose []
$pwmstring =~ s/\n /\n/g; # lose leading spaces
my @pwmlines = split("\n", $pwmstring); # f
$pwmstring = join ("\n", @pwmlines[2..5])."\n";
# dump pwm into a tempfile
my ($pwmFH, $pwmfile) = tmpnam(); # we need $pwmfile below
print $pwmFH $pwmstring;
close $pwmFH;
# run pwmsearch
my $hitlist = TFBS::SiteSet->new();
my ($TFname, $TFclass) = ($self->{name}, $self->{class});
my @search_result_lines =
`$PWM_SEARCH $pwmfile $fastafile $threshold -n $TFname -c $TFclass`;
foreach (@search_result_lines) {
chomp;
my ($seq_id, $factor, $class, $strand, $score, $pos, $siteseq) =
(split)[0, 2, 3, 4, 5, 7, 9];
my $correct_strand = ($strand eq "+")? "-1" : "1";
my $site = TFBS::Site->new ( -seq_id => $seqobj->display_id()."",
-seqobj => $seqobj,
-strand => $correct_strand."",
-pattern => $self,
-siteseq => $siteseq."",
-score => $score."",
-start => $pos,
-end => $pos + length($siteseq) -1
);
$hitlist->add_site($site);
}
# cleanup
unlink $fastafile unless $seqobj->{_fastafile};
unlink $pwmfile;
return $hitlist;
}
sub _bsearch {
# this is Perl/PDL only search routine. For experimental purposes only
my ($self,%args) = @_; #the rest of @_ goes to _to_seqob;
my @PWMs;
# prepare the sequence
my $seqobj = $self->_to_seqobj(%args);
my $seqmatrix = (defined $seqobj->{_pdl_matrix})
? $seqobj->{_pdl_matrix}
: _seq_to_pdlmatrix($seqobj);
# calculate threshold
my $threshold;
if ($args{-threshold}) {
if ($args{-threshold} =~ /(.+)%/) {
# percentage
$threshold = $self->{min_score} +
($self->{max_score} - $self->{min_score})* $1/100;
}
else {
# absolute value
$threshold = $args{-threshold};
}
}
else {
# no threshold given
$threshold = $self->{min_score} -1;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm ($self, $self->revcom()) {
my $TFlength = $pwm->pdl_matrix->getdim(0);
my $position_score_pdl = zeroes($seqmatrix->getdim(0) - $TFlength + 1);
my $position_index_pdl = sequence($seqmatrix->getdim(0) - $TFlength + 1)+1;
foreach my $i (0..($TFlength-1)) {
my $columnproduct = $seqmatrix * $pwm->pdl_matrix->slice("$i,:");
$position_score_pdl +=
$columnproduct->xchg(0,1)->sumover->slice($i.":".($i-$TFlength));
}
my @hitpositions =
list $position_index_pdl->where($position_score_pdl >= $threshold);
my @hitscores =
list $position_score_pdl->where($position_score_pdl >= $threshold);
for my $i(0..$#hitpositions) {
my($pos,$score) = ($hitpositions[$i], $hitscores[$i]);
my $siteseq = scalar($seqobj->subseq($pos, $pos+$TFlength-1));
my $site = TFBS::Site->new ( -seq_id => $seqobj->display_id(),
-seqobj => $seqobj,
-strand => $pwm->{strand},
-Matrix => $pwm,
-siteseq => $siteseq,
-score => $score,
-start => $pos);
$hitlist->add_site($site);
}
}
return $hitlist;
}
sub _to_seqobj {
my ($self, %args) = @_;
my $seq;
if ($args{-file}) { # not a Bio::Seq
return Bio::SeqIO->new(-file => $args{-file},
-format => 'fasta',
-moltype => 'dna')->next_seq();
}
elsif ($args{-seqstring}
or $args{-seq})
{ # I guess it's a string then
return Bio::Seq->new(-seq => ($args{-seqstring} or $args{-seq}),
-id => ($args{-seq_id} or "undefined"),
-moltype => 'dna');
}
elsif ($args{'-seqobj'} and ref($args{'-seqobj'}) and $args{'-seqobj'}->can("seq")) {
# do nothing (maybe check later)
return $args{'-seqobj'};
}
#elsif (ref($format) =~ /Bio\:\:Seq/ and !defined $seq) {
# if only one parameter passed and it's a Bio::Seq
#return $format;
#}
else {
$self->throw ("Wrong parameters passed to search method: ".%args);
}
}
sub _seq_to_pdlmatrix {
# called from ?search
# not OO - help function for search
my $seqobj = shift;
my $seqstring = uc($seqobj->seq());
my @perlarray;
foreach (qw(A C G T)) {
my $seqtobits = $seqstring;
eval "\$seqtobits =~ tr/$_/1/"; # curr. letter $_ to 1
eval "\$seqtobits =~ tr/1/0/c"; # non-1s to 0
push @perlarray, [split("", $seqtobits)];
}
return byte (\@perlarray);
}
sub DESTROY {
# nothing
}
1;
TFBS-0.7.1/blib/lib/TFBS/Matrix/_Alignment.pm 0000664 0000000 0000000 00000027374 13057522667 0020402 0 ustar 00root root 0000000 0000000 package TFBS::Matrix::_Alignment;
use vars qw(@ISA $AUTOLOAD);
use TFBS::SitePair;
use TFBS::SitePairSet;
use Bio::Root::Root;
use Bio::Seq;
use Bio::SimpleAlign;
use Bio::AlignIO;
use IO::String;
use PDL;
use strict;
@ISA =('Bio::Root::Root');
# CONSTANTS
use constant DEFAULT_WINDOW => 50;
use constant DEFAULT_CUTOFF => 70;
use constant DEFAULT_THRESHOLD => "80%";
sub new {
# this is ugly; OK, OK, I'll rewrite it as soon as I can
my ($caller, %args) = @_;
my $self = bless {}, ref $caller || $caller;
$self->window($args{-window} or DEFAULT_WINDOW);
$self->_parse_alignment(%args);
$self->seq1length(length(_strip_gaps($self->alignseq1())));
$self->seq2length(length(_strip_gaps($self->alignseq2())));
$self->_set_subpart_bounds($args{-subpart});
#
# If a conservation profile is provided, no need to compute it again.
# NOTE: conservation2 never seems to be used anywhere else so don't worry
# about the fact we are ignoring it if conservation is passed in :)
#
my $cp = $args{-conservation};
if ($cp) {
$self->conservation1([$cp->conservation()]);
} else {
$self->conservation1($self->_calculate_conservation($self->window(),1));
$self->conservation2($self->_calculate_conservation($self->window(),2));
}
$self->cutoff($args{-cutoff} or DEFAULT_CUTOFF);
#$self->threshold($args{-threshold} or DEFAULT_THRESHOLD);
#$self->_do_sitesearch
#(($args{-pattern_set} or $self->throw("No -matrixset parameter")),
# ($args{-threshold} or DEFAULT_THRESHOLD),
# ());
# $self->_set_start_end(%args); # Maybe later...
return $self;
}
sub DESTROY {
# empty
}
sub _parse_alignment {
my ($self, %args) = @_;
my ($seq1, $seq2, $start);
my $alignobj;
if (defined $args{'-alignstring'}) {
$alignobj = _alignstring_to_alignobj($args{'-alignstring'});
}
elsif (defined $args{'-file'}) {
$alignobj = _alignfile_to_alignobj($args{'-file'});
}
elsif (defined $args{-alignobj}) {
$alignobj = $args{'-alignobj'};
}
else {
$self->throw("No -alignstring, -file or -alignobj passed.");
}
my @match;
my ($seqobj1, $seqobj2) = $alignobj->each_seq;
($seq1, $seq2) = ($seqobj1->seq, $seqobj2->seq);
$start = 1;
$self->seq1name($seqobj1->display_id);
$self->seq2name($seqobj2->display_id);
$self->alignseq1($seq1);
$self->alignseq2($seq2);
my @seq1 = ("-", split('', $seq1) );
my @seq2 = ("-", split('', $seq2) );
$self->{alignseq1array} = [@seq1];
$self->{alignseq2array} = [@seq2];
my (@seq1index, @seq2index);
my ($i1, $i2) = (0, 0);
for my $pos (0..$#seq1) {
my ($s1, $s2) = (0, 0);
$seq1[$pos] ne "-" and $s1 = ++$i1;
$seq2[$pos] ne "-" and $s2 = ++$i2;
push @seq1index, $s1;
push @seq2index, $s2;
}
$self->pdlindex( pdl [ [list sequence($#seq1+1)],
[@seq1index],
[@seq2index],
[list zeroes ($#seq1+1)] ]) ;
return 1;
}
sub pdlindex {
my ($self, $input, $p1, $p2) = @_ ;
# print ("PARAMS ", join(":", @_), "\n");
if (ref($input) eq "PDL") {
$self->{pdlindex} = $input;
}
unless (defined $p2) {
return $self->{pdlindex};
}
else {
my @results = list
$self->{pdlindex}->xchg(0,1)->slice($p2)->where
($self->{pdlindex}->xchg(0,1)->slice($p1)==$input);
wantarray ? return @results : return $results[0];
}
}
sub lower_pdlindex {
my ($self, $input, $p1, $p2) = @_;
unless (defined $p2) {
$self->throw("Wrong number of parameters passed to lower_pdlindex");
}
my $result;
my $i = $input;
until ($result = $self->pdlindex($i, $p1 => $p2)) {
$i--;
last if $i==0;
}
return $result or 1;
}
sub higher_pdlindex {
my ($self, $input, $p1, $p2) = @_;
unless (defined $p2) {
$self->throw("Wrong number of parameters passed to lower_pdlindex");
}
my $result;
my $i = $input;
until ($result = $self->pdlindex($i, $p1 => $p2)) {
$i++;
last unless ($self->pdlindex($i, $p1=>0) > 0);
}
return $result;
}
sub _calculate_conservation {
my ($self, $WINDOW, $which) = @_;
my (@seq1, @seq2);
if ($which==2) {
@seq1 = @{$self->{alignseq2array}};
@seq2 = @{$self->{alignseq1array}};
}
else {
@seq1 = @{$self->{alignseq1array}};
@seq2 = @{$self->{alignseq2array}};
$which=1;
}
my @CONSERVATION;
my @match;
while ($seq1[0] eq "-") {
shift @seq1;
shift @seq2;
}
for my $i (0..$#seq1) {
push (@match,( uc($seq1[$i]) eq uc($seq2[$i]) ? 1:0))
unless ($seq1[$i] eq "-" or $seq1[$i] eq ".");
}
my @graph=($match[0]);
for my $i (1..($#match+$WINDOW/2)) {
$graph[$i] = ($graph[$i-1] or 0)
+ ($i>$#match ? 0: $match[$i])
- ($i<$WINDOW ? 0: $match[$i-$WINDOW]);
}
# at this point, the graph values are shifted $WINDOW/2 to the right
# i.e. the score at a certain position is the score of the window
# UPSTREAM of it: To fix it, we should discard the first $WINDOW/2 scores:
#$self->conservation1 ([]);
foreach my $pos (@graph[int($WINDOW/2)..$#graph]) {
push @CONSERVATION, 100*$pos/$WINDOW;
}
# correction
foreach my $pos (0..int($WINDOW/2)) {
$CONSERVATION[$pos] =
$CONSERVATION[$pos]*$WINDOW/(int($WINDOW/2)+$pos);
$CONSERVATION[$#CONSERVATION - $pos] =
$CONSERVATION[$#CONSERVATION - $pos]*$WINDOW/(int($WINDOW/2)+$pos);
}
return [@CONSERVATION];
}
sub _strip_gaps {
# a utility function
my $seq = shift;
$seq =~ s/\-|\.//g;
return $seq;
}
sub do_sitesearch {
my ($self, @args ) = @_;
my ($MATRIXSET, $THRESHOLD, $CUTOFF) =
$self->_rearrange([qw(PATTERN_SET THRESHOLD CUTOFF)], @args);
if (!$MATRIXSET) {
$self->throw("No -pattern_set passed to do_sitesearch");
}
$CUTOFF = ($CUTOFF or DEFAULT_CUTOFF);
$THRESHOLD = ($THRESHOLD or DEFAULT_THRESHOLD);
$self->site_pair_set(TFBS::SitePairSet->new());
return if(($self->subpart1 and $self->subpart1->{-start} == 0) or
($self->subpart2 and $self->subpart2->{-start} == 0));
# ^^^ If one of the subparts is a gap, there's no point in searching
my $seqobj1 = Bio::Seq->new(-seq=>_strip_gaps($self->alignseq1()),
-id => "Seq1");
my $siteset1 =
$MATRIXSET->search_seq(-seqobj => $seqobj1,
-threshold => $THRESHOLD,
-subpart => $self->subpart1);
my $siteset1_itr = $siteset1->Iterator(-sort_by => "start");
my $seqobj2 = Bio::Seq->new(-seq=>_strip_gaps($self->alignseq2()),
-id => "Seq2");
my $siteset2 =
$MATRIXSET->search_seq(-seqobj => $seqobj2,
-threshold => $THRESHOLD,
-subpart => $self->subpart2);
my $siteset2_itr = $siteset2->Iterator(-sort_by => "start");
my $site1 = $siteset1_itr->next();
my $site2 = $siteset2_itr->next();
while (defined $site1 and defined $site2) {
my $pos1_in_aln = $self->pdlindex($site1->start(), 1=>0);
my $pos2_in_aln = $self->pdlindex($site2->start(), 2=>0);
my $cmp = (($pos1_in_aln <=> $pos2_in_aln)
or ($site1->pattern->name() cmp $site2->pattern->name())
or ($site1->strand() cmp $site2->strand()));
if ($cmp==0) { ### match
if (# threshold test:
$self->conservation1->[$site1->start()]
>=
$self->cutoff()
)
{
my $site_pair = TFBS::SitePair->new($site1, $site2);
$self->site_pair_set->add_site_pair($site_pair);
}
$site1 = $siteset1_itr->next();
$site2 = $siteset2_itr->next();
}
elsif ($cmp<0) { ### $siteset1 is behind
$site1 = $siteset1_itr->next();
}
elsif ($cmp>0) { ### $siteset2 is behind
$site2 = $siteset2_itr->next();
}
}
}
sub _set_subpart_bounds {
my ($self, $subpart) = @_;
if(defined $subpart) {
my ($relative_to, $start, $end) = ($subpart->{-relative_to},
$subpart->{-start},
$subpart->{-end});
unless(defined($relative_to) and defined($start) and defined($end) ) {
$self->throw("Option -subpart missing suboption -relative_to, -start or -end");
}
if($relative_to == 1) {
my $other_start = $self->higher_pdlindex($start, 1 => 2);
my $other_end = $self->lower_pdlindex($end, 1 => 2);
($other_start, $other_end) = (0,0) if($other_start > $other_end);
$self->subpart1({ -start => $start, -end => $end });
$self->subpart2({ -start => $other_start, -end => $other_end });
}
elsif($relative_to == 2) {
my $other_start = $self->higher_pdlindex($start, 2 => 1);
my $other_end = $self->lower_pdlindex($end, 2 => 1);
($other_start, $other_end) = (0,0) if($other_start > $other_end);
$self->subpart1({ -start => $other_start, -end => $other_end });
$self->subpart2({ -start => $start, -end => $end });
}
else {
$self->throw("Suboption -relative_to should be 1 or 2");
}
}
}
sub _calculate_cutoff {
my ($self) = @_;
my $ile = 0.9;
my @conservation_array = sort {$a <=> $b} @{$self->conservation1()};
my $perc_90 = $conservation_array[int($ile*scalar(@conservation_array))];
return $perc_90;
}
sub _alignfile_to_string {
# a utility function
# DEPRECATED !!!
my $alignfile = shift;
if ($alignfile =~ /\.msf$/i) {
my $alignobj = Bio::SimpleAlign->new();
$alignobj->read_MSF($alignfile);
return _alignobj_to_string($alignobj);
}
else { #assumed clustalw - no AlignIO import yet
local $/ = undef;
open FILE, $alignfile
or die("Could not read alignfile $alignfile, stopped");
my $alignstring = ;
return $alignstring;
}
}
sub _alignfile_to_alignobj {
# a utility function
my ($alignfile, $format) = (@_,'clustalw');
if (!$format and $alignfile =~ /\.msf$/i) { $format = 'msf' ;}
my $alnio = Bio::AlignIO->new(-file=>$alignfile, -format=>$format);
return $alnio->next_aln;
}
sub _alignobj_to_string {
# a utility function
# DEPRECATED
my $alignobj = shift;
my $alignstring;
my $io = IO::String->new($alignstring);
my $alnio = Bio::AlignIO->new(-fh=>$io, -format=>"clustalw");
$alnio->write_aln($alignobj);
$alnio->close();
# $io->close;
return $alignstring;
}
sub _alignstring_to_alignobj {
# a utility function
my ($alignstring, $format) = (@_, 'clustalw');
my $io = IO::String->new($alignstring);
my $alnio = Bio::AlignIO->new(-fh=>$io, -format=>$format);
my $alignobj = $alnio->next_aln();
$alnio->close();
# $io->close;
return $alignstring;
}
# uglier than AUTOLOAD, but faster - a quick fix to get rid of Class::MethodMaker
sub cutoff
{ $_[0]->{'cutoff'} = $_[1] if exists $_[1]; $_[0]->{'cutoff'}; }
sub window
{ $_[0]->{'window '} = $_[1] if exists $_[1]; $_[0]->{'window '}; }
sub alignseq1
{ $_[0]->{'alignseq1'} = $_[1] if exists $_[1]; $_[0]->{'alignseq1'}; }
sub alignseq2
{ $_[0]->{'alignseq2'} = $_[1] if exists $_[1]; $_[0]->{'alignseq2'}; }
sub site_pair_set
{ $_[0]->{'site_pair_set'} = $_[1] if exists $_[1]; $_[0]->{'site_pair_set'};}
sub seq1name
{ $_[0]->{'seq1name'} = $_[1] if exists $_[1]; $_[0]->{'seq1name'}; }
sub seq2name
{ $_[0]->{'seq2name'} = $_[1] if exists $_[1]; $_[0]->{'seq2name'}; }
sub seq1length
{ $_[0]->{'seq1length'} = $_[1] if exists $_[1]; $_[0]->{'seq1length'}; }
sub seq2length
{ $_[0]->{'seq2length'} = $_[1] if exists $_[1]; $_[0]->{'seq2length'}; }
sub subpart1
{ $_[0]->{'subpart1'} = $_[1] if exists $_[1]; $_[0]->{'subpart1'}; }
sub subpart2
{ $_[0]->{'subpart2'} = $_[1] if exists $_[1]; $_[0]->{'subpart2'}; }
sub conservation1
{ $_[0]->{'conservation1'} = $_[1] if exists $_[1]; $_[0]->{'conservation1'};}
sub conservation2
{ $_[0]->{'conservation2'} = $_[1] if exists $_[1]; $_[0]->{'conservation2'};}
sub exclude_orf
{ $_[0]->{'exclude_orf'} = $_[1] if exists $_[1]; $_[0]->{'exclude_orf'}; }
sub start_at
{ $_[0]->{'start_at'} = $_[1] if exists $_[1]; $_[0]->{'start_at'}; }
sub end_at
{ $_[0]->{'end_at'} = $_[1] if exists $_[1]; $_[0]->{'end_at'}; }
1;
TFBS-0.7.1/blib/lib/TFBS/MatrixSet.pm 0000664 0000000 0000000 00000031004 13057522667 0016762 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::MatrixSet
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::Matrix::Set - an agregate class representing a set of matrix patterns, containing methods for manipulating the set as a whole
=head1 SYNOPSIS
# creation of a TFBS::MatrixSet object
# let @list_of_matrix_objects be a list of TFBS::Matrix::* objects
###################################
# Create a TFBS::MatrixSet object:
my $matrixset = TFBS::MatrixSet->new(); # creates an empty set
$matrixset->add_Matrix(@list_of_matrix_objects); #add matrix objects to set
$matrixset->add_Matrix($matrixobj); # adds a single matrix object to set
# or, same as above:
my $matrixset = TFBS::MatrixSet->new(@list_of_matrix_objects, $matrixobj);
###################################
#
=head1 DESCRIPTION
TFBS::MatrixSet is an aggregate class storing a set of TFBS::Matrix::* subclass objects, and providing methods form manipulating those sets as a whole. TFBS::MatrixSet objects are created de novo or returned by some database (TFBS::DB::*) retrieval methods.
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are preceded with an underscore.
=cut
# The code begins HERE:
package TFBS::MatrixSet;
use vars '@ISA';
use PDL;
use Bio::Seq;
use Bio::SeqIO;
use Bio::Root::Root;
use File::Temp qw/:POSIX/;
use TFBS::Matrix;
use TFBS::_Iterator::_MatrixSetIterator;
use TFBS::SiteSet;
use strict;
@ISA = qw(Bio::Root::Root);
=head2 new
=cut
sub new {
my ($caller, @matrices) = shift;
my $self = bless {matrix_list =>[]}, ref($caller) || $caller;
$self->add_matrix(@matrices) if @matrices;
return $self;
}
=head2 add_matrix
Title : add_matrix
Usage : $matrixset->add_matrix(@list_of_matrix_objects);
Function: Adds matrix objects to matrixset
Returns : object reference (usually ignored)
Args : one or more TFBS::Matrix::* objects
=cut
sub add_matrix {
my ($self, @matrices) = @_;
foreach my $matrix (@matrices) {
$self->throw("Argument to add_matrix_set not a TFBS::Matrix object")
unless $matrix->isa("TFBS::Matrix");
}
push @{$self->{matrix_list}}, @matrices;
return $self;
}
=head2 add_matrix_set
Title : add_matrix
Usage : $matrixset->add_matrix(@list_of_matrixset_objects);
Function: Adds to the matrixset matrix objects contained in one or
more other matrixsets
Returns : object reference (usually ignored)
Args : one or more TFBS::MatrixSet objects
=cut
sub add_matrix_set {
my ($self, @sets) = @_;
foreach my $matrixset (@sets) {
$self->throw("Argument to add_matrix_set not a TFBS::Matrixset object")
unless $matrixset->isa("TFBS::MatrixSet");
push @{$self->{matrix_list}}, @{$matrixset->{matrix_list}};
}
}
sub reset {
my ($self) = @_;
$self->warn("reset: Deprecated method use Iterator instead.");
@{$self->{_iterator_list}} = @{$self->{matrix_list}};
}
sub sort_by_name {
my ($self) = @_;
$self->warn("sort_by_name: Deprecated method use Iterator instead.");
@{$self->{matrix_list}} = sort { uc($a->{name}) cmp uc ($b->{name}) }
@{$self->{matrix_list}};
$self->reset();
}
sub next {
my ($self) = @_;
$self->warn("next: Deprecated method use Iterator instead.");
if (my $next_matrix = shift (@{$self->{_iterator_list}})) {
return $next_matrix;
}
else {
$self->reset;
return undef;
}
}
=head2 search_seq
Title : search_seq
Usage : my $siteset = $matrixset->search_seq(%args)
Function: scans a nucleotide sequence with all patterns represented
stored in $matrixset;
It works only if all matrix objects in $matrixset understand
search_seq method (currently only TFBS::Matrix::PWM objects do)
Returns : a TFBS::SiteSet object
Args : # you must specify either one of the following three:
-file, # the name od a fasta file (single sequence)
#or
-seqobj # a Bio::Seq object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-seqstring # a string containing the sequence
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
=cut
sub search_seq {
my ($self, %args) = @_;
$self->_search(%args);
}
=head2 search_aln
Title : search_aln
Usage : my $site_pair_set = $matrixset->search_aln(%args)
Function: Scans a pairwise alignment of nucleotide sequences
with the pattern represented by the PWM: it reports only
those hits that are present in equivalent positions of both
sequences and exceed a specified threshold score in both, AND
are found in regions of the alignment above the specified
conservation cutoff value.
It works only if all matrix object in $matrixset understand
search_aln method (currently only TFBS::Matrix::PWM objects do)
Returns : a TFBS::SitePairSet object
Args : # you must specify either one of the following three:
-file, # the name of the alignment file in Clustal
format
#or
-alignobj # a Bio::SimpleAlign object
# (more accurately, a Bio::PrimarySeqobject or a
# subclass thereof)
#or
-alignstring # a multi-line string containing the alignment
# in clustal format
#############
-threshold, # minimum score for the hit, either absolute
# (e.g. 11.2) or relative (e.g. "75%")
# OPTIONAL: default "80%"
-window, # size of the sliding window (inn nucleotides)
# for calculating local conservation in the
# alignment
# OPTIONAL: default 50
-cutoff # conservation cutoff (%) for including the
# region in the results of the pattern search
# OPTIONAL: default "70%"
-subpart # subpart of the alignment to search, given as e.g.
# -subpart => { relative_to => 1,
# start => 140,
# end => 180 }
# where start and end are coordinates in the
# sequence indicated by relative_to (1 for the
# 1st sequence in the alignment, 2 for the 2nd)
# OPTIONAL: by default searches entire alignment
-conservation
# conservation profile, a TFBS::ConservationProfile
# OPTIONAL: by default the conservation profile is
# computed internally on the fly (less efficient)
=cut
sub search_aln {
my ($self, %args) = @_;
my $mxit = $self->Iterator();
my $sitepairset = TFBS::SitePairSet->new;
my $aln = TFBS::Matrix::_Alignment->new(%args);
while (my $mx = $mxit->next) {
my $singleset = $mx->search_aln(%args,
-alignment_setup => $aln);
$sitepairset->add_site_pair_set($singleset);
}
return $sitepairset;
}
=head2 size
Title : size
Usage : my $number_of_matrices = $matrixset->size;
Function: gets the number of matrix objects in the $matrixset
(i.e. the size of the set)
Returns : a number
Args : none
=cut
sub size {
scalar @{ $_[0]->{matrix_list} };
}
=head2 Iterator
Title : Iterator
Usage : my $matrixset_iterator =
$matrixset->Iterator(-sort_by =>'total_ic');
while (my $matrix_object = $matrix_iterator->next) {
# do whatever you want with individual matrix objects
}
Function: Returns an iterator object that can be used to go through
all members of the set
Returns : an iterator object (currently undocumentened in TFBS -
but understands the 'next' method)
Args : -sort_by # optional - currently it accepts
# 'ID' (alphabetically)
# 'name' (alphabetically)
# 'class' (alphabetically)
# 'total_ic' (numerically, decreasing order)
-reverse # optional - reverses the default sorting order if true
=cut
sub Iterator {
my ($self, %args) = @_;
return TFBS::_Iterator::_MatrixSetIterator->new($self->{matrix_list},
$args{'-sort_by'},
$args{'-reverse'}
);
}
sub _search {
my ($self, %args) = @_;
# DIRTY - stick tmp file name to seq object
my $seqobj = $self->_to_seqobj(%args);
($seqobj->{_fastaFH}, $seqobj->{_fastafile}) = tmpnam();
# we need $fastafile below
my $outstream = Bio::SeqIO->new(-file=>">".$seqobj->{_fastafile}, -format=>"Fasta");
my $subseqobj;
if(my $subpart = $args{-subpart}) {
my $subseq_start = $subpart->{-start};
my $subseq_end = $subpart->{-end};
unless($subseq_start and $subseq_end) {
$self->throw("Option -subpart missing suboption -relative_to, -start or -end");
}
$subseqobj = Bio::Seq->new(-seq => $seqobj->subseq($subseq_start, $subseq_end),
-id => $seqobj->id);
}
$outstream->write_seq($subseqobj or $seqobj);
$outstream->close;
# iterate through pwms
my @PWMs;
my $mxit = $self->Iterator();
while (my $pwm = $mxit->next() ) {
push @PWMs,$pwm;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm (@PWMs) {
my $threshold = ($args{-threshold} or $pwm->{minscore});
$hitlist->add_siteset($pwm->search_seq(-seqobj=>$seqobj,
-threshold =>$threshold,
-subpart=>$args{-subpart}));
}
delete $seqobj->{_fastaFH};
unlink $seqobj->{_fastafile};
delete $seqobj->{_fastafile};
return $hitlist;
}
sub _csearch {
my ($self, %args) = @_;
my $PWM_SEARCH = '/home/httpd/cgi-bin/CONSITE/bin/pwm_searchPFF';
# DIRTY - stick tmp file name to seq object
my $seqobj = $self->_to_seqobj(%args);
($seqobj->{_fastaFH}, $seqobj->{_fastafile}) = tmpnam();
# we need $fastafile below
my $seqFH = Bio::SeqIO->newFh(-fh=>$seqobj->{_fastaFH}, -format=>"Fasta");
print $seqFH $seqobj;
# iterate through pwms
my @PWMs;
$self->reset();
while (my $pwm = $self->next() ) {
push @PWMs,$pwm;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm (@PWMs) {
my $threshold = ($args{-threshold} or $pwm->{minscore});
$hitlist->add_siteset($pwm->search_seq(-seqobj=>$seqobj,
-threshold =>$threshold ));
}
delete $seqobj->{_fastaFH};
delete $seqobj->{_fastafile};
return $hitlist;
}
sub _bsearch {
my ($self,%args) = @_; #the rest of @_ goes to _to_seqob;
my @PWMs;
# prepare the sequence
my $seqobj = $self->_to_seqobj(%args);
$seqobj->{_pdl_matrix} = _seq_to_pdlmatrix($seqobj);
# prepare the PWMs
$self->reset();
while (my $pwm = $self->next() ) {
push @PWMs,$pwm;
}
# do the analysis
my $hitlist = TFBS::SiteSet->new();
foreach my $pwm (@PWMs) {
my $threshold = ($args{-threshold} or $pwm->{minscore});
$hitlist->add_siteset($pwm->bsearch(-seqobj=>$seqobj,
-threshold =>$threshold ));
}
delete $seqobj->{_pdl_matrix};
return $hitlist;
}
sub _seq_to_pdlmatrix {
# not OO - help function for search
my $seqobj = shift;
my $seqstring = uc($seqobj->seq());
my @perlarray;
foreach (qw(A C G T)) {
my $seqtobits = $seqstring;
eval "\$seqtobits =~ tr/$_/1/"; # curr. letter $_ to 1
eval "\$seqtobits =~ tr/1/0/c"; # non-1s to 0
push @perlarray, [split("", $seqtobits)];
}
return byte (\@perlarray);
}
sub _to_seqobj {
my ($self, %args) = @_;
my $seq;
if ($args{-file}) { # not a Bio::Seq
return Bio::SeqIO->new(-file => $args{-file},
-format => 'fasta',
-moltype => 'dna')->next_seq();
}
elsif ($args{-seqstring}
or $args{-seq})
{ # I guess it's a string then
return Bio::Seq->new(-seq => ($args{-seqstring} or $args{-seq}),
-id => ($args{-seq_id} or "undefined"),
-moltype => 'dna');
}
elsif ($args{'-seqobj'} and ref($args{'-seqobj'}) =~ /Bio\:\:Seq/) {
# do nothing (maybe check later)
return $args{'-seqobj'};
}
#elsif (ref($format) =~ /Bio\:\:Seq/ and !defined $seq) {
# if only one parameter passed and it's a Bio::Seq
#return $format;
#}
else {
$self->throw ("Wrong parameters passed to search method: ".%args);
}
# CONTINUE HERE TOMORROW
}
sub add_Matrix {
my ($self, @matrixlist) = @_;
foreach (@matrixlist) {
ref($_) =~ /TFBS::Matrix::/
or $self->throw("Attempted to add an element ".
"that is not a TFBS::Matrix object.");
push @{$self->{matrix_list}}, $_;
push @{$self->{_iterator_list}}, $_;
}
return 1;
}
1;
TFBS-0.7.1/blib/lib/TFBS/PatternGen.pm 0000664 0000000 0000000 00000011302 13057522667 0017110 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen
#
# Copyright Boris Lenhard
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen - a base class for pattern generators
=head1 DESCRIPTION
TFBS::PatternGen is a base class providing methods common to all pattern generating
modules. It is meant to be inherited by a concrete pattern generator, which must have its own
constructor.
=cut
package TFBS::PatternGen;
# Object preamble - inherits from TFBS::PatternGenI;
use vars qw(@ISA);
use strict;
use TFBS::PatternGenI;
# use TFBS::PatternGen::_Motif_;
use Bio::Seq;
use Bio::SeqIO;
use Carp;
@ISA = qw(TFBS::PatternGenI);
sub new {
confess("TFBS::PatterGen is a base class for particular pattern generators".
"and cannot be instantiated itself.");
}
=head2 pattern
Title : pattern
Usage : my $pattern_obj = $patterngen->pattern()
Function: retrieves a pattern object produced by the pattern generator
Returns : a pattern object (currently available pattern generators
return a TFBS::Matrix::PFM object)
Args : none
Warning : If a pattern generator produces more than one pattern,
this method call returns only the first one and prints
a warning on STDERR, In those cases you should use
I or I methods.
=cut
sub pattern {
my ($self, %args) =@_;
my @PFMs = $self->_motifs_to_patterns(%args);
if (scalar(@PFMs) > 1) {
$self->warn("The pattern generator produced multiple patterns. ".
"Please use patternSet method to retrieve a set object, ".
"or all_patterns method to retrieve an array of patterns");
}
return $PFMs[0];
}
=head2 patternSet
Title : patternSet
Usage : my $patternSet = $patterngen->patternSet()
Function: retrieves a pattern set object containing all the patterns
produced by the pattern generator
Returns : a pattern set object (currently available pattern generators
return a TFBS::MatrixSet object)
Args : none
=cut
sub patternSet {
my ($self, %args) = @_;
my @PFMs = $self->_motifs_to_patterns(%args);
my $set = TFBS::MatrixSet->new();
$set->add_matrix(@PFMs);
return $set;
}
=head2 all_patterns
Title : all_patterns
Usage : my @patterns = $patterngen->all_patterns()
Function: retrieves an array of pattern objects
produced by the pattern generator
Returns : an array of pattern set objects (currently available
pattern generators return an array of
TFBS::Matrix::PFM objects)
Args : none
=cut
sub all_patterns {
my ($self, %args) = @_;
my @patterns = $self->_motifs_to_patterns(%args);
return @patterns;
}
sub _create_seq_set {
my ($self, %args) = @_;
my (@raw_set, @final_set);
if ($args{-seq_list}) {
@raw_set = @{$args{-seq_list}};
}
elsif ($args{-seq_stream} ) {
while (my $seqobj = $args{-seq_stream}->next_seq()) {
push @raw_set, $seqobj;
}
}
elsif ($args{-seq_file} ) {
my $seqstream = Bio::SeqIO->new(-file=>$args{-seq_file},
-format=>"fasta");
while (my $seqobj = $seqstream->next_seq()) {
push @raw_set, $seqobj;
}
}
foreach my $seqobj (@raw_set) {
my $i = 1; #for unnamed sequences
if (ref($seqobj)) {
my $seqstring;
eval { $seqstring = $seqobj->seq() };
if ($@) {
$self->throw("Invalid sequence object passed in -seq_set.");
}
else {
_validate_seq(uc $seqstring)
or $self->throw("Illegal character(s) in sequence: $seqstring");
}
push @final_set, $seqobj;
}
else {
my $seqstring = $seqobj;
_validate_seq(uc $seqstring)
or $self->throw("Illegal character(s) in sequence: $seqstring");
push @final_set, Bio::Seq->new(-seq=>$seqstring,
-ID=>"unnamed".$i++,
-type=>"dna");
}
}
$self->{'seq_set'} = \@final_set;
return 1;
}
sub _motifs_to_patterns {
my ($self, %args) = @_;
my $i = 1;
my @patterns;
my %params = ( -name => "motif",
-ID => "motif",
-class => "unknown",
%args);
foreach my $motif (@{ $self->{'motifs'} }) {
push @patterns, $motif->pattern(-name => $params{-name}.$i,
-ID => $params{-ID}."#".$i,
-class => $params{-class});
$i++;
}
return @patterns;
}
sub _validate_seq {
# a utility function
my $sequence = uc $_[0];
$sequence=~ s/[ACGT]//g;
return ($sequence eq "" ? 1 : 0);
}
sub _check_seqs_for_uniform_length {
my $self = shift;
my $reflength = $self->{'seq_set'}->[-1]->length();
foreach my $seqobj ( @{ $self->{'seq_set'} } ) {
if ($seqobj->length() != $reflength) {
$self->throw(ref($self). "object has received sequences of unequal length");
}
}
}
sub all_motifs {
return @{$_[0]->{'motifs'}} if $_[0]->{'motifs'};
}
TFBS-0.7.1/blib/lib/TFBS/PatternGen/ 0000775 0000000 0000000 00000000000 13057522667 0016555 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/TFBS/PatternGen/AnnSpec.pm 0000664 0000000 0000000 00000014005 13057522667 0020442 0 ustar 00root root 0000000 0000000
# TFBS module for TFBS::PatternGen::AnnSpec
#
# Copyright Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec - a pattern factory that uses the AnnSpec program
=head1 SYNOPSIS
my $patterngen =
TFBS::PatternGen::AnnSpec->new(-seq_file=>'sequences.fa',
-binary => 'ann-spec '
my $pfm = $patterngen->pattern(); # $pfm is now a TFBS::Matrix::PFM object
=head1 DESCRIPTION
TFBS::PatternGen::AnnSpec builds position frequency matrices
using an external program AnnSpec (Workman, C. and Stormo, G.D. (2000) ANN-Spec: A method for discovering transcription factor binding sites with improved specificity. Proc. Pacific Symposium on Biocomputing 2000).
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Wynand Alkema
Wynand Alkema EWynand.Alkema@cgb.ki.seE
=cut
package TFBS::PatternGen::AnnSpec;
use vars qw(@ISA);
use strict;
# Object preamble - inherits from TFBS::PatternGen;
use TFBS::PatternGen;
use TFBS::PatternGen::AnnSpec::Motif;
use File::Temp qw(:POSIX);
use Bio::Seq;
use Bio::SeqIO;
@ISA = qw(TFBS::PatternGen);
=head2 new
Title : new
Usage : my $pattrengen = TFBS::PatternGen::AnnSpec->new(%args);
Function: the constructor for the TFBS::PatternGen::AnnSpec object
Returns : a TFBS::PatternGen::AnnSpec object
Args : This method takes named arguments;
you must specify one of the following three
-seq_list # a reference to an array of strings
# and/or Bio::Seq objects
# or
-seq_stream # A Bio::SeqIO object
# or
-seq_file # the name of the fasta file containing
# all the sequences
Other arguments are:
-binary # a fully qualified path to the 'meme' executable
# OPTIONAL: default 'ann-spec'
-additional_params # a string containing additional
# command-line switches for the
# ann-spec program
=cut
sub new {
my ($caller, %args) = @_;
my $self = bless {}, ref($caller) || $caller;
$self->{'filename'} =$args{'-seq_file'};
$self->{'additional_params'} =
($args{'-additional_params'}
? (ref($args{'-additional_params'})
? join(' ', @{$args{'-additional_params'}})
: $args{'-additional_params'})
: "" );
$self->{'binary'} = $args{'-binary'} || 'ann-spec';
$self->_create_seq_set(%args) or die ('Error creating sequence set');
$self->_run_AnnSpec() or $self->throw("Error running AnnSpec.");
return $self;
}
=head2 pattern
=head2 all_patterns
=head2 patternSet
The three methods listed above are used for the retrieval of patterns,
and are common to all TFBS::PatternGen::* classes. Please
see L for details.
=cut
sub _run_AnnSpec{
my ($self)=shift;
my $tmp_file = tmpnam();
my $outstream = Bio::SeqIO->new(-file=>">$tmp_file", -format=>"fasta");
foreach my $seqobj (@{ $self->{'seq_set'} } ) {
$outstream->write_seq($seqobj);
}
$outstream->close();
my $command_line =
$self->{'binary'}." ".
"-p ".$tmp_file." ".
# $self->{'motif_length_string'}." ".
# $self->{'nr_hits_string'}." ".
$self->{'additional_params'}.
"";
# print STDERR "$command_line\n";
my $resultstring = `$command_line`;
# print STDERR $resultstring;
$self->_parse_AnnSpec_output($resultstring,$command_line);
unlink $tmp_file;
return 1
}
sub _parse_AnnSpec_output{
my ($self,$resultstring,$command_line)=@_;
if ($resultstring eq''){
# warn "Error running AnnSpec\nNo patterns produced";
$self->throw ("Error running AnnSpec using command:\n $command_line");
return;
}
my ($consensus,$matrix)=$self->_parse_raw_matrix($resultstring);
my ($score,$sites)=$self->_parse_sites($resultstring);
my $motif =TFBS::PatternGen::AnnSpec::Motif->new
(
#-length => $length."",
# -bg_probabilities => [split /\s+/, $raw_bp],
-tags => {consensus => $consensus,
score=>$score},
-nr_hits => 1,
-sites=>$sites,
-matrix => $matrix
);
push @{ $self->{'motifs'} }, $motif;
return
}
sub _parse_sites{
my ($self,$string)=@_;
# print $raw_motif;
my @hits;
my ($sites)=$string=~/STR BEST_SITES\n(.*)STR ave\(S\)/s;
my ($average)=$string=~/STR ave\(S\)\s+(\d*\.*\d*)/;
my ($score)=$string=~/STR ln\(ave\(sum\(exp\(S\)\)\)\)\s+(\d*\.*\d*)/;
# print STDERR $score,"\n";
my @sites=split/\n/,$sites;
shift @sites;
# print "@sites\n";
foreach my $site (@sites){
my @site_array=split(/\s+/,$site);
# print "$site_array[3]\n";
# print "$site_array[5]\n";
my ($seq_id)=$site_array[5]=~/>(.*)/;
my $strand=1;
$strand=-1 if $site_array[3]=~/\'/;#MEans we have a pattern in the reverse strand
my ($start)=$site_array[3]=~/(\d+)/;
my $site = Bio::SeqFeature::Generic->new ( -start => $start,
-end => $start+(length$site_array[4])-1,
-strand => $strand,
-source => 'AnnSpec',
-score => $site_array[2],
);
#
foreach my $seq(@{$self->{'seq_set'}}){
if ($seq->id eq $seq_id){
$site->attach_seq ($seq);
}
}
push (@hits,$site);
}
return $score,\@hits;
}
sub _parse_raw_matrix{
my ($self,$string)=@_;
my ($matrix)=$string=~/ALR ALIGNMENT_MATRIX.*ALR\s+-+(.*)ALR CONSENSUS/s;
my ($consensus)=$string=~/ALR CONSENSUS (.*)\n/;
#print $consensus;
my @matrix=split("\n",$matrix);
shift @matrix;
my @pfm;
foreach my $row(@matrix){
# print $row;
my @row=split /\s+/, $row;
push @pfm, [@row[2..scalar@row-1]];
}
return $consensus, \@pfm;
}
1;
TFBS-0.7.1/blib/lib/TFBS/PatternGen/AnnSpec/ 0000775 0000000 0000000 00000000000 13057522667 0020104 5 ustar 00root root 0000000 0000000 TFBS-0.7.1/blib/lib/TFBS/PatternGen/AnnSpec/Motif.pm 0000664 0000000 0000000 00000002311 13057522667 0021515 0 ustar 00root root 0000000 0000000 # TFBS module for TFBS::PatternGen::AnnSpec::Motif
#
# Copyright Boris Lenhard and Wynand Alkema
#
# You may distribute this module under the same terms as perl itself
#
# POD
# POD
=head1 NAME
TFBS::PatternGen::AnnSpec::Motif - class for unprocessed motifs and associated
numerical scores created by the Gibbs program
=head1 SYNOPSIS
=head1 DESCRIPTION
TFBS::PatternGen::AnnSpec::Motif is used to store and manipulate unprocessed
motifs and associated numerical scores created by the AnnSpec program. You do not
normally want to create a TFBS::PatternGen::AnnSpec::Motif yourself. They are created
by running TFBS::PatternGen::AnnSpec
=head1 FEEDBACK
Please send bug reports and other comments to the author.
=head1 AUTHOR - Boris Lenhard and Wynand Alkema
Boris Lenhard EBoris.Lenhard@cgb.ki.seE
Wynand Alkema EWynand.Alkema@cgb.ki.seE | |