view release on metacpan or  search on metacpan

contrib/roary2svg/roary2svg.pl  view on Meta::CPAN

my $csv = Text::CSV->new() or die $!;
my $count=0;
my @matrix;
my @id;
my $N;
my $C=0;
my @tally;  # genes per taxon
my @is_core; # boolean for this cluster being core

while (my $row = $csv->getline(\*ARGV) ) {
  if ($count == 0) {
    @id = splice @$row, $taxacol;
    $N = scalar(@id);
    print STDERR "Found $N taxa: @id\n";    
  }
  else {
    my @present = map { $row->[$taxacol+$_] ? 1 : 0 } (0 .. $N-1);
    my $num_present = sum(@present);
    $is_core[$count] = ($num_present == $N);
    next if $acconly and $is_core[$count];
#    next if $panonly and all { $_==1 } @present;
    push @{ $matrix[$_] }, $present[$_] for (0 .. $N-1);
    $tally[$_] += $present[$_] for (0 .. $N-1);
    $C++;
  }
  $count++;
}
print STDERR "Found $C clusters.\n";

my $real_height = $height*($N+1);
my $svg = SVG->new(width=>$width, height=>$real_height);
my $dy = $height;
my $fontsize = 0.75 * $dy;

my $lchars = max( map { length($_) } @id );
my $llen =  $fontsize * (1 + $lchars) * FONT_ASPECT;

my $rchars = max( map { length("$_") } @tally);
my $rlen = $fontsize * (1 + $rchars) * FONT_ASPECT;

my $width2 = $width - $llen - $rlen;
my $dx = $width2 / $C;
my $font_style = { 'font-family'=>'sans-serif', 'fill'=>'black', 'font-size'=>$fontsize };

print STDERR "Box = $dx x $dy px\n";
print STDERR "Left label = $lchars chr x $fontsize px\n";
print STDERR "Right label = $rchars chr x $fontsize px\n";

for my $j (0 .. $N-1) {
  for my $i (0 .. $C-1) {
#    print STDERR "$j $i $matrix[$j][$i]\n";
    if ($matrix[$j][$i]) {
      # box for each present gene
      $svg->rectangle( 
          'x' => $llen+$i*$dx, 'y' => $j*$dy, 'width' => $dx, 'height' => $dy-1, 
          'style' => { fill=>$colour, opacity=>($is_core[$i] ? 1 : 0.75) },
      );      
    }
  }
  # taxon label for each row
  $svg->text( x=>$fontsize, y=>($j+0.75)*$dy, -cdata=>$id[$j], style=>$font_style );
  # number of genes for each row
  $svg->text( x=>$llen+$width2+$fontsize, y=>($j+0.75)*$dy, -cdata=>$tally[$j], style=>$font_style );
  # separator line
  my $ypos = ($j+1)*$dy;
  $svg->line( x1=>0, y1=>$ypos, x2=>$width, y2=>$ypos, style=>{stroke=>$sepcolour});
}

# bottom label
my $bottom_text = "$N taxa, $C clusters";
$bottom_text .= $acconly ? " (accessory only)" : " (core + accessory)";
$svg->text( x=>$llen, y=>($N+0.75)*$dy, -cdata=>$bottom_text, style=>$font_style );

# border
if ($border) {
  $svg->rectangle( 
    'x' => 0, 'y' => 0, 'width' => $width, 'height' => $real_height, 
    'style' => { stroke=>$sepcolour, fill=>'none' },
  );      
}

print STDERR "Writing SVG file\n";
print STDOUT $svg->xmlify;

print STDERR "Done.\n";

#----------------------------------------------------------------------
# Option setting routines

sub setOptions {
  use Getopt::Long;

  @Options = (
    {OPT=>"help",    VAR=>\&usage,             DESC=>"This help"},
    {OPT=>"verbose!",  VAR=>\$verbose, DEFAULT=>0, DESC=>"Verbose output"},
    {OPT=>"width=i",  VAR=>\$width, DEFAULT=>1024, DESC=>"Canvas width"},
    {OPT=>"height=i",  VAR=>\$height, DEFAULT=>20, DESC=>"Row height"},
    {OPT=>"taxacolumn=i",  VAR=>\$taxacol, DEFAULT=>14, DESC=>"Column in gpa.csv where taxa begin"},
    {OPT=>"colour=s",  VAR=>\$colour, DEFAULT=>'DimGray', DESC=>"Colour of core cells"},
    {OPT=>"sepcolour=s",  VAR=>\$sepcolour, DEFAULT=>'LightGray', DESC=>"Colour of horizontal separators/borders"},
    {OPT=>"acconly!",  VAR=>\$acconly, DEFAULT=>0, DESC=>"Only draw accessory (non-core) genes"},
#    {OPT=>"consensus!",  VAR=>\$consensus, DEFAULT=>0, DESC=>"Add consensus row"},
    {OPT=>"border!",  VAR=>\$border, DEFAULT=>0, DESC=>"Add outline border"},
  );

  (!@ARGV) && (usage());

  &GetOptions(map {$_->{OPT}, $_->{VAR}} @Options) || usage();

  # Now setup default values.
  foreach (@Options) {
    if (defined($_->{DEFAULT}) && !defined(${$_->{VAR}})) {
      ${$_->{VAR}} = $_->{DEFAULT};
    }
  }
}

sub usage {
  print "Usage: $0 [options] gene_presence_absence.csv > pan_genome.svg\n";
  foreach (@Options) {
    printf "  --%-13s %s%s.\n",$_->{OPT},$_->{DESC},
           defined($_->{DEFAULT}) ? " (default '$_->{DEFAULT}')" : "";
  }
  exit(1);
}
 
#----------------------------------------------------------------------