view release on metacpan or  search on metacpan

lib/Bio/App/SELEX/Stockholm.pm  view on Meta::CPAN

# to_file method
sub to_file {
    my ( $self, $filename, $maxcols ) = @_;

    local *FILE;
    open FILE, ">$filename"
      or croak "Couldn't open '$filename' for writing: $!";
    print FILE $self->to_string($maxcols);
    close FILE or croak "Couldn't close '$filename': $!";

    return $filename;
}

=head2 to_string

    print $stock->to_string ($maxcols)
    print $stock->to_string ($maxcols, ARG1=>VAL1, ARG2=>VAL2 ...)
    print $stock->to_string (MAXCOLS=>$maxcols, ARG1=>VAL1, ARG2=>VAL2 ...)

Returns the object as a Stockholm-formatted string.

ARGs can include...
        MAXCOLS    -- limit maximum number of columns (can also be specified as a single scalar arg)
        NOSEQDATA  -- don\'t print any sequence data (can be used this to compress output)

=cut

# to_string method
# Usage:
#        $stock->to_string ($maxcols)
#        $stock->to_string ($maxcols, ARG1=>VAL1, ARG2=>VAL2 ...)
#        $stock->to_string (MAXCOLS=>$maxcols, ARG1=>VAL1, ARG2=>VAL2 ...)
# Args:
#        MAXCOLS    -- limit maximum number of columns (can also be specified as a single scalar arg)
#        NOSEQDATA  -- don't print any sequence data ("windowlicker.pl" uses this to compress output)
sub to_string {
    my ( $self, @args ) = @_;
    my ( %args, $maxcols );
    if ( @args % 2 == 1 ) {
        $maxcols = shift @args;
        %args    = @args;
    }
    else {
        %args    = @args;
        $maxcols = $args{'MAXCOLS'};
    }
    $maxcols = 80 unless defined $maxcols;    # default 80-column output

    # init output array
    my @out;
    push @out, "# STOCKHOLM 1.0";

    # determine alignment columns, legend columns & effective columns per line
    my $acols   = $self->columns;
    my $lcols   = $self->lcols;
    my $colstep = $maxcols < 1 ? $acols : $maxcols - $lcols - 1;
    $colstep = $maxcols
      if $colstep < 1;    # protect against negative and 0 colstep...

    # GF lines
    # check for gfOrder (insane, fragile Stockholm line ordering strikes again)
    if ( @{ $self->gfOrder } == map { (@$_) } values %{ $self->gf } )
    {                     # gfOrder same number of lines as #=GF block?
        my %gfCursor = map ( ( $_ => 0 ), keys %{ $self->gf } );
        foreach my $feature ( @{ $self->gfOrder } ) {
            push @out,
              $self->prettify(
                $lcols,
                "#=GF $feature",
                $self->gf_($feature)->[ $gfCursor{$feature}++ ]
              );
        }
    }
    else {
        @{ $self->gfOrder } = ();    # gfOrder is useless, so flush it
        foreach my $feature ( sort { $a cmp $b } keys %{ $self->gf } ) {
            push @out,
              $self->prettify(
                $lcols,
                "#=GF $feature",
                @{ $self->gf_($feature) }
              );
        }
    }

    # GS lines
    my @gs_seqname = @{ $self->seqname };
    my %gs_seqname_hash = map ( ( $_ => 1 ),
        grep ( !exists $self->seqdata->{$_},
            map ( keys( %{ $self->gs_($_) } ), keys %{ $self->gs } ) ) );
    push @gs_seqname, keys %gs_seqname_hash;
    foreach my $feature ( sort { $a cmp $b } keys %{ $self->gs } ) {
        my $hash = $self->gs_($feature);
        foreach my $seqname ( grep ( exists( $hash->{$_} ), @gs_seqname ) ) {
            push @out,
              $self->prettify(
                $lcols,
                "#=GS $seqname $feature",
                @{ $hash->{$seqname} }
              );
        }
    }

    my @gcfeat          = sort { $a cmp $b } keys %{ $self->gc };
    my @gr_seqname      = @{ $self->seqname };
    my %gr_seqname_hash = map ( ( $_ => 1 ),
        grep ( !exists $self->seqdata->{$_},
            map ( keys( %{ $self->gr_($_) } ), keys %{ $self->gr } ) ) );
    push @gr_seqname, keys %gr_seqname_hash;

    # Loop over columns
    for ( my $col = 0 ; $col < $acols ; $col += $colstep ) {

        # GC lines
        foreach my $feature (@gcfeat) {
            push @out,
              $self->prettify(
                $lcols,
                "#=GC $feature",
                safe_substr( $self->gc_($feature), $col, $colstep )
              );