File Coverage

blib/lib/SNA/Network/Algorithm/Louvain.pm

Criterion	Covered	Total	%
statement	130	130	100.0
branch	24	24	100.0
condition	2	2	100.0
subroutine	13	13	100.0
pod	1	1	100.0
total	170	170	100.0

package SNA::Network::Algorithm::Louvain;

use strict;
use warnings;

require Exporter;
use base qw(Exporter);
our @EXPORT = qw(identify_communities_with_louvain);

use SNA::Network::Community;

use List::Util qw(sum);
use List::MoreUtils qw(uniq);


=head1 NAME

SNA::Network::Algorithm::Louvain - identifies communities with the Louvain-method developed by Blondel and Guillaume and Lamboitte and Lefebvre


=head1 SYNOPSIS

    use SNA::Network;

    my $net = SNA::Network->new();
    $net->load_from_pajek_net($filename);
    ...
    my $num_communities = $net->identify_communities_with_louvain;


=head1 METHODS

The following methods are added to L.

=head2 identify_communities_with_louvain

Performs the community identification algorithm and returns the number of communities it identified. The corresponding L objects can be accessed with the C method of L.

=cut

sub identify_communities_with_louvain {
	my ($self, $level) = @_;
	$level ||= 0;
	$self->{louvain_levels} = $level;

	$self->{total_weight} = $self->total_weight;

	# initialize communities
	foreach ($self->nodes) {
		$_->{community} = $_->index;
		$_->{_k_i} = $_->weighted_summed_degree;
		_propagate_new_community_id($_) if $level > 0;
	}
	my @communities = map {
		SNA::Network::Community->new(
			network     => $self,
			index       => $_->index,
			members_ref => [$_],
			w_in        => $level > 0 ? $_->loop->weight : 0,
			w_tot       => $_->{_k_i} - ($level > 0 ? $_->loop->weight : 0),
		)
	} $self->nodes;

	$self->{communities_ref} = \@communities;

	my $has_changed = 0;
	my $has_improved;

	PHASE_ONE_ITERATIONS:
	do {
		$has_improved = 0;

		foreach my $node_i ($self->nodes) {
			my $max_gain = 0;
			my $best_community_id;

			$node_i->{_k_i_in} = sum(
				$level > 0 ? - $node_i->loop->weight : 0,
				map {
					$_->weight
				} grep {
					$_->source->community == $_->target->community
				} $node_i->edges
			);

			my $current_community = @communities[ $node_i->community ];

			# gain in current community on removal
			my $current_community_module = _module_value(
				$current_community->w_in,
				$current_community->w_tot,
				$self->{total_weight},
			);

			my $new_current_community_module = _module_value(
				$current_community->w_in - $node_i->{_k_i_in},
				$current_community->w_tot - $node_i->{_k_i} + $node_i->{_k_i_in},
				$self->{total_weight},
			);

			my $gain_on_removal = $new_current_community_module - $current_community_module;

			# pre-calculate k_i_new values for all neighbour communities
			foreach ($node_i->outgoing_edges) {
				$node_i->{_k_i_new}->{ $_->target->community } += $_->weight
			}

			foreach ($node_i->incoming_edges) {
				$node_i->{_k_i_new}->{ $_->source->community } += $_->weight
			}

			if ($level > 0) {
				my $loop_weight = $node_i->loop->weight;

				foreach ( values %{ $node_i->{_k_i_new} } ) {
					$_ += $loop_weight;
				}
			}

			my @neighbour_community_ids = uniq grep {
				$_ != $node_i->community
			} map {
				$_->community
			} $node_i->related_nodes;

			foreach my $neighbour_community_id (@neighbour_community_ids) {
				# calculate modularity changes
				my $gain_on_addition = _modularity_gain($self, $node_i, $neighbour_community_id);
				my $gain = $gain_on_removal + $gain_on_addition;

				if ( $gain > $max_gain ) {
					$max_gain = $gain;
					$best_community_id = $neighbour_community_id;
				}
			}

			if ( $max_gain > 0.0000001 ) {
				# merge node to best community

				_switch_community($self, $node_i, $best_community_id);
				$has_improved = 1;
				$has_changed = 1;
			}

			undef $node_i->{_k_i_in};
			undef $node_i->{_k_i_new};
		}
	} while ($has_improved);

	return @communities unless $has_changed;
	$self->{louvain_levels} += 1;

	# consolidate community structure;
	_consolidate_community_structure($self);


	PHASE_TWO:

	# merge communities to new nodes in a new network
	my $next_level_network = _create_next_level_network($self);

	# apply the algorithm recursively to the new network
	my @new_community_structure = $next_level_network->identify_communities_with_louvain($level + 1);

	$self->{louvain_levels} = $next_level_network->{louvain_levels};
	return @new_community_structure if $level > 0;

	foreach my $community (@new_community_structure) {
		$community->{members_ref} = [ grep {
			$_->community == $community->index
		} $self->nodes ];
	};

	$self->{communities_ref} = \@new_community_structure;
	return int $self->communities;
}


sub _modularity_gain {
	my ($net, $node_i, $new_community_id) = @_;
	my $new_community = $net->{communities_ref}->[$new_community_id];

	my $k_i_new = $node_i->{_k_i_new}->{ $new_community_id };

	my $neighbour_community_module = _module_value(
		$new_community->w_in,
		$new_community->w_tot,
		$net->{total_weight},
	);

	my $new_neighbour_community_module = _module_value(
		$new_community->w_in + $k_i_new,
		$new_community->w_tot + $node_i->{_k_i} - $k_i_new,
			$net->{total_weight},
	);

	return $new_neighbour_community_module - $neighbour_community_module;
}


sub _module_value {
	my ($w_in, $w_tot, $w_net) = @_;
	return $w_in / $w_net - ( ( $w_in + $w_tot ) / ( 2 * $w_net ) ) ** 2;
}


sub _switch_community {
	my ($net, $node, $new_community_id) = @_;
	my $current_community = $net->{communities_ref}->[ $node->community ];
	my $new_community = $net->{communities_ref}->[$new_community_id];

	@{ $current_community->members_ref } = grep {
		$_ != $node
	} $current_community->members;

	push @{ $new_community->{members_ref} }, $node;

	$node->{community} = $new_community_id;

	$current_community->{w_in}  -= $node->{_k_i_in};
	$current_community->{w_tot} -= $node->{_k_i} - $node->{_k_i_in};

	$new_community->{w_in}  += $node->{_k_i_new}->{ $new_community_id };
	$new_community->{w_tot} += $node->{_k_i} - $node->{_k_i_new}->{ $new_community_id };
}


sub _consolidate_community_structure {
	my ($self) = @_;

	@{$self->{communities_ref}} = grep {
		int $_->members > 0
	} $self->communities;

	for my $index (0 .. int($self->communities) - 1) {
		$self->{communities_ref}->[$index]->{index} = $index;
		foreach my $member ($self->{communities_ref}->[$index]->members) {
			$member->{community} = $index;
		}
	}
}


sub _create_next_level_network {
	my ($net) = @_;

	my $next_level_network = SNA::Network->new;
	foreach my $community ($net->communities) {
		my $new_node = $next_level_network->create_node(
			community    => $community->index,
			subcommunity => $community,
		);
		$next_level_network->create_edge(
			source_index => $new_node->index,
			target_index => $new_node->index,
			weight       => $community->w_in,
		);
	}

	my $nc = int $net->communities;
	my @edge_weights = map { {} } 1 .. $nc;
	foreach my $edge ($net->edges) {
		$edge_weights[ $edge->source->community ]->{ $edge->target->community } += $edge->weight;
	}

	foreach my $meta_node ($next_level_network->nodes) {
		PEERS:
		foreach my $peer_node ($next_level_network->nodes) {
			next PEERS if $meta_node == $peer_node;
			my $weight = $edge_weights[ $meta_node->index ]->{ $peer_node->index };

			if ($weight) {
				$next_level_network->create_edge(
					source_index => $meta_node->index,
					target_index => $peer_node->index,
					weight       => $weight,
				);
			}
		}
	}

	return $next_level_network;
}


sub _propagate_new_community_id {
	my ($node) = @_;
	if ($node->{subcommunity}) {
		foreach my $sub_member ($node->{subcommunity}->members) {
			$sub_member->{community} = $node->community;
			_propagate_new_community_id($sub_member);
		}
	}
}


=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 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2012 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;