view release on metacpan or  search on metacpan

lib/Bio/Roary/Output/EmblGroups.pm  view on Meta::CPAN

    return $self->heatmap_lookup_table->[ $number_of_colours - 1 ] if ( @{$taxon_names} == $number_of_files );

    my $block_size   = $number_of_files / @{ $self->heatmap_lookup_table };
    my $colour_index = ceil( @{$taxon_names} / $block_size ) - 1;
    return $self->heatmap_lookup_table->[$colour_index];
}

sub _build_heatmap_lookup_table {
    my ($self) = @_;
    return [
        4,     # blue (RGB values: 0 0 255)
        5,     # cyan (RGB values: 0 255 255)
        9,     # light sky blue (RGB values: 135 206 250)
        8,     # pale green (RGB values: 152 251 152)
        3,     # green (RGB values: 0 255 0)
        7,     # yellow (RGB values: 255 255 0)
        10,    # orange (RGB values: 255 165 0)
        16,    # light red (RGB values: 255 127 127)
        15,    # mid red: (RGB values: 255 63 63)
        2,     # red (RGB values: 255 0 0)
    ];
}

sub _block_colour {
    my ( $self, $accessory_label ) = @_;
    my $colour = 2;
    return $colour unless ( defined($accessory_label) );

    $colour += $accessory_label % 6;
    return $colour;
}

sub _header_block {
    my ( $self, $group ) = @_;
    my $annotated_group_name = $self->annotate_groups_obj->_groups_to_consensus_gene_names->{$group};
    my $colour               = 1;

    return ''
      if (
        !(
               defined( $self->groups_to_contigs->{$annotated_group_name} )
            && defined( $self->groups_to_contigs->{$annotated_group_name}->{ $self->ordering_key } )
        )
      );
    return ''
      if ( defined( $self->groups_to_contigs->{$annotated_group_name}->{comment} )
        && $self->groups_to_contigs->{$annotated_group_name}->{comment} ne '' );
    my $coordindates    = $self->groups_to_contigs->{$annotated_group_name}->{ $self->ordering_key };
    my $annotation_type = $self->_annotation_type($annotated_group_name);

    $colour = $self->_block_colour( $self->groups_to_contigs->{$annotated_group_name}->{accessory_label} );

    my $tab_file_entry = "FT$annotation_type$coordindates\n";
    $tab_file_entry .= "FT                   /label=$annotated_group_name\n";
    $tab_file_entry .= "FT                   /locus_tag=$annotated_group_name\n";
    $tab_file_entry .= "FT                   /colour=$colour\n";

    return $tab_file_entry;
}

sub _fragment_blocks {
    my ( $self, $fh ) = @_;
    my %fragment_numbers;
    for my $group ( @{ $self->annotate_groups_obj->_groups } ) {
        my $annotated_group_name = $self->annotate_groups_obj->_groups_to_consensus_gene_names->{$group};

        next unless ( defined( $self->groups_to_contigs->{$annotated_group_name}->{accessory_label} ) );
        next unless ( defined( $self->groups_to_contigs->{$annotated_group_name}->{ $self->ordering_key } ) );
        next if ( $self->groups_to_contigs->{$annotated_group_name}->{ $self->ordering_key } eq '' );
        push(
            @{ $fragment_numbers{ $self->groups_to_contigs->{$annotated_group_name}->{accessory_label} } },
            $self->groups_to_contigs->{$annotated_group_name}->{ $self->ordering_key }
        );
    }

    for my $accessory_label ( keys %fragment_numbers ) {
        next unless ( defined( $fragment_numbers{$accessory_label} ) );
        my @sorted_fragment = sort { $a <=> $b } @{ $fragment_numbers{$accessory_label} };
        my $tab_file_entry = '';
        if ( @sorted_fragment > 1 ) {
            my $min = $sorted_fragment[0];
            my $max = $sorted_fragment[-1];

            next if ( !defined($min) || !defined($max) || $min eq '' || $max eq '' );
            $tab_file_entry = "FT   feature         $min" . '..' . "$max\n";
        }
        elsif ( @sorted_fragment == 1 ) {
            my $min = $sorted_fragment[0];
            next if ( !defined($min) || $min eq '' );
            $tab_file_entry = "FT   feature         $min\n";
        }
        else {
            next;
        }
        $tab_file_entry .= "FT                   /colour=" . $self->_block_colour($accessory_label) . "\n";

        print {$fh} $tab_file_entry;
    }

}

sub create_files {
    my ($self) = @_;

    print { $self->_output_header_fh } $self->_header_top();
    for my $group ( @{ $self->annotate_groups_obj->_groups } ) {
        print { $self->_output_fh } $self->_block($group);
        print { $self->_output_header_fh } $self->_header_block($group);
    }
    $self->_fragment_blocks( $self->_output_header_fh );
    print { $self->_output_header_fh } $self->_header_bottom();
    close( $self->_output_header_fh );
    close( $self->_output_fh );
}

no Moose;
__PACKAGE__->meta->make_immutable;

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Bio::Roary::Output::EmblGroups - Create a tab/embl file with the features for drawing pretty pictures

=head1 VERSION

version 3.13.0

=head1 SYNOPSIS

reate a tab/embl file with the features for drawing pretty pictures
   use Bio::Roary::Output::EmblGroups;

   my $obj = Bio::Roary::Output::EmblGroups->new(
     output_filename => 'group_statitics.csv',
     annotate_groups_obj => $annotate_groups_obj,
     analyse_groups_obj  => $analyse_groups_obj
   );
   $obj->create_file;

=head1 AUTHOR

Andrew J. Page <ap13@sanger.ac.uk>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2013 by Wellcome Trust Sanger Institute.

This is free software, licensed under:

  The GNU General Public License, Version 3, June 2007

=cut