File Coverage

blib/lib/Color/TupleEncode.pm
Criterion Covered Total %
statement 200 247 80.9
branch 71 102 69.6
condition 5 9 55.5
subroutine 32 40 80.0
pod 17 17 100.0
total 325 415 78.3


line stmt bran cond sub pod time code
1             package Color::TupleEncode;
2              
3 8     8   187773 use warnings FATAL=>"all";
  8         21  
  8         347  
4 8     8   44 use strict;
  8         17  
  8         287  
5              
6             # use Smart::Comments;
7              
8 8     8   339492 use parent qw(Exporter);
  8         2711  
  8         64  
9              
10             our %EXPORT_TAGS = ("all"=>[qw(tuple_asRGB tuple_asRGB255 tuple_asRGBhex tuple_asHSV)]);
11             Exporter::export_ok_tags("all");
12              
13 8     8   663 use Carp;
  8         15  
  8         635  
14 8     8   11693 use Graphics::ColorObject;
  8         3425685  
  8         593  
15 8     8   4820 use Color::TupleEncode::Baran;
  8         24  
  8         281  
16 8     8   5580 use Color::TupleEncode::2Way;
  8         23  
  8         259  
17 8     8   59 use Math::VecStat qw(min max);
  8         13  
  8         672  
18 8     8   47 use POSIX qw(fmod);
  8         13  
  8         68  
19 8     8   449 use Readonly;
  8         17  
  8         25109  
20              
21             # Additional allowable options - added to those of the implementation method
22             Readonly::Hash our %OPTIONS_DEFAULT => (-method=>"Color::TupleEncode::Baran");
23             Readonly::Array our @OPTIONS_OK => (qw(-method));
24              
25             =head1 NAME
26              
27             Color::TupleEncode - Encode a tuple (vector) into a color - useful for
28             generating color representation of a comparison of multiple values.
29              
30             =head1 VERSION
31              
32             Version 0.11
33              
34             =cut
35              
36             our $VERSION = '0.11';
37              
38             =head1 SYNOPSIS
39              
40             Given a tuple (e.g. three numbers) , apply color-coding method to
41             encode the tuple by a color in HSV (hue, saturation, value) space. For a visual tour of the results, see L.
42              
43             use Color::TupleEncode;
44              
45             # By default the encoding method Color::TupleEncode::Baran will be used
46              
47             # initialize and define in one step
48             $encoder = Color::TupleEncode->new(tuple=>[$a,$b,$c]);
49              
50             # pass in some options understood by the encoding implementation
51             %options = {-ha=>30, -saturation=>{dmin=>0.2,dmax=>0.8}};
52             $encoder = Color::TupleEncode->new(tuple=>[$a,$b,$c],options=>\%options);
53              
54             # initialize tuple directly
55             $encoder->set_tuple($a,$b,$c);
56             $encoder->set_tuple([$a,$b,$c]);
57              
58             # obtain RGB (0 <= R,G,B <= 1) values
59             ($r,$g,$b) = $encoder->as_RGB;
60              
61             # obtain RGB (0 <= R,G,B <= 255) values
62             ($r255,$g255,$b255) = $encoder->as_RGB255;
63              
64             # obtain RGB hex (e.g. FF00FF - note no leading #)
65             $hex = $encoder->as_RGBhex;
66              
67             # obtain HSV (0 <= H < 360, 0 <= S,V <= 1) values
68             ($h,$s,$v) = $encoder->as_HSV;
69              
70             # change the encoding method
71             $encoder->set_method("Color::TupleEncode::2Way");
72              
73             # see how many values this method accepts ($tuple_size = 2)
74             $tuple_size = $encoder->get_tuple_size();
75              
76             # set the tuple with the new method and encode
77             $encoder->set_tuple(1,2);
78              
79             ($r,$g,$b) = $encoder->as_RGB;
80              
81             Use C<%options> to define implementation and any parameters that control the encoding.
82              
83             %options = (-method=>"Color::TupleEncode::Baran");
84              
85             %options = (-method=>"Color::TupleEncode::Baran",
86             -saturation=>{min=>0,max=>1,dmin=>0,dmax=>1});
87              
88             A non-OO interface is also supported.
89              
90             # import functions explicitly
91             use Color::TupleEncode qw(tuple_asRGB tuple_asRGB255 tuple_asHSV tuple_asRGBhex);
92              
93             # or import them all automatically
94             use Color::TupleEncode qw(:all);
95              
96             # pass tuple and options just like with new()
97             ($r,$g,$b) = tuple_asRGB(tuple=>[$a,$b,$c]);
98              
99             # specify options
100             ($r,$g,$b) = tuple_asRGB(tuple=>[$a,$b,$c],options=>\%options)
101              
102             # specify method directly - note that ::2Way takes two values
103             ($r,$g,$b) = tuple_asRGB(tuple=>[$a,$b],method=>"Color::TupleEncode::2Way");
104              
105             # tuple_asRGB255, tuple_asHSV and tuple_asRGBhex work analogously
106              
107             =head1 COLOR ENCODINGS
108              
109             =head2 Default Encoding
110              
111             The default encoding method is due to I (see L
112             ENCODINGS>). This method encodes a 3-tuple C<(x,y,z)> by first assigning a
113             characteristic hue to each variable and then calculating a color based
114             on the relative relationship of the values. The encoding is designed
115             to emphasize the variable that is most different.
116              
117             The default encoding is implemented in L.
118              
119             =head2 C
120              
121             This encoding converts a 2-tuple C<(x,y)> to color. It is implemented in the module L.
122              
123             If you would like to implement your own encoding, I suggest editing and extend this module. See
124             L for more details.
125              
126             =head2 Other Encodings
127              
128             C is designed to derive encoding functionality
129             from utility modules, such as L. The
130             utility modules implement the specifics of the tuple-to-color
131             conversion and L does the housekeeping.
132              
133             You can change the class by using C<-method> in the C<%options> hash passed to C
134              
135             %options = (-method=>"Color::TupleEncode::2Way");
136              
137             set the option directly
138              
139             $threeway->set_options(-method=>"Color::TupleEncode::2Way");
140              
141             or pass the method name to C
142              
143             Color::TupleEncode->new(method=>"Color::TupleEncode::2Way");
144              
145             Note that when using the options hash, option names are prefixed by
146             C<->. When passing arguments to C, however, the C<-> is not
147             used.
148              
149             =head1 EXAMPLES
150              
151             =head2 Quick encoding
152              
153             To encode a tuple with the default encoding scheme (C):
154              
155             use Color::TupleEncode qw(as_HSV as_RGBhex);
156              
157             my @tuple = (0.2,0.5,0.9);
158              
159             my @hsv = as_HSV(tuple=>\@tuple); # 291 0.7 1.0
160             my @rgb = as_RGB255(tuple=>\@tuple); # 230 77 255
161             my $hex = as_RGBhex(tuple=>\@tuple); # E64DFF
162              
163             =head2 Encoding with options
164              
165             Options control how individual encodings work. The
166             C method supports changing the
167             characteristic hues of each variable, min/max ranges for saturation
168             and value and min/max ranges for the largest variable difference for
169             saturation and value components.
170              
171             # change the characteristic hues
172             my @hsv = as_HSV(tuple=>\@tuple,options=>{-ha=>60,-hb=>180,-hc=>300}); # 351 0.7 1.0
173              
174             =head2 Using another implementation
175              
176             use Color::TupleEncode qw(as_HSV as_RGBhex);
177              
178             my @tuple = (0.2,0.5,0.9);
179              
180             my $method = "Color::TupleEncode::2Way";
181             my @hsv = tuple_asHSV(tuple=>\@tuple,method=>$method); # 255 0.6 1.0
182             my @rgb = tuple_asRGB255(tuple=>\@tuple,method=>$method); # 102 140 255
183             my @rgb = tuple_asRGBhex(tuple=>\@tuple,method=>$method); # 668Cff
184              
185             =head2 examples/example-3way
186              
187             This is one of the example scripts in the C directory. It
188             shows how to use the 3-tuple encoding implemented by L
189              
190             The C takes a 3-tuple (or uses a random one) and reports its HSV, RGB and hex colors.
191              
192             # use a random tuple
193             > examples/example-3way
194             The 3-tuple 0.787 0.608 0.795 encodes as follows
195              
196             hue 125 saturation 0.186 value 1.000
197             R 207 G 255 B 211
198             hex CFFFD3
199              
200             # use a 3-tuple specified with -tuple
201             > examples/example-3way -tuple 0.2,0.3,0.9
202             The 3-tuple 0.200 0.300 0.900 encodes as follows
203              
204             hue 257 saturation 0.700 value 1.000
205             R 128 G 77 B 255
206             hex 804DFF
207              
208             =head2 examples/examples-2way
209              
210             This is one of the example scripts in the C directory. It
211             shows how to use the 2-tuple encoding implemented by L
212              
213             The C takes a 2-tuple (or uses a random one) and reports its HSV, RGB and hex colors.
214              
215             # use a random 2-tuple
216             > examples/example-2way
217             The 2-tuple 0.786 0.524 encodes as follows
218              
219             hue 240 saturation 0.440 value 0.126
220             R 18 G 18 B 32
221             hex 121220
222              
223             # use a 2-tuple specified with -tuple
224             > examples/example-2way -tuple 0.2,0.9
225             The 2-tuple 0.200 0.900 encodes as follows
226              
227             hue 40 saturation 0.167 value 0.422
228             R 108 G 102 B 90
229             hex 6C665A
230              
231             =head2 examples/tuple2color
232              
233             This script is much more flexible. It can read tuples from a file, or
234             generate a matrix of tuples that span a given range. You can specify
235             the implementation and options on the command line.
236              
237             The script can also generate a PNG color chart of the kind seen at L.
238              
239             By default C uses the 3-tuple encoding.
240              
241             # generate a matrix of tuples and report RGB, HSV and hex values
242             > examples/tuple2color
243             abc 0 0 0 rgb 255 255 255 hsv 0 0 1 hex FFFFFF
244             abc 0.2 0 0 rgb 255 204 204 hsv 0 0.2 1 hex FFCCCC
245             abc 0.4 0 0 rgb 255 153 153 hsv 0 0.4 1 hex FF9999
246             abc 0.6 0 0 rgb 255 102 102 hsv 0 0.6 1 hex FF6666
247             abc 0.8 0 0 rgb 255 51 51 hsv 0 0.8 1 hex FF3333
248             ...
249              
250             # specify range of matrix values (default is min=0, max=1, step=(max-min)/10)
251             tuple2color -min 0 -max 1 -step 0.1
252              
253             # you can overwrite one or more matrix settings
254             tuple2color -step 0.2
255              
256             # instead of using an automatically generated matrix,
257             # specify input data (tuples)
258             tuple2color -data matrix_data.txt
259              
260             # specify how matrix entries should be sorted (default no sort)
261             tuple2color -data matrix_data.txt -sortby a,b,c
262             tuple2color -data matrix_data.txt -sortby b,c,a
263             tuple2color -data matrix_data.txt -sortby c,a,b
264              
265             # specify implementation
266             tuple2color -data matrix_data.txt -method Color::TupleEncode::Baran
267              
268             # specify options for Color::Threeway
269             draw_color_char ... -options "-saturation=>{dmin=>0,dmax=>1}"
270              
271             In addition, generate a PNG image of values and corresponding encoded colors.
272              
273             # draw color patch matrix using default settings
274             tuple2color -draw
275              
276             # specify output image size
277             tuple2color ... -width 500 -height 500
278              
279             # specify output file
280             tuple2color ... -outfile somematrix.png
281              
282             The 2-way and 3-way encoding color charts are bundled with this
283             module, at C.
284              
285             These charts were generated using C as follows.
286              
287             A large 2-tuple encoding chart with C<[a,b]> in the range C<[0,2]> sampling every C<0.15>.
288              
289             ./tuple2color -method "Color::TupleEncode::2Way" \
290             -min 0 -max 2 -step 0.15 \
291             -outfile color-chart-2way.png \
292             -width 600 -height 1360 \
293             -draw
294              
295             A small 2-tuple encoding chart with C<[a,b]> in the range C<[0,2]> sampling every C<0.3>.
296              
297             ./tuple2color -method "Color::TupleEncode::2Way" \
298             -min 0 -max 2 -step 0.3 \
299             -outfile color-chart-2way-small.png \
300             -width 600 -height 430 \
301             -draw
302              
303             A large 3-tuple encoding chart with C<[a,b,c]> in the range C<[0,1]> sampling every C<0.2>.
304              
305             ./tuple2color -step 0.2 \
306             -outfile color-chart-3way.png \
307             -width 650 -height 1450 \
308             -draw
309              
310             A large 2-tuple encoding chart with C<[a,b,c]> in the range C<[0,1]> sampling every C<1/3>.
311              
312             ./tuple2color -step 0.33333333333 \
313             -outfile color-chart-3way-small.png \
314             -width 650 -height 450 \
315             -draw
316              
317             =head1 SUBROUTINES/METHODS
318              
319             =head2 C
320              
321             =head2 C [ $a,$b,$c ] )>
322              
323             =head2 C [ $a,$b,$c ], options =E \%options)>
324              
325             =head2 C [ $a,$b,$c ], method =E $class_name)>
326              
327             =head2 C [ $a,$b,$c ], method =E $class_name, options =E \%options)>
328              
329             Initializes the encoder object. You can immediately pass in a tuple,
330             options and/or an encoding method. The method can be part of the option hash (as C<-method>).
331              
332             Options are passed in as a hash reference and the encoding method as
333             the name of the module that implements the encoding. Two
334             methods are available (C (default encoding)
335             and C).
336              
337             At any time if you try to pass in incorrectly formatted input (e.g. the wrong number of elements in a tuple, an option that is not understood by the encoding method), the module dies using C.
338              
339             You can write your own encoding method - see L
340             ENCODING CLASS> for details.
341              
342             =cut
343              
344             sub new {
345 93     93 1 2222936 my $class = shift;
346              
347 93 100 100     671 if(@_ && @_ % 2) {
348 3         556 confess "Arguments to new must be a hash (i.e. even number of entries)";
349             }
350            
351 90 100       285 $class = ref($class) ? ref($class) : $class;
352 90         179 my $self = {};
353 90         249 bless $self, $class;
354              
355             # immediately set the method to default - this ensures that
356             # a method is set for any further steps
357 90         502 $self->_set_method($OPTIONS_DEFAULT{-method});
358              
359 90         451 my %args = @_;
360              
361 90 100       272 if($args{method}) {
362 4         11 $self->_set_method($args{method});
363             }
364              
365 89         342 my %args_ok = (options=>1,tuple=>1,method=>1);
366            
367 89 100       433 if(my @args_notok = grep(! $args_ok{$_}, keys %args)) {
368 2         312 confess "Do not understand new() arguments ".join(" ",@args_notok);
369             }
370              
371 87 100       252 if($args{options}) {
372 59         91 my $options = $args{options};
373 59         154 $self->set_options($options);
374             }
375 85 100       247 if($args{tuple}) {
376 68         207 $self->set_tuple( $args{tuple} );
377             }
378              
379 77         515 return $self;
380             }
381              
382             =head2 C
383              
384             Define options that control how encoding is done. Each encoding method has
385             its own set of options. For details, see L.
386              
387             Options are passed in as a hash and option names are prefixed with C<->.
388              
389             $encoder->set_options(-ha=>0,-hb=>120,-hc=>240);
390              
391             =cut
392              
393             sub set_options {
394 218     218 1 1518 my ($self,@options) = @_;
395 218 100       551 return if ! @options;
396 217         298 my %options;
397 217 100       846 if(not @options % 2) {
    50          
398 12         32 %options = @options;
399             }
400             elsif (@options == 1) {
401 205         415 my $options_first = $options[0];
402 205 50       462 if(ref( $options_first ) eq "HASH") {
403 205         992 %options = %$options_first;
404             } else {
405 0         0 confess "Value passed to options must be a hash or hash reference";
406             }
407             }
408             else {
409 0         0 confess "Value passed to options must be a hash or hash reference";
410             }
411 217         751 my @option_names = keys %options;
412             # make sure that the -method option, if it exists, is set first
413 217         1078 @option_names = (grep($_ eq "-method", @option_names),
414             grep($_ ne "-method", @option_names));
415 217         535 for my $option_name (@option_names) {
416 903         1770 my $option_value = $options{$option_name};
417 903 100       1731 if($option_name eq "-method") {
418 54         131 $self->_set_method($option_value);
419             } else {
420 849         2366 my $method = $self->get_options(-method);
421 849         2415 $self->_validate_option($option_name,$option_value);
422 846 100       1627 if(! defined $option_value) {
423 36         296 $self->_clear_option($option_name);
424             }
425             else {
426 810         3420 $self->{options}{$option_name} = $option_value;
427             }
428             }
429             }
430             }
431              
432             =pod
433              
434             =head2 C<$ok = has_option( $option_name )>
435              
436             Tests whether the current encoding scheme supports (and has set) the option C<$option_name>.
437              
438             If the method does not support the option, undef is returned.
439              
440             If the method supports the option, but it is not set, 0 is returned.
441              
442             If the method supports the option, and the option is set, 1 is returned.
443              
444             =cut
445              
446             sub has_option {
447 0     0 1 0 my ($self,$option_name) = @_;
448 0         0 my @options_ok = $self->_get_ok_options();
449 0 0 0     0 if(! grep($_ eq $option_name, @options_ok)) {
    0          
450 0         0 return;
451             } elsif (exists $self->{options}{$option_name}
452             &&
453             defined $self->{options}{$option_name}) {
454 0         0 return 1;
455             } else {
456 0         0 return 0;
457             }
458             }
459              
460             =for comment
461             Validate an option as acceptable. Returns 1 if the option is supported by the current method, and dies otherwise.
462              
463             =cut
464              
465             sub _validate_option {
466 849     849   1473 my ($self,$option_name,$option_value) = @_;
467 849 50       1812 confess "Cannot validate an undefined option name." unless defined $option_name;
468 849         1064 my @options_ok;
469             my $method;
470 849 50       2271 if(! defined $self->{options}{-method}) {
471             # this package's default options
472 0         0 confess "Cannot set options to an object that does not have encoding implementation defined.";
473             }
474             else {
475             # this package's default options and the implementation's default options
476 849         1652 @options_ok = $self->_get_ok_options();
477 849         2365 $method = $self->{options}{-method};
478             }
479 849 100       3514 if(! grep($_ eq $option_name, @options_ok)) {
480 3         606 confess "Encoding implementation $method does not support option $option_name.";
481             }
482 846 100       1645 if(! defined $option_value) {
483             # An undefined option value is acceptable - the option will be cleared
484 36         102 return 1;
485             } else {
486 810         2269 return 1;
487             }
488             }
489              
490             =pod
491              
492             =head2 C<%options = get_options()>
493              
494             =head2 C<$option_value = get_options( "-saturation" )>
495              
496             =head2 C<($option_value_1,$option_value_2) = get_options( qw(-saturation -value) )>
497              
498             Retrieve one or more (or all) option values. Options control how color
499             encoding is done and are set by C or during
500             initialization.
501              
502             If no option names are passed, a hash of all defined options (hash
503             keys) and their values (hash values) is returned.
504              
505             If one or more option names is passed, a list of corresponding values
506             is returned.
507              
508             =cut
509              
510             sub get_options {
511 2140     2140 1 35758 my $self = shift;
512 2140         6511 my @options = @_;
513            
514 2140 50       7086 if(! defined $self->{options}{-method}) {
515 0         0 confess "Cannot get_options() on an object which does not have the encoding method set.";
516             }
517             # get a list of all allowable options for this implementation
518 2140         4148 my $method = $self->{options}{-method};
519 2140         4462 my @ok_options = $self->_get_ok_options();
520 2140         3543 my $output_hash = 0;
521             # if no options were asked for, we'll return them all
522 2140 100       5203 if(! @options) {
523 56         153 my @ok_options = $self->_get_ok_options();
524 56         151 @options = @ok_options;
525 56         113 $output_hash = 1;
526             }
527 2140         2702 my @values;
528             my %values;
529 2140         3813 for my $option_name (@options) {
530 2693 50       9514 if(grep($_ eq $option_name, @ok_options)) {
531 2693         3286 my $option_value;
532 2693 100 66     30844 if(exists $self->{options}{$option_name} && defined $self->{options}{$option_name}) {
533 2508         4762 $option_value = $self->{options}{$option_name};
534             } else {
535 185         337 $option_value = undef;
536             }
537 2693         3866 push @values, $option_value;
538 2693         9433 $values{$option_name} = $option_value;
539             } else {
540 0         0 confess "You asked for option $option_name - this option is not supported by method $method.";
541             }
542             }
543 2140 100       4473 if($output_hash) {
544 56         660 return %values;
545             } else {
546 2084 100       4428 if(@values == 1) {
547 1939         9709 return $values[0];
548             } else {
549 145         910 return @values;
550             }
551             }
552             }
553              
554             =for comment
555             Clear options
556              
557             =cut
558              
559             sub _clear_options {
560 146     146   249 my $self = shift;
561 146         545 $self->{options} = {};
562             }
563              
564             =for comment
565             Clear option by deleting its entry.
566              
567             =cut
568              
569             sub _clear_option {
570 36     36   83 my ($self,$option_name) = shift;
571 36 50       199 if(defined $option_name) {
572 0         0 delete $self->{options}{$option_name};
573             }
574             }
575              
576              
577             =pod
578              
579             =head2 C
580              
581             =head2 C
582              
583             Define the tuple to encode to a color. Retrieve with C.
584              
585             The tuple size must be compatible with the encoding method. You can check the required size with C.
586              
587             =cut
588              
589             sub set_tuple {
590 132     132 1 38631 my ($self,@tuple) = @_;
591 132         368 my @ok_tuple = $self->_validate_tuple(@tuple);
592 115         361 $self->_set_tuple(@ok_tuple);
593             }
594              
595             =for comment
596             Set object's data tuple.
597              
598             =cut
599              
600             sub _set_tuple {
601 115     115   239 my ($self,@tuple) = @_;
602 115         2749177 $self->{data} = [@tuple];
603             }
604              
605             =pod
606              
607             =head2 C<@tuple = get_tuple()>
608              
609             Retrieve the current tuple, defind by C.
610              
611             =cut
612              
613             sub get_tuple {
614 861     861 1 1148 my $self = shift;
615 861 100       2306 if($self->{data}) {
616 860         893 return @{$self->{data}};
  860         3638  
617             } else {
618 1         13 return;
619             }
620             }
621              
622             =pod
623              
624             =head2 C<$size = get_tuple_size()>
625              
626             Retrieve the size of the tuple for the current implementation. For
627             example, the method by I (see L) uses three
628             values as input, thus C<$size=3>.
629              
630             =cut
631              
632             sub get_tuple_size {
633 1     1 1 2 my $self = shift;
634 1         5 my $method = $self->get_options(-method);
635 1 50       4 if(! defined $method) {
636 0         0 confess "Cannot retrieve tuple size for an undefined method";
637             } else {
638 1         4 return $method->_get_tuple_size();
639             }
640             }
641              
642              
643             =for comment
644             Set and get the encoding method.
645              
646             =cut
647              
648             sub _set_method {
649 148     148   524 my ($self,$method) = @_;
650 148 100       967 if(ref($method)) {
651 1         177 confess "The implementation method must be a string, e.g. 'Color::TupleEncode::2Way'";
652             }
653 147         292 for my $fn (qw(_get_value _get_saturation _get_hue _get_tuple_size _get_ok_options _get_default_options)) {
654 877 100       5185 if(! $method->can($fn)) {
655 1         274 confess "Thex encoding implementation $method does not support $fn";
656             }
657             }
658 146 50       586 if($method->_get_tuple_size() <= 0) {
659 0         0 confess "The encoding implementation $method did not return a positive tuple size. Make sure $method::_get_tuple_size() returns a positive number!";
660             }
661 146 50       498 if(! $method->_get_default_options()) {
662 0         0 confess "The encoding implementation $method does define \%OPTIONS_DEFAULT";
663             }
664 146 50       1463 if(! $method->_get_ok_options()) {
665 0         0 confess "The encoding implementation $method does define \@OPTIONS_OK";
666             }
667             # when we set a method, clear options because they may have been
668             # set by a previous method.
669 146         1045 $self->_clear_options();
670 146         501 $self->{options}{-method} = $method;
671             # upon setting the method, set all default options associated with the method
672 146         365 $self->set_options( $self->_get_implementation_default_options() );
673             }
674              
675             =pod
676              
677             =head2 C<$method = get_method()>
678              
679             Retrieve the current encoding method. By default, this is L.
680              
681             =cut
682              
683             sub get_method {
684 0     0 1 0 my $self = shift;
685 0         0 return $self->{options}{-method};
686             }
687              
688             =pod
689              
690             =head2 C
691              
692             Set the encoding method. By default, the method is L.
693              
694             You can also set the method as an option
695              
696             $encoder->set_options(-method=>"Color::TupleEncode::2Way");
697              
698             or at initialization
699              
700             Color::TupleEncode->new(method=>"Color::TupleEncode::2Way");
701              
702             Color::TupleEncode->new(options=>{-method=>"Color::TupleEncode::2Way"});
703              
704             Note that when using the options hash, option names are prefixed by
705             C<->. When passing arguments to C, however, the C<-> is not
706             used.
707              
708             =cut
709              
710             sub set_method {
711 0     0 1 0 my ($self,$method) = @_;
712 0         0 $self->_set_method($method);
713             }
714              
715             =pod
716              
717             =head2 C<($r,$g,$b) = as_RGB()>
718              
719             Retrieve the RGB encoding of the current tuple. The tuple is set by either C or at initialization.
720              
721             Each of the returned RGB component values are in the range C<[0,1]>.
722              
723             If the tuple is not defined, then C, this and other C methods return nothing (evaluates to false in all contexts).
724              
725             =cut
726              
727             sub as_RGB {
728 0     0 1 0 my $self = shift;
729 0 0       0 if(! $self->get_tuple) {
730 0         0 return;
731             }
732 0         0 my @hsv = $self->as_HSV();
733 0         0 my $color = Graphics::ColorObject->new_HSV(\@hsv);
734 0         0 return @{$color->as_RGB};
  0         0  
735             }
736              
737             =pod
738              
739             =head2 C
740              
741             Analogous to C but each of the returned RGB component values
742             are in the range C<[0,255]>.
743              
744             =cut
745              
746             sub as_RGB255 {
747 72     72 1 229 my $self = shift;
748 72 50       142 if(! $self->get_tuple) {
749 0         0 return;
750             }
751 72         185 my @hsv = $self->as_HSV();
752 72         468 my $color = Graphics::ColorObject->new_HSV(\@hsv);
753 72         21037 return @{$color->as_RGB255};
  72         287  
754              
755             }
756              
757             =pod
758              
759             =head2 C<$hex = as_RGBhex()>
760              
761             Analogous to C but returned is the hex encoding (e.g. C) of the RGB color.
762              
763             Note that the hex encoding does not have a leading C<#>.
764              
765             =cut
766              
767             sub as_RGBhex {
768 36     36 1 5960 my $self = shift;
769 36 50       104 if(! $self->get_tuple) {
770 0         0 return;
771             }
772 36         145 my @hsv = $self->as_HSV();
773 36         218 my $color = Graphics::ColorObject->new_HSV(\@hsv);
774 36         9763 return $color->as_RGBhex;
775              
776             }
777              
778             =pod
779              
780             =head2 C<($h,$s,$v) = as_HSV()>
781              
782             Retrieve the HSV encoding of the current tuple. The tuple is set by either C or at initialization.
783              
784             Hue C<$h> is in the range C<[0,360)> and saturation C<$s> and value C<$v> in the range C<[0,1]>.
785              
786             =cut
787              
788             sub as_HSV {
789 174     174 1 1239 my $self = shift;
790 174 50       362 if(! $self->get_tuple) {
791 0         0 return;
792             }
793 174         263 my ($h,$s,$v);
794 174         353 $h = $self->_get_hue;
795 174         391 $s = $self->_get_saturation;
796 174         431 $v = $self->_get_value;
797 174 50       400 confess "problem" if ! defined $v;
798 174         633 return ($h,$s,$v);
799             }
800              
801             =pod
802              
803             =head1 EXPORT
804              
805             In addition to the object oriented interface, you can call these
806             functions directly to obtain the color encoding. Note that any
807             encoding options must be passed in each call.
808              
809             =head2 C<($r,$g,$b) = tuple_asRGB( tuple =E [$a,$b,$c])>
810              
811             =head2 C<($r,$g,$b) = tuple_asRGB( tuple =E [$a,$b,$c], options =E %options)>
812              
813             =head2 C<($r,$g,$b) = tuple_asRGB( tuple =E [$a,$b,$c], method =E $class_name)>
814              
815             =head2 C<($r,$g,$b) = tuple_asRGB( tuple =E [$a,$b,$c], method =E $class_name, options =E %options)>
816              
817             =cut
818              
819             sub tuple_asRGB {
820 0     0 1 0 my @args = @_;
821 0         0 my $self = Color::TupleEncode->new(@args);
822 0 0       0 confess "No data values provided" if ! $self->get_tuple;
823 0         0 return $self->as_RGB();
824             }
825              
826             =head2 C<($r,$g,$b) = tuple_asRGB255()>
827              
828             =head2 C<$hex = tuple_asRGBhex()>
829              
830             =head2 C<($h,$s,$v) = tuple_asHSV()>
831              
832             These functions work just like tuple_asRGB, but return the color in a different color space (e.g. RGB, HSV) or form (component or hex).
833              
834             =cut
835              
836             sub tuple_asRGB255 {
837 36     36 1 111 my @args = @_;
838 36         176 my $self = Color::TupleEncode->new(@args);
839 36 50       131 confess "No data values provided" if ! $self->get_tuple;
840 36         122 return $self->as_RGB255();
841             }
842              
843             sub tuple_asRGBhex {
844 0     0 1 0 my @args = @_;
845 0         0 my $self = Color::TupleEncode->new(@args);
846 0 0       0 confess "No data values provided" if ! $self->get_tuple;
847 0         0 return $self->as_RGBhex();
848             }
849              
850             sub tuple_asHSV {
851 15     15 1 33 my @args = @_;
852 15         39 my $self = Color::TupleEncode->new(@args);
853 15 50       32 confess "No data values provided" if ! $self->get_tuple;
854 15         44 return $self->as_HSV();
855             }
856              
857             =for comment
858             Having defined a tuple with new() or set_tuple(), return the corresponding color value.
859              
860             =cut
861              
862             sub _get_value {
863 174     174   220 my $self = shift;
864 174         473 my $method = $self->get_options(-method);
865 174         10443 my $v = eval $method.q{::_get_value($self)};
866 174 50       658 confess "Problem calculating value: $@" if $@;
867 174         380 return $v;
868             }
869              
870             =for comment
871             Having defined a tuple with new() or set_tuple(), return the corresponding color saturation.
872              
873             =cut
874              
875             sub _get_saturation {
876 174     174   278 my $self = shift;
877 174         459 my $method = $self->get_options(-method);
878 174         10805 my $s = eval $method.q{::_get_saturation($self)};
879 174 50       641 confess "Problem calculating saturation: $@" if $@;
880 174         386 return $s;
881             }
882              
883             =for comment
884             Having defined a tuple with new() or set_tuple(), return the corresponding color hue.
885              
886             =cut
887              
888             sub _get_hue {
889 174     174   215 my $self = shift;
890 174         519 my $method = $self->get_options(-method);
891 174         13024 my $h = eval $method.q{::_get_hue($self)};
892 174 50       899 confess "Problem calculating hue: $@" if $@;
893 174         436 return $h;
894             }
895              
896             =for comment
897             Check that the data triplet has all values defined. A list must be passed - not a list reference!
898              
899             =cut
900              
901             sub _validate_tuple {
902 132     132   228 my ($self,@tuple_in) = @_;
903 132         182 my @ok_tuple;
904             my @tuple;
905 132 100       310 if(@tuple_in == 1) {
906 124         205 my $tuple_in_first = $tuple_in[0];
907 124 100       331 if( ref( $tuple_in_first ) eq "ARRAY") {
    50          
908 123         339 @tuple = @$tuple_in_first;
909             }
910             elsif ( ref( $tuple_in_first ) ) {
911 1         144 confess "Tuple must be passed in as a list or array reference.";
912             }
913             else {
914 0         0 @tuple = @tuple_in;
915             }
916             }
917             else {
918 8         16 @tuple = @tuple_in;
919             }
920 131         429 my $method = $self->get_options(-method);
921 131         473 my $tuple_size = $method->_get_tuple_size();
922 131 100       301 if(@tuple == $tuple_size) {
923 124         324 for my $i (0..$tuple_size-1) {
924 332 100       1416 confess "value at index [$i] in data tuple is not defined." if ! defined $tuple[$i];
925 327 100       1132 confess "value at index [$i] cannot be a reference - saw $tuple[$i] which is a ".ref($tuple[$i]) if ref $tuple[$i];
926 324 100       4636 confess "value at index [$i] in data tuple is not a number." if $tuple[$i] !~ qr{^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$};
927             }
928 115         533 return @tuple;
929             } else {
930 7         1077 confess "Wrong number of values in tuple. Must pass exactly ",$tuple_size," values as input data, either as list reference. Saw ".int(@tuple)." values: ".join(" ",@tuple);
931             }
932             }
933              
934             =for comment
935             Retrieve allowed and default options
936              
937             =cut
938              
939             sub _get_ok_options {
940 3045     3045   3894 my $self = shift;
941 3045         5490 my $method = $self->{options}{-method};
942 3045         11198 my @OK = ($method->_get_ok_options,@OPTIONS_OK);
943 3045         109616 return @OK;
944             }
945              
946             sub _get_implementation_ok_options {
947 0     0   0 my $self = shift;
948 0         0 my $method = $self->{options}{-method};
949 0         0 my @OK = $method->_get_ok_options;
950 0         0 return @OK;
951             }
952              
953             sub _get_default_options {
954 0     0   0 my $self = shift;
955 0         0 my $method = $self->{options}{-method};
956 0         0 my %DEF = (%OPTIONS_DEFAULT,$method->_get_default_options);
957 0         0 return \%DEF;
958             }
959             sub _get_implementation_default_options {
960 146     146   199 my $self = shift;
961 146         300 my $method = $self->{options}{-method};
962 146         447 my %DEF = $method->_get_default_options;
963 146         5728 return \%DEF;
964             }
965              
966             =pod
967              
968             =head1 IMPLEMENTING AN ENCODING CLASS
969              
970             =head2 Required Functions
971              
972             It is assumed that the encoding utility class will implement the following functions.
973              
974             =over
975              
976             =item C<_get_hue()>
977              
978             =item C<_get_saturation()>
979              
980             =item C<_get_value()>
981              
982             =back
983              
984             Encodings must be done from a tuple to HSV color space. HSV is a
985             natural choice because it is possible to visually identify individual
986             H,S,V components of a color (e.g. orage saturated dark). On the other
987             hand, doing so in RGB is very difficult (what is the R,G,B
988             decomposition of a dark desaturated orange?).
989              
990             Each of these functions should be implemented as follows. For example, C<_get_saturation>
991              
992             sub _get_saturation {
993             # obtain the Color::TupleEncode object
994             my $self = shift;
995             # extract data tuple
996             my (@tuple) = $self->get_tuple;
997             my $saturation;
998             ... now use @tuple to define $saturation
999             return $saturation;
1000             }
1001              
1002             =over
1003              
1004             =item C<_get_tuple_size()>
1005              
1006             =back
1007              
1008             This function returns the size of the tuple used by the encoding. You
1009             can implement this as follows,
1010              
1011             Readonly::Scalar our $TUPLE_SIZE => 3;
1012              
1013             sub _get_tuple_size {
1014             return $TUPLE_SIZE;
1015             }
1016              
1017             =over
1018              
1019             =item C<_get_ok_options()>
1020              
1021             =item C<_get_default_options()>
1022              
1023             =back
1024              
1025             You must define a package variable C<@OPTIONS_OK>, which lists all
1026             acceptable options for this encoding. Any options you wish to be set
1027             by default when this method is initially set should be in C<%OPTIONS_DEFAULT>.
1028              
1029             For example,
1030              
1031             Readonly::Array our @OPTIONS_OK =>
1032             (qw(-ha -hb -hc -saturation -value));
1033            
1034             Readonly::Hash our %OPTIONS_DEFAULT =>
1035             (-ha=>0,-hb=>120,-hc=>240,-saturation=>{dmin=>0,dmax=>1});
1036              
1037             Two functions provice access to these variables
1038              
1039             sub _get_ok_options {
1040             return @OPTIONS_OK;
1041             }
1042              
1043             sub _get_default_options {
1044             return %OPTIONS_DEFAULT;
1045             }
1046              
1047             =head2 Using Your Implementation
1048              
1049             See the example files with this distribution
1050              
1051             # uses Color::TupleEncode::2Way
1052             > examples/example-2way
1053              
1054             # uses Color::TupleEncode::Baran
1055             > examples/example-3way
1056              
1057             of how to go about using your implementation.
1058              
1059             For example, if you have created C, which
1060             encodes 4-tuples, then you would use it thus
1061              
1062             use Color::TupleEncode;
1063             use Color::TupleEncode::4Way;
1064              
1065             # set the method to your implementation
1066             $encoder = Color::TupleEncode->new(method=>"Color::TupleEncode::4Way");
1067              
1068             # set any options for your implementation
1069             $encoder->set-options(-option1=>1,-option2=>10)
1070              
1071             # encode
1072             ($h,$s,$v) = $encoder->as_HSV(1,2,3,4);
1073              
1074             =head1 AUTHOR
1075              
1076             Martin Krzywinski, C<< >>
1077              
1078             =head1 BUGS
1079              
1080             Please report any bugs or feature requests to C, or through
1081             the web interface at L. I will be notified, and then you'll
1082             automatically be notified of progress on your bug as I make changes.
1083              
1084             =head1 SUPPORT
1085              
1086             You can find documentation for this module with the perldoc command.
1087              
1088             perldoc Color::TupleEncode
1089              
1090             You can also look for information at:
1091              
1092             =over 4
1093              
1094             =item * RT: CPAN's request tracker
1095              
1096             L
1097              
1098             =item * AnnoCPAN: Annotated CPAN documentation
1099              
1100             L
1101              
1102             =item * CPAN Ratings
1103              
1104             L
1105              
1106             =item * Search CPAN
1107              
1108             L
1109              
1110             =back
1111              
1112             =head1 SEE ALSO
1113              
1114             L for converting colors between color spaces.
1115              
1116             L for the 3-tuple encoding (by I).
1117              
1118             L for the 2-tuple encoding (by Author).
1119              
1120             =head1 ACKNOWLEDGEMENTS
1121              
1122             For details about the color encoding, see
1123              
1124             =over
1125              
1126             =item Color::TupleEncode::Baran
1127              
1128             Encodes a 3-tuple to a color using the scheme described in
1129              
1130             Visualization of three-way comparisons of omics data
1131             Richard Baran Martin Robert, Makoto Suematsu, Tomoyoshi Soga and Masaru Tomita
1132             BMC Bioinformatics 2007, 8:72 doi:10.1186/1471-2105-8-72
1133              
1134             This publication can be accessed at L
1135              
1136             =back
1137              
1138             =head1 LICENSE AND COPYRIGHT
1139              
1140             Copyright 2010 Martin Krzywinski.
1141              
1142             This program is free software; you can redistribute it and/or modify it
1143             under the terms of either: the GNU General Public License as published
1144             by the Free Software Foundation; or the Artistic License.
1145              
1146             See http://dev.perl.org/licenses/ for more information.
1147              
1148             =cut
1149              
1150             1; # End of Color::TupleEncode