File Coverage

blib/lib/Bio/Metabolic/Network.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

=head1 NAME

Bio::Metabolic::Network - Perl extension for biochemical reaction networks

=head1 SYNOPSIS

  use Bio::Metabolic::Network;

  my $net = Bio::Metabolic::Network->new($reaction1, $reaction2, ... );


=head1 DESCRIPTION

This class implements objects representing biochemical reaction networks.
A reaction network is defined a number of biochemical reactions.

=head2 EXPORT

None

=head2 OVERLOADED OPERATORS

  String Conversion
    $string = "$network";
    print "\$network = '$network'\n";

  Comparison
    if ($network1 <= $network2)...


=head1 AUTHOR

Oliver Ebenhoeh, [e-mail]

=head1 SEE ALSO

Bio::Metabolic Bio::Metabolic::Substrate Bio::Metabolic::Substrate::Cluster Bio::Metabolic::Reaction.

=cut

package Bio::Metabolic::Network;

require 5.005_62;
use strict;
use warnings;

require Exporter;

use Bio::Metabolic::Substrate;
use Bio::Metabolic::Substrate::Cluster;
use PDL;
use PDL::Matrix;

#use Math::Symbolic;
#use Math::Symbolic::VectorCalculus;

#use PDL::Matrix::Extras;

use Carp;

use overload
  "\"\"" => \&network_to_string,
  "+"    => \&add_networks,
  "<="   => \&is_in,
  ">="   => sub {
    my $n1 = shift;
    my $n2 = shift;
    return ( $n2 <= $n1 );
  },
  "==" => sub {
    my $n1 = shift;
    my $n2 = shift;
    return ( $n1 <= $n2 && $n2 <= $n1 );
  };

our @ISA = qw(Exporter);

# 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 Bio::Metabolic::Network ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = (
    'all' => [
        qw(

          )
    ]
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);
our $VERSION = '0.07';

our %OutputFormat = (
    'substrate' => "%20s",
    'entry'     => "%5d"
);

# Below is stub documentation for your module. You better edit it!

=head1 METHODS

=head2 Constructor new

Returns a new Bio::Metabolic::Network object.
Passed arguments must be Bio::Metabolic::Reaction objects.

Every network object is associated with a matrx, the stoichiometric matrix.
This matrix is defined by the reactions and gets determined upon creation.

=cut

sub new {
    my $pkg       = shift;
    my @reactions = @_ ? $_[0] =~ /ARRAY/ ? @{ $_[0] } : @_ : ();

    #  my $reactions = @_ ? shift : [ ];

    #  $reactions = [$reactions, @_] unless ref($reactions) =~ /ARRAY/;

    my $new_network = bless { reactions => \@reactions } => $pkg;
    $new_network->new_matrix;

    return $new_network;
}

=head2 Method copy

Returns a clone of the network.
However, the references to the reactions point to exactly the same reactions.
If one gets modified, it effects all networks with that reaction.

=cut

sub copy {
    my $orig = shift;
    return ref($orig)->new( $orig->reactions );
}

=head2 Method reactions

Returns an arrayref of the reactions.

=cut

sub reactions {
    return shift->{'reactions'};
}

=head2 Method has_reaction

Argument is a reaction. Returns 1 if the network contains the raction, 0 otherwise.

=cut

sub has_reaction {
    my ( $network, $reaction ) = @_;

    my $nr    = 0;
    my @rlist = @{ $network->reactions };

    #  print "rlist has ".eval(@rlist)." elements\n";
    foreach my $netr (@rlist) {
        $nr++ if ( $netr == $reaction );
    }

    return $nr;
}

=head2 Method add_reaction

Argument is a Bio::Metabolic::Reaction.
Alters the object in-line, adding the reaction to the list.

=cut

sub add_reaction {
    my ( $network, $reaction ) = @_;

    unless ( $network->has_reaction($reaction) ) {
        push( @{ $network->reactions }, $reaction );
        $network->new_matrix;
    }
}

=head2 Method remove_reaction

Argument is a Bio::Metabolic::Reaction.
Altering the object in-line, removeing the reaction from the network.
Return undef if network did not have the reaction, 1 on success.

=cut

sub remove_reaction {
    my ( $network, $reaction ) = @_;

    return undef unless $network->has_reaction($reaction);

    my $cut  = 0;
    my $netr = $network->reactions;
    my $cnt  = 0;
    while ( $cnt < @$netr ) {
        if ( $netr->[$cnt] == $reaction ) {
            splice( @$netr, $cnt, 1 );
            $network->new_matrix;
            $cut++;
        }
        else {
            $cnt++;
        }
    }

    #  print "remove_reaction: $cut removed.\n";
    return $cut;
}

=head2 Method network_to_string

Returns a string representation of the network

=cut

sub network_to_string {
    my $network = shift;

    my @rlist  = @{ $network->reactions };
    my $nr     = @rlist;
    my $retstr = "$nr reactions:\n";
    foreach my $r (@rlist) {
        $retstr .= $r . "-------------------------------------------\n";
    }
    return $retstr;
}

=head2 Method add_networks

Adds an arbitrary number of networks, returning a new object containing all reactions that are
contained at least present in one of the networks.

=cut

sub add_networks {
    my @nets = @_;

    # this is due to an extra value passed by the overload Module
    pop(@nets) if ( ref( $nets[ @nets - 1 ] ) ne ref( $nets[0] ) );

    croak("add_network needs at least one network!") if @nets == 0;

    my $newnet = ref( $nets[0] )->new;

    foreach my $network (@nets) {
        foreach my $reaction ( @{ $network->reactions } ) {
            $newnet->add_reaction($reaction);
        }
    }

    return $newnet;
}

=head2 Method is_in

$net1->is_in($net2) Returns 1 if all reactions in $net1 also occur in $net2,
i.e. if $net1 is a subnetwork of $net2.

=cut

sub is_in {
    my ( $net1, $net2 ) = @_;

    foreach my $reaction ( @{ $net1->reactions } ) {
        return 0 unless $net2->has_reaction($reaction);
    }

    return 1;
}

=head2 Method dist

Provides a distance measure between networks. Returns the number of reactions that are
different in the two networks.

=cut

sub dist {
    my ( $net1, $net2 ) = @_;

    my @r1 = @{ $net1->reactions };
    my @r2 = @{ $net2->reactions };

    my $dist = @r1 > @r2 ? @r1 : @r2;
    foreach my $reaction (@r1) {
        $dist-- if $net2->has_reaction($reaction);
    }

    return $dist;
}

=head2 Method substrates

Returns a Bio::Metabolic::Substrate::Cluster containing all substrates participating in at least
one reaction.
=cut

sub substrates {
    my $network = shift;

    my $cluster = Bio::Metabolic::Substrate::Cluster->new;

    return $cluster->add_clusters(
        map( $_->substrates, @{ $network->reactions } ) );
}

=head2 Method matrix

Returns the stoichiometric matrix of the network as a PD::Matrix object.

=cut

sub matrix {
    my $network = shift;

    $network->{matrix} = shift if @_;
    return $network->{matrix};
}

=head2 Method new_matrix

determines the stoichiometric matrix of the network defined by its reactions.

=cut

sub new_matrix {
    my $network = shift;

    my $reactions  = $network->reactions;
    my $substrates = $network->substrates;

    my @slist = $substrates->list;
    my $cols  = @$reactions;
    my $rows  = @slist;

    #  croak("cannot create matrix from nothing!") if $cols == 0 || $rows == 0;
    if ( $cols == 0 || $rows == 0 ) {
        $network->matrix( PDL::Matrix->null );
        return undef;
    }

    my $matrix = mzeroes( $rows, $cols );

    for ( my $r = 0 ; $r < $cols ; $r++ ) {
        foreach my $substrate ( $reactions->[$r]->substrates->list ) {
            my $s = $substrates->which($substrate);

            $matrix->set( $s, $r,
                $matrix->at( $s, $r ) +
                  $reactions->[$r]->stoichiometry->{ $substrate->name } );
        }
    }

    $network->matrix($matrix);
}

=head2 Method print_matrix

Prints the matrix in a way that describes which substrates are associated with which rows
and which reactions with which columns.

=cut

sub print_matrix {
    my $network = shift;

    my $m     = $network->matrix;
    my @slist = $network->substrates->list;

    # changed 7.11.02
    #  my ($cols,$rows) = $m->dims;
    my ( $rows, $cols ) = $m->mdims;

    my $retstr = sprintf( $OutputFormat{'substrate'}, "" );
    for ( my $r = 0 ; $r < $cols ; $r++ ) {
        $retstr .= sprintf( $OutputFormat{'entry'}, $r );
    }
    $retstr .= "\n";

    for ( my $s = 0 ; $s < $rows ; $s++ ) {
        $retstr .= sprintf( $OutputFormat{'substrate'}, $slist[$s] . ": [" );
        for ( my $r = 0 ; $r < $cols ; $r++ ) {

            # changed 7.11.02
            #      $retstr .= sprintf($OutputFormat{'entry'},$m->at($r,$s));
            $retstr .= sprintf( $OutputFormat{'entry'}, $m->at( $s, $r ) );
        }
        $retstr .= "]\n";
    }

    return $retstr;
}

sub can_convert {
    my $network = shift;

    my @substrates = ();
    if (@_) {
        if ( ref( $_[0] ) eq 'Bio::Metabolic::Substrate::Cluster' ) {
            @substrates = shift->list;
        }
        elsif ( ref( $_[0] ) eq 'ARRAY' ) {
            @substrates = @{ shift() };
        }
        else {
            @substrates = @_;
        }
    }

    my @ex_indices = ();
    my $slist      = $network->substrates;
    foreach my $ext (@substrates) {
        push( @ex_indices, $slist->which($ext) ) if defined $slist->which($ext);
    }

    #  print "deleting rows (".join(',',@ex_indices).")\n";
    my $reduced = $network->matrix->copy;
    $reduced->delrows(@ex_indices);

    #  print "reduced matrix is : $reduced\n";

    my $kernel = $reduced->kernel();

    #  print "kernel is $kernel\n";
    return undef if $kernel->isempty;

    #  my ($kerneldim,$nor) = $kernel->dims();

    my $convert = $network->matrix x $kernel;

    #  print "convert: $convert\n";
    foreach my $ext (@ex_indices) {

        # changed 8.11.02
        #    my $res = $convert->slice(":,($ext)");
        my $res = $convert->slice("($ext),:");
        return undef if ( $res->where( $res != 0 )->isempty );
    }

    return $kernel;
}

sub is_elementary {
    my $net = shift;

    my $kernel = $net->can_convert(@_);

    return undef unless defined($kernel);

    my @kdims = $kernel->mdims;

    return undef if $kdims[1] != 1;

    return undef if which( $kernel->slice(":,(0)") == 0 )->nelem > 0;

    my $conversion = $net->matrix x $kernel;
    my @cdims      = $conversion->mdims;

    return undef
      if which( $conversion->slice(":,(0)") == 0 )->nelem == $cdims[0];

    return $kernel;
}

1;
__END__