lib/CXGN/Phylo/Tree_browser.pm

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use File::Temp;
   5
   6 use CXGN::Phylo::Configuration;
   7
   8 package CXGN::Phylo::Tree_browser;
   9
  10 sub new {
  11     my $class = shift;
  12         my $directives = shift;
  13
  14     my $args= {};
  15     my $self = bless $args, $class;
  16
  17     # set the default using the setter functions
  18     #
  19     $self->set_tree(undef);
  20         #want this to work outside of mod_perl: (ccarpita)
  21         unless($directives->{no_apache}){
  22             $self->set_temp_file(undef);
  23         }
  24     $self->set_temp_url(undef);
  25     $self->set_tree_string(undef);
  26     $self->set_temp_dir(undef);
  27     $self->set_hilite(0);
  28
  29     # build the function hash
  30     #
  31     $self->add_code_table("r", "function_rotate_node", 2);
  32     $self->add_code_table("h", "function_hide_node", 2);
  33     $self->add_code_table("s", "function_prune_to_subtree", 1);
  34     $self->add_code_table("t", "function_reset_root", 1);
  35
  36     return $self;
  37 }
  38
  39 =head2 function get_tree()
  40
  41   Synopsis:
  42   Arguments:
  43   Returns:
  44   Side effects:
  45   Description:
  46
  47 =cut
  48
  49 sub get_tree {
  50     my $self=shift;
  51     return $self->{tree};
  52 }
  53
  54 =head2 function set_tree
  55
  56   Synopsis:
  57   Arguments:
  58   Returns:
  59   Side effects:
  60   Description:
  61
  62 =cut
  63
  64 sub set_tree {
  65     my $self=shift;
  66     $self->{tree}=shift;
  67 }
  68
  69 sub create_temp_file {
  70     my $self = shift;
  71
  72     my $tempdir = $self->get_temp_dir();
  73     #print STDERR "TEMPDIR: $tempdir\n";
  74     my ($tempfh, $tempfile) = File::Temp::tempfile("tree-XXXXXX", DIR=>$tempdir);
  75     print $tempfh $self->get_tree_string();
  76     $tempfh->close();
  77
  78     my $temp_url = $tempfile;
  79     $temp_url =~ s/.*(tempfiles.*$)/$1/;
  80
  81     $temp_url = "/documents/$temp_url";
  82
  83     $self->set_temp_url($temp_url);
  84     $self->set_temp_file($tempfile);
  85
  86     return ($tempfile, $temp_url);
  87 }
  88
  89 sub read_temp_file {
  90     my $self = shift;
  91
  92     my $file_contents="";
  93
  94     if( open my $fh, $self->get_temp_file() ) {
  95       while (<$fh>) {
  96         chomp;
  97         $file_contents .= $_;
  98       }
  99       close $fh;
 100     }
 101
 102     $self->set_tree_string($file_contents);
 103 }
 104
 105
 106 =head2 function get_temp_url()
 107
 108   Synopsis:
 109   Arguments:
 110   Returns:
 111   Side effects:
 112   Description:
 113
 114 =cut
 115
 116 sub get_temp_url {
 117     my $self=shift;
 118     if (!$self->{temp_url}) {
 119         my $url = $self->get_temp_file();
 120         $url = File::Basename::basename($url);
 121         $url = "/documents/tempfiles/tree_browser/$url";
 122         $self->{temp_url}=$url;
 123     }
 124     return $self->{temp_url};
 125 }
 126
 127 =head2 function set_temp_url()
 128
 129   Synopsis:
 130   Arguments:
 131   Returns:
 132   Side effects:
 133   Description:
 134
 135 =cut
 136
 137 sub set_temp_url {
 138     my $self=shift;
 139     $self->{temp_url}=shift;
 140 }
 141
 142 =head2 function get_temp_file()
 143
 144   Synopsis:
 145   Arguments:
 146   Returns:
 147   Side effects:
 148   Description:
 149
 150 =cut
 151
 152 sub get_temp_file {
 153     my $self=shift;
 154
 155     my $tf = $self->{temp_file};
 156
 157     #print STDERR "in Tree_browser::get_temp_file(), temp_file: [", $tf, "]\n";
 158
 159     return $self->{temp_file};
 160 }
 161
 162 =head2 function set_temp_file()
 163
 164   Synopsis:     $browser->set_temp_file($filename);
 165   Arguments:    a valid filename
 166   Returns:      nothing
 167   Side effects: tries to read the tree string from $filename
 168                 and sets it using set_tree_string()
 169   Description:
 170
 171 =cut
 172
 173 sub set_temp_file {
 174     my $self=shift;
 175     $self->{temp_file}=shift;
 176     if (!$self->get_tree_string()) { $self->read_temp_file(); }
 177 }
 178
 179 =head2 function get_tree_string()
 180
 181   Synopsis:
 182   Arguments:
 183   Returns:
 184   Side effects:
 185   Description:
 186
 187 =cut
 188
 189 sub get_tree_string {
 190     my $self=shift;
 191     return $self->{tree_string};
 192 }
 193
 194 =head2 function set_tree_string()
 195
 196   Synopsis:
 197   Arguments:
 198   Returns:
 199   Side effects:
 200   Description:
 201
 202 =cut
 203
 204 sub set_tree_string {
 205     my $self=shift;
 206     $self->{tree_string}=shift;
 207 }
 208
 209 =head2 function get_temp_dir
 210
 211   Synopsis:
 212   Arguments:    none
 213   Returns:      a temp directory. If the directory was not set using
 214                 set_temp_dir(), it tries to come up with a good guess.
 215   Side effects: the temp_dir property is used to write the temporary files
 216                 to. If it is not correct, the browser won\'t work.
 217   Description:
 218
 219 =cut
 220
 221 sub get_temp_dir {
 222     my $self=shift;
 223
 224     if (!exists($self->{temp_dir}) || !$self->{temp_dir}) {
 225         $self->{temp_dir} = CXGN::Phylo::Configuration->new()->get_temp_dir();
 226     }
 227     return $self->{temp_dir};
 228 }
 229
 230 =head2 function set_temp_dir
 231
 232   Synopsis:
 233   Arguments:
 234   Returns:
 235   Side effects:
 236   Description:
 237
 238 =cut
 239
 240 sub set_temp_dir {
 241     my $self=shift;
 242     $self->{temp_dir}=shift;
 243 }
 244
 245 =head2 function recursive_manage_labels()
 246
 247   Synopsis:
 248   Arguments:
 249   Returns:
 250   Side effects:
 251   Description:
 252
 253 =cut
 254
 255 sub recursive_manage_labels {
 256     my $self = shift;
 257     my $node = shift;
 258
 259     # check the shortest branch length on this node
 260     #
 261     my $shortest = 1e200;
 262     foreach my $c ($node->get_children()) {
 263         if ($c->get_branch_length() < $shortest) {
 264             $shortest=$c->get_branch_length();
 265         }
 266     }
 267     #
 268     my $scaling_factor = $self->get_tree()->get_layout()->get_horizontal_scaling_factor();
 269     if ( ($shortest * $scaling_factor) > (length($node->get_name())*5) )  {
 270         $node->get_label()->set_hidden(0);
 271     }
 272     elsif ($node->get_hilited()) {
 273         $node->get_label()->set_hidden(0);
 274     }
 275     elsif ($node->is_leaf()) {
 276         $node->get_label()->set_hidden(0);
 277     }
 278     elsif ($node->get_label()->get_hilite()) {
 279         $node->get_label()->set_hidden(0);
 280     }
 281     elsif ($node->get_hidden()) {
 282         $node->get_label()->set_hidden(0);
 283     }
 284     else {
 285         $node->get_label()->set_hidden(1);
 286     }
 287
 288     foreach my $c ($node->get_children()) {
 289         $self->recursive_manage_labels($c);
 290     }
 291
 292 }
 293
 294
 295
 296
 297 =head2 function get_hilite
 298
 299   Synopsis:
 300   Arguments:
 301   Returns:      the node key (NOT a node object) of the hilited node
 302   Side effects:
 303   Description:
 304
 305 =cut
 306
 307 sub get_hilite {
 308     my $self=shift;
 309     return $self->{hilite};
 310 }
 311
 312 =head2 function set_hilite
 313
 314   Synopsis:
 315   Arguments:
 316   Returns:
 317   Side effects:
 318   Description:
 319
 320 =cut
 321
 322 sub set_hilite {
 323     my $self=shift;
 324     my $hilite = shift;
 325
 326     # if hilite is undefined, everything will be hilited,
 327     # which is not the desired behavior.
 328     #
 329     if (!defined($hilite)) { $hilite=""; }
 330
 331     $self->{hilite}=$hilite;
 332 }
 333
 334 sub get_node_operations {
 335     my $self=shift;
 336     if (!exists($self->{node_operations})) { @{$self->{node_operations}}=(); }
 337     return @{$self->{node_operations}};
 338 }
 339
 340 =head2 function toggle_node_operation()
 341
 342   Synopsis:      $a_tree_browser->toggle_node_operation($the_operation);
 343   Arguments:    A node operation.
 344   Returns:
 345   Side effects:  Removes the operation from the node_operation list, if initially present,
 346       and pushes in onto the list if not initially present.
 347   Description:  node operations have to be played back in the same order
 348                 as they were generated by the user. The node operations
 349                 are therefore stored in an array. (in a first version,
 350                 they were stored in a hash which caused play back problems).
 351
 352 =cut
 353
 354 sub toggle_node_operation {
 355         my $self=shift;
 356         my $operation = shift;
 357         if (!exists($self->{node_operations})) { #initialize node operations array to empty list
 358                 @{$self->{node_operations}}=();
 359         }
 360         my $exists = 0;
 361         for (my $i=0; $i<@{$self->{node_operations}}; $i++) { # loop over node operations in the list
 362                 if (${$self->{node_operations}}[$i] =~ /^$operation$/i) {
 363                         $exists=1;
 364                         splice @{$self->{node_operations}}, $i, 1;
 365                 }
 366         }
 367         if (!$exists) {
 368                 push @{$self->{node_operations}}, $operation;
 369         }
 370 }
 371
 372 sub add_code_table {
 373     my $self = shift;
 374     my $code = shift;
 375     my $function = shift;
 376     my $priority = shift;
 377     ${$self->{op_code}}{$code}=$function;
 378     ${$self->{op_code_priority}}{$code}=$priority;
 379 }
 380
 381 sub get_code_table {
 382     my $self = shift;
 383     my $code = shift;
 384         return unless $code;
 385     my $function;
 386     if (exists(${$self->{op_code}}{$code})) {
 387         return (${$self->{op_code}}{$code}, ${$self->{op_code_priority}}{$code});
 388     }
 389     else {
 390         print STDERR "tree_browser.pm: $code is not a recognized function.\n";
 391         return undef;
 392     }
 393 }
 394
 395 =head2 function play_back_operations()
 396
 397   Synopsis:     $browser->play_back_operations();
 398   Arguments:    none
 399   Returns:      nothing
 400   Side effects: takes the operations as set by set_node_operations() and
 401                 executes the commands on the tree data structure.
 402                 It is important that the operations are played back in the
 403                 exact order they were initiated by the user.
 404   Description:
 405
 406 =cut
 407
 408 sub play_back_operations {
 409     my $self  = shift;
 410
 411     my @node_operations = $self->get_node_operations();
 412     #print STDERR "Operations: ".(join "|", @node_operations)."\n";
 413
 414     foreach my $priority (1, 2) {
 415         foreach my $operation (@node_operations) {
 416             my $code=""; my $node_key=0;
 417             if ($operation =~ m/([a-z]+)(\d+)/i) {
 418                 $code=$1;
 419                 $node_key=$2;
 420             }
 421
 422             #print STDERR "OPERATION: $code ON NODE $node_key\n";
 423             my $node = $self->get_tree()->get_node($node_key);
 424
 425             if ($code && !$self->get_code_table($code)) { print STDERR "Operation $code is undefined!\n"; next; }
 426             my ($operation_sub, $operation_priority) = $self->get_code_table($code);
 427             #print STDERR "Executing function $code on node $node_key\n";
 428             if ($node)  {
 429                 if ($priority == $operation_priority)  {
 430                     $self->$operation_sub($node);
 431                 }
 432             }
 433         }
 434     }
 435
 436     # recalculate tree parameters
 437     #
 438     $self->get_tree()->regenerate_node_hash($self->get_tree()->get_root());
 439     $self->get_tree()->get_root()->calculate_distances_from_root();
 440
 441     $self->get_tree()->calculate_leaf_list();
 442     $self->get_tree()->get_root()->recursive_propagate_properties();
 443
 444 }
 445
 446 sub function_rotate_node {
 447     my $self = shift;
 448     my $node = shift;
 449     #print STDERR "sub function_rotate_node: Rotating node: ".$node->get_node_key()."\n";
 450     $node->rotate_node();
 451 }
 452
 453 sub function_hide_node {
 454     my $self = shift;
 455     my $node = shift;
 456     $node->set_hidden(1);
 457 }
 458
 459 sub function_prune_to_subtree {
 460     my $self = shift;
 461     my $node = shift;
 462     $self->get_tree->prune_to_subtree($node);
 463 }
 464
 465 sub function_reset_root {
 466     my $self = shift;
 467     my $node = shift;
 468     $self->get_tree()->reset_root($node);
 469 }
 470
 471
 472 1;
 473