GraphViz.pm 4.07 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
=pod 

=head1 NAME

    Bio::EnsEMBL::Hive::Utils::GraphViz

=head1 DESCRIPTION

    An extension of GraphViz that supports nested clusters

=head1 EXTERNAL DEPENDENCIES

    GraphViz

=head1 LICENSE

17
    Copyright [1999-2015] Wellcome Trust Sanger Institute and the EMBL-European Bioinformatics Institute
18 19 20 21 22 23 24 25 26 27 28 29

    Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
    You may obtain a copy of the License at

         http://www.apache.org/licenses/LICENSE-2.0

    Unless required by applicable law or agreed to in writing, software distributed under the License
    is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
    See the License for the specific language governing permissions and limitations under the License.

=head1 CONTACT

30
    Please subscribe to the Hive mailing list:  http://listserver.ebi.ac.uk/mailman/listinfo/ehive-users  to discuss Hive-related questions or to be notified of our updates
31 32

=cut
33 34 35 36 37 38 39 40 41


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

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


42
sub cluster_2_nodes {
43 44
    my $self = shift @_;
    if(@_) {
45
        $self->{_cluster_2_nodes} = shift @_;
46
    }
47
    return $self->{_cluster_2_nodes};
48 49 50
}


51
sub main_pipeline_name {
52 53
    my $self = shift @_;
    if(@_) {
54
        $self->{_main_pipeline_name} = shift @_;
55
    }
56
    return $self->{_main_pipeline_name};
57 58 59
}


60
sub semaphore_bgcolour {
61 62
    my $self = shift @_;
    if(@_) {
63
        $self->{_semaphore_bgcolour} = shift @_;
64
    }
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
    return $self->{_semaphore_bgcolour};
}


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


sub other_pipeline_bgcolour {
    my $self = shift @_;
    if(@_) {
        $self->{_other_pipeline_bgcolour} = shift @_;
    }
    return $self->{_other_pipeline_bgcolour};
84 85 86
}


87
sub display_subgraph {
88 89
    my ($self, $cluster_name, $depth) = @_;

90
    my $box_colour_pair  = $depth
91 92 93 94
        ? $self->semaphore_bgcolour
        : ( $cluster_name eq $self->main_pipeline_name)
            ? $self->main_pipeline_bgcolour
            : $self->other_pipeline_bgcolour;
95
    my ($colour_scheme, $colour_offset) = $box_colour_pair && @$box_colour_pair;
96 97

    my $prefix = "\t" x $depth;
98 99
    my  $text = '';
        $text .= $prefix . "subgraph cluster_${cluster_name} {\n";
100 101

        # uncomment the following line to see the cluster names:
102
#     $text .= $prefix . "\tlabel=\"$cluster_name\";\n";
103

104
    if($colour_scheme) {
105
        $text .= $prefix . "\tstyle=filled;\n";
106 107 108 109 110 111 112 113

        if(defined($colour_offset)) {
            $text .= $prefix . "\tcolorscheme=$colour_scheme;\n";
            $text .= $prefix . "\tcolor=".($depth+$colour_offset).";\n";
        } else {    # it's just a simple colour:
            $text .= $prefix . "\tcolor=${colour_scheme};\n";
        }
    } # otherwise just draw a black frame around the subgraph
114

115
    foreach my $node_name ( @{ $self->cluster_2_nodes->{ $cluster_name } || [] } ) {
116 117

        $text .= $prefix . "\t${node_name};\n";
118
        if( @{ $self->cluster_2_nodes->{ $node_name } || [] } ) {
119
            $text .= $self->display_subgraph( $node_name, $depth+1 );
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
        }
    }
    $text .= $prefix . "}\n";

    return $text;
}


sub _as_debug {
    my $self = shift @_;

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

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

135 136
    foreach my $node_name ( grep { !/^dfr_/ } keys %{ $self->cluster_2_nodes } ) {
        $text .= $self->display_subgraph( $node_name, 0);
137 138 139
    }
    $text .= "}\n";

140
        # GraphViz.pm thinks 'record' is the only shape that allows HTML-like labels,
141 142 143
        # but newer versions of dot allow more freedom.
        # Since we wanted to stick with the older GraphViz, we initially ask for shape="record",
        # but put the desired shape into the comment and patch dot input after generation:
144
        #
145
    $text=~s/\bcomment="new_shape:(\w+)",(.*shape=)"record"/$2"$1"/mg;
146

147
        # uncomment the following line to see the final input to dot
148
#    print $text;
149 150 151 152 153 154

    return $text;
}

1;