Bio-NEXUS
view release on metacpan or search on metacpan
lib/Bio/NEXUS/Tools/NexPlotter.pm view on Meta::CPAN
return;
}
sub __print_piechart {
my ($my_data, $node, $otu_seq_hash) = @_;
my $name = $node->get_name();
my $x = $node->_get_xcoord;
my $y = $node->_get_ycoord;
my $seq = $otu_seq_hash->{$name}->[$ppp_param-1];
my $prob = 0;
$prob = ((ref $seq) eq 'ARRAY') ? $seq->[1] : $seq;
&__draw_piechart($my_data,$x, $y, $nexusG->get_pieChartRadius, $prob);
foreach my $child (@{$node->get_children()}) {
&__print_piechart($my_data,$child,$otu_seq_hash);
}
}
sub __print_tree {
my ($my_data,$node, $x0, $y0,$otuseqs) = @_;
my $name = $node->get_name();
my $x1 = int($node->_get_xcoord);
my $y1 = 0;
my $color;
my $prob_val = '';
my $treeNodeRadius = $nexusG->get_treeNodeRadius;
my $pieChartRadius = $nexusG->get_pieChartRadius;
$color = (!$runtime_options->{'set_type'} || $runtime_options->{'set_type'} eq 'None') ? $my_data->get_node_color($name)||'black' : $my_data->get_node_color($name)||'gray';
#$y1 += $nexusG->get_fontHeight;
if ($ppp_param && $nexusObject->get_block('history','intron')) {
my $seq = $otuseqs->{$name}->[$ppp_param-1];
$prob_val = (ref $seq) ? $seq->[1] : $seq;
$prob_val = ":p(1) = ". $prob_val;
$y1 = int($node->_get_ycoord);
&__draw_line($my_data,$x0, $y1, $x1, $y1, $color, 2);
if ($y1 > $y0) {
&__draw_line($my_data,$x0, $y1, $x0, $y0 + $pieChartRadius/2, $color, 2) unless $node->get_name eq 'root' ;
}
else {
&__draw_line($my_data,$x0, $y1, $x0, $y0 - $pieChartRadius / 2, $color, 2) unless $node->get_name eq 'root' ;
}
}
else {
$y1 = int($node->_get_ycoord);
&__draw_line($my_data,$x0, $y1, $x1, $y1, $color, 2);
&__draw_line($my_data,$x0, $y0, $x0, $y1, $color, 2) unless $node->get_name eq 'root' ;
}
if ($node->is_otu()) {
&__print_label($my_data, $x1+$pieChartRadius*.75, $y1,$node->get_name,$color) ;
}
my $x2 = int( $x1 + $treeNodeRadius );
my $y2 = int( $y1 + $treeNodeRadius );
if ( not $ppp_param ) {
&__draw_circle($my_data,$x1, $y1,$treeNodeRadius,$color) if (!$node->is_otu);
}
$my_data->set_tree_map_coord( $node->get_name, [$x1,$y1,$x2,$y2] ) if $runtime_options->{'output_type'} eq 'png';
if ($node->{name} ne "root") {
#$query->delete("session") if ($runtime_options->{'session'});
$node->_set_xcoord($x1);
$node->_set_ycoord($y1);
#$areaMap .= qq(<area shape=rect onMouseOver="showtip(this,event,'$node->{name} options $prob_val')" onMouseOut="PopUpMenu2_Hide();" coords=$x1,$y1,$x2,$y2 href="javascript:PopUpMenu2_Set(getParam(\'$qs\',\'$node->{name}\',\'$file_param\',\'$colorn...
}
else {
#$areaMap .= qq(<area shape=rect onMouseOver="showtip(this,event,'Root node options $prob_val')" onMouseOut="PopUpMenu2_Hide();" coords=$x1,$y1,$x2,$y2 href="javascript:PopUpMenu2_Set(getParamRoot(\'$qs\',\'$node->{name}\',\'$file_param\',\'$colorn...
}
if (not $node->is_otu) {
my @nodes = @{$node->get_children()};
foreach my $child (@nodes) {
&__print_tree($my_data,$child, $x1, $y1,$otuseqs);
}
}
}
sub __print_matrix {
my ($my_data, $x0, $y0,$taxlabels,$is_print_labels) = @_;
my $seqs = $my_data->get_char_block_seq;
foreach my $taxa (@{$taxlabels}) {
my $color = $my_data->get_node_color($taxa);
&__print_label($my_data,$x0,$y0,$taxa,$color) if $is_print_labels;
my $xPos = $nexusG->get_characterStartXpos;
$color = 'gray' if ( (defined @{ $runtime_options->{'highlight_otus'} }) and ($color eq 'black') );
&__print_sequence($my_data, $xPos,$y0,$seqs->{$taxa},$taxa, $color) if defined $seqs;
$y0 += $nexusG->get_verticalOtuSpacing;
}
}
sub __print_label {
my ($my_data, $x, $y,$taxon_name, $color) = @_;
my ($x1,$x2,$y1,$y2);
$color = ( defined($color) ? $color : 'black' );
my $tip = ($color ne 'gray') ? 'OTU options' : 'Taxonomy not identified for this sequence';
# Print either left justified or right justified names
if ($runtime_options->{'right_justify_labels'} eq 'on') {
$x1 = $x;
$y1 = $y;
$x2 = $nexusG->get_characterStartXpos - (length($taxon_name) * $nexusG->get_fontWidth) - $nexusG->get_labelMatrixGapWidth;
$y2 = $y;
&__draw_text($my_data,$x2,$y2,$taxon_name,$color);
$my_data->set_label_map_coord( $taxon_name, [$x2,$y2,$x2+length($taxon_name)*$nexusG->get_fontWidth,$y2+$nexusG->get_fontHeight] ) if $runtime_options->{'output_type'} eq 'png';
$x1 += $nexusG->get_fontWidth;
$x2 -= $nexusG->get_fontWidth;
&__draw_line($my_data,$x1,$y1,$x2,$y1,'gray',1) if (($x1 < $x2) && ($runtime_options->{'show_content'} ne 'Data only'));
} else {
$x1 = $x;
$x2 = $nexusG->get_characterStartXpos - $nexusG->get_labelMatrixGapWidth;
$y1 = $y;
#$y2 = $y-( $nexusG->get_fontHeight/2);
$y2 = $y;
&__draw_text($my_data,$x1,$y2,$taxon_name,$color);
$my_data->set_label_map_coord( $taxon_name, [$x1,$y2,$x1+length($taxon_name)*$nexusG->get_fontWidth,$y2+$nexusG->get_fontHeight] ) if $runtime_options->{'output_type'} eq 'png';
#$areaMap.= sprintf "<area shape=rect onMouseOver=\"showtip(this,event,\'$tip\')\" onMouseOut=\"PopUpMenu2_Hide();\" coords=%d,%d,%d,%d href=\"javascript:PopUpMenu2_Set(getParam2(\'$qs\',\'%s\',\'$file_param\',\'$dir_param\',\'$highlight_params[$#h...
$x1 += length($taxon_name) * $nexusG->get_fontWidth + $nexusG->get_fontWidth;
&__draw_line($my_data,$x1,$y1,$x2,$y1,'gray',1) if (($x1 < $x2) && ($runtime_options->{'show_content'} ne 'Tree only') && $my_data->get_char_column_labels);
}
}
sub __print_sequence() {
my ($my_data, $x, $y, $sequence, $taxName, $color) = @_;
my $block = $my_data->get_selected_char_block;
$color = ( defined($color) ? $color : 'black' );
my $data_type = $block->get_format()->{'datatype'} if ($block->get_format());
my $gap_val = $block->get_format()->{'gap'} if ($block->get_format()->{'gap'});
my $missing_val = $block->get_format()->{'missing'} if ($block->get_format()->{'missing'});
my $max_val = $block->get_format()->{'max'} if ($block->get_format()->{'max'});
$sequence = uc (&__processSeqForDisplay($sequence)) if ($data_type ne 'continuous');
my $fontWidth = $nexusG->get_fontWidth;
my $fontHeight = $nexusG->get_fontHeight;
my $blockWidth = $nexusG->get_charLabelBlockWidth;
my $xnew = $x;
if ($data_type eq 'continuous') {
my $continuousMax; # Largest value in a continuous data matrix
if (not $max_val) { ##Find largest value in continuous data
my @array = sort { $a <=>$b } split(' ',$my_data->get_char_block_seq->{$taxName});
$continuousMax = pop @array;
}
my $max = $max_val || $continuousMax;
my $xpos = $x;
my $columnCount = 0;
my $colorscale;
my $color;
my @states = split(' ',$sequence);
my $im_h = $my_data->get_image_handler;
for (1 .. scalar(@states)) {
my $val = $states[$_-1];
$my_data->add_contin_data_map_coord($taxName,[$xpos,$y,$xpos+$fontWidth,$y+$fontHeight]) if $runtime_options->{'output_type'} eq 'png';
if ($gap_val eq $val) {
#$floatMap .=sprintf "<area shape=\"rect\" coords=%d,%d,%d,%d onMouseOver=\"showtip(this,event,'Gap')\">\n",$xpos,$y,$xpos+$fontWidth,$y+$fontHeight;
}
elsif ($missing_val eq $val) {
&__draw_text($my_data,$xpos,$y,'?','black');
#$floatMap .=sprintf "<area shape=\"rect\" coords=%d,%d,%d,%d onMouseOver=\"showtip(this,event,'Missing')\">\n",$xpos,$y,$xpos+$fontWidth,$y+$fontHeight;
}
else {
$colorscale = ($max == 0) ? 0 : $val/$max;
if ($colorscale > 0.75) {
$color = [255,(1-($colorscale-0.75)/0.25)*255,0];
}
elsif ($colorscale > 0.5) {
$color = [($colorscale-0.5)/0.25*255,255,0];
}
elsif ($colorscale > 0.25) {
$color = [0,255,(1-($colorscale-0.25)/0.25)*255];
}
else {
$color = [0,$colorscale/.25*255,255];
}
&__draw_filledRect($my_data,$xpos,$y+$fontHeight-($fontHeight*$colorscale),$xpos+$fontWidth,$y+$fontHeight,$color);
&__draw_line($my_data,$xpos,$y+$fontHeight-($fontHeight*$colorscale),$xpos,$y+$fontHeight,'black',0.5); # Left border
&__draw_line($my_data,$xpos+$fontWidth,$y+$fontHeight-($fontHeight*$colorscale),$xpos+$fontWidth,$y+$fontHeight,'black',0.5); # Right border
lib/Bio/NEXUS/Tools/NexPlotter.pm view on Meta::CPAN
$blank += $nexusG ->get_fontWidth;
}
my $label=$columnLabels[$i];
my $x = $nexusG->get_characterStartXpos + $blank + $i * $nexusG->get_fontWidth;
my $colpos = 0;
for (1 .. scalar(@columnLabelsAll)) {
#print "$highlightcol , $columnLabelsAll[$_-1]<br>";
#print "@columnLabels<br>";
if ($highlightcol eq $columnLabels[$_-1]) {
$colpos = $_;
last;
}
}
my $color = ($ppp_param && ($colpos==($i+1))) ? 'darkgreen': 'darkred';
$my_data->set_label_map_coord($label,[$x,$yPosition,$x+$nexusG->get_fontWidth,$nexusG->get_lowerYbound-$nexusG->get_fontHeight]) if $runtime_options->{'output_type'} eq 'png';
$label =~ s/-|_/\|/;
substr($label,0,0) = ' ' x (($longestLabel/$nexusG->get_fontHeight)-length($label));
&__print_vertical_label($my_data, $x, $yPosition, $label, $color, @columnLabelsAll);
}
}
sub __highlight_char{
my ($my_data, $block) = @_;
warn("Grabbing characters block from NEXUS file...\n") if $DEBUG;
my @columnLabels = $my_data->get_char_column_labels;
warn "WARNING: No labels\n" unless @columnLabels;
my $blank = 0;
for (my $i = 0; $i <= $#columnLabels; $i++) {
if ( $i && ($i % ($nexusG->get_charLabelBlockWidth) == 0) ) { # char #11, #21, etc.
$blank += $nexusG ->get_fontWidth;
}
my $label=$columnLabels[$i];
my $x = $nexusG->get_characterStartXpos + $blank + $i * $nexusG->get_fontWidth;
if (my $char_highlight_pos = grep /^$columnLabels[$i]$/ , @{$runtime_options->{'highlight_chars'} } ) {
&__draw_filledRect($my_data,$x,1,$x+$nexusG->get_fontWidth,$nexusG->get_lowerYMargin,'pink');
&__draw_filledRect($my_data,$x,$nexusG->get_upperYbound,$x+$nexusG->get_fontWidth,$nexusG->get_ysize-1,'pink');
}
}
}
sub __print_vertical_label {
my ($my_data, $x, $y, $label, $color,@columnLabelsAll) = @_;
foreach my $letter (split(//,$label)) {
&__draw_text($my_data,$x,$y,$letter,$color);
$y += $nexusG->get_fontHeight;
}
$label =~ s/\|/-/;
$label =~ s/\s//g;
&__print_intron_history($my_data,$x,$y,$label,$color,@columnLabelsAll) if ( (lc $runtime_options->{'character_data_type'}) eq 'intron') && ($nexusObject->get_block('history','intron'));
}
sub __print_intron_history {
my ($my_data, $x, $y, $label,$color,@columnLabelsAll) = @_;
&__draw_text($my_data,$x,$y,'H','blue');
$my_data->set_intron_map_coord($label,[$x,$y,$x+$nexusG->get_fontWidth,$y+$nexusG->get_fontHeight]) if $runtime_options->{'output_type'} eq 'png';
#$labelAreaMap .=sprintf "<area shape=\"rect\" onMouseOver=\"showtip(this,event,'Intron history options for $label')\" onMouseOut=\"PopUpMenu2_Hide();\" coords=%d,%d,%d,%d href=\"javascript:PopUpMenu2_Set(getParam3(\'$qs\',\'$charnum\'),'','','','','...
}
sub __plot_wts {
my ($my_data, @weights) = @_;
my $blank = 0;
my $is_weights;
for (my $i = 0; $i <= $#weights; $i++) {
my $height = $weights[$i] * $nexusG->get_histogramHeight ;
if ( $i && ($i % ($nexusG->get_charLabelBlockWidth)) == 0 ) { # char #11, #21, etc.
$blank += $nexusG->get_fontWidth;
}
my $x1 = $nexusG->get_characterStartXpos + $blank + $i * $nexusG->get_fontWidth + (0.25 * $nexusG->get_fontWidth);
my $x2 = $x1 + ($nexusG->get_fontWidth/2);
my $y1 = $nexusG->get_lowerYbound - $height - $nexusG->get_charLabelMatrixGapWidth;
my $y2 = $nexusG->get_lowerYbound - $nexusG->get_charLabelMatrixGapWidth;
&__draw_filledRect($my_data,$x1,$y1,$x2,$y2,'darkgreen');
}
}
sub __set_node_coords {
my $tree = shift;
my $treeName = $tree->get_name() || "unnamed";
my $cladogram_type = $runtime_options->{'cladogram_mode'} if $runtime_options->{'show_cladogram'};
$tree->_set_xcoord($nexusG->get_TreeWidth,$cladogram_type);
$tree->_set_ycoord(0,$nexusG->get_verticalOtuSpacing);
my @nodes = @{$tree->get_nodes()};
my $root = $tree->get_rootnode();
warn("Getting names of OTUs in tree...\n") if ( $DEBUG );
my @sorted;
for my $node (@nodes) {
push @sorted, $node->_get_xcoord();
}
@sorted = sort { $a <=> $b } @sorted;
my $sortedNum = pop @sorted;
my $amp = $nexusG->get_TreeWidth / $sortedNum if ($sortedNum != 0); # unit of branch length
foreach my $node (@nodes) {
$node->_set_xcoord(($node->_get_xcoord* $amp) + $nexusG->get_lowerXbound);
$node->_set_ycoord($node->_get_ycoord + $nexusG->get_lowerYbound);
}
}
sub __print_inode_names() {
my ($my_data, $nodes) = @_;
my ($xnew,$x1, $y1);
foreach my $node (@{$nodes}) {
next if $node->is_otu;
$x1 = int($node->_get_xcoord);
$y1 = int($node->_get_ycoord);
$xnew = $x1 + $nexusG->get_fontWidth/2;
$xnew += $nexusG->get_pieChartRadius* 0.5 if ($ppp_param);
&__draw_text($my_data,$xnew, $y1,$node->get_name, 'darkgray');
}
}
sub __print_boot_strap() {
my ($my_data, $nodes) = @_;
foreach my $node (@{$nodes}) {
my $name = $node->get_name();
next unless $node->get_support_value; # print only non-zero values and only if defined in the tree
&__draw_text($my_data,$node->_get_xcoord - ($nexusG->get_fontWidth * 4),$node->_get_ycoord + ($nexusG->get_fontHeight)/2,$node->get_support_value,'red');
}
( run in 0.932 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )