cgi-bin/tools/tree_browser/index.pl

   1 #!/usr/bin/perl
   2
   3 =head1 NAME
   4
   5 tree_browser/index.pl - the script controlling the tree browser tool
   6
   7 =head1 DESCRIPTION
   8
   9 soon
  10
  11 =head1 DEPENDENCIES
  12
  13 soon
  14
  15 =head1 AUTHOR
  16
  17 Lukas Mueller <lam87@cornell.edu>
  18
  19
  20 =cut
  21
  22 use strict;
  23 use warnings;
  24
  25 use CGI qw/ -compile :standard /;
  26
  27 use File::Temp qw/ tempfile tempdir /;
  28 use File::Basename;
  29 use Tie::UrlEncoder;
  30
  31 use CXGN::Page;
  32 use CXGN::Page::FormattingHelpers qw/ page_title_html info_section_html/;
  33
  34 use CXGN::Tools::Identifiers qw | identifier_url identifier_namespace |;
  35 use CXGN::Tools::Gene;
  36 use CXGN::Tools::Param qw/ hash2param hash2hiddenpost /;
  37
  38 use CXGN::Phylo::Parser;
  39 use CXGN::Phylo::Tree_browser;
  40 use CXGN::Phylo::File;
  41
  42 use CXGN::Phylo::Alignment;
  43 use CXGN::Phylo::Alignment::Member;
  44
  45 use Bio::SeqIO;
  46 use CatalystX::GlobalContext '$c';
  47
  48 use HTML::Entities;
  49
  50 our %urlencode;
  51
  52 my $request = shift;
  53
  54 my $page = CXGN::Page->new( "SGN Tree Browser", "Lukas" );
  55
  56 our ($align_temp_show, $newick_temp_show, $example_show, $native_commands) =
  57     $page->get_encoded_arguments(qw/align_temp_show newick_temp_show example_show native_commands/);
  58
  59 my (
  60     $action,                $tree_string,
  61     $file,                  $shared_file,
  62     $hilite,                $ops,
  63     $term,                  $title,
  64     $tree_style,            $show_blen,
  65     $preset,                $height,
  66     $reroot,                $show_orthologs,
  67     $show_species,          $collapse_single_species_subtrees,
  68     $show_standard_species,
  69     $use_html_path,         $show_skip_form,
  70     $align_format,          $align_seq_data,
  71     $align_temp_file,       $align_type,
  72     $hide_alignment,        $tree_from_align,
  73     $show_sigpep,           $show_domains,
  74     $stored_genes,          $family_nr,
  75     $i_value
  76   )
  77   = $page->get_encoded_arguments(
  78     "action",                "tree_string",
  79     "file",                  "shared_file",
  80     "hilite",                "ops",
  81     "term",                  "title",
  82     "tree_style",            "show_blen",
  83     "preset",                "height",
  84     "reroot",                "show_orthologs",
  85     "show_species",          "collapse_single_species_subtrees",
  86     "show_standard_species",
  87     "use_html_path",         "show_skip_form",
  88     "align_format",          "align_seq_data",
  89     "align_temp_file",       "align_type",
  90     "hide_alignment",        "tree_from_align",
  91     "show_sigpep",           "show_domains",
  92     "stored_genes",          "family_nr",
  93     "i_value"
  94   );
  95 my $tree_string_param = $tree_string;    #keep track of provided param
  96
  97 $height = 50 if ( $height =~ /^\d+$/ && $height < 50 );
  98
  99 $show_domains = 1 unless ( $show_domains =~ /^(1|0)$/ && $show_domains == 0 );
 100
 101 our %PARAM = (
 102     "action"      => $action,
 103     "file"        => $file,
 104     "shared_file" => $shared_file,
 105     "hilite"      => $hilite,
 106     "ops"         => $ops,
 107     "term"        => $term,
 108     "title"       => $title,
 109     "tree_style"  => $tree_style,
 110     "show_blen"   => $show_blen,
 111     "preset"      => $preset,
 112     "height"      => $height,
 113     "reroot"      => $reroot,
 114
 115     "align_format"                     => $align_format,
 116     "align_temp_file"                  => $align_temp_file,
 117     "align_type"                       => $align_type,
 118     "hide_alignment"                   => $hide_alignment,
 119     "tree_from_align"                  => $tree_from_align,
 120     "show_sigpep"                      => $show_sigpep,
 121     "show_domains"                     => $show_domains,
 122     "stored_genes"                     => $stored_genes,
 123     "show_orthologs"                   => $show_orthologs,
 124     "show_species"                     => $show_species,
 125     "collapse_single_species_subtrees" => $collapse_single_species_subtrees,
 126 );
 127
 128 our $HTML_ROOT_PATH = $c->path_to->stringify;
 129 our $DOC_PATH = $c->tempfiles_subdir('align_viewer');
 130 our $PATH     = $c->path_to( $DOC_PATH );
 131
 132 our $CMD_QUICKTREE = $c->config->{cluster_shared_bindir}."/quicktree";
 133 our $CMD_SREFORMAT = $c->config->{cluster_shared_bindir}."/sreformat";
 134 $CMD_QUICKTREE = "quicktree" unless ( -x $CMD_QUICKTREE );
 135 $CMD_SREFORMAT = "sreformat" unless ( -x $CMD_SREFORMAT );
 136
 137 unless ( !$align_temp_show || $align_temp_show =~ /\// ) {
 138     $align_temp_show = $PATH . "/" . $align_temp_show;
 139 }
 140 unless ( !$newick_temp_show || $newick_temp_show =~ /\// ) {
 141     $newick_temp_show = $PATH . "/" . $newick_temp_show;
 142 }
 143 if ($use_html_path) {
 144     $align_temp_show  = $HTML_ROOT_PATH . $align_temp_show;
 145     $newick_temp_show = $HTML_ROOT_PATH . $newick_temp_show;
 146 }
 147
 148 #Family Shortcuts
 149 #Copy newick/alignment to temp files based on family information:
 150 if (   !( -f ( $PATH . "/" . $align_temp_file ) && -f ( $PATH . "/" . $file ) )
 151     && $family_nr
 152     && $i_value )
 153 {
 154     my $family_basedir = "/data/prod/public/family/$i_value";
 155     unless ( -d $family_basedir ) {
 156         input_err_page( $page,
 157             "No current family build corresponds to an i_value of $i_value" );
 158     }
 159     unless ( -f "$family_basedir/pep_align/$family_nr.pep.aligned.fasta" ) {
 160         input_err_page( $page, "Alignment was not calculated for this family" );
 161     }
 162     unless ( -f "$family_basedir/newick/$family_nr.newick" ) {
 163         $tree_from_align = 1;
 164     }
 165     else {
 166
 167         #Make new temporary alignment and newick files
 168         my $tmp_fh = File::Temp->new(
 169             DIR    => $PATH,
 170             UNLINK => 0
 171         );
 172         $file = $tmp_fh->filename();
 173         $tmp_fh->close();
 174
 175         system "cp $family_basedir/newick/$family_nr.newick $file";
 176     }
 177
 178     my $tmp_fh = File::Temp->new(
 179         DIR    => $PATH,
 180         UNLINK => 0
 181     );
 182     $align_temp_file = $tmp_fh->filename();
 183     $tmp_fh->close();
 184     my @out =
 185 `cp $family_basedir/pep_align/$family_nr.pep.aligned.fasta $align_temp_file 2>/dev/stdout`;
 186 }
 187
 188 # 'show_skip_form' is a url parameter of unknown function, but it seems to have to do
 189 # something with the combined tree/alignment view
 190 #
 191 if ($show_skip_form) {
 192
 193     #Copy files to real temp directory
 194     my $temp_fh = File::Temp->new(
 195         DIR    => $PATH,
 196         UNLINK => 0
 197     );
 198     open( FH, $newick_temp_show );
 199     my $content = "";
 200     $content .= $_ while <FH>;
 201     close(FH);
 202     print $temp_fh $content;
 203     $file = $temp_fh->filename;
 204
 205     $temp_fh = File::Temp->new( DIR => $PATH, UNLINK => 0 );
 206
 207     open( FH, $align_temp_show );
 208     $content = "";
 209     $content .= $_ while <FH>;
 210     close(FH);
 211     print $temp_fh $content;
 212     $align_temp_file = $temp_fh->filename;
 213 }
 214
 215 our $align_tmp_fh;
 216 unless ( $align_temp_file =~ /\// ) {
 217     $align_temp_file = $PATH . "/" . $align_temp_file;
 218 }
 219
 220 if ( $align_seq_data ne '' ) {
 221     $align_tmp_fh = File::Temp->new(
 222         DIR    => $PATH,
 223         UNLINK => 0,
 224     );
 225
 226     $align_temp_file = $align_tmp_fh->filename;
 227     $align_seq_data =~ s/\&gt\;/\>/g;
 228     $align_seq_data =~ s/\&lt\;/\</g;
 229     $align_seq_data =~ s/\&\#124;/\|/g;
 230     print $align_tmp_fh "$align_seq_data";
 231     close $align_tmp_fh;
 232
 233     # Convert the input file into fasta if it is clustal
 234     #
 235     if ( $align_format eq 'clustalw' ) {
 236         my $align_temp_file_fasta = $align_temp_file . ".fasta";
 237         convert_clustal_fasta( $align_temp_file, $align_temp_file_fasta );
 238
 239         # continue with the converted file...
 240         #
 241         $align_temp_file = $align_temp_file_fasta;
 242     }
 243 }
 244 if ( -f $align_temp_file ) {
 245     my ( $align_seq_count, $align_max_lengthh ) =
 246       fasta_check( $align_temp_file, $page )
 247       if $align_temp_file;
 248 }
 249 if ( $align_format eq "clustalw" && $align_temp_file && !$align_seq_data ) {
 250     my $align_temp_file_fasta = $align_temp_file . ".fasta";
 251     convert_clustal_fasta( $align_temp_file, $align_temp_file_fasta );
 252     $align_temp_file = $align_temp_file_fasta;
 253     $align_format    = "aligned_fasta";
 254 }
 255
 256 #print STDERR "Done checking some file stuff\n";
 257
 258 #### Construct Alignment ##############################################
 259 my $alignment = CXGN::Phylo::Alignment->new(
 260     name   => "Untitled",
 261     width  => 800,
 262     height => 2000,
 263     type   => $align_type
 264 );
 265 my $instream;
 266 my $len;
 267 my %fasta_hash = ();
 268 $instream = Bio::SeqIO->new( -file => $align_temp_file, -format => 'fasta' );
 269 while ( my $in = $instream->next_seq() ) {
 270     my $seq = $in->seq();
 271     my $id  = $in->id();
 272     chomp $seq;
 273     $len = length $seq;
 274     $fasta_hash{$id} = $seq;
 275     my $member = CXGN::Phylo::Alignment::Member->new(
 276         start_value => 1,
 277         end_value   => $len,
 278         id          => $id,
 279         seq         => $seq,
 280         type        => $align_type
 281     );
 282     eval { $alignment->add_member($member); };
 283     $@ and input_err_page( $page, $@ );
 284
 285 }
 286
 287 #print STDERR "Done defining alignment...\n";
 288
 289 if ($tree_from_align) {
 290     input_err_page( $page, "No alignment file" ) unless ( -f $align_temp_file );
 291     my @sre = `$CMD_SREFORMAT stockholm $align_temp_file`;
 292
 293     # input_err_page($page, "sreformat command:  $CMD_SREFORMAT");
 294     input_err_page( $page,
 295         "Utility \"sreformat\" didn't work, or no alignment" )
 296       unless (@sre);
 297     my $sre_temp_fh = File::Temp->new( DIR => $PATH, UNLINK => 1 );
 298     print $sre_temp_fh $_ foreach (@sre);
 299     my $sre_temp = $sre_temp_fh->filename;
 300     my @newick   = `$CMD_QUICKTREE -kimura $sre_temp`;
 301     input_err_page( $page,
 302         "Program \"quicktree\" didn't work, or no alignment" )
 303       unless (@newick);
 304     $tree_string = "";
 305     $tree_string .= $_ foreach (@newick);
 306     $sre_temp_fh->close();
 307 }
 308
 309 # create a new Tree_browser object which will handle most of the stuff
 310 #
 311 my $browser = CXGN::Phylo::Tree_browser->new();
 312
 313 #print STDERR "Done creating tree browser object..\n";
 314 ##Maybe do this:
 315 $browser->set_temp_dir($PATH);
 316
 317 my $temp_dir = $browser->get_temp_dir();
 318
 319 # check to see if we have a preset tree that we should show
 320 #
 321 if ($preset) {
 322     my $plants_file =
 323       CXGN::Phylo::File->new( $page->path_to("data/asterids.newick.txt") );
 324
 325     my $plants_tree = $plants_file->get_tree();
 326     $tree_string = $plants_tree->get_root()->recursive_generate_newick();
 327
 328     my $new_root = $plants_tree->get_node_by_name($preset);
 329     if ($new_root) {
 330         $ops = "s" . $new_root->get_node_key();
 331     }
 332 }
 333
 334 #print STDERR "Done dealing with presets...\n";
 335
 336 # get an upload object to upload a file, copy the
 337 # file to a temp location
 338 #
 339 use CatalystX::GlobalContext qw( $c );
 340 my $upload = $c->req->upload($file);
 341
 342 my ( $temp_fh, $temp_file ) =
 343   File::Temp::tempfile( "tree-XXXXXX", DIR => $temp_dir );
 344
 345 # print STDERR "upload: [$upload] <br>";
 346 if ( defined $upload ) {
 347     my $upload_fh = $upload->fh();
 348     while (<$upload_fh>) {
 349
 350         #print STDERR $_;
 351         print $temp_fh $_;
 352     }
 353     close($temp_fh);
 354     close($upload_fh);
 355
 356     #print STDERR "Uploading file $temp_file...\n ";
 357
 358     my $tree_file = CXGN::Phylo::File->new($temp_file);
 359     my $tree_obj  = $tree_file->get_tree();
 360     if ($tree_obj) {
 361         $tree_string = $tree_obj->get_root()->recursive_generate_newick();
 362     }
 363     #print STDERR "TREE STRING= $tree_string\n";
 364 }
 365
 366 if ($shared_file) {
 367     if ( $shared_file =~ /\/\./ ) {
 368         $page->error_page( 'Invalid file location.',
 369             "Invalid file location: $shared_file" );
 370     }
 371     my $shared_data_path = $c->config->{'static_datasets_path'};
 372     my $shared_data_url  = $c->config->{'static_datasets_url'};
 373     $shared_file =~ /^$shared_data_url\/cosii\/[\w\-\/]+\.\d\.ml\.tre$/
 374       or $page->error_page( "Invalid file location",
 375         "Invalid file location: $shared_file" );
 376     $title = $shared_file;
 377     $shared_file =~ s/$shared_data_url//;
 378     my $filename  = $shared_data_path . $shared_file;
 379     my $tree_file = CXGN::Phylo::File->new($filename);
 380     my $tree_obj  = $tree_file->get_tree();
 381
 382     if ($tree_obj) {
 383         $tree_string = $tree_obj->get_root()->recursive_generate_newick();
 384     }
 385 }
 386
 387 #print STDERR "Done with shared file...\n";
 388 # for now, the species tree is just hard-coded:
 389
 390 my $species_tree_newick = "(chlamydomonas[species=Chlamydomonas_reinhardtii]:1,
 391 (physcomitrella[species=Physcomitrella_patens]:1,(selaginella[species=Selaginella_moellendorffii]:1,
 392 (loblolly_pine[species=Pinus_taeda]:1,(amborella[species=Amborella_trichopoda]:1,
 393 ((date_palm[species=Phoenix_dactylifera]:1,((foxtail_millet[species=Setaria_italica]:1,
 394 (sorghum[species=Sorghum_bicolor]:1,maize[species=Zea_mays]:1):1):1,
 395 (rice[species=Oryza_sativa]:1,(brachypodium[species=Brachypodium_distachyon]:1,
 396 (wheat[species=Triticum_aestivum]:1,barley[species=Hordeum_vulgare]:1):1):1):1):1):1,
 397 (columbine[species=Aquilegia_coerulea]:1,
 398 ((((((((((tomato[species=Solanum_lycopersicum]:1, potato[species=Solanum_tuberosum]:1):1,
 399 eggplant[species=Solanum_melongena]:1):1, pepper[species=Capsicum_annuum]:1):1,
 400 tobacco[species=Nicotiana_tabacum]:1):1, petunia[species=Petunia]:1):1,
 401 sweet_potato[species=Ipomoea_batatas]:1):1,
 402 (arabica_coffee[species=Coffea_arabica]:1,robusta_coffee[species=Coffea_canephora]:1):1):1,
 403 snapdragon[species=Antirrhinum]:1):1,
 404 ((sunflower[species=Helianthus_annuus]:1,lettuce[species=Lactuca_sativa]:1):1,
 405 carrot[species=Daucus_carota]:1):1):1,(grape[species=Vitis_vinifera]:1,
 406 ((eucalyptus[species=Eucalyptus_grandis]:1,
 407 ((orange[species=Citrus_sinensis]:1, clementine[species=Citrus_clementina]:1):1,
 408 ((cacao[species=Theobroma_cacao]:1,cotton[species=Gossypium_raimondii]:1):1,
 409 (papaya[species=Carica_papaya]:1,(turnip[species=Brassica_rapa]:1,
 410 (salt_cress[species=Thellungiella_parvula]:1,(red_shepherds_purse[species=Capsella_rubella]:1,
 411 (arabidopsis_thaliana[species=Arabidopsis_thaliana]:1,arabidopsis_lyrata[species=Arabidopsis_lyrata]:1):1)
 412 :1):1):1):1):1):1):1,
 413 (((peanut[species=Arachis_hypogaea]:1,
 414 ((soy[species=Glycine_max]:1,pigeon_pea[species=Cajanus_cajan]:1):1,
 415 (medicago[species=Medicago_truncatula]:1,lotus[species=Lotus_japonicus]:1):1):1):1,
 416 (hemp[species=Cannabis_sativa]:1,
 417 (((apple[species=Malus_domestica]:1,peach[species=Prunus_persica]:1):1,
 418 woodland_strawberry[species=Fragaria_vesca]:1):1, cucumber[species=Cucumis_sativus]:1):1):1):1,
 419 ((castorbean[species=Ricinus_communis]:1,cassava[species=Manihot_esculenta]:1):1,
 420 (poplar[species=Populus_trichocarpa]:1,flax[species=Linum_usitatissimum]:1):1):1):1):1):1):1):1):1):1
 421 ):1):1):1)";
 422
 423 #print STDERR "species tree newick: \n", $species_tree_newick, "\n";
 424
 425 my $species_tree =
 426   CXGN::Phylo::Parse_newick->new($species_tree_newick)->parse()
 427   ;    #construct Parse_newick for string $newick
 428
 429 ## these aren't needed for the hard coded species tree, but may be needed if/when we allow other trees (user supplied)
 430 $species_tree->set_missing_species_from_names();    # if get_species() not defined get species from name
 431 $species_tree->impose_branch_length_minimum();
 432 $species_tree->collapse_tree();
 433 my $species_name_map = CXGN::Phylo::Species_name_map->new();
 434 $species_tree->set_species_standardizer($species_name_map);
 435
 436 # the user can either submit a tree string (using the tree_string html
 437 # parameter, or a temp file name is supplied with the file parameter (for
 438 # clicks that are generated after the initial parsing).
 439 # If we have neither, show the input form.
 440 #
 441 if ($tree_string) {
 442
 443     # clean the string...
 444     $tree_string =~ s/\n//g;
 445     $tree_string =~ s/\r//g;
 446
 447     #print STDERR "TREESTRING: $tree_string\n";
 448
 449     # because we used CXGN::Page::encoded_arguments we have to
 450     # do some translation back to normal ascii
 451     #
 452     while ( $tree_string =~ m/(.*)\&quot\;(.*?)\&quot\;(.*)/gi ) {
 453
 454         #print "MATCHED: $2\n";
 455         my $encoded = URI::Escape::uri_escape( $2, ":" );
 456         $tree_string = $1 . $encoded . $3;
 457     }
 458     $browser->set_tree_string($tree_string);
 459     $file = $browser->create_temp_file();
 460 }
 461
 462 if ($file) {
 463     $file = File::Basename::basename($file);
 464     $file = $PATH . "/" . $file unless ( $file =~ /\// );
 465     $browser->set_temp_file($file);
 466 }
 467
 468 $browser->set_hilite($hilite);
 469
 470 my @operations = split / /, $ops;
 471 foreach my $o (@operations) {
 472     $browser->toggle_node_operation($o);
 473 }
 474
 475 #print("browser->get_tree_string: ", $browser->get_tree_string(), "\n");
 476 if ( !$browser->get_tree_string() ) {
 477
 478     show_form($page);
 479     $show_orthologs                   = 0;
 480     $show_species                     = 0;
 481     $collapse_single_species_subtrees = 0;
 482
 483 }
 484 else {
 485     my $tree_string = $browser->get_tree_string();
 486     my $parser      = CXGN::Phylo::Parse_newick->new($tree_string);
 487     my $tree        = $parser->parse();
 488
 489     if ( !$tree ) {
 490         my $error = $parser->get_error();
 491         $page->message_page(
 492             "SGN tree browser error",
 493 "This does not seem to be a legal Newick formatted tree.<br />Error possibly near highlighted token:<br />$error"
 494         );
 495     }
 496     $tree->impose_branch_length_minimum()
 497       ;    # impose the default minimum branch length (0.0001),
 498      # because zero branch lengths can lead to leaves getting lost during rerooting.
 499     $tree->set_show_species_in_label(1);
 500
 501     if ( @{ $alignment->{members} } ) {
 502         $tree->set_alignment($alignment);
 503     }
 504
 505     $tree->set_line_color( 150, 150, 150 );
 506     if ( !$title ) {
 507         $title = "Untitled Tree";
 508     }
 509     $tree->set_name($title);
 510     $tree->set_show_species_in_label($show_species);
 511     $tree->set_show_standard_species($show_standard_species);
 512
 513     #    $tree->set_line_color(0, 200, 0);
 514     $tree->set_missing_species_from_names();
 515     $tree->impose_branch_length_minimum();
 516     $tree->get_root()->recursive_implicit_names();    # needed?
 517
 518     $tree->set_species_standardizer($species_name_map);
 519     $tree->update_label_names();
 520
 521     # species tree is already set up (check this is always true)
 522     my $spec_bit_hash = $tree->get_species_bithash($species_tree);
 523     $species_tree->get_root()->recursive_implicit_species();
 524     $species_tree->get_root()
 525       ->recursive_set_implicit_species_bits($spec_bit_hash);
 526
 527 #reroot the gene tree
 528 # reroot the tree at the point which minimizes the variance of the root-leaf distances
 529 #print blue_section_html("tree style: $tree_style <br> \n");
 530
 531     if ( $reroot and ( $reroot ne "Original" ) )
 532     {    # reroot the tree according to the selected method
 533
 534         my @new_root_point;
 535         if ( $reroot eq "MinVariance" ) {
 536             @new_root_point = $tree->min_leaf_dist_variance_point();
 537         }
 538         elsif ( $reroot eq "Midpoint" ) {
 539             @new_root_point = $tree->find_point_closest_to_furthest_leaf();
 540         }
 541         elsif ( $reroot eq "MinDuplication" ) {
 542             @new_root_point = $tree->find_mindl_node($species_tree);
 543         }
 544         elsif ( $reroot eq "MaxMin" ) {
 545             @new_root_point = $tree->find_point_furthest_from_leaves();
 546         }
 547         $tree->reset_root_to_point_on_branch(@new_root_point);
 548     }
 549
 550     $tree->get_root()->recursive_implicit_names();
 551     $tree->get_root()->recursive_implicit_species();
 552     $tree->update_label_names();
 553
 554 #    if (0) {
 555 #        my $spec_bit_hash = $browser->get_tree()->get_species_bithash($species_tree);
 556
 557 #        $species_tree->get_root()->recursive_implicit_species();
 558 #        #print STDERR "ccccc\n";
 559 #        $species_tree->get_root()->recursive_set_implicit_species_bits($spec_bit_hash);
 560
 561 #        $browser->get_tree()->get_root()->rs
 562 #        $browser->get_tree()->get_root()->recursive_set_implicit_species_bits($spec_bit_hash);
 563 #        $browser->get_tree()->get_root()->recursive_implicit_names(); # this is needed, but why?
 564
 565 #        $browser->get_tree()->get_root()->recursive_set_speciation($species_tree);
 566 #        $browser->get_tree()->get_root()->recursive_hilite_speciation_nodes($species_tree);
 567 #    }
 568
 569     #    $tree->get_root()->recursive_set_leaf_species_count();
 570     #    $tree->get_root()->recursive_set_leaf_count();
 571     if ($collapse_single_species_subtrees) {
 572         $tree->collapse_unique_species_subtrees()
 573           ;    # this seems to be causing problems
 574         $tree->get_root()->recursive_implicit_names()
 575           ;    # this is needed, but why?
 576         $tree->get_root()->recursive_implicit_species();
 577     }
 578     if ($show_orthologs) {
 579
 580         $tree->get_root()->recursive_implicit_names()
 581           ;    # this is needed, but why?
 582         $tree->get_root()->recursive_implicit_species();
 583
 584 #    print STDERR "root implicit species: ", join(";", ($tree->get_root()->get_implicit_species())), "\n";
 585         $tree->get_root()->recursive_set_implicit_species_bits($spec_bit_hash);
 586
 587         $tree->update_label_names();
 588
 589         #### handle possible trifurcation at root
 590         my $root_spec =
 591           $tree->get_root()->speciation_at_this_node($species_tree);
 592
 593         # print "root_spec: $root_spec \n";
 594         if ( $root_spec < 0 )
 595         {   # if trifurcation at root, reroot to one of the neighboring branches
 596                 # if this will yield a speciation at root...
 597             my $cn = ( $tree->get_root()->get_children() )[ $root_spec + 3 ];
 598             my $bl = $cn->get_branch_length();
 599             $tree->reset_root_to_point_on_branch( $cn, 0.5 * $bl );
 600             $tree->get_root()->recursive_implicit_names();
 601             $tree->get_root()->recursive_implicit_species();
 602             $tree->get_root()
 603               ->recursive_set_implicit_species_bits($spec_bit_hash);
 604         }
 605         #### end of handling trifurcation at root
 606
 607         $tree->get_root()->recursive_set_speciation($species_tree);
 608         $tree->get_root()->recursive_hilite_speciation_nodes($species_tree);
 609     }
 610
 611     #    $tree->set_line_color(100, 100, 0);
 612     $tree->set_hilite_color( 100, 200, 200 );
 613
 614     $tree->show_newick_attribute("species");
 615
 616     #    $tree->set_hilite_color(150, 0, 200);
 617
 618     $browser->set_tree($tree);
 619
 620     #    $page->message_page("tree_style, reroot: [$tree_style], [$reroot]\n");
 621
 622     # initialize the layout object
 623     #
 624     my $layout = CXGN::Phylo::Layout_left_to_right->new($tree);
 625
 626     # initialize an approprate layout object
 627     #
 628
 629     $layout->set_top_margin(20);
 630     $layout->set_bottom_margin(20);
 631
 632     #    $layout->set_image_height(400);
 633     $layout->set_image_width(700);
 634     $tree->set_layout($layout);
 635
 636     #Highlight domains, utilize stored genes if possible to eliminate
 637     #database querying time.  Eval used for whole operation, since
 638     #none of it is critical for the viewer
 639     eval {
 640         my $genes;
 641         if ($stored_genes) {
 642             my $filepath = $stored_genes;
 643             $filepath = $PATH . "/" . $stored_genes
 644               unless ( $stored_genes =~ /\// );
 645             $genes = retrieve $filepath if ( -f $filepath );
 646
 647             unlink $filepath
 648               ;    #we will always store to a new file, so this one must go!
 649         }
 650         $genes = $alignment->highlight_domains($genes)
 651           if ( $show_domains && !$hide_alignment );
 652         my $storetemp = File::Temp->new( DIR => $PATH, UNLINK => 0 );
 653         my $storefile = $storetemp->filename;
 654         store( $genes, $storefile ) if ref $genes eq "HASH";
 655         $stored_genes = File::Basename::basename($storefile);
 656         $PARAM{stored_genes} = $stored_genes;
 657     };
 658
 659     my @nodes = $tree->get_all_nodes();
 660
 661     my %id2mem = ();
 662     foreach my $m ( @{ $alignment->{members} } ) {
 663         my $name = $m->get_id();
 664         $id2mem{$name} = $m;
 665     }
 666
 667     my %models;
 668
 669     foreach my $n (@nodes) {
 670         my $key  = $n->get_node_key();
 671         my $file = File::Basename::basename( $browser->get_temp_file() );
 672         $align_temp_file = "" if ( $align_temp_file =~ /\/$/ );
 673         my $align_temp_name = File::Basename::basename($align_temp_file);
 674
 675 #        my $link_tail = "&amp;hilite=$key\&amp;height=$height&amp;file=$file&amp;action=display&amp;term=$term&amp;title=$urlencode{$title}&amp;style=$style&amp;show_blen=$show_blen&amp;align_temp_file=$align_temp_name&align_type=$align_type&hide_alignment=$hide_alignment";
 676         $PARAM{align_temp_file} = $align_temp_name;
 677         $PARAM{file}            = $file;
 678
 679 # if the node is hidden, we generate a link that will unhide it if you click on it!
 680 # (we remove the node from the node_operations list)
 681 #
 682         my @ops = $browser->get_node_operations();
 683
 684         for ( my $i = 0 ; $i < @ops ; $i++ ) {
 685             if ( $ops[$i] =~ /^h$key$/i ) {
 686                 splice @ops, $i, 1;
 687             }
 688         }
 689         my $tooltip = $n->get_tooltip();
 690         if (!$tooltip) {
 691             $tooltip = "Node " . $n->get_node_key() . ": " . $n->get_label()->get_name();
 692         }
 693
 694         #    my $tooltip = "Node " . $n->get_node_key();
 695         my $model = $n->get_attribute("model");
 696         if ($model) {
 697             $tooltip .= ", Model: " . ucfirst($model);
 698             $models{$model}++;
 699         }
 700         $n->set_tooltip($tooltip);
 701
 702         my $link = "?"
 703           . hash2param(
 704             \%PARAM,
 705             {
 706                 hilite => $key,
 707                 ops    => ( join "+", @ops )
 708             }
 709           );
 710
 711         # set the link...
 712         #
 713         $n->set_link($link);
 714
 715         if ( $n->is_leaf() ) {
 716
 717             if ( !$n->get_label()->get_link() ) {
 718                 my $name = $n->get_label()->get_name();
 719                 my $link = identifier_url($name);
 720
 721                 #print STDERR "Name: ".$n->get_name()." LINK: ".$link."\n";
 722                 if ($link) {
 723                     $n->get_label()->set_link($link);
 724                 }
 725                 my $ns = identifier_namespace($name);
 726                 if ( $ns && $ns =~ /(sgn_u)|(tair_gene_model)/ ) {
 727                     my ( $gene, $annot );
 728                     eval {
 729
 730                         #print STDERR "Before Gene->new...\n";
 731                         $gene = CXGN::Tools::Gene->new($name);
 732
 733                         #    print STDERR "After Gene->new...\n";
 734                         $annot = $gene->getAnnotation();
 735                         $annot = HTML::Entities::encode($annot);
 736                     };
 737                     unless ($@) {
 738                         $n->get_label()->set_tooltip($annot) if $annot;
 739                     }
 740
 741                 }
 742             }
 743
 744           # adjust the label colors if there is a link. internal links are blue,
 745           # while external links are purple.
 746           #
 747             if ( $n->get_label()->get_link() ) {
 748                 $n->get_label()->set_line_color( 0, 0, 255 );
 749             }
 750             if ( $n->get_label()->get_link() =~ /^\s*http/ ) {
 751                 $n->get_label()->set_line_color( 200, 0, 200 );
 752             }
 753         }
 754
 755         #$n->print();
 756     }    # end of foreach my $n (@nodes) loop
 757
 758     # if a search was performed, hilite the results
 759     #
 760     my @search_nodes =
 761       $browser->get_tree()->search_label_name("$term")
 762       ;    # search_node_name("$term");
 763     foreach my $n (@search_nodes) {
 764         $n->get_label()->set_hilite(1);    #
 765         $n->get_label()->set_hilite_color( 255, 200, 85 );
 766     }
 767
 768     $browser->play_back_operations();
 769
 770 # hilite the node if the node is still in the tree (may have disappeared due to subtree etc)
 771 #
 772     if ( $hilite && $tree->get_node($hilite) ) {
 773         $tree->get_node($hilite)->set_hilited(1);
 774     }
 775     $tree->set_hilite_color( 140, 60, 60 );
 776
 777     # initialize an appropriate renderer and render the image
 778     #
 779     my $renderer = undef;
 780
 781     # deal with the tree_style
 782     #
 783     if ( !$tree_style ) { $tree_style = "straight"; }
 784     if ( $tree_style eq "round" ) {
 785         $renderer = CXGN::Phylo::PNG_round_tree_renderer->new($tree);
 786     }
 787     elsif ( $tree_style eq "angle" ) {
 788         $renderer = CXGN::Phylo::PNG_angle_tree_renderer->new($tree);
 789     }
 790     else { $renderer = CXGN::Phylo::PNG_tree_renderer->new($tree); }
 791
 792     $renderer->set_show_branch_length($show_blen);
 793
 794     my @model_colors = (
 795         [ 100, 40,  100 ],
 796         [ 50,  140, 50 ],
 797         [ 40,  40,  170 ],
 798         [ 150, 90,  10 ],
 799         [ 100, 100, 40 ]
 800     );
 801     foreach my $model ( sort { $models{$b} <=> $models{$a} } keys %models ) {
 802         my $color_array = shift @model_colors;
 803         $renderer->hilite_model( $model, $color_array ) if $color_array;
 804     }
 805
 806     $renderer->hide_alignment() if ($hide_alignment);
 807     $tree->set_renderer($renderer);
 808
 809     #    $tree->layout();
 810
 811     $browser->recursive_manage_labels( $browser->get_tree()->get_root() );
 812     $tree->get_root()->recursive_propagate_properties();
 813
 814     my $DEFAULT_HEIGHT = 400;
 815     if ( !$height ) {
 816         $height = "stretch";
 817     }
 818     my $image_height = $DEFAULT_HEIGHT;
 819     if ( $height =~ /stretch/i ) {
 820         $tree->get_renderer()->set_font( GD::Font->Small() );
 821         $image_height = $tree->get_unhidden_leaf_count() * 12;
 822         if ( $image_height > $DEFAULT_HEIGHT ) {
 823             $height = $image_height;
 824         }
 825         else {
 826             $height = $DEFAULT_HEIGHT;
 827         }
 828     }
 829     $layout->set_image_height($height);
 830
 831     my $unique = "_" . time() . $$;
 832
 833     my $new_align_temp_fh = File::Temp->new(
 834         DIR    => $PATH,
 835         UNLINK => 0,
 836     );
 837     my $new_align_temp     = $new_align_temp_fh->filename;
 838     my $new_hilite_temp_fh = File::Temp->new(
 839         DIR    => $PATH,
 840         UNLINK => 0,
 841     );
 842     my $new_hilite_temp = $new_hilite_temp_fh->filename;
 843
 844     my $s = 0;
 845
 846     foreach my $n ( $tree->get_leaf_list ) {
 847
 848         #alignment member stuff:
 849         $s++;
 850         my ( @mem_color, @hilite_color, @label_color, @label_hilite_color );
 851         if ( $s % 2 == 1 )
 852         {    # alignments shown with alternating darker and lighter colors...
 853             @mem_color          = ( 60,  60, 140 );
 854             @hilite_color       = ( 140, 60, 60 );
 855             @label_color        = ( 80,  80, 120 );
 856             @label_hilite_color = ( 120, 80, 80 );
 857         }
 858         else {
 859             @mem_color          = ( 20,  20, 110 );
 860             @hilite_color       = ( 110, 20, 20 );
 861             @label_color        = ( 20,  20, 60 );
 862             @label_hilite_color = ( 60,  20, 20 );
 863         }
 864
 865         my $key = $n->get_name();
 866         my $m   = $id2mem{$key};
 867         next unless $m;
 868         $n->set_alignment_member($m);
 869         if ( $n->get_hilited ) {
 870             $m->set_color(@hilite_color);
 871             print $new_hilite_temp_fh ">$key\n" . $fasta_hash{$key} . "\n";
 872             $n->get_label()->set_text_color(@label_hilite_color)
 873               unless $hide_alignment;
 874         }
 875         else {
 876             $m->set_color(@mem_color);
 877             $n->get_label()->set_text_color(@label_color)
 878               unless $hide_alignment;
 879         }
 880         print $new_align_temp_fh ">$key\n" . $fasta_hash{$key} . "\n";
 881     }
 882
 883     my $start_value = 1;
 884     my $end_value   = $alignment->get_end_value();
 885
 886     # add the process id to the file name of the image to create
 887     # a unique filename, so that the image is re-loaded every time
 888     # it is clicked (required by Explorer).
 889     #
 890
 891     $tree->render_png( ( $browser->get_temp_file() ) . "$unique.png" );
 892
 893     my $filename = File::Basename::basename($file);
 894     my $temp_url = "/documents/tempfiles/align_viewer/${filename}$unique.png";
 895
 896  #   print "filename: $filename, temp url: $temp_url \n";
 897
 898     # display the page
 899     #
 900     $page->header();
 901     my $align_filename = File::Basename::basename($align_temp_file);
 902     print page_title_html(
 903 qq|<a href="?align_temp_show=$align_filename&newick_temp_show=$filename">Tree browser:</a> |
 904           . $tree->get_name() );
 905
 906     print $renderer->get_html_image_map( "tree_image_map", $new_align_temp,
 907         $new_hilite_temp, $align_type );
 908
 909     my $file_for_link = File::Basename::basename( $browser->get_temp_file() );
 910
 911     my $node_operations = join( " ", $browser->get_node_operations() );
 912     my $new_rotated_node_operations =
 913       join( " ", $node_operations, ( "r" . $browser->get_hilite() ) );
 914     my $new_hidden_node_operations =
 915       join( " ", $node_operations, ( "h" . $browser->get_hilite() ) );
 916     my $new_set_root_node_operations =
 917       join( " ", $node_operations, ( "s" . $browser->get_hilite() ) );
 918     my $new_reset_root_operations =
 919       join( " ", $node_operations, ( "t" . $browser->get_hilite() ) );
 920
 921     my $active_if_hilite_button = "";
 922     my $not_show_blen           = !$show_blen;
 923     my $not_show_orthologs      = !$show_orthologs;
 924     my $not_collapse_single_species_subtrees =
 925       !$collapse_single_species_subtrees;
 926     my $not_show_species = !$show_species;
 927
 928     #    my $not_root_min_var = !$root_min_var;
 929     if ( !$hilite ) {
 930         $active_if_hilite_button = "disabled";
 931     }
 932     my $not_hide_alignment = !$hide_alignment;
 933
 934     my $active_if_changed_button = "disabled";
 935     if ( $hilite || $ops ) {
 936         $active_if_changed_button = "";
 937     }
 938     chomp($tree_style);
 939
 940     #print STDERR "Tree_style: $tree_style\n";
 941     my ( $round_selected, $angle_selected, $straight_selected ) =
 942       ( "", "", "" );
 943     if ( $tree_style =~ /round/i ) {
 944         $round_selected    = "selected=\"selected\"";
 945         $angle_selected    = "";
 946         $straight_selected = "";
 947     }
 948     if ( $tree_style =~ /angle/i ) {
 949         $round_selected    = "";
 950         $angle_selected    = "selected=\"selected\"";
 951         $straight_selected = "";
 952     }
 953     if ( $tree_style =~ /straight/i ) {
 954         $round_selected    = "";
 955         $angle_selected    = "";
 956         $straight_selected = "selected=\"selected\"";
 957     }
 958
 959     my (
 960         $original_selected, $midpoint_selected, $minvar_selected,
 961         $mindl_selected,    $maxmin_selected
 962     ) = ( "", "", "", "", "" );
 963     if ( $reroot =~ /Midpoint/i ) {
 964         $midpoint_selected = "selected=\"selected\"";
 965     }
 966     elsif ( $reroot =~ /MinVariance/i ) {
 967         $minvar_selected = "selected=\"selected\"";
 968     }
 969     elsif ( $reroot =~ /MinDuplication/i ) {
 970         $mindl_selected = "selected=\"selected\"";
 971     }
 972     elsif ( $reroot =~ /MaxMin/i ) {
 973         $maxmin_selected = "selected=\"selected\"";
 974     }
 975     else {
 976         $original_selected = "selected=\"selected\"";
 977     }
 978
 979     my $smaller_height = int( $height * 0.7 );
 980     my $larger_height  = int( $height * 1.3 );
 981
 982     my $not_show_domains = 0;
 983     $not_show_domains = 1 unless $show_domains;
 984
 985     my $blen_text = "Show Branch Length";
 986     $blen_text = "Hide Branch Length" if $show_blen;
 987     my $align_text = "Hide Alignment";
 988     $align_text = "Show Alignment" if $hide_alignment;
 989     my $domain_text = "Hide Domains";
 990     $domain_text = "Show Domains" unless $show_domains;
 991     my $show_species_text = "Hide species";
 992     $show_species_text = "Show species" unless $show_species;
 993
 994     #    my $root_min_var_text = "Reroot (Min Var)";
 995     #    $root_min_var_text = "Original Root" if $root_min_var;
 996     my $ortho_text = ($show_orthologs) ? "Hide Orthologs" : "Show Orthologs";
 997     my $collapse_single_species_text =
 998       ($collapse_single_species_subtrees)
 999       ? "Uncollapse 1-species subtrees"
1000       : "Collapse 1-species subtrees";
1001
1002     unless ( $tree->get_alignment() ) {
1003         $align_text  = "";
1004         $domain_text = "";
1005     }
1006     $domain_text = "" if $hide_alignment;
1007
1008     my $param_reset = hash2param( \%PARAM, { ops => "", hilite => "" } );
1009     my $param_rotate = hash2param(
1010         \%PARAM,
1011         {
1012             action => "rotate",
1013             ops    => $new_rotated_node_operations
1014         }
1015     );
1016
1017     my $param_hide = hash2param(
1018         \%PARAM,
1019         {
1020             action => "hide",
1021             ops    => $new_hidden_node_operations
1022         }
1023     );
1024
1025     my $param_prune_to_subtree = hash2param(
1026         \%PARAM,
1027         {
1028             height => "stretch",
1029             ops    => $new_set_root_node_operations
1030         }
1031     );
1032
1033     my $param_set_as_root = hash2param(
1034         \%PARAM,
1035         {
1036             action => "reset_root",
1037             ops    => $new_reset_root_operations
1038         }
1039     );
1040
1041     my $param_unselect = hash2param( \%PARAM, { hilite => "" } );
1042     my $param_align_toggle =
1043       hash2param( \%PARAM, { hide_alignment => $not_hide_alignment } );
1044     my $param_domain_toggle =
1045       hash2param( \%PARAM, { show_domains => $not_show_domains } );
1046     my $param_blen_toggle =
1047       hash2param( \%PARAM, { show_blen => $not_show_blen } );
1048     my $xxxxxx = $show_orthologs;
1049     my $param_orthologs_toggle =
1050       hash2param( \%PARAM, { show_orthologs => $not_show_orthologs } );
1051     my $param_collapse_toggle = hash2param(
1052         \%PARAM,
1053         {
1054             collapse_single_species_subtrees =>
1055               $not_collapse_single_species_subtrees
1056         }
1057     );
1058
1059 #    $page->message_page("xxxxxx, show ortho, std spec: ", "[$xxxxxx], [$show_orthologs], [$show_standard_species]<br>");
1060     my $param_show_species_toggle =
1061       hash2param( \%PARAM, { show_species => $not_show_species } );
1062
1063     #    my $param_reroot = hash2param(\%PARAM, { reroot => $reroot });
1064
1065     my ( $param_smaller, $param_larger, $param_autosize ) =
1066       map { hash2param( \%PARAM, { height => $_ } ) }
1067       ( $smaller_height, $larger_height, "stretch" );
1068
1069     my $param_input_tree_style = hash2hiddenpost( \%PARAM, {}, ["tree_style"] );
1070     my $param_input_reroot     = hash2hiddenpost( \%PARAM, {}, ["reroot"] );
1071
1072     my $param_input_term = hash2hiddenpost( \%PARAM, {}, ["term"] );
1073
1074     my $original_link = qq|<a href="?$param_reset">&lt;&lt; See Original Tree</a>&nbsp;&nbsp;&nbsp;|;
1075     $original_link = ""
1076       if ( $upload || $tree_string_param || !$node_operations );
1077
1078     my $w1 = "30%";
1079     my $w2 = "35%";
1080     my $w3 = "40%";
1081
1082
1083     my $treestyle_str = <<EOH;
1084 <td width="33%" >
1085   <form id="tree_style_form" style="margin-bottom:0; margin-top:0;font-size:1.0em">
1086     <table width="100%">
1087       <tr>
1088         <td style="font-size:1.1em" width="$w1" >Tree Style:&nbsp; </td>
1089         <td width="$w2" >
1090           <select name="tree_style" onchange="document.getElementById('tree_style_form').submit(); return false">
1091             <option value="round" $round_selected>curve</option>
1092             <option value="angle" $angle_selected>straight</option>
1093             <option value="straight" $straight_selected>corner</option>
1094           </select>
1095         </td>
1096         <td width="$w3">
1097           <input type="submit" value="Change" />
1098           $param_input_tree_style
1099         </td>
1100       </tr>
1101     </table>
1102   </form>
1103 </td>
1104 EOH
1105
1106     my $reroot_str = <<EOH;
1107 <td>
1108   <form id="reroot_form" style="margin-bottom:0; margin-top:0;font-size:1.0em">
1109     <table width="100%">
1110     <tr>
1111       <td width="$w1">Reroot:&nbsp;</td>
1112       <td width="$w2" >
1113         <select name="reroot" onchange=" document.getElementById('reroot_form').submit(); return false;    ">
1114           <option value ="Original" $original_selected>original</option>
1115           <option value="Midpoint" $midpoint_selected>midpoint</option>
1116           <option value="MinVariance" $minvar_selected>minvar</option>
1117           <option value="MinDuplication" $mindl_selected>mindupl</option>
1118           <option value="MaxMin" $maxmin_selected>maxmin</option>
1119         </select>
1120       </td>
1121      <td width="$w3">
1122        <input type="submit" value="Change" />
1123        $param_input_reroot
1124      </td>
1125     </tr>
1126     </table>
1127   </form>
1128 </td>
1129
1130 <!-- is this needed? seems to work just when you select new style in menu. maybe some browsers behave differently?-->
1131 EOH
1132
1133     my $highlight_str = <<EOH;
1134 <td width = "28%">
1135   <form style="margin-bottom:0; margin-top:0">
1136     <table>
1137     <tr>
1138       <td><input name="term" size="10" value="$term" /></td>
1139       <td><input type="submit" value="Highlight" />    $param_input_term</td>
1140     </tr>
1141     </table>
1142   </form>
1143 </td>
1144 EOH
1145
1146     my $show_species_str = qq|<td style="text-align:center"> <a href="?$param_show_species_toggle">$show_species_text</a> </td>|;
1147
1148     my $show_blen = <<EOH;
1149 <td style="text-align:center">
1150   <a href="?$param_blen_toggle"
1151      onMouseover="oldwindowstatus = window.status; window.status=$show_blen; return true"
1152      onMouseout="window.status=oldwindowstatus; return true">
1153     $blen_text
1154   </a>
1155 </td>
1156 EOH
1157
1158     my $show_ortho = qq|<td  style="text-align:center"> <a href="?$param_orthologs_toggle">$ortho_text</a> </td>|;
1159     my $collapse_single_species =
1160 qq|<td style="text-align:center"> <a href="?$param_collapse_toggle">$collapse_single_species_text</a> </td>|;
1161
1162     my $imagesize_str = <<EOH;
1163 <td style="text-align:center; vertical-align:bottom">
1164   <span style="font-size:1.1em">Image Size:&nbsp;</span>
1165   <a style="font-size:0.90em" href="?$param_smaller">Smaller</a>
1166   <a style="font-size:1.18em" href="?$param_larger">Larger</a>
1167   <a href="?$param_autosize">AUTO</a>
1168 </td>
1169 EOH
1170
1171     my $align_domain_str = <<EOH;
1172 <td colspan="2" style="text-align:center">
1173   <a href="?$param_align_toggle">$align_text</a>
1174   &nbsp;&nbsp;&nbsp;
1175   <a href="?$param_domain_toggle">$domain_text</a>
1176 </td>
1177 EOH
1178
1179     print <<HTML;
1180 <table width="100%">
1181   <tr>
1182     $treestyle_str
1183     $highlight_str
1184     $imagesize_str
1185   </tr>
1186   <tr>
1187     $reroot_str
1188     $show_ortho
1189     $collapse_single_species
1190   </tr>
1191   <tr>
1192     $show_blen
1193     $show_species_str
1194     $align_domain_str
1195   </tr>
1196 HTML
1197
1198     my $node_control = <<HTML;
1199   <tr>
1200     <td style="padding:10px">
1201       <div style="text-align: center">
1202         <table style="border:1px solid #922; cell-padding:5px; padding:5px;font-size:1.0em;background-color:#eee">
1203           <tr>
1204             <td><a href="?$param_unselect">X</a></td>
1205             <td><span style="font-weight:bold; color:#411">Node $hilite</span>&nbsp;&nbsp;&nbsp;</td>
1206             <td><a href="?$param_hide">Hide</a>&nbsp;&nbsp;</td>
1207             <td><a href="?$param_rotate">Rotate</a>&nbsp;&nbsp;</td>
1208             <td><a href="?$param_prune_to_subtree">Subtree</a>&nbsp;&nbsp;</td>
1209             <td><a href="?$param_set_as_root">Set&nbsp;as&nbsp;Root</a>&nbsp;&nbsp;</td>
1210           </tr>
1211         </table>
1212       </div>
1213     </td>
1214   </tr>
1215 HTML
1216     print $node_control if $hilite;
1217
1218     print <<HTML;
1219 </table>
1220 <img style="display: block; margin: 2em auto" src="$temp_url" usemap="#tree_image_map" alt="" />
1221 <a name="bottom">&nbsp;</a>
1222 HTML
1223
1224     # print STDERR "term: $term.   param_input_term: $param_input_term \n";
1225
1226     if ($show_orthologs) {
1227 #         if (0) {
1228 #             $species_tree->get_root()->recursive_implicit_species();
1229
1230 #             $species_tree->get_root()
1231 #               ->recursive_set_implicit_species_bits($spec_bit_hash);
1232 #             $browser->get_tree()->get_root()->recursive_implicit_species();
1233
1234 #             $browser->get_tree()->get_root()
1235 #               ->recursive_set_implicit_species_bits($spec_bit_hash);
1236 #             $browser->get_tree()->get_root()->recursive_implicit_names();
1237 #             $browser->get_tree()->get_root()
1238 #               ->recursive_set_speciation($species_tree);
1239 #             $browser->get_tree()->get_root()
1240 #               ->recursive_hilite_speciation_nodes($species_tree);
1241 #         }
1242
1243         $browser->get_tree()->set_line_color( 0, 200, 0 );
1244         $browser->get_tree()->set_hilite_color( 100, 200, 200 );
1245
1246         my @leaves = $browser->get_tree->get_leaves;
1247         $browser->get_tree->set_show_standard_species($show_species);
1248         my $ortho_hilite_only = 0;
1249         my $first_cell_text = "Orthologs of&nbsp&nbsp";
1250         @leaves = sort { $a->get_name cmp $b->get_name } @leaves;
1251         my $ostring = "";
1252         foreach my $leaf (@leaves) {
1253
1254             # next line to only show orthologs of highlighted nodes,
1255             # if any are highlighted
1256             next unless    !$ortho_hilite_only
1257                         || !@search_nodes
1258                         || $leaf->get_label->get_hilite;
1259
1260             my $the_name = $leaf->get_name;
1261             if ( $the_name =~ /([^{|]+)/ ) {
1262                 $the_name = $1;
1263             }                   # i.e. trim off everything from the first pipe or { on
1264             $first_cell_text = "";
1265             $ostring .= Tr(
1266                 td( $first_cell_text ),
1267                 td( "$the_name:&nbsp&nbsp&nbsp&nbsp"),
1268                 td( join( ",&nbsp ", sort $leaf->collect_orthologs_of_leaf ) ),
1269                );
1270         }
1271         $ostring = table($ostring);
1272
1273         $browser->get_tree->show_newick_attribute("speciation");
1274         $browser->get_tree->show_newick_attribute("species");
1275         my $newick_string = $browser->get_tree->generate_newick();
1276
1277         print info_section_html(
1278             title         => 'Ortholog pairs',
1279             contents      => $ostring,
1280             collapsible   => 'true',
1281             empty_message => ""
1282         );
1283
1284     }
1285
1286     if ( $hilite && ( $height > ( $DEFAULT_HEIGHT + 200 ) ) ) {
1287         $node_control =~ s/href="(.*?)"/href="$1#bottom"/ig;
1288         print $node_control;
1289     }
1290
1291     $page->footer();
1292 }
1293
1294 sub show_form {
1295     my $page = shift;
1296
1297     $page->header();
1298
1299     print page_title_html("Tree browser");
1300
1301     my $submit_preset = "";
1302     my $align_preset  = "";
1303     if ( -f $align_temp_show ) {
1304         open my $af, '<', $align_temp_show or die "$! opening '$align_temp_show'";
1305         while (<$af>) {
1306             $align_preset .= $_;
1307         }
1308     }
1309
1310     my $newick_preset = "";
1311     if ( -f $newick_temp_show ) {
1312         open my $nf, '<', $newick_temp_show or die "$! opening '$newick_temp_show'";
1313         while (<$nf>) {
1314             $newick_preset .= $_;
1315         }
1316     }
1317
1318     my $title_preset = "";
1319     #print STDERR "Debug marker 702\n";
1320
1321     if ($example_show) {
1322         $title_preset = "Arabidopsis Family Example";
1323         if( open my $af, '<', "$HTML_ROOT_PATH/cgi-bin/tools/tree_browser/data/example_align_preset.txt" ) {
1324             while (<$af>) {
1325                 $align_preset .= $_;
1326             }
1327             $submit_preset ||= "View Tree and Alignment";
1328         }
1329         else { $align_preset = "Example File Not Found" }
1330         if( open my $nf, '<', "$HTML_ROOT_PATH/cgi-bin/tools/tree_browser/data/example_newick_preset.txt" ) {
1331             while (<$nf>) {
1332                 $newick_preset .= $_;
1333             }
1334         }
1335         else {
1336             $newick_preset = "Example File Not Found";
1337         }
1338     }
1339     print table({ style => 'margin: 0 auto'},
1340                 Tr( td( 'Enter a tree in',
1341                         a( {href=> 'http://evolution.genetics.washington.edu/phylip/newicktree.html'},
1342                            'newick',
1343                          ),
1344                         a( {href=> '?example_show=1'},
1345                            'Show Me an Example',
1346                          ),
1347                       ),
1348                   ),
1349                 Tr(
1350                    td( start_form(),
1351                        hidden( 'action', 'display'),
1352                        dl(
1353                           dt('Title'),
1354                           dd(textfield( -id   => 'title_box',
1355                                         -size => 30,
1356                                         -name => 'title',
1357                                         -value => $title_preset,
1358                                       ),
1359                             ),
1360                           dt('Newick'),
1361                           dd(textarea( -name => 'tree_string',
1362                                        -id   => 'tree_string_box',
1363                                        -rows => 4,
1364                                        -columns => 80,
1365                                        -value => $newick_preset,
1366                                      ),
1367                             ),
1368                           dt('Optional Alignment'),
1369                           dd( {class => 'boxbgcolor5'},
1370                               div( 'Type:',
1371                                    radio_group(  -name => 'align_type',
1372                                                  -labels => { nt => 'Nucleotide',
1373                                                               pep => 'Peptide',
1374                                                             },
1375                                                  -values => [qw[ nt pep ]],
1376                                                  -default => 'pep',
1377                                               ),
1378                                  ),
1379                               div( 'Format:',
1380                                    radio_group( -name => 'format',
1381                                                 -values => [qw[clustalw fasta]],
1382                                                 -labels => { clustalw => 'CLUSTAL alignment',
1383                                                              fasta => 'Fasta (Gapped)',
1384                                                            },
1385                                                 -default => 'fasta',
1386                                               ),
1387                                  ),
1388                               div( 'Input Sequences:' ),
1389                               div( textarea(
1390                                             -onBlur => <<EOJS,
1391 document.getElementById('tree_submit').value = document.getElementById('align_seq_data_box').value ? 'View Tree and Alignment' : 'View Tree';
1392 return false;
1393 EOJS
1394                                             -name    => 'align_seq_data',
1395                                             -id      => 'align_seq_data_box',
1396                                             -rows    => 6,
1397                                             -columns => 76,
1398                                             -value   => $align_preset,
1399                                            ),
1400                                  ),
1401                             ),
1402                          ),
1403                        CGI::reset( -value => 'Clear form',
1404                                    -onClick => <<EOJS,
1405 document.getElementById('align_seq_data_box').value =
1406 document.getElementById('tree_string_box').value =
1407 document.getElementById('title_box').value = '';
1408 return false;
1409 EOJS
1410                                  ),
1411                        submit(
1412                               -id => 'tree_submit',
1413                               -value => $submit_preset || "View Tree",
1414                              ),
1415                        end_form(),
1416                      ),
1417                   ),
1418                );
1419
1420     $page->footer();
1421 }
1422
1423 #Alignment-Related Subroutines ###############################################
1424
1425 sub fasta_check {
1426     my ( $file, $page, $n ) = @_;
1427     my ($filename) = $file =~ /([^\/]+)$/;
1428     my $count      = 0;
1429     my $maxlen     = 0;
1430     my $instream = Bio::SeqIO->new( -file => $file, -format => 'fasta' );
1431     my $entry = $instream->next_seq();
1432     unless ( $entry && $entry->id && $entry->seq ) {
1433         input_err_page( $page, "FASTA needs IDs and Sequences [$filename]" );
1434     }
1435     $count++;
1436     $maxlen = length( $entry->seq );
1437     $entry  = $instream->next_seq;
1438
1439     #    print STDERR "Checking sequence number $count in $file...\n";
1440     unless ( $entry && $entry->id && $entry->seq ) {
1441         input_err_page( $page, "FASTA must have at least two valid sequences" );
1442     }
1443     $count++;
1444     $maxlen = length( $entry->seq ) if length( $entry->seq ) > $maxlen;
1445     while ( $entry = $instream->next_seq() ) {
1446         unless ( $entry->id && $entry->seq ) {
1447             input_err_page( $page, "Every entry must have ID AND sequence" );
1448         }
1449         $maxlen = length( $entry->seq ) if length( $entry->seq ) > $maxlen;
1450         $count++;
1451     }
1452     return ( $count, $maxlen );
1453 }
1454
1455 sub convert_clustal_fasta {
1456     my $clustal_file = shift;
1457     my $fasta_file   = shift;
1458
1459     my $in = Bio::AlignIO->new(
1460         -file   => $clustal_file,
1461         -format => 'clustalw'
1462     );
1463     my $cl_out = Bio::AlignIO->new(
1464         -file   => ">$fasta_file",
1465         -format => 'fasta',
1466     );
1467
1468     while ( my $aln = $in->next_aln() ) {
1469         $aln->set_displayname_flat();
1470         $cl_out->write_aln($aln);
1471     }
1472     $cl_out->close();
1473     $in->close();
1474 }
1475
1476 #############
1477
1478 # spaces-> &nbsp; and /n-><br>
1479 sub htmlize {
1480     my $string = shift;
1481     $string =~ s/ /&nbsp;/g;
1482     $string =~ s/\n/<br>/g;
1483     return $string;
1484 }
1485
1486 # \n -> new row
1487 # >=2 whitespace characters -> go to next cell to right
1488 sub html_tableize {
1489     my $instring = shift;
1490     $instring =~ s/^\s*//;    # remove leading whitespace.
1491     $instring =~ s/\s*$//;    # remove trailing whitespace
1492     my $outstring = qq|<table width="100%" border="1"><tr><td>|;
1493     $outstring .= $instring;
1494     $outstring =~ s!\n!</td></tr><tr><td>!g;    # /n -> new row
1495     $outstring =~
1496       s!\s{2,}!</td><td>!g;    # >= 2 of any whitespace char -> new cell
1497     $outstring .= "</td></tr></table>";
1498     return $outstring;
1499 }
1500
1501 sub input_err_page {
1502     my $input_err_page = shift;
1503     my $err_message    = shift;
1504     $input_err_page->header();
1505     print page_title_html("Combined Tree/Alignment Error");
1506     print "$err_message<br><br><a href=\"index.pl\">Start over</a><br>";
1507     $input_err_page->footer();
1508     exit;
1509 }
1510
1511
1512 # this one will have col headings ortholog group, leaf names, leaf species, agrees with species tree (distance)
1513 sub oglist_html_table {
1514     my $browser     = shift;
1515     my $tree        = $browser->get_tree();
1516     my @oglist      = @_;
1517     my $cell_spacer = "</td><td>";
1518     my $row_end     = "</td></tr>";
1519     my $oglstring   = "<table width=\"100%\" border=\"0\" ><tr><td>";
1520     $oglstring .=
1521         "Ortholog group"
1522       . $cell_spacer . "Names"
1523       . $cell_spacer
1524       . "Species"
1525       . $cell_spacer
1526       . "Matches species tree?"
1527       . $cell_spacer
1528       . "Distance"
1529       . $row_end;
1530
1531     my $ognumber = 1;
1532     if ( scalar @oglist == 0 ) {
1533         $oglstring .= "<tr><td>No ortholog groups found.$row_end";
1534     }
1535     else {
1536         foreach my $o (@oglist) {
1537
1538 #    print STDOUT "ZZZ tree copy root qrfd: [", $o->get_tree()->get_root()->get_attribute("qRF_distance"), "] [", $o->get_tree()->get_root()->get_attribute("subtree_leaves_match"), "]<br>\n";
1539
1540             $o->get_ortholog_tree()->get_root()->recursive_implicit_species();
1541             my $og_row_string =
1542               $o->table_row_string();    # this can have multiple rows...
1543                                          #Use a non-greedy quantifier here!!
1544             while ( $og_row_string =~ m/<tr><td>([a-z]*)_(.*?)$cell_spacer/ ) {
1545                 $og_row_string =~
1546 s{<tr><td([a-z]*)_(.*?)$cell_spacer}{<tr><td>$ognumber$1$cell_spacer$2$cell_spacer}
1547                   ;                      #just 1 subst.
1548
1549                 my $implname = $2;       #this is ", " separated
1550                 $implname =~ s/,\s*/\t/g;    # make it space separated
1551                 my $ogletter = $1;
1552                 my ( $key, $node ) =
1553                   $tree->node_from_implicit_name_string($implname);
1554
1555                 my @ops  = $browser->get_node_operations();
1556                 my $link = "?"
1557                   . hash2param(
1558                     \%PARAM,
1559                     {
1560                         hilite => $key,
1561                         ops    => ( join "+", @ops )
1562                     }
1563                   );
1564                 my $lnkstr = "<a href=\"$link\">";
1565                 $og_row_string =~
1566 s{<tr><td>($ognumber$ogletter)?$cell_spacer}{<tr><td>$lnkstr$1$cell_spacer}
1567                   ;    #put in the links
1568
1569             }
1570             $oglstring .= $og_row_string;
1571             $ognumber++;
1572         }
1573     }
1574     $oglstring .= "</table>";
1575     return $oglstring;
1576 }