File Coverage

blib/lib/SNA/Network/Filter/Guess.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	10	16	62.5
condition	2	4	50.0
subroutine	12	12	100.0
pod	3	3	100.0
total	98	106	92.4

package SNA::Network::Filter::Guess;

use strict;
use warnings;

require Exporter;
use base qw(Exporter);
our @EXPORT = qw(load_from_gdf new_from_gdf save_to_gdf);

use Carp;
use English;
use List::MoreUtils qw(pairwise);


=head1 NAME

SNA::Network::Filter::Guess - load and save networks from/to Guess .gdf files


=head1 SYNOPSIS

    use SNA::Network;

    my $net = SNA::Network->new();
    $net->load_from_gdf($filename);
    ...
    # shortcut
    my $net = SNA::Network->new_from_gdf($filename);
    ...
    $net->save_to_gdf(filename => $filename, edge_fields => ['weight']);


=head1 DESCRIPTION

This enables import/export to the GUESS data format.
See L for details about the format.


=head1 METHODS

The following methods are added to L.

=head2 load_from_gdf

load a network from a passed filename.
Nodes and edges are created with the fields specified in the file.
They are accessible as hash entries of the objects.

=cut

sub load_from_gdf {
	my ($self, $filename) = @_;
	open my $GDF_FILE, '<', $filename or croak "cannot open '$filename': $OS_ERROR\n";

	my $line;

	# search start of node definitions
	START:
	while (defined($line = <$GDF_FILE>)) {
		last START if $line =~ m/^nodedef>/;
	}
	$line =~ m/^nodedef> (.+)$/;
	my ($name, $label, @fields) = split /,/, $1;
	foreach (@fields) {
		s/\s*(\w+).*/$1/
	}

	# read nodes and create graph nodes
	NODES:
	while (defined($line = <$GDF_FILE>)) {
		last NODES if $line =~ m/^edgedef> (.+)$/;

		#chomp $line;
		$line =~ s/\s//g;
		my ($node_number, $node_name, @field_values) = split ',', $line;

		$self->create_node_at_index(
			index => _extract_index($node_number),
			name  => $node_name,
			(pairwise { ($a, $b) } @fields, @field_values)
		);
	}

	# read arcs and create graph edges
	$line =~ m/^edgedef> (.+)$/;
	my ($node1, $node2);
	($node1, $node2, @fields) = split /,/, $1;
	foreach (@fields) {
		s/\s*(\w+).*/$1/
	}

	EDGES:
	while (defined($line = <$GDF_FILE>)) {
		last EDGES unless $line =~ m/\s*\w+,\s*\w+/;

		$line =~ s/\s//g;
		my ($source, $target, @field_values) = split ',', $line;
		$self->create_edge(
			source_index => _extract_index($source),
			target_index => _extract_index($target),
			(pairwise { ($a, $b) } @fields, @field_values)
		);
	}

	close $GDF_FILE or croak "cannot close '$filename': $OS_ERROR\n";
}


=head2 new_from_gdf

Returns a newly created network from a passed filename.
Nodes and edges are created with the fields specified in the file.
They are accessible as hash entries of the objects.

=cut

sub new_from_gdf {
	my ($package, $filename) = @_;
	my $net = $package->new;
	$net->load_from_gdf($filename);
	return $net;
}



=head2 save_to_gdf

Saves the current network to a GDF file.
The named parameters are B,
and optionally array references in B and B,
that will write the corresponding hash entries of the objects into the file.

=cut

sub save_to_gdf {
	my ($self, %params) = @_;
	croak "no filename passed to save_to_gdf!" unless $params{filename};
	$params{node_fields} ||= [];
	$params{edge_fields} ||= [];

	open my $GDF_FILE, '>', $params{filename} or croak "cannot open '$params{filename}': $OS_ERROR\n";

	# process nodes
	printf $GDF_FILE "nodedef> %s\n", join ',', ('name', 'label', @{ $params{node_fields} });

	foreach my $node ($self->nodes()) {
		printf $GDF_FILE "%s\n", join(',',
			'n' . ($node->index() + 1),
			$node->{name},
			map { $node->{$_} } @{ $params{node_fields} }
		);
	}

	# process edges
	printf $GDF_FILE "edgedef> %s\n", join ',', qw(node1 node2 directed), @{ $params{edge_fields} };

	foreach my $edge ($self->edges()) {
		printf $GDF_FILE "%s\n", join(',',
			( map { 'n' . ($_->index() + 1) } ($edge->source(), $edge->target()) ),
			'true',
			( map { $edge->{$_} } @{ $params{edge_fields} } )
		);
	}

	close $GDF_FILE or croak "cannot close '$params{filename}': $OS_ERROR\n";
}


sub _extract_index {
	my ($node_name) = @_;
	$node_name =~ m/\D+(\d+)/;
	return $1 - 1;
}


=head1 AUTHOR

Darko Obradovic, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc SNA::Network


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 COPYRIGHT & LICENSE

Copyright 2009 Darko Obradovic, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of SNA::Network::Filter::Guess