GraphViz.pm 2.71 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19

# an extension of GraphViz that supports nested clusters

package Bio::EnsEMBL::Hive::Utils::GraphViz;

use strict;
use warnings;
use base ('GraphViz');


sub subgraphs {
    my $self = shift @_;
    if(@_) {
        $self->{_subgraphs} = shift @_;
    }
    return $self->{_subgraphs};
}


20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
sub colour_scheme {
    my $self = shift @_;
    if(@_) {
        $self->{_colour_scheme} = shift @_;
    }
    return $self->{_colour_scheme};
}


sub colour_offset {
    my $self = shift @_;
    if(@_) {
        $self->{_colour_offset} = shift @_;
    }
    return $self->{_colour_offset};
}


38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
sub get_top_clusters {
    my $self = shift @_;

    my $subgraphs = $self->subgraphs();

    my %set = ();
    foreach my $top_cluster (values %$subgraphs) {
        if( $top_cluster and !$subgraphs->{ $top_cluster } ) {  # if it's a valid node not mentioned in the keys, it is a top cluster
            $set{$top_cluster}++;
        }
    }
    return [ keys %set ];
}


sub get_nodes_that_point_at {
    my ($self, $node) = @_;

    my $subgraphs = $self->subgraphs();
    my %set = ();
    while( my ($key,$value) = each %$subgraphs) {
        if($value and ($value eq $node)) {
            $set{$key}++;
        }
    }
    return [ keys %set ];
}


sub generate_subgraph {
    my ($self, $cluster_name, $depth) = @_;

70 71 72
    my $subgraphs       = $self->subgraphs();
    my $colour_scheme   = $self->colour_scheme();
    my $colour_offset   = $self->colour_offset();
73 74 75 76 77 78 79

    my $prefix = "\t" x $depth;

    my $text = '';

    $text .= $prefix . "subgraph cluster_${cluster_name} {\n";
#    $text .= $prefix . "\tlabel=\"$cluster_name\";\n";
80
    $text .= $prefix . "\tcolorscheme=$colour_scheme;\n";
81
    $text .= $prefix . "\tstyle=filled;\n";
82
    $text .= $prefix . "\tcolor=".($depth+$colour_offset).";\n";
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110

    foreach my $node_name ( @{ $self->get_nodes_that_point_at( $cluster_name ) } ) {

        $text .= $prefix . "\t${node_name};\n";
        if( @{ $self->get_nodes_that_point_at( $node_name ) } ) {
            $text .= $self->generate_subgraph( $node_name, $depth+1 );
        }
    }
    $text .= $prefix . "}\n";

    return $text;
}


sub _as_debug {
    my $self = shift @_;

    my $text = $self->SUPER::_as_debug;

    my $subgraphs = $self->subgraphs();

    $text=~s/^}$//m;

    foreach my $node_name ( @{ $self->get_top_clusters() } ) {
        $text .= $self->generate_subgraph( $node_name, 1);
    }
    $text .= "}\n";

111 112 113 114 115 116 117
        # GraphViz.pm thinks 'record' is the only shape that allows HTML-like labels,
        # but newer versions of dot allow more freedom, so we patch dot input after generation:
        #
    $text=~s/^(\s+table_.*)"record"/$1"tab"/mg;
    $text=~s/^(\s+analysis_.*)"record"/$1"Mrecord"/mg;

    print $text;
118 119 120 121 122 123

    return $text;
}

1;