File Coverage

blib/lib/ICC/Support/ratfunc.pm
Criterion Covered Total %
statement 18 213 8.4
branch 1 120 0.8
condition 0 60 0.0
subroutine 5 19 26.3
pod 1 8 12.5
total 25 420 5.9


line stmt bran cond sub pod time code
1             package ICC::Support::ratfunc;
2              
3 2     2   81605 use strict;
  2         12  
  2         49  
4 2     2   9 use Carp;
  2         4  
  2         124  
5              
6             our $VERSION = 0.10;
7              
8             # revised 2016-10-26
9             #
10             # Copyright © 2004-2020 by William B. Birkett
11              
12             # inherit from Shared
13 2     2   377 use parent qw(ICC::Shared);
  2         259  
  2         11  
14              
15             # enable static variables
16 2     2   89 use feature 'state';
  2         4  
  2         5488  
17              
18             =encoding utf-8
19              
20             This module implements a simple rational function ('ratfunc') transform for 3-channel data.
21              
22             The transform is explained in the document 'rational_function_color_transform.txt'.
23              
24             The primary application is converting RGB camera/scanner data to XYZ.
25              
26             We often use a 3x4 matrix to do this,
27              
28             | a11, a12, a13, a14 |
29             | a21, a22, a23, a24 |
30             | a31, a32, a33, a34 |
31              
32             To use this matrix, we add a column containing '1' to the input data,
33              
34             [R, G, B] => [R, G, B, 1]
35              
36             Then we use matrix multiplication to compute the XYZ values from these augmented RGB values.
37              
38             [X, Y, Z] = [3x4 matrix] x [R, G, B, 1]
39              
40             If the camera or scanner has RGB spectral sensitivities derived from color matching functions (Luther-Ives condition), the accuracy
41             of this simple transform will be excellent. However, the spectral sensitivity curves are not always optimal.
42              
43             We may be able to achieve slightly better results using rational functions. A rational function is the ratio of two polynomial
44             functions. We use extremely simple, linear functions of RGB. We extend the 3x4 matrix by adding three rows to get a 6x4 matrix,
45              
46             | a11, a12, a13, a14 |
47             | a21, a22, a23, a24 |
48             | a31, a32, a33, a34 |
49             | a41, a42, a43, 1 |
50             | a51, a52, a53, 1 |
51             | a61, a62, a63, 1 |
52              
53             Now, when we multiply by the augmented RGB matrix, we get,
54              
55             [Xn, Yn, Zn, Xd, Yd, Zd] = [6x4 matrix] x [R, G, B, 1]
56              
57             Then we reduce these values to ratios,
58              
59             [X, Y, Z] = [Xn/Xd, Yn/Yd, Zn/Zd]
60              
61             If the added coefficients, a41, a42, ... a63, are all zero, the denominators will all be 1, and the transform is the same as the 3x3
62             matrix with offsets. If these coefficients are non-zero, the X, Y, Z functions will be non-linear, which may improve the accuracy of
63             the transform.
64              
65             The advantage of this transform is that it provides some additional degrees of freedom compared to the 3x3 matrix. This allows us to
66             'fix' some points to improve the reproduction of a particular original. The transform may have some curvature, but it is smooth and
67             gradual, so congruence is maintained. This transform cannot improve the color quality of the sensor, but it can be used to fine tune
68             images.
69              
70             The object's matrix is compatible with the XS function 'ICC::Support::Image::ratfunc_transform_float'. The intention is to optimize
71             the matrix using the 'ratfunc.pm' object, then transform images using the XS function.
72              
73             The size of the object's matrix is always 6x4. If we attempt to make a larger matrix, an error occurs. If we supply a smaller matrix,
74             the missing coefficients are those of the identity matrix. The identity matrix looks like this,
75              
76             | 1, 0, 0, 0 |
77             | 0, 1, 0, 0 |
78             | 0, 0, 1, 0 |
79             | 0, 0, 0, 1 |
80             | 0, 0, 0, 1 |
81             | 0, 0, 0, 1 |
82              
83             For example, a 3x3 matrix will be copied to the first three rows and columns of the above identity matrix. In that case, the 'ratfunc'
84             transform will be the same as the 'matf' transform (straight matrix multiplication).
85              
86             =cut
87              
88             # create new ratfunc object
89             # returns an empty object with no parameters
90             # hash keys are: ('header', 'matrix', 'offset')
91             # 'header' value is a hash reference
92             # 'matrix' value is a 2D array reference -or- Math::Matrix object
93             # returns identity object with an empty hash ({})
94             # when the parameters are input and output arrays, the 'fit' method is called on the object
95             # parameter: ()
96             # parameter: ({})
97             # parameter: (ref_to_attribute_hash)
98             # parameter: (matf_object)
99             # parameters: (ref_to_input_array, ref_to_output_array)
100             # returns: (ref_to_object)
101             sub new {
102              
103             # get object class
104 1     1 0 691 my $class = shift();
105              
106             # create empty ratfunc object
107 1         4 my $self = [
108             {}, # header
109             [], # matrix
110             ];
111              
112             # local parameter
113 1         1 my ($info);
114              
115             # if there are parameters
116 1 50       4 if (@_) {
117            
118             # if one parameter, a hash reference
119 0 0 0     0 if (@_ == 1 && ref($_[0]) eq 'HASH') {
    0 0        
    0 0        
120            
121             # make new ratfunc object from attribute hash
122 0         0 _new_from_hash($self, shift());
123            
124             # if one parameter, a 'matf' object
125             } elsif (@_ == 1 && UNIVERSAL::isa(ref($_[0]), 'ICC::Profile::matf')) {
126            
127             # make new ratfunc object from 'matf' object
128 0         0 _new_from_matf($self, shift());
129            
130             # if two or three parameters
131             } elsif (@_ == 2 || @_ == 3) {
132            
133             # fit the object to data
134 0 0       0 ($info = fit($self, @_)) && croak("\'fit\' routine failed with error $info");
135            
136             } else {
137            
138             # error
139 0         0 croak('\'ratfunc\' invalid parameter(s)');
140            
141             }
142            
143             }
144              
145             # bless object
146 1         2 bless($self, $class);
147              
148             # return object reference
149 1         2 return($self);
150              
151             }
152              
153             # get/set reference to header hash
154             # parameters: ([ref_to_new_hash])
155             # returns: (ref_to_hash)
156             sub header {
157              
158             # get object reference
159 0     0 0   my $self = shift();
160              
161             # if there are parameters
162 0 0         if (@_) {
163            
164             # if one parameter, a hash reference
165 0 0 0       if (@_ == 1 && ref($_[0]) eq 'HASH') {
166            
167             # set header to new hash
168 0           $self->[0] = {%{shift()}};
  0            
169            
170             } else {
171            
172             # error
173 0           croak('\'header\' attribute must be a hash reference');
174            
175             }
176            
177             }
178              
179             # return reference
180 0           return($self->[0]);
181              
182             }
183              
184             # get/set reference to matrix array
185             # parameters: ([ref_to_new_array])
186             # returns: (ref_to_array)
187             sub matrix {
188              
189             # get object reference
190 0     0 0   my $self = shift();
191              
192             # if there are parameters
193 0 0         if (@_) {
194            
195             # if one parameter, a reference to a 2-D array -or- Math::Matrix object
196 0 0 0       if (@_ == 1 && ((ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {ref() eq 'ARRAY'} @{$_[0]}) || UNIVERSAL::isa($_[0], 'Math::Matrix'))) {
      0        
197            
198             # verify number of rows
199 0 0         ($#{$_[0]} < 6) or croak('\'matrix\' array has more than 6 rows');
  0            
200            
201             # make identity matrix (6x4)
202 0           $self->[1] = bless([
203             [1, 0, 0, 0],
204             [0, 1, 0, 0],
205             [0, 0, 1, 0],
206             [0, 0, 0, 1],
207             [0, 0, 0, 1],
208             [0, 0, 0, 1],
209             ], 'Math::Matrix');
210            
211             # for each row
212 0           for my $i (0 .. $#{$_[0]}) {
  0            
213            
214             # verify number of columns
215 0 0         ($#{$_[0]->[$i]} < 4) or croak('\'matrix\' array has more than 4 columns');
  0            
216            
217             # for each column
218 0           for my $j (0 .. $#{$_[0]->[$i]}) {
  0            
219            
220             # verify matrix element is a number
221 0 0         (Scalar::Util::looks_like_number($_[0]->[$i][$j])) or croak('\'matrix\' element not numeric');
222            
223             # copy matrix element
224 0           $self->[1][$i][$j] = $_[0]->[$i][$j];
225            
226             }
227            
228             }
229            
230             } else {
231            
232             # error
233 0           croak('\'matrix\' attribute must be a 2-D array reference or Math::Matrix object');
234            
235             }
236            
237             }
238              
239             # return object reference
240 0           return($self->[1]);
241              
242             }
243              
244             # fit ratfunc object to data
245             # uses LAPACK dgels function to perform a least-squares fit
246             # fitting is done with or without offset, according to offset_flag
247             # input and output are 2D array references -or- Math::Matrix objects
248             # parameters: (ref_to_input_array, ref_to_output_array, [offset_flag])
249             # returns: (dgels_info_value)
250             sub fit {
251              
252             # get parameters
253 0     0 0   my ($self, $in, $out, $oflag) = @_;
254              
255             # local variables
256 0           my ($info, $ab);
257              
258             # check if ICC::Support::Lapack module is loaded
259 0           state $lapack = defined($INC{'ICC/Support/Lapack.pm'});
260              
261             # verify ICC::Support::Lapack module is loaded
262 0 0         ($lapack) or croak('\'fit\' method requires ICC::Support::Lapack module');
263              
264             # resolve offset flag
265 0 0         $oflag = 0 if (! defined($oflag));
266              
267             # verify input array
268 0 0 0       (ref($in) eq 'ARRAY' && ref($in->[0]) eq 'ARRAY' && ! ref($in->[0][0])) || UNIVERSAL::isa($in, 'Math::Matrix') or croak('fit input not a 2-D array reference');
      0        
      0        
269              
270             # verify output array
271 0 0 0       (ref($out) eq 'ARRAY' && ref($out->[0]) eq 'ARRAY' && ! ref($out->[0][0])) || UNIVERSAL::isa($out, 'Math::Matrix') or croak('fit output not a 2-D array reference');
      0        
      0        
272              
273             # verify array dimensions
274 0 0         ($#{$in} == $#{$out}) or croak('input and output arrays have different number of rows');
  0            
  0            
275 0 0         ($#{$in->[0]} == 2) or croak('input samples must have 3 elements');
  0            
276 0 0         ($#{$out->[0]} == 2) or croak('output samples must have 3 elements');
  0            
277              
278             # fit the matrix
279 0           ($info, $ab) = ICC::Support::Lapack::matf_fit($in, $out, $oflag);
280              
281             # check result
282 0 0         carp('fit failed - bad parameter when calling dgels') if ($info < 0);
283 0 0         carp('fit failed - A matrix not full rank') if ($info > 0);
284              
285             # initialize matrix object
286 0           $self->[1] = bless([], 'Math::Matrix');
287              
288             # for each row
289 0           for my $i (0 .. 2) {
290            
291             # for each column
292 0           for my $j (0 .. 2) {
293            
294             # set matrix element (transposing)
295 0           $self->[1][$i][$j] = $ab->[$j][$i];
296            
297             }
298            
299             # set offset value
300 0 0         $self->[1][$i][3] = $oflag ? $ab->[3][$i] : 0;
301            
302             # set divisor row
303 0           $self->[1][$i + 3] = [0, 0, 0, 1];
304            
305             }
306              
307             # return info value
308 0           return($info);
309              
310             }
311              
312             # transform data
313             # supported input types:
314             # parameters: (list, [hash])
315             # parameters: (vector, [hash])
316             # parameters: (matrix, [hash])
317             # parameters: (Math::Matrix_object, [hash])
318             # parameters: (structure, [hash])
319             # returns: (same_type_as_input)
320             sub transform {
321              
322             # set hash value (0 or 1)
323 0 0   0 0   my $h = ref($_[-1]) eq 'HASH' ? 1 : 0;
324              
325             # if input a 'Math::Matrix' object
326 0 0 0       if (@_ == $h + 2 && UNIVERSAL::isa($_[1], 'Math::Matrix')) {
    0 0        
    0          
327            
328             # call matrix transform
329 0           &_trans2;
330            
331             # if input an array reference
332             } elsif (@_ == $h + 2 && ref($_[1]) eq 'ARRAY') {
333            
334             # if array contains numbers (vector)
335 0 0 0       if (! ref($_[1][0]) && @{$_[1]} == grep {Scalar::Util::looks_like_number($_)} @{$_[1]}) {
  0 0 0        
  0            
  0            
336            
337             # call vector transform
338 0           &_trans1;
339            
340             # if array contains vectors (2-D array)
341 0 0         } elsif (ref($_[1][0]) eq 'ARRAY' && @{$_[1]} == grep {ref($_) eq 'ARRAY' && Scalar::Util::looks_like_number($_->[0])} @{$_[1]}) {
  0            
  0            
342            
343             # call matrix transform
344 0           &_trans2;
345            
346             } else {
347            
348             # call structure transform
349 0           &_trans3;
350            
351             }
352            
353             # if input a list (of numbers)
354 0           } elsif (@_ == $h + 1 + grep {Scalar::Util::looks_like_number($_)} @_) {
355            
356             # call list transform
357 0           &_trans0;
358            
359             } else {
360            
361             # error
362 0           croak('invalid transform input');
363            
364             }
365            
366             }
367              
368             =cut
369              
370             # inverse transform
371             # note: number of undefined output values must equal number of defined input values
372             # note: input array contains the final calculated input values upon return
373             # parameters: (ref_to_input_array, ref_to_output_array)
374             sub inverse {
375              
376             # get parameters
377             my ($self, $in, $out) = @_;
378              
379             # local variables
380             my ($i, $j, @si, @so);
381             my ($int, $info, $delta, $sys, $res, $mat);
382              
383             # check if ICC::Support::Lapack module is loaded
384             state $lapack = defined($INC{'ICC/Support/Lapack.pm'});
385              
386             # initialize indices
387             $i = $j = -1;
388              
389             # build slice arrays while validating input and output arrays
390             ((grep {$i++; defined() && push(@si, $i)} @{$in}) == (grep {$j++; ! defined() && push(@so, $j)} @{$out})) or croak('wrong number of undefined values');
391              
392             # for each undefined output value
393             for my $i (@so) {
394            
395             # set to 0
396             $out->[$i] = 0;
397            
398             }
399              
400             # if ICC::Support::Lapack module is loaded
401             if ($lapack) {
402            
403             # compute initial transform values
404             $int = ICC::Support::Lapack::matf_vec_trans($out, $self->[1]);
405            
406             # for each input
407             for my $i (0 .. $#si) {
408            
409             # for each output
410             for my $j (0 .. $#so) {
411            
412             # copy Jacobian value to system matrix
413             $sys->[$i][$j] = $self->[1][$si[$i]][$so[$j]];
414            
415             }
416            
417             # compute residual value
418             $res->[$i][0] = $in->[$si[$i]] - $int->[$si[$i]];
419            
420             }
421            
422             # solve for delta values
423             ($info, $delta) = ICC::Support::Lapack::solve($sys, $res);
424            
425             # report linear system error
426             ($info) && print "ratfunc inverse error $info: @{$in}\n";
427            
428             # for each output value
429             for my $i (0 .. $#so) {
430            
431             # add delta value
432             $out->[$so[$i]] += $delta->[$i][0];
433            
434             }
435            
436             # compute final transform values
437             @{$in} = @{ICC::Support::Lapack::matf_vec_trans($out, $self->[1])};
438            
439             } else {
440            
441             # compute initial transform values
442             $int = [_trans0($self, @{$out})];
443            
444             # for each input
445             for my $i (0 .. $#si) {
446            
447             # for each output
448             for my $j (0 .. $#so) {
449            
450             # copy Jacobian value to solution matrix
451             $mat->[$i][$j] = $self->[1][$si[$i]][$so[$j]];
452            
453             }
454            
455             # save residual value to solution matrix
456             $mat->[$i][$#si + 1] = $in->[$si[$i]] - $int->[$si[$i]];
457            
458             }
459            
460             # bless Matrix
461             bless($mat, 'Math::Matrix');
462            
463             # solve for delta values
464             $delta = $mat->solve || print "ratfunc inverse error: @{$in}\n";
465            
466             # for each output value
467             for my $i (0 .. $#so) {
468            
469             # add delta value
470             $out->[$so[$i]] += $delta->[$i][0];
471            
472             }
473            
474             # compute final transform values
475             @{$in} = _trans0($self, @{$out});
476            
477             }
478            
479             }
480              
481             # compute Jacobian matrix
482             # note: input values only required for output values
483             # parameters: ([input_vector])
484             # returns: (ref_to_Jacobian_matrix, [output_vector])
485             sub jacobian {
486              
487             # get object reference
488             my $self = shift();
489              
490             # if output values wanted
491             if (wantarray) {
492            
493             # return Jacobian and output values
494             return(bless(Storable::dclone($self->[1]), 'Math::Matrix'), _trans1($self, $_[0]));
495            
496             } else {
497            
498             # return Jacobian only
499             return(bless(Storable::dclone($self->[1]), 'Math::Matrix'));
500            
501             }
502            
503             }
504              
505             =cut
506              
507             # get number of input channels
508             # returns: (number)
509             sub cin {
510              
511             # get object reference
512 0     0 0   my $self = shift();
513              
514             # return
515 0           return(3);
516              
517             }
518              
519             # get number of output channels
520             # returns: (number)
521             sub cout {
522              
523             # get object reference
524 0     0 0   my $self = shift();
525              
526             # return
527 0           return(3);
528              
529             }
530              
531             # print object contents to string
532             # format is an array structure
533             # parameter: ([format])
534             # returns: (string)
535             sub sdump {
536              
537             # get parameters
538 0     0 1   my ($self, $p) = @_;
539              
540             # local variables
541 0           my ($fmt, $s, $rows, $fn);
542              
543             # resolve parameter to an array reference
544 0 0         $p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];
    0          
545              
546             # get format string
547 0 0 0       $fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'm';
548              
549             # set string to object ID
550 0           $s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);
551              
552             # get matrix rows
553 0           $rows = $#{$self->[1]};
  0            
554              
555             # if empty object
556 0 0         if ($rows < 0) {
557            
558             # append string
559 0           $s .= "\n";
560            
561             } else {
562            
563             # append string
564 0           $s .= "matrix values\n";
565            
566             # for each row
567 0           for my $i (0 .. $rows) {
568            
569             # make number format
570 0           $fn = ' %10.5f' x @{$self->[1][$i]};
  0            
571            
572             # append matrix row
573 0           $s .= sprintf("$fn\n", @{$self->[1][$i]});
  0            
574            
575             }
576            
577             }
578              
579             # return string
580 0           return($s);
581              
582             }
583              
584             # recursive transform
585             # array structure is traversed until scalar arrays are found and transformed
586             # parameters: (ref_to_object, subroutine_reference, input_array_reference, output_array_reference)
587             sub _crawl {
588              
589             # get parameters
590 0     0     my ($self, $sub, $in, $out) = @_;
591              
592             # if input is a vector (reference to a numeric array)
593 0 0         if (@{$in} == grep {Scalar::Util::looks_like_number($_)} @{$in}) {
  0            
  0            
  0            
594            
595             # transform input vector and copy to output
596 0           @{$out} = @{$sub->($self, $in)};
  0            
  0            
597            
598             } else {
599            
600             # for each input element
601 0           for my $i (0 .. $#{$in}) {
  0            
602            
603             # if an array reference
604 0 0         if (ref($in->[$i]) eq 'ARRAY') {
605            
606             # transform next level
607 0           _crawl($self, $sub, $in->[$i], $out->[$i] = []);
608            
609             } else {
610            
611             # error
612 0           croak('invalid input structure');
613            
614             }
615            
616             }
617            
618             }
619            
620             }
621              
622             # transform list
623             # parameters: (object_reference, list, [hash])
624             # returns: (list)
625             sub _trans0 {
626              
627             # local variables
628 0     0     my ($self, $hash, @out, $den);
629              
630             # get object reference
631 0           $self = shift();
632              
633             # get optional hash
634 0 0         $hash = pop() if (ref($_[-1]) eq 'HASH');
635              
636             # validate number of input channels
637 0 0         (@_ == 3) or croak('input samples must have 3 channels');
638              
639             # augment input sample
640 0           push(@_, 1);
641              
642             # for each output
643 0           for my $i (0 .. 2) {
644            
645             # compute denominator
646 0           $den = ICC::Shared::dotProduct(\@_, $self->[1][$i + 3]);
647            
648             # add matrix value
649 0 0         $out[$i] = ($den == 0) ? 'inf' : ICC::Shared::dotProduct(\@_, $self->[1][$i])/$den;
650            
651             }
652              
653             # return output data
654 0           return(@out);
655              
656             }
657              
658             # transform vector
659             # parameters: (object_reference, vector, [hash])
660             # returns: (vector)
661             sub _trans1 {
662              
663             # get parameters
664 0     0     my ($self, $in, $hash) = @_;
665              
666             # check if ICC::Support::Lapack module is loaded
667 0           state $lapack = defined($INC{'ICC/Support/Lapack.pm'});
668              
669             # validate number of input channels
670 0 0         (@{$in} == 3) or croak('input samples must have 3 channels');
  0            
671              
672             # if ICC::Support::Lapack module is loaded
673 0 0         if ($lapack) {
674            
675             # compute output vector using BLAS dgemv function
676 0           return(ICC::Support::Lapack::ratfunc_vec_trans($in, $self->[1]));
677            
678             } else {
679            
680             # return
681 0           return([_trans0($self, @{$in})]);
  0            
682            
683             }
684              
685             }
686              
687             # transform matrix (2-D array -or- Math::Matrix object)
688             # parameters: (object_reference, matrix, [hash])
689             # returns: (matrix)
690             sub _trans2 {
691              
692             # get parameters
693 0     0     my ($self, $in, $hash) = @_;
694              
695             # local variables
696 0           my ($info, $out, $aug, $den);
697              
698             # check if ICC::Support::Lapack module is loaded
699 0           state $lapack = defined($INC{'ICC/Support/Lapack.pm'});
700              
701             # validate number of input channels
702 0 0         (@{$in->[0]} == 3) or croak('input samples must have 3 channels');
  0            
703              
704             # if ICC::Support::Lapack module is loaded
705 0 0         if ($lapack) {
706            
707             # compute output matrix using BLAS dgemm function
708 0           $out = ICC::Support::Lapack::ratfunc_mat_trans($in, $self->[1]);
709            
710             } else {
711            
712             # for each row
713 0           for my $i (0 .. $#{$in}) {
  0            
714            
715             # augment input sample
716 0           $aug = [@{$in->[$i]}, 1];
  0            
717            
718             # for each column
719 0           for my $j (0 .. 2) {
720            
721             # compute denominator
722 0           $den = ICC::Shared::dotProduct($aug, $self->[1][$j + 3]);
723            
724             # add dot product
725 0 0         $out->[$i][$j] = ($den == 0) ? 'inf' : ICC::Shared::dotProduct($aug, $self->[1][$j])/$den;
726            
727             }
728            
729             }
730            
731             }
732              
733             # return output matrix (Math::Matrix object or 2-D array)
734 0 0         return(UNIVERSAL::isa($in, 'Math::Matrix') ? bless($out, 'Math::Matrix') : $out);
735              
736             }
737              
738             # transform structure
739             # parameters: (object_reference, structure, [hash])
740             # returns: (structure)
741             sub _trans3 {
742              
743             # get parameters
744 0     0     my ($self, $in, $hash) = @_;
745              
746             # transform the array structure
747 0           _crawl($self, \&_trans1, $in, my $out = []);
748              
749             # return output structure
750 0           return($out);
751              
752             }
753              
754             # make new ratfunc object from matf object
755             # parameters: (ref_to_object, matf_object)
756             sub _new_from_matf {
757              
758             # get parameters
759 0     0     my ($self, $matf) = @_;
760              
761             # local variables
762 0           my ($value);
763              
764             # make identity matrix (6x4)
765 0           $self->[1] = bless([
766             [1, 0, 0, 0],
767             [0, 1, 0, 0],
768             [0, 0, 1, 0],
769             [0, 0, 0, 1],
770             [0, 0, 0, 1],
771             [0, 0, 0, 1],
772             ], 'Math::Matrix');
773              
774             # get 'matf' matrix
775 0           $value = $matf->matrix;
776              
777             # verify number of rows
778 0 0         ($#{$value} < 6) or croak('\'matf\' matrix has more than 6 rows');
  0            
779              
780             # for each row
781 0           for my $i (0 .. $#{$value}) {
  0            
782            
783             # verify number of columns
784 0 0         ($#{$value->[$i]} < 3) or croak('\'matf\' matrix has more than 3 columns');
  0            
785            
786             # for each column
787 0           for my $j (0 .. $#{$value->[$i]}) {
  0            
788            
789             # verify matrix element is a number
790 0 0         (Scalar::Util::looks_like_number($value->[$i][$j])) or croak('\'matf\' matrix element not numeric');
791            
792             # copy matrix element
793 0           $self->[1][$i][$j] = $value->[$i][$j];
794            
795             }
796            
797             }
798              
799             # get 'matf' offset
800 0           $value = $matf->offset;
801              
802             # verify number of elements
803 0 0         ($#{$value} < 3) or croak('\'matf\' offset has more than 3 elements');
  0            
804              
805             # for each element
806 0           for my $i (0 .. $#{$value}) {
  0            
807            
808             # verify array element is a number
809 0 0         (Scalar::Util::looks_like_number($value->[$i])) or croak('\'matf\' offset element not numeric');
810            
811             # copy offset to object
812 0           $self->[1][$i][3] = $value->[$i];
813            
814             }
815            
816             }
817              
818             # make new ratfunc object from attribute hash
819             # hash keys are: ('header', 'matrix', 'offset')
820             # object elements not specified in the hash are unchanged
821             # parameters: (ref_to_object, ref_to_attribute_hash)
822             sub _new_from_hash {
823              
824             # get parameters
825 0     0     my ($self, $hash) = @_;
826              
827             # local variables
828 0           my ($value);
829              
830             # make identity matrix (6x4)
831 0           $self->[1] = bless([
832             [1, 0, 0, 0],
833             [0, 1, 0, 0],
834             [0, 0, 1, 0],
835             [0, 0, 0, 1],
836             [0, 0, 0, 1],
837             [0, 0, 0, 1],
838             ], 'Math::Matrix');
839              
840             # if 'header' key defined
841 0 0         if (defined($hash->{'header'})) {
842            
843             # if reference to hash
844 0 0         if (ref($hash->{'header'}) eq 'HASH') {
845            
846             # set object element
847 0           $self->[0] = {%{$hash->{'header'}}};
  0            
848            
849             } else {
850            
851             # wrong data type
852 0           croak('wrong \'header\' data type');
853            
854             }
855            
856             }
857              
858             # if 'matrix' key defined
859 0 0         if (defined($hash->{'matrix'})) {
860            
861             # get value
862 0           $value = $hash->{'matrix'};
863            
864             # if a reference to a 2-D array -or- Math::Matrix object
865 0 0 0       if ((ref($value) eq 'ARRAY' && @{$value} == grep {ref() eq 'ARRAY'} @{$value}) || UNIVERSAL::isa($value, 'Math::Matrix')) {
  0   0        
  0            
  0            
866            
867             # verify number of rows
868 0 0         ($#{$value} < 6) or croak('\'matrix\' array has more than 6 rows');
  0            
869            
870             # for each row
871 0           for my $i (0 .. $#{$value}) {
  0            
872            
873             # verify number of columns
874 0 0         ($#{$value->[$i]} < 4) or croak('\'matrix\' array has more than 4 columns');
  0            
875            
876             # for each column
877 0           for my $j (0 .. $#{$value->[$i]}) {
  0            
878            
879             # verify matrix element is a number
880 0 0         (Scalar::Util::looks_like_number($value->[$i][$j])) or croak('\'matrix\' element not numeric');
881            
882             # copy matrix element
883 0           $self->[1][$i][$j] = $value->[$i][$j];
884            
885             }
886            
887             }
888            
889             } else {
890            
891             # wrong data type
892 0           croak('wrong \'matrix\' data type');
893            
894             }
895            
896             }
897              
898             # if 'offset' key defined
899 0 0         if (defined($hash->{'offset'})) {
900            
901             # get value
902 0           $value = $hash->{'offset'};
903            
904             # if a reference to an array of scalars
905 0 0 0       if (ref($value) eq 'ARRAY' && @{$value} == grep {! ref()} @{$value}) {
  0            
  0            
  0            
906            
907             # verify number of elements
908 0 0         ($#{$value} < 3) or croak('\'offset\' array has more than 3 elements');
  0            
909            
910             # for each element
911 0           for my $i (0 .. $#{$value}) {
  0            
912            
913             # verify array element is a number
914 0 0         (Scalar::Util::looks_like_number($value->[$i])) or croak('\'offset\' element not numeric');
915            
916             # copy offset to object
917 0           $self->[1][$i][3] = $value->[$i];
918            
919             }
920            
921             } else {
922            
923             # wrong data type
924 0           croak('wrong \'offset\' data type');
925            
926             }
927            
928             }
929            
930             }
931              
932             1;