view release on metacpan or  search on metacpan

lib/Bio/MUST/Apps/OmpaPa/Roles/Parsable.pm  view on Meta::CPAN

}

sub _build_idl_file {
    return file( change_suffix( shift->new_parameter_file, '.idl'   ) );
}

sub _build_fas_file {
    return file( change_suffix( shift->new_parameter_file, '.fasta' ) );
}

sub _build_tax_file {
    return file( change_suffix( shift->new_parameter_file, '.tax'   ) );
}

sub _build_list_file {
    return file( change_suffix( shift->new_parameter_file, '.list'  ) );
}   # TODO: choose better suffix: .text?

sub _build_json_file {
    return shift->new_parameter_file;
}

sub _build_new_parameter_file {
    my $self = shift;

    my $filename = $self->last_parameter_file;
    my ($basename, $dir, $suf) = fileparse( $filename, '.json' );
       ($basename, $dir, $suf) = fileparse( $self->file, qr{ \.[^.]* }xms )
           unless ($basename);      # if first time
    my @parts = split q{-}, $basename;
    # default if it's the first time
    my $file = join q{-}, @parts;
    my $new_num = 1;

    my $num = pop @parts;
    if (looks_like_number $num) {
        $new_num = $num + 1;
        $file = join q{-}, @parts;
    }

    my $new_file = join q{.}, ( join q{-}, $file, $new_num ), 'json';

    return file( $dir, $new_file );
}

sub _build_last_parameter_file {
    my $self = shift;

    my ($file, $dir, $suf) = fileparse( $self->file, qr{ \.[^.]* }xms );
    my @files = File::Find::Rule->file()
                                ->name( $file . '*.json' )
                                ->in( $self->file->dir );
    my @sorted = nsort( @files );

    # because File::Find::Rule goes recursively in directories
    # use the directory of entry file
    my @finalsort;

    FINALSORT:
    for my $f (@sorted) {
        my @parts = split m{/}xms, $f;
        if ("$parts[0]/" eq $dir) {
            push @finalsort, $f;
            next FINALSORT;
        }
        push @finalsort, $f if @parts < 2;
    }

    return file( $finalsort[-1] );
}

sub _build_avg_len {
    my $self = shift;

    # TODO: change: 10 bins eval + mean length // idem but length alignment
    # compute average length of the top-25% hits
    my $quarter = ceil( $self->count_hits / 4 );
    my @lengths = $self->map_hits( sub { $_->{'len'} } );
    my $avg_len = sum( @lengths[ 0 .. $quarter-1 ] ) / $quarter;

    return $avg_len;
}

sub _build_coeffs {
    my $self = shift;

    my %count_for;
    my %coeffs_for;

    for my $hit ($self->all_hits) {
        # TODO: use SeqId methods: $_->$method // $_->taxon_id
        my $org = (split m{\|}xms, $hit->{acc})[0];
        $count_for{$org}++;

        my $coeff_len = $hit->{len} / $hit->{qlen};
        my $coeff_hmm
            = ( $hit->{hmm_to} - $hit->{hmm_from} + 1 ) / $hit->{qlen};

        my ($index, $label) = $self->scheme
            ? $self->scheme->icol( $hit->{acc} ) : (undef, undef);
        unless (defined $index) {
            $index = 0;
            $label = 'MISSING';
        }

        $coeffs_for{ $hit->{acc} } = {
            org       => $org,
            count     => $count_for{$org},
            max_count => undef,
            coeff_len => sprintf("%.3f", $coeff_len),
            align     => sprintf("%.3f", $coeff_hmm),
            tax       => $label,
            index_tax => $index,
        };
    }

    for my $hit ($self->all_hits) {
        $coeffs_for{$hit->{acc}}{max_count}
            = $count_for{$coeffs_for{$hit->{acc}}{org}};
    }

    return \%coeffs_for;
}

sub _build_data_handle {
    my $self = shift;

    # open anonymous temporary file...
    # ... and ensures immediate communication with gnuplot
    my $data_handle = File::Temp->new(SUFFIX => '.dat', UNLINK => 1);

    # write pairs of -log10(evalue) / length as data points
    for my $hit ($self->all_hits) {

        my $info_for = $self->get_coeffs( $hit->{acc} );
        #### $info_for

        say {$data_handle} join "\t",
            _eval2log10( $hit->{exp} ), $hit->{len},
            $info_for->{count}, $info_for->{align}, $info_for->{coeff_len},
            ( $self->scheme ? $info_for->{index_tax} : () )
        ;

    }

    return $data_handle;
}

sub _build_parameters {
    my $self = shift;

    return Parameters->load( $self->last_parameter_file->stringify )

lib/Bio/MUST/Apps/OmpaPa/Roles/Parsable.pm  view on Meta::CPAN

        unless ($explanation) {
            $msg = <<'EOT';
Define the hit bounding-box using the mouse (button 3).
If needed, reset the zoom level by pressing the 'U' key in the plot window.
Press 'H' to get help for other hot keys.
Which coloration information would you like? (If you do not want to change colors, press 'Return'.)
EOT
            $explanation = 1;
        }

        $ans = prompt $msg,
                      -def => 'N',
                      -menu => { 'Organisms' => 'O',
             ( $self->scheme ? ( 'Taxonomy'  => 'T' ) : () ),
                                 'Alignment' => 'A',
                                 'Global'    => 'G' },
                      '>';

        $coloration = $ans;
    };

    return;
}

sub _coeff_col {
    my $self = shift;

    my $palette_hmm = "0 \t 'yellow', 0.5 \t 'green', 1 \t 'black'"; # 1 = perfectly aligned
    my $color_n_hmm = 1;
    my $tic_hmm = "\"0\" 0, \"0.2\" 0.2, \"0.4\" 0.4, \"0.6\" 0.6, \"0.8\" 0.8, \"1\" 1";

    # TODO: find another way (do it twice: here and in _build_data_handle)
    my $top;
    my $bottom;
    my $qlen;

    HIT:
    for my $hit ($self->all_hits) {
        $top = $hit->{qlen} * 1.5;
        $bottom = $hit->{qlen} * 0.5;
        $qlen = $hit->{qlen};
        last HIT if ($qlen);
    }

    my %return = (
        color_n_hmm => $color_n_hmm,
        palette_hmm => $palette_hmm,
        tic_hmm     => $tic_hmm,
        top         => $top,
        bottom      => $bottom,
        qlen        => $qlen
    );

    return \%return;
}

sub _org_col {
    my $self = shift;

    my @ids = map { $_->{acc} } $self->all_hits;
    my @orgs = map { (split m{\|}xms, $_)[0] } @ids;
    my %count_orgs;

    for my $org (@orgs) {
        $count_orgs{$org}++;
    }

    my $nb_org_tot = keys %count_orgs;
    my $max = (sort {$a <=> $b} values %count_orgs)[$nb_org_tot-1];
    my $color_n = $max;         # range scale palette
    # limit coloration: 3 (default) or more times the same organism in yellow
    my $limit = $self->max_copy;
    # if black: bug!
    my $palette = "0 \t 'black', 1 \t 'red', $limit \t 'yellow', $max \t 'yellow'";

    if ($limit > $max) {
        $palette = "0 \t 'black', 1 \t 'red', $max \t 'yellow'";

        if ($max == 1) {
            $palette = "0 \t 'black', 1 \t 'red'";
        }
    }

    my %return = (
        color_n  => $color_n,
        palette  => $palette,
    );

    return \%return;
}

sub _tax_col {
    my $self = shift;

    # make palette for legend
    my $scheme = $self->scheme;
    my $color_n = $scheme->count_colors;        # range scale palette
    my %color_for = $scheme->all_icols;
    #### %color_for

    # TODO: exclude black specs?
    # TODO: warn of dupe specs
    my %colorcode_for = (
                           0 => '#000000',      # unclassified hit = black
        map { $color_for{$_} => $_ } keys %color_for
    );
    #### %colorcode_for

    my @strings;
    my $inc = 0;
    for my $num ( sort {$a <=> $b} keys %colorcode_for ) {
        push @strings, ($num-$inc) . "\t \"" . $colorcode_for{$num} . q{"};
        $inc ||= $inc + 0.5;
        push @strings, ($num+$inc) . "\t \"" . $colorcode_for{$num} . q{"};
    }
    #### @strings
    my $palette = join q{,}, @strings;

    # make labels for legend
    my @names = $scheme->all_names;