code_perl/Maasha/KISS/Draw.pm

   1 package Maasha::KISS::Draw;
   2
   3 # Copyright (C) 2009 Martin A. Hansen.
   4
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # http://www.gnu.org/copyleft/gpl.html
  20
  21
  22 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  23
  24
  25 # Routines for creating KISS graphics.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use Data::Dumper;
  34 use SVG;
  35
  36 use vars qw( @ISA @EXPORT );
  37
  38 @ISA = qw( Exporter );
  39
  40
  41 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  42
  43
  44 sub svg_init
  45 {
  46     # Martin A. Hansen, October 2005.
  47
  48     # inititalizes SVG object, which is returned.
  49
  50     my ( $height,   # Height in pixels
  51          $width,    # Width in pixels
  52        ) = @_;
  53
  54     my $svg;
  55
  56     $svg = SVG->new(
  57         id          => 'KISS',
  58         height      => $height,
  59         width       => $width,
  60     );
  61
  62     return $svg;
  63 }
  64
  65
  66 sub svg_frame
  67 {
  68     # Martin A. Hansen, October 2009.
  69
  70     # Adds a top level layer frame of given
  71     # height and width to an SVG object.
  72
  73     my ( $height,   # Height in pixels
  74          $width,    # Width in pixels
  75          $svg,      # SVG objact
  76        ) = @_;
  77
  78     # Returns nothing.
  79
  80     my ( $frame );
  81
  82     $frame = $svg->group(
  83         id => 'GROUP_FRAME',
  84     );
  85
  86     $frame->rectangle(
  87         id     => 'FRAME',
  88         x      => 0,
  89         y      => 0,
  90         width  => $width,
  91         height => $height,
  92         rx     => 10,
  93         ry     => 10,
  94         style  => {
  95             fill           => 'none',
  96             'stroke'       => 'red',
  97             'stroke-width' => 3,
  98         }
  99     );
 100 }
 101
 102
 103 sub svg_track_dna
 104 {
 105     # Martin A. Hansen, October 2009.
 106
 107     # Given a DNA sequence as a list add a string
 108     # of chars to a SVG object.
 109
 110     my ( $width,   # width
 111          $svg,     # SVG object
 112          $dna,
 113        ) = @_;
 114
 115     # Returns nothing.
 116
 117     my ( $track );
 118
 119     $dna = 'GAACGACGAGCATCAGCGGACACTACATCATATACTACATC';
 120
 121     $track = $svg->group(
 122         id => 'TRACK_DNA',
 123         style => {
 124          #   'stroke-width' => 5,
 125          #   stroke         => 'black',   # TODO can this be removed?
 126             'font-family'       => 'Courier New',
 127             'font-size'         => '15px',
 128             'letter-spacing'    => '15',
 129         }
 130     );
 131
 132     $track->text(
 133         id => 'DNA',
 134         x  => 0,
 135         y  => 20,
 136         -cdata => $dna,
 137     );
 138 }
 139
 140
 141 sub svg_track_feature
 142 {
 143     # Martin A. Hansen, October 2009.
 144
 145     # Given a list of features add these to
 146     # a SVG object.
 147
 148     my ( $height,     # Height in pixels
 149          $width,      # Width in pixels
 150          $svg,        # SVG object
 151          $features,   # List of features
 152          $track_id,   # Unique track id
 153          $color,      # Color of features
 154        ) = @_;
 155
 156     # Returns nothing.
 157
 158     my ( $track, $i, $id, $x, $y, $w, $h );
 159
 160     $track = $svg->group(
 161         id => $track_id,
 162         style => {
 163             'stroke-width' => 5,
 164             stroke         => $color,
 165         }
 166     );
 167
 168     for ( $i = 0; $i < @{ $features }; $i++ )
 169     {
 170         $id = "FEAT_$i";
 171         $x  = $features->[ $i ]->{ 'x' };
 172         $y  = $features->[ $i ]->{ 'y' };
 173         $h  = $features->[ $i ]->{ 'height' };
 174         $w  = $features->[ $i ]->{ 'width' };
 175
 176         # $track->rectangle( id => $id, x => $x, y => $y, width => $w, height => $h );
 177
 178         $track->line( id => $id, x1 => $x, y1 => $y, x2 => $x + $w, y2 => $y );
 179     }
 180 }
 181
 182
 183 sub svg_track_histogram
 184 {
 185     # Given a list of features add these to
 186     # a SVG object.
 187
 188     my ( $svg,        # SVG object
 189          $features,   # List of features
 190          $track_id,   # Unique track id
 191          $color,      # Color of features
 192        ) = @_;
 193
 194     # Returns nothing.
 195
 196     my ( $track, $i );
 197
 198     $track = $svg->group(
 199         id => $track_id,
 200         style => {
 201             'stroke-width' => 5,
 202             stroke         => $color,
 203         }
 204     );
 205
 206     for ( $i = 0; $i < @{ $features }; $i++ )
 207     {
 208         $track->line(
 209             id => "HIST_$i",
 210             x1 => $features->[ $i ]->{ 'x1' },
 211             y1 => $features->[ $i ]->{ 'y1' },
 212             x2 => $features->[ $i ]->{ 'x2' },
 213             y2 => $features->[ $i ]->{ 'y2' },
 214         );
 215     }
 216 }
 217
 218
 219 sub svg_print
 220 {
 221     # Martin A. Hansen, October 2009.
 222
 223     # Prints XML output from a SVG object.
 224
 225     my ( $svg,   # SVG object
 226          $fh,    # file handle  -  OPTIONAL
 227        ) = @_;
 228
 229     # Returns nothing
 230
 231     $fh ||= \*STDOUT;
 232
 233     print $fh $svg->xmlify;
 234 }
 235
 236
 237 sub hdump
 238 {
 239     my ( $foo ) = @_;
 240
 241     my ( @html );
 242
 243     @html = "Content-Type: text/html; charset=ISO-8859-1\n\n";
 244
 245     push @html, "<pre>\n";
 246     push @html, Dumper( $foo );
 247     push @html, "</pre>\n";
 248
 249     return wantarray ? @html : \@html;
 250 }
 251
 252
 253 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 254
 255 1;
 256
 257