User defined colours in newick and nexus export. Yes/No dialog for co…

…lour export. Updates #630
shawnlaffan · Dec 23, 2016 · b786fca · b786fca
1 parent d80b2b1
commit b786fca
Show file tree

Hide file tree

Showing 4 changed files with 81 additions and 18 deletions.
diff --git a/lib/Biodiverse/GUI/Export.pm b/lib/Biodiverse/GUI/Export.pm
@@ -21,10 +21,13 @@ use Biodiverse::GUI::GUIManager;
 use Biodiverse::GUI::ParametersTable;
 use Biodiverse::GUI::YesNoCancel;
 
+use 5.010;
 
 sub Run {
-    my $object = shift;
-    my $selected_format = shift // '';
+    my ($object, %args) = @_;
+
+    my $selected_format = $args{selected_format};
+    my $export_colours = $args{export_colours};
 
     #  sometimes we get called on non-objects,
     #  eg if nothing is highlighted
@@ -140,8 +143,9 @@ sub Run {
 
         eval {
             $object->export(
-                format   => $selected_format,
-                file     => $filename,
+                format         => $selected_format,
+                file           => $filename,
+                export_colours => $export_colours,
                 @$params,
             )
         };

diff --git a/lib/Biodiverse/GUI/Tabs/Tab.pm b/lib/Biodiverse/GUI/Tabs/Tab.pm
@@ -965,12 +965,24 @@ sub update_export_menu {
 sub do_export {
     my $args = shift;
     my $self = $args->[0];
-    my @rest_of_args;
-    if (scalar @$args > 1) {
-        @rest_of_args = @$args[1..$#$args];
-    }
 
-    Biodiverse::GUI::Export::Run($self->{output_ref}, @rest_of_args);
+    my %args_hash;
+
+    my $selected_format = $args->[1] // '';
+
+
+    # ask whether they want to include colours
+    # TODO: check if colours have actually been changed/selected
+    my $response = Biodiverse::GUI::YesNoCancel->run({
+        header => "Export colours?",
+        hide_cancel => 1,
+    });
+
+
+    $args_hash{ export_colours  } = ($response eq 'yes');
+    $args_hash{ selected_format } = $selected_format;    
+
+    Biodiverse::GUI::Export::Run($self->{output_ref}, %args_hash);
 }
 
 

diff --git a/lib/Biodiverse/Tree.pm b/lib/Biodiverse/Tree.pm
@@ -709,7 +709,7 @@ sub get_unique_name {
 sub export {
     my $self = shift;
     my %args = @_;
-
+    
     croak "[TREE] Export:  Argument 'file' not specified or null\n"
         if not defined $args{file}
             || length ($args{file}) == 0;
@@ -1091,6 +1091,7 @@ sub export_tabular_tree {
         symmetric   => 1,
         name        => $name,
         use_internal_names => 1,
+        export_colours => $args{export_colours},
         %args,
     );
 

diff --git a/lib/Biodiverse/TreeNode.pm b/lib/Biodiverse/TreeNode.pm
@@ -1574,6 +1574,27 @@ sub get_colour {
     }
 }
 
+sub get_colour_string {
+    my ($self, %args) = @_;
+
+    my @long_format_string = split("", $self->get_colour()->to_string());
+
+
+    # to_string() gives a colour in a 12 digit format e.g. 1F1F 4444
+    # 0000. Seems like you can just take the first two digits of each
+    # colour block?
+
+    my $short_format_string = "#";
+    $short_format_string .= $long_format_string[1];
+    $short_format_string .= $long_format_string[2];
+    $short_format_string .= $long_format_string[5];
+    $short_format_string .= $long_format_string[6];
+    $short_format_string .= $long_format_string[9];
+    $short_format_string .= $long_format_string[10];
+
+    return $short_format_string;
+}
+
 
 #  convert the entire tree to a table structure, using a basestruct
 #  object as an intermediate
@@ -1598,7 +1619,7 @@ sub to_table {
         NAME => $treename,
     );  #  may need to specify some other params
 
-
+   
     my @header = qw /TREENAME NODE_NUMBER PARENTNODE LENGTHTOPARENT NAME COLOUR/;
 
 
@@ -1897,26 +1918,51 @@ sub to_newick {   #  convert the tree to a newick format.  Based on the NEXUS li
         if (defined $self->get_length) {
             $string .= ":" . $self->get_length;
         }
+
+        # build the bootstrap block
+        my @bootstrap_items = ();
         if (defined $self->get_value($boot_name)) {
-            $string .= "[" . $self->get_value($boot_name) . "]";
+            push @bootstrap_items, $self->get_value($boot_name);
+        }
+        if ($args{export_colours}) {
+            push @bootstrap_items, "&!color:".$self->get_colour_string();
+        }
+
+        if(scalar(@bootstrap_items) > 0) {
+            $string .= "[";
+            $string .= join(",", @bootstrap_items);
+            $string .= "]";
         }
-
     }
-    else { # terminal nodes
-        #$string .= "'" . $name . "'";
+    # terminal nodes
+    else {
         $string .= $name;
+
         if (defined $self->get_length) { 
             $string .= ":" . $self->get_length;
         }
-        if (defined $self->get_value($boot_name)) { # state at nodes sometimes put as bootstrap values
-            $string .= "[" . $self->get_value($boot_name) . "]";
+
+        # build the bootstrap block
+        my @bootstrap_items = ();
+        if (defined $self->get_value($boot_name)) {
+            push @bootstrap_items, $self->get_value($boot_name);
+        }
+        if ($args{export_colours}) {
+            push @bootstrap_items, "&!color:".$self->get_colour_string();
+        }
+
+        if(scalar(@bootstrap_items) > 0) {
+            $string .= "[";
+            $string .= join(",", @bootstrap_items);
+            $string .= "]";
         }
-        #$string .= ",";
     }
 
     return $string;
 }
 
+
+
 sub print { # prints out the tree (for debugging)
     my $self = shift;
     my $space = shift || $EMPTY_STRING;