view release on metacpan or  search on metacpan

lib/Bio/Graphics/Wiggle.pm  view on Meta::CPAN

use warnings;
use IO::File;
use Carp 'croak','carp','confess';

use constant HEADER_LEN => 256;
    # seqid, step, min, max, span, mean, stdev, version, start
use constant HEADER => '(Z50LFFLFFSL)@'.HEADER_LEN; 
use constant BODY   => 'C';
use constant DEBUG  => 0;
use constant DEFAULT_SMOOTHING => 'mean';
use constant VERSION => 0;
our $VERSION = '1.0';

sub new {
  my $class          = shift;
  my ($path,$write,$options) = @_;
  $path ||= ''; # to avoid uninit warning
  my $mode = $write ? -e $path   # if file already exists...
                         ? '+<'    # ...open for read/write
                         : '+>'    # ...else clobber and open a new one
                    : '<';       # read only
  my $fh = $class->new_fh($path,$mode);
  $fh or die (($path||'temporary file').": $!");

  $options ||= {};

  my $self = bless {fh      => $fh,
		    write   => $write,
		    dirty   => scalar keys %$options
		   }, ref $class || $class;

  my $stored_options = eval {$self->_readoptions} || {};
  $options->{start}-- if defined $options->{start};  # 1-based ==> 0-based coordinates
  my %merged_options = (%$stored_options,%$options);
  # warn "merged options = ",join ' ',%merged_options;
  $merged_options{version}||= 0;
  $merged_options{seqid}  ||= 'chrUnknown';
  $merged_options{min}    ||= 0;
  $merged_options{max}    ||= 255;
  $merged_options{mean}   ||= 128;
  $merged_options{stdev}  ||= 255;
  $merged_options{trim}   ||= 'none';
  $merged_options{step}   ||= 1;
  $merged_options{start}  ||= 0;
  $merged_options{span}   ||= $merged_options{step};
  $self->{options}         = \%merged_options;
  $self->_do_trim        unless $self->trim eq 'none';
  return $self;
}

sub new_fh {
    my $self = shift;
    my ($path,$mode) = @_;
    return $path ? IO::File->new($path,$mode)
                 : IO::File->new_tmpfile;
}

sub end {
  my $self = shift;
  unless (defined $self->{end}) {
      my $size     = (stat($self->fh))[7];
      my $data_len = $size - HEADER_LEN();
      return unless $data_len>0;   # undef end
      $self->{end} = ($self->start-1) + $data_len * $self->step;
  }
  return $self->{end};
}

sub DESTROY { shift->write }

sub erase {
  my $self = shift;
  $self->fh->truncate(HEADER_LEN);
}

sub fh     { shift->{fh}    }
sub seek   { shift->fh->seek(shift,0) }
sub tell   { shift->fh->tell()        }

sub _option {
  my $self   = shift;
  my $option = shift;
  my $d      = $self->{options}{$option};
  if (@_) {
    $self->{dirty}++;
    $self->{options}{$option} = shift;
    delete $self->{scale} if $option eq 'min' or $option eq 'max';
  }
  return $d;
}

sub version  { shift->_option('version',@_)  }
sub seqid    { shift->_option('seqid',@_) }
sub min      { shift->_option('min',@_) }
sub max      { shift->_option('max',@_) }
sub step     { shift->_option('step',@_) }
sub span     { shift->_option('span',@_) }
sub mean     { shift->_option('mean',@_) }
sub stdev    { shift->_option('stdev',@_) }
sub trim     { shift->_option('trim',@_)  }

sub start    {  # slightly different because we have to deal with 1 vs 0-based coordinates
    my $self  = shift;
    my $start = $self->_option('start');
    $start++;   # convert into 1-based coordinates
    if (@_) {
	my $newstart = shift;
	$self->_option('start',$newstart-1); # store in zero-based coordinates
    }
    return $start;
}

sub smoothing {
  my $self = shift;
  my $d    = $self->{smoothing} || DEFAULT_SMOOTHING;
  $self->{smoothing} = shift if @_;
  $d;
}

sub write {
  my $self = shift;