add Graph::GEXF while it's not on CPAN

Signed-off-by: franck cuny <franck@lumberjaph.net>

10 files changed, 710 insertions, 0 deletions

diff --git a/lib/Graph/GEXF.pm b/lib/Graph/GEXF.pm
new file mode 100644
index 0000000..f226b06
--- /dev/null
+++ b/lib/Graph/GEXF.pm
@@ -0,0 +1,177 @@
+package Graph::GEXF;
+
+# ABSTRACT: Manipulate graph file in GEXF
+
+use Moose;
+
+use Data::UUID::LibUUID;
+use Moose::Util::TypeConstraints;
+
+use Graph::GEXF::Node;
+
+with
+  'Graph::GEXF::Role::XML',
+  'Graph::GEXF::Role::Attributes' =>
+  { for => [qw/node edge/], with_method => 1 };
+
+=attr visualization (B<Boolean>)
+
+if set to true, the generated graph will includes visualizations informations
+
+=cut
+
+has visualization => (
+    is        => 'ro',
+    isa       => 'Bool',
+    predicate => 'has_visualization',
+);
+
+=attr graph_mode (B<static|dynamic>)
+
+Is your graph static or dynamic.
+
+=cut
+
+has graph_mode => (
+    is       => 'ro',
+    isa      => enum( [qw/static dynamic/] ),
+    required => 1,
+    default  => 'static',
+);
+
+=attr edge_type (B<directed|undirected|mutual|notset>)
+
+The type of the edges
+
+=cut
+
+has edge_type => (
+    is       => 'ro',
+    isa      => enum( [qw/directed undirected mutual notset/] ),
+    required => 1,
+    default  => 'directed',
+);
+
+=attr nodes
+
+a HashRef of L<Graph::GEXF::Node> objects.
+
+=cut
+
+=method total_nodes
+
+Return the list of nodes attached to the graph
+
+=cut
+
+=method get_node
+
+Return a node
+
+=cut
+
+=method add_node_attribute($name, $type, [$default_value])
+
+Add attributes to node
+
+=method all_nodes
+
+Return all the nodes
+
+=cut
+
+has nodes => (
+    traits     => ['Hash'],
+    is         => 'rw',
+    isa        => 'HashRef[Graph::GEXF::Node]',
+    default    => sub { {} },
+    auto_deref => 1,
+    handles    => {
+        _node_exists => 'exists',
+        _add_node    => 'set',
+        total_nodes  => 'count',
+        get_node     => 'get',
+        all_nodes    => 'keys',
+    },
+);
+
+=method add_node
+
+Add a new node to the graph
+
+=cut
+
+sub add_node {
+    my $self = shift;
+    my ($id, %attributes);
+
+    # TODO should be possible to add a Graph::GEXF::Node too
+    
+    if ( @_ == 1 ) {
+        $id = shift;
+    }
+    else {
+        if ( ( @_ % 2 ) == 0 ) {
+            %attributes = @_;
+        }
+        else {
+            $id = shift;
+            %attributes = @_;
+        }
+    }
+
+    if ($id && $self->_node_exists($id)) {
+        die "Can't add node wih id $id: already exists";
+    }
+
+    $id = new_uuid_string() if !defined $id;
+
+    my $node = Graph::GEXF::Node->new(id => $id);
+
+    map {
+        my $attribute = $self->get_node_attribute($_);
+        $node->set_node_attribute(
+            $_ => {
+                id   => $attribute->{id},
+                name => $attribute->{name},
+                type => $attribute->{type},
+            }
+        );
+    } $self->attributes_node_list;
+
+    $self->_add_node($id => $node);
+    $node;
+}
+
+1;
+
+=head1 SYNOPSIS
+
+    # create a new graph
+    my $graph = Graph::GEXF->new();
+
+    # add some attributes for nodes
+    $graph->add_node_attribute('url', 'string');
+
+    # create a new node and set the label
+    my $n1 = $graph->add_node(0);
+    $n1->label('Gephi');
+
+    my $n2 = $graph->add_node(1);
+    $n2->label('WebAtlas');
+
+    my $n3 = $graph->add_node(2);
+    $n3->label('RTGI');
+
+    # create relations between nodes
+    $n1->link_to(1, 2);
+    $n2->link_to(0);
+    $n3->link_to(1);
+
+    # set the value for attributes
+    $n1->attribute('url' => 'http://gephi.org/');
+    $n2->attribute('url' => 'http://webatlas.fr/');
+    $n3->attribute('url' => 'http://rtgi.fr/');
+
+    # render the graph in XML
+    my $xml = $graph->to_xml;
diff --git a/lib/Graph/GEXF/Attribute.pm b/lib/Graph/GEXF/Attribute.pm
new file mode 100644
index 0000000..3360307
--- /dev/null
+++ b/lib/Graph/GEXF/Attribute.pm
@@ -0,0 +1,16 @@
+package Graph::GEXF::Attribute;
+
+use Moose;
+
+has id => (is => 'ro', isa => 'Int', required => 1,);
+has title => (is => 'rw', isa => 'Str');
+has value => (is => 'rw', isa => 'Str');
+has type  => (
+    is  => 'ro',
+    isa => enum([qw/string integer float double boolean date anyURI/])
+);
+
+no Moose;
+
+1;
+
diff --git a/lib/Graph/GEXF/Edge.pm b/lib/Graph/GEXF/Edge.pm
new file mode 100644
index 0000000..a116a01
--- /dev/null
+++ b/lib/Graph/GEXF/Edge.pm
@@ -0,0 +1,24 @@
+package Graph::GEXF::Edge;
+
+use Moose;
+use Data::UUID::LibUUID;
+
+with
+  'Graph::GEXF::Role::Viz::Size'  => { as  => 'thickness' },
+  'Graph::GEXF::Role::Viz::Shape' => { for => 'edge' };
+
+has id => (
+    is       => 'ro',
+    isa      => 'Str',
+    required => 1,
+    default  => sub { new_uuid_string() }
+);
+
+has source => (is => 'ro', isa => 'Str', required => 1);
+has target => (is => 'ro', isa => 'Str', required => 1);
+has label  => (is => 'rw', isa => 'Str');
+has weight => (is => 'rw', isa => 'Num', lazy => 1, default => 1);
+
+no Moose;
+
+1;
diff --git a/lib/Graph/GEXF/Node.pm b/lib/Graph/GEXF/Node.pm
new file mode 100644
index 0000000..8f8187a
--- /dev/null
+++ b/lib/Graph/GEXF/Node.pm
@@ -0,0 +1,155 @@
+package Graph::GEXF::Node;
+
+use Moose;
+use Graph::GEXF::Edge;
+
+with
+  'Graph::GEXF::Role::Attributes' => { for => [qw/node/] },
+  'Graph::GEXF::Role::Viz::Color', 'Graph::GEXF::Role::Viz::Position',
+  'Graph::GEXF::Role::Viz::Size'  => { as  => 'size' },
+  'Graph::GEXF::Role::Viz::Shape' => { for => 'node' };
+
+has id => (
+    is       => 'ro',
+    isa      => 'Str',
+    required => 1,
+    traits   => ['Chained']
+);
+
+has label => (
+    is     => 'rw',
+    isa    => 'Str',
+    traits => ['Chained']
+);
+
+has edges => (
+    traits  => ['Hash'],
+    is      => 'rw',
+    isa     => 'HashRef[Graph::GEXF::Edge]',
+    default => sub { {} },
+    handles => {
+        add_edge    => 'set',
+        has_link_to => 'exists',
+        all_edges   => 'keys',
+        get_edge    => 'get',
+    }
+);
+
+sub link_to {
+    my $self     = shift;
+    my @nodes_id = @_;
+
+    foreach my $node_id (@nodes_id) {
+        my $edge;
+        if ( ref $node_id ) {
+            $edge = Graph::GEXF::Edge->new(
+                source => $self->id,
+                target => $node_id->{target},
+                weight => $node_id->{weight}
+            );
+            $self->add_edge( $node_id->{target} => $edge );
+        }
+        else {
+            $edge = Graph::GEXF::Edge->new(
+                source => $self->id,
+                target => $node_id,
+            );
+            $self->add_edge( $node_id => $edge );
+        }
+    }
+}
+
+sub attribute {
+    my ($self, $attribute_name, $value) = @_;
+
+#    return 0 unless $self->has_node_attribute;
+
+    if (!$self->has_node_attribute($attribute_name)) {
+        die "this attribute doesn't exists";
+    }
+
+    $self->node_attributes->{$attribute_name}->{value} = $value;
+
+    1;
+}
+
+no Moose;
+
+1;
+
+=head1 SYNOPSIS
+
+    my $graph = Graph::GEXF->new();
+
+    my $n = $graph->add_node();
+
+=head1 DESCRIPTION
+
+=head2 ATTRIBUTES
+
+=head3 id
+
+    my $n = $graph->add_node(1);
+    $n->id; # returns 1
+
+The B<id> of a node can't be changed once the node is created.
+
+=head3 label
+
+    $n->label('franckcuny');
+    $n->label();
+
+Each node has a label. If the B<label> is not defined, the default value is the B<id>. This value can be changed at any time.
+
+=head3 viz
+
+If B<visualization> is set to true, thoses values will be added to the XML.
+
+=over
+
+=item r,g,b,a
+
+    $n->r(255);
+
+=head3 x,y,z
+
+    $n->x(1);
+
+=head3 shape
+
+    $n->shape('disc');
+
+can be any of B<disc>, B<square>, B<triangle>, B<diamond>.
+
+=head3 size
+
+    $n->size(2);
+
+=back
+
+=head2 METHODS
+
+=head3 link_to
+
+   my $n1 = $graph->add_node();
+   my $n2 = $graph->add_node();
+   my $n3 = $graph->add_node();
+
+   $n1->link_to($n2->id);
+   $n1->link_to($n3->id);
+
+   # or
+   $n1->link_to($n2->id, $n3->id);
+
+This method will create an edge between some nodes.
+
+=head3 attribute
+
+=head3 add_edge
+
+=head3 has_link_to
+
+=head3 all_edges
+
+=head3 get_edge
+
diff --git a/lib/Graph/GEXF/Role/Attributes.pm b/lib/Graph/GEXF/Role/Attributes.pm
new file mode 100644
index 0000000..e03f5b1
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Attributes.pm
@@ -0,0 +1,60 @@
+package Graph::GEXF::Role::Attributes;
+
+use MooseX::Role::Parameterized;
+
+parameter for => (
+    is       => 'ro',
+    required => 1,
+);
+
+parameter with_method => (
+    is      => 'ro',
+    default => 0,
+);
+
+role {
+    my $p = shift;
+
+    foreach my $type (@{$p->for}) {
+
+        my $attr_name  = $type . '_attributes';
+        my $total_attr = 'attributes_' . $type . '_total';
+        my $set_attr   = 'set_' . $type . '_attribute';
+        my $get_attr   = 'get_' . $type . '_attribute';
+        my $list_attr  = 'attributes_' . $type . '_list';
+        my $has_attr   = 'has_' . $type . '_attribute';
+
+        has $attr_name => (
+            traits  => ['Hash'],
+            is      => 'rw',
+            isa     => 'HashRef',
+            lazy    => 1,
+            default => sub { {} },
+            handles => {
+                $total_attr => 'count',
+                $set_attr   => 'set',
+                $get_attr   => 'get',
+                $list_attr  => 'keys',
+                $has_attr   => 'exists',
+            }
+        );
+
+        if ($p->with_method) {
+            my $method_name = 'add_' . $type . '_attribute';
+
+            method $method_name => sub {
+                my ($self, $name, $type, $default_value) = @_;
+                my $id = $self->$total_attr();
+                my $attr = {
+                    id      => $id,
+                    title   => $name,
+                    type    => $type,
+                    default => [$default_value],
+                };
+                $self->$set_attr($name => $attr);
+            };
+        }
+    }
+};
+
+1;
diff --git a/lib/Graph/GEXF/Role/Viz/Color.pm b/lib/Graph/GEXF/Role/Viz/Color.pm
new file mode 100644
index 0000000..d7c30f1
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Viz/Color.pm
@@ -0,0 +1,32 @@
+package Graph::GEXF::Role::Viz::Color;
+
+use Moose::Role;
+use Moose::Util::TypeConstraints;
+
+subtype RGBColor => as 'Num' => where { $_ >= 0 && $_ <= 255 };
+subtype Alpha => as 'Num' => where { $_ > 0 and $_ <= 1 };
+
+my $_has_colors  = 0;
+
+has [qw/r g b/] => (
+    is      => 'rw',
+    isa     => 'RGBColor',
+    default => 0,
+    trigger => sub {$_has_colors++},
+    traits  => ['Chained'],
+);
+
+has a => (
+    is      => 'rw',
+    isa     => 'Alpha',
+    default => 1,
+    traits  => ['Chained'],
+);
+
+sub has_colors { $_has_colors }
+
+no Moose::Util::TypeConstraints;
+no Moose::Role;
+
+
+1;
diff --git a/lib/Graph/GEXF/Role/Viz/Position.pm b/lib/Graph/GEXF/Role/Viz/Position.pm
new file mode 100644
index 0000000..c9e79c3
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Viz/Position.pm
@@ -0,0 +1,18 @@
+package Graph::GEXF::Role::Viz::Position;
+
+use Moose::Role;
+
+my $_has_position = 0;
+
+has [qw/x y z/] => (
+    is      => 'rw',
+    isa     => 'Num',
+    trigger => sub { $_has_position++ },
+    traits  => ['Chained'],
+);
+
+sub has_position { $_has_position }
+
+no Moose::Role;
+
+1;
diff --git a/lib/Graph/GEXF/Role/Viz/Shape.pm b/lib/Graph/GEXF/Role/Viz/Shape.pm
new file mode 100644
index 0000000..b092d6d
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Viz/Shape.pm
@@ -0,0 +1,39 @@
+package Graph::GEXF::Role::Viz::Shape;
+
+use Moose::Util::TypeConstraints;
+use MooseX::Role::Parameterized;
+
+enum EdgeShape => qw(solid doted dashed double);
+enum NodeShape => qw(disc square triangle diamond);
+
+parameter for => (
+    is       => 'ro',
+    required => 1,
+);
+
+role {
+    my $p = shift;
+
+    my ( $type, $default );
+
+    $type = ucfirst( $p->for ) . 'Shape';
+
+    if ( $p->for eq 'node' ) {
+        $default = 'disc';
+    }
+    else {
+        $default = 'solid';
+    }
+
+    has shape => (
+        is      => 'rw',
+        isa     => $type,
+        default => $default,
+        traits  => ['Chained'],
+    );
+};
+
+no Moose::Util::TypeConstraints;
+
+1;
+
diff --git a/lib/Graph/GEXF/Role/Viz/Size.pm b/lib/Graph/GEXF/Role/Viz/Size.pm
new file mode 100644
index 0000000..aef1574
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Viz/Size.pm
@@ -0,0 +1,21 @@
+package Graph::GEXF::Role::Viz::Size;
+
+use MooseX::Role::Parameterized;
+
+parameter as => (
+    is       => 'ro',
+    required => 1,
+);
+
+role {
+    my $p = shift;
+
+    has $p->as => (
+        is      => 'rw',
+        isa     => 'Num',
+        default => '1.0',
+        traits  => ['Chained'],
+    );
+};
+
+1;
diff --git a/lib/Graph/GEXF/Role/XML.pm b/lib/Graph/GEXF/Role/XML.pm
new file mode 100644
index 0000000..cf12170
--- /dev/null
+++ b/lib/Graph/GEXF/Role/XML.pm
@@ -0,0 +1,168 @@
+package Graph::GEXF::Role::XML;
+
+use Moose::Role;
+
+use XML::Simple;
+
+has gexf_ns => (
+    is      => 'ro',
+    isa     => 'Str',
+    default => 'http://www.gexf.net/1.2draft'
+);
+
+has gexf_version => (
+    is      => 'ro',
+    isa     => 'Num',
+    default => '1.2'
+);
+
+sub to_xml {
+    my $self = shift;
+
+    my $graph = $self->_init_graph();
+
+    foreach (qw/node edge/) {
+        $self->_add_attributes( $graph, $_ );
+    }
+
+    $self->_add_nodes($graph);
+
+    my $xml_out = XMLout($graph, AttrIndent => 1, keepRoot => 1);
+    $xml_out;
+}
+
+sub _add_attributes {
+    my ($self, $graph, $type) = @_;
+
+    my $list_attr = 'attributes_' . $type . '_list';
+    my $get_attr  = 'get_' . $type . '_attribute';
+
+    my $attributes;
+    $attributes->{class} = $type;
+
+    foreach my $attr_id ($self->$list_attr) {
+        my $attribute = $self->$get_attr($attr_id);
+        push @{$attributes->{attribute}},
+          { id      => $attribute->{id},
+            type    => $attribute->{type},
+            title   => $attribute->{title},
+            default => $attribute->{default},
+          };
+    }
+
+    push @{$graph->{gexf}->{graph}->{attributes}}, $attributes;
+}
+
+sub _init_graph {
+    my $self = shift;
+
+    # XXX this need some refactoring
+    return {
+        gexf => {
+            xmlns   => $self->gexf_ns,
+            version => $self->gexf_version,
+            meta    => {creator => ['Graph::GEXF']},
+            graph   => {
+                mode            => $self->graph_mode,
+                defaultedgetype => $self->edge_type,
+            }
+        }
+    };
+}
+
+sub _add_nodes {
+    my ( $self, $graph ) = @_;
+
+    my $edges_id = 0;
+
+    foreach my $node_id ( $self->all_nodes ) {
+        my $node = $self->get_node($node_id);
+        my ( $node_desc, $edges ) = $self->_create_node($node);
+        push @{ $graph->{gexf}->{graph}->{nodes}->{node} }, $node_desc;
+        foreach my $edge (@$edges) {
+            push @{ $graph->{gexf}->{graph}->{edges}->{edge} }, $edge;
+        }
+    }
+}
+
+sub _create_node {
+    my ( $self, $node ) = @_;
+
+    my $label = $node->label || $node->id;
+
+    my $node_desc = { id => $node->id, label => $label };
+
+    foreach my $attr_id ( $node->attributes_node_list ) {
+        my $attr = $node->get_node_attribute($attr_id);
+        push @{ $node_desc->{attvalues}->{attvalue} },
+          { for => $attr->{id}, value => $attr->{value} };
+    }
+
+    $self->_add_visualizations_elements($node, $node_desc);
+
+    my @edges =
+      map { $self->_create_edge( $node->get_edge($_) ) } $node->all_edges;
+
+    return ($node_desc, \@edges);
+}
+
+sub _create_edge {
+    my ( $self, $edge ) = @_;
+    my $edge_desc = {
+        id     => $edge->id,
+        source => $edge->source,
+        target => $edge->target,
+        weight => $edge->weight,
+    };
+
+    $self->_add_shape($edge, $edge_desc);
+    
+    return $edge_desc;
+}
+
+sub _add_visualizations_elements {
+    my ( $self, $node, $node_desc ) = @_;
+
+    return unless $self->has_visualization;
+
+    foreach (qw/colors size shape position/){
+        my $method = "_add_$_";
+        $self->$method($node, $node_desc);
+    }
+}
+
+sub _add_colors {
+    my ( $self, $element, $element_desc ) = @_;
+
+    return unless $element->has_colors;
+    push @{ $element_desc->{'viz:color'} },
+      $self->_add_viz_elements( $element, qw/r g b a/ );
+}
+
+sub _add_size {
+    my ($self, $element, $element_desc) = @_;
+    push @{$element_desc->{'viz:size'}}, {value => $element->size};
+}
+
+sub _add_shape {
+    my ($self, $element, $element_desc) = @_;
+    push @{$element_desc->{'viz:shape'}}, {value => $element->shape};
+}
+
+sub _add_position {
+    my ($self, $element, $element_desc) = @_;
+
+    return unless $element->has_position;
+    push @{ $element_desc->{'viz:position'} },
+      $self->_add_viz_elements( $element, qw/x y z/ );
+}
+
+sub _add_viz_elements {
+    my ( $self, $element, @attrs ) = @_;
+    my %hash = map { $_ => $element->$_ } @attrs;
+    \%hash;
+}
+
+no Moose::Role;
+
+1;