← Back to branch summary

~ubuntu-branches/ubuntu/trusty/circos/trusty

« back to all changes in this revision

Viewing changes to lib/Circos/#PNG.pm#

  • Committer: Package Import Robot
  • Author(s): Olivier Sallou, Olivier Sallou, Charles Plessy, Andreas Tille
  • Date: 2012-06-14 12:56:33 UTC
  • mfrom: (1.1.1)
  • Revision ID: package-import@ubuntu.com-20120614125633-0wh7ovv69s5k1uiq
Tags: 0.61-1
[ Olivier Sallou ]
* New upstream release

[ Charles Plessy ]
* renamed debian/upstream-metadata.yaml to debian/upstream

[ Andreas Tille ]
* debian/upstream: enhanced citation information 

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Circos/#PNG.pm#
 
1
package Circos::PNG;
 
2
 
 
3
=pod
 
4
 
 
5
=head1 NAME
 
6
 
 
7
Circos::PNG - PNG routines for PNG in Circos
 
8
 
 
9
=head1 SYNOPSIS
 
10
 
 
11
This module is not meant to be used directly.
 
12
 
 
13
=head1 DESCRIPTION
 
14
 
 
15
Circos is an application for the generation of publication-quality,
 
16
circularly composited renditions of genomic data and related
 
17
annotations.
 
18
 
 
19
Circos is particularly suited for visualizing alignments, conservation
 
20
and intra and inter-chromosomal relationships. However, Circos can be
 
21
used to plot any kind of 2D data in a circular layout - its use is not
 
22
limited to genomics. Circos' use of lines to relate position pairs
 
23
(ribbons add a thickness parameter to each end) is effective to
 
24
display relationships between objects or positions on one or more
 
25
scales.
 
26
 
 
27
All documentation is in the form of tutorials at L<http://www.circos.ca>.
 
28
 
 
29
=cut
 
30
 
 
31
# -------------------------------------------------------------------
 
32
 
 
33
use strict;
 
34
use warnings;
 
35
 
 
36
use base 'Exporter';
 
37
our @EXPORT = qw();
 
38
 
 
39
use Carp qw( carp confess croak );
 
40
use FindBin;
 
41
use GD;
 
42
use Params::Validate qw(:all);
 
43
 
 
44
use lib "$FindBin::RealBin";
 
45
use lib "$FindBin::RealBin/../lib";
 
46
use lib "$FindBin::RealBin/lib";
 
47
 
 
48
use Circos::Configuration;
 
49
use Circos::Colors;
 
50
use Circos::Constants;
 
51
use Circos::Debug;
 
52
use Circos::Error;
 
53
use Circos::Image qw(!draw_line);
 
54
use Circos::Utils;
 
55
 
 
56
use Memoize;
 
57
 
 
58
our $default_color = "black";
 
59
 
 
60
for my $f ( qw ( ) ) {
 
61
  memoize($f);
 
62
}
 
63
 
 
64
################################################################
 
65
# Draw a line
 
66
 
 
67
sub draw_arc {
 
68
  my %params;
 
69
  if( fetch_conf("debug_validate") ) {
 
70
      %params = validate(@_,{
 
71
          point            => { type    => ARRAYREF },
 
72
          width            => 1,
 
73
          height           => 0,
 
74
          angle_start      => { default => 0 },
 
75
          angle_end        => { default => 360 },
 
76
          stroke_color     => 0,
 
77
          stroke_thickness => 0,
 
78
          color            => 0,
 
79
                         });
 
80
  } else {
 
81
      %params = @_;
 
82
      $params{angle_start}      ||= 0;
 
83
      $params{angle_end}        ||= 360;
 
84
  }
 
85
  
 
86
  $params{height} ||= $params{width};
 
87
  
 
88
  if(@{$params{point}} != 2) {
 
89
      fatal_error("argument","list_size",current_function(),current_package(),2,int(@{$params{point}}));
 
90
  }
 
91
  
 
92
  printdebug_group("png","arc",@{$params{point}},@params{qw(width height angle_start angle_end)});
 
93
 
 
94
  # first fill the arc
 
95
  if(my $color = $params{color}) {
 
96
      my $color_obj = aa_color($color,$IM,$COLORS);
 
97
      $IM->filledArc(@{$params{point}},@params{qw(width height angle_start angle_end)},$color_obj);
 
98
  }
 
99
  
 
100
  # stroke the arc
 
101
  stroke($params{stroke_thickness},$params{stroke_color},"arc",@{$params{point}},@params{qw(width height angle_start angle_end)});
 
102
}
 
103
 
 
104
sub draw_polygon {
 
105
  my %params;
 
106
  if( fetch_conf("debug_validate") ) {
 
107
      %params = validate(@_,{
 
108
          polygon          => 1,
 
109
          color            => fetch_conf("default_color") || $default_color,
 
110
          thickness        => 0,
 
111
          pattern          => 0,
 
112
          fill_color       => 0,
 
113
                         });v
 
114
  } else {
 
115
      %params = @_;
 
116
      $params{color}            ||= fetch_conf("default_color") || $default_color;
 
117
  }
 
118
  
 
119
  printdebug_group("png","polygon",map {@$_} $params{polygon}->vertices);
 
120
  
 
121
  if($params{pattern}) {
 
122
      my ($color_idx,$tile);
 
123
      if ($params{fill_color} ) {
 
124
          $tile = Circos::fetch_colored_fill_pattern($params{pattern},$params{fill_color});
 
125
      } elsif ($params{pattern}) {
 
126
          $tile = Circos::fetch_fill_pattern($params{pattern});
 
127
      }
 
128
      if (defined $tile) {
 
129
          $IM->setTile($tile);
 
130
          $IM->filledPolygon($params{polygon},gdTiled);
 
131
      }
 
132
  } elsif ($params{fill_color} && ref $params{polygon} eq "GD::Polygon") {
 
133
      my $color_obj = aa_color( $params{fill_color}, $IM, $COLORS );
 
134
      $IM->filledPolygon($params{polygon},$color_obj);
 
135
  }
 
136
 
 
137
  stroke($params{thickness},$params{color},"polydraw",$params{polygon});
 
138
}
 
139
 
 
140
sub draw_line {
 
141
  my %params;
 
142
  if( fetch_conf("debug_validate") ) {
 
143
    %params = validate(@_,{
 
144
        points           => { type    => ARRAYREF },
 
145
        color            => { default => fetch_conf("default_color") || $default_color  },
 
146
        thickness        => { default => 1 },
 
147
                       });
 
148
  } else {
 
149
      %params = @_;
 
150
      $params{color}            ||= fetch_conf("default_color") || $default_color;
 
151
      $params{thickness}        ||= 1;
 
152
  }
 
153
  
 
154
  if(@{$params{points}} != 4) {
 
155
      fatal_error("argument","list_size",current_function(),current_package(),4,int(@{$params{points}}));
 
156
  }
 
157
  
 
158
  printdebug_group("png","line",@{$params{points}},$params{color},$params{thickness});
 
159
 
 
160
  stroke($params{thickness},$params{color},"line",@{$params{points}});
 
161
}
 
162
 
 
163
# -------------------------------------------------------------------
 
164
sub draw_bezier {
 
165
  my %params;
 
166
  if( fetch_conf("debug_validate") ) {
 
167
    %params = validate(@_,{
 
168
        points           => { type    => ARRAYREF },
 
169
        color            => { default => fetch_conf("default_color") || $default_color  },
 
170
        thickness        => { default => 1 },
 
171
                       });
 
172
  } else {
 
173
      %params = @_;
 
174
      $params{color}            ||= fetch_conf("default_color") || $default_color;
 
175
      $params{thickness}        ||= 1;
 
176
  }
 
177
  
 
178
  if ( $params{thickness} > 100 ) {
 
179
      fatal_error("links","too_thick",$params{thickness});
 
180
  } elsif ( $params{thickness} < 1 ) {
 
181
      fatal_error("links","too_thin",$params{thickness});
 
182
  }
 
183
  
 
184
  # In the current implementation of gd (2.0.35) antialiasing is
 
185
  # incompatible with thick lines and transparency. Thus, antialiased lines
 
186
  # are available only when thickness=1 and the color has no alpha channel.
 
187
 
 
188
  printdebug_group("link","thickness",$params{thickness},"color",$params{color});
 
189
 
 
190
  my $bezier_poly_line = GD::Polyline->new();
 
191
  for my $point ( @{$params{points}} ) {
 
192
      $bezier_poly_line->addPt(@$point);
 
193
  }
 
194
 
 
195
  stroke($params{thickness},$params{color},"polydraw",$bezier_poly_line);
 
196
}
 
197
 
 
198
# applies a stroke to a GD object drawn by function $fn
 
199
# added on island of Capri :)
 
200
sub stroke {
 
201
    my ($st,$sc,$fn,@args) = @_;
 
202
    return unless $st;
 
203
    my $color_obj;
 
204
    $sc ||= fetch_conf("default_color") || $default_color;
 
205
    if(fetch_conf("anti_aliasing") && $st == 1 && rgb_color_opacity($sc) == 1) {
 
206
        $IM->setAntiAliased(fetch_color($sc));
 
207
        $color_obj = gdAntiAliased;
 
208
    } else {
 
209
        $IM->setThickness($st) if $st > 1;
 
210
        $color_obj = fetch_color($sc);
 
211
    }
 
212
    $IM->$fn(@args,$color_obj);
 
213
    $IM->setThickness(1) if $st > 1;
 
214
}
 
215
 
 
216
1;