File Coverage

/root/.cpan/build/PDL-CCS-1.23.13-0/blib/lib/PDL/CCS/Functions.pm
Criterion Covered Total %
statement 28 62 45.1
branch 6 36 16.6
condition 0 8 0.0
subroutine 8 11 72.7
pod 3 4 75.0
total 45 121 37.1


line stmt bran cond sub pod time code
1             ## File: PDL::CCS::Functions.pm
2             ## Author: Bryan Jurish
3             ## Description: useful perl-level functions for PDL::CCS
4              
5             package PDL::CCS::Functions;
6 4     4   30 use PDL::CCS::Config qw(ccs_indx);
  4         9  
  4         232  
7 4     4   2044 use PDL::CCS::Utils;
  4         13  
  4         29  
8 4     4   663 use PDL::VectorValued;
  4         9  
  4         23  
9 4     4   747 use PDL;
  4         9  
  4         32  
10 4     4   11263 use strict;
  4         9  
  4         5943  
11              
12             our $VERSION = '1.23.13'; ##-- update with perl-reversion from Perl::Version module
13             our @ISA = ('PDL::Exporter');
14             our @EXPORT_OK =
15             (
16             ##
17             ##-- Decoding
18             qw(ccs_decode ccs_pointerlen),
19             ##
20             ##-- Vector Operations (compat)
21             qw(ccs_binop_vector_mia),
22             (map { "ccs_${_}_vector_mia" } (
23             qw(plus minus mult divide modulo power),
24             qw(gt ge lt le eq ne spaceship),
25             qw(and2 or2 xor shiftleft shiftright),
26             )),
27             ##
28             ##-- qsort
29             qw(ccs_qsort),
30             );
31             our %EXPORT_TAGS =
32             (
33             Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully)
34             );
35              
36              
37             ##======================================================================
38             ## pod: headers
39             =pod
40              
41             =head1 NAME
42              
43             PDL::CCS::Functions - Useful perl-level functions for PDL::CCS
44              
45             =head1 SYNOPSIS
46              
47             use PDL;
48             use PDL::CCS::Functions;
49              
50             ##---------------------------------------------------------------------
51             ## ... stuff happens
52              
53             =cut
54              
55              
56             ##======================================================================
57             ## Decoding
58             =pod
59              
60             =head1 Decoding
61              
62             =cut
63              
64             ##---------------------------------------------------------------
65             ## Decoding: utils
66             =pod
67              
68             =head2 ccs_pointerlen
69              
70             =for sig
71              
72             Signature: (indx ptr(N+1); indx [o]len(N))
73              
74             Get number of non-missing values for each axis value from a CCS-encoded
75             offset pointer vector $ptr().
76              
77             =cut
78              
79             ;#-- emacs
80              
81             *ccs_pointerlen = \&PDL::ccs_pointerlen;
82              
83             ##-- now a PDL::PP function in PDL::CCS::Utils
84             *PDL::ccs_pointerlen_perl = \&ccs_pointerlen_perl;
85             sub ccs_pointerlen_perl :lvalue {
86 0     0 0 0 my ($ptr,$len) = @_;
87 0 0       0 if (!defined($len)) {
88 0         0 $len = $ptr->slice("1:-1") - $ptr->slice("0:-2");
89             } else {
90 0         0 $len .= $ptr->slice("1:-1");
91 0         0 $len -= $ptr->slice("0:-2");
92             }
93 0         0 return $len;
94             }
95              
96             ##---------------------------------------------------------------
97             ## Decoding: generic
98             =pod
99              
100             =head2 ccs_decode
101              
102             =for sig
103              
104             Signature: (indx whichnd(Ndims,Nnz); nzvals(Nnz); missing(); \@Dims; [o]a(@Dims))
105              
106             Decode a CCS-encoded matrix (no dataflow).
107              
108             =cut
109              
110             ;#-- emacs
111              
112             *PDL::ccs_decode = \&ccs_decode;
113             sub ccs_decode :lvalue {
114 7     7 1 54 my ($aw,$nzvals,$missing,$dims,$a) = @_;
115 7 50       19 $missing = $PDL::undefval if (!defined($missing));
116 7 50       18 if (!defined($dims)) {
117 0 0       0 barf("PDL::CCS::ccs_decode(): whichnd() is empty; you must specify \@Dims!") if ($aw->isempty);
118 0         0 $dims = [ map {$aw->slice("($_),")->max+1} (0..($aw->dim(0)-1))];
  0         0  
119             }
120 7 100       20 $a = zeroes($nzvals->type, @$dims) if (!defined($a));
121 7         200 $a .= $missing;
122              
123 7         144 (my $tmp=$a->indexND($aw)) .= $nzvals; ##-- CPAN tests puke here with "Can't modify non-lvalue subroutine call" in 5.15.x (perl bug #107366)
124              
125             ##-- workaround for missing empty pdl support in PDL 2.4.10 release candidates (pdl bug #3462924), fixed in 2.4.9_993
126             #$a->indexND($aw) .= $nzvals if (!$nzvals->isempty);
127             #if (!$nzvals->isempty) {
128             # my $tmp = $a->indexND($aw);
129             # $tmp .= $nzvals;
130             #}
131              
132 7         746 return $a;
133             }
134              
135             ##======================================================================
136             ## Scalar Operations
137             =pod
138              
139             =head1 Scalar Operations
140              
141             Scalar operations can be performed in parallel directly on C<$nzvals>
142             (and if applicable on C<$missing> as well):
143              
144             $c = 42;
145              
146             $nzvals2 = $nzvals + $c; $missing2 = $missing + $c;
147             $nzvals2 = $nzvals - $c; $missing2 = $missing - $c;
148             $nzvals2 = $nzvals * $c; $missing2 = $missing * $c;
149             $nzvals2 = $nzvals / $c; $missing2 = $missing / $c;
150              
151             $nzvals2 = $nzvals ** $c; $missing2 = $missing ** $c;
152             $nzvals2 = log($nzvals); $missing2 = log($missing);
153             $nzvals2 = exp($nzvals); $missing2 = exp(missing);
154              
155             $nzvals2 = $nzvals->and2($c,0); $missing2 = $missing->and($c,0);
156             $nzvals2 = $nzvals->or2($c,0); $missing2 = $missing->or2($c,0);
157             $nzvals2 = $nzvals->not(); $missing2 = $missing->not();
158              
159             Nothing prevents scalar operations from producing new "missing" values (e.g. $nzvals*0),
160             so you might want to re-encode your compressed data after applying the operation.
161              
162             =cut
163              
164              
165             ##======================================================================
166             ## Vector Operations
167             =pod
168              
169             =head1 Vector Operations
170              
171             =head2 ccs_OP_vector_mia
172              
173             =for sig
174              
175             Signature: (indx whichDimV(Nnz); nzvals(Nnz); vec(V); [o]nzvals_out(Nnz))
176              
177             A number of row- and column-vector operations may be performed directly
178             on encoded Nd-PDLs, without the need for decoding to a (potentially huge)
179             dense temporary. These operations assume that "missing" values are
180             annihilators with respect to the operation in question, i.e.
181             that it holds for all C<$x> in C<$vec> that:
182              
183             ($missing __OP__ $x) == $missing
184              
185             This is in line with the usual PDL semantics if your C<$missing> value is C,
186             but may produce unexpected results when e.g. adding a vector to a sparse PDL with C<$missing>==0.
187             If you really need to do something like the latter, then you're probably better off decoding to
188             a dense PDL anyway.
189              
190             Predefined function names for encoded-PDL vector operations are all of the form:
191             C, where ${OPNAME} is the base name of the operation:
192              
193             plus ##-- addition
194             minus ##-- subtraction
195             mult ##-- multiplication (NOT matrix-multiplication)
196             divide ##-- division
197             modulo ##-- modulo
198             power ##-- potentiation
199              
200             gt ##-- greater-than
201             ge ##-- greater-than-or-equal
202             lt ##-- less-than
203             le ##-- less-than-or-equal
204             eq ##-- equality
205             ne ##-- inequality
206             spaceship ##-- 3-way comparison
207              
208             and2 ##-- binary AND
209             or2 ##-- binary OR
210             xor ##-- binary XOR
211             shiftleft ##-- left-shift
212             shiftright ##-- right-shift
213              
214             =head2 \&CODE = ccs_binop_vector_mia($opName, \&PDLCODE);
215              
216             Returns a generic vector-operation subroutine which reports errors as C<$opName>
217             and uses \&PDLCODE to perform underlying computation.
218              
219             =cut
220              
221             ##======================================================================
222             ## Vector Operations: Generic
223              
224             *PDL::ccs_binop_vector_mia = \&ccs_binop_vector_mia;
225             sub ccs_binop_vector_mia {
226 72     72 1 135 my ($opName,$pdlCode) = @_;
227             return sub :lvalue {
228 2     2   7 my ($wi,$nzvals_in, $vec,$nzvals_out) = @_;
229 2 50       10 $nzvals_out = zeroes(($nzvals_in->type > $vec->type ? $nzvals_in->type : $vec->type), $nzvals_in->nelem)
    50          
230             if (!defined($nzvals_out));
231 2         284 $pdlCode->($nzvals_in, $vec->index($wi), $nzvals_out, 0);
232 2         15 return $nzvals_out;
233 72         320 };
234             }
235              
236             ##-- Arithmetic
237             *PDL::ccs_plus_vector_mia = *ccs_plus_vector_mia = ccs_binop_vector_mia('plus',\&PDL::plus); ##-- addition
238             *PDL::ccs_minus_vector_mia = *ccs_minus_vector_mia = ccs_binop_vector_mia('minus',\&PDL::minus); ##-- subtraction
239             *PDL::ccs_mult_vector_mia = *ccs_mult_vector_mia = ccs_binop_vector_mia('mult',\&PDL::mult); ##-- multiplication
240             *PDL::ccs_divide_vector_mia = *ccs_divide_vector_mia = ccs_binop_vector_mia('divide',\&PDL::divide); ##-- division
241             *PDL::ccs_modulo_vector_mia = *ccs_modulo_vector_mia = ccs_binop_vector_mia('modulo',\&PDL::modulo); ##-- modulo
242             *PDL::ccs_power_vector_mia = *ccs_power_vector_mia = ccs_binop_vector_mia('power',\&PDL::power); ##-- potentiation
243              
244             ##-- Comparison
245             *PDL::ccs_gt_vector_mia = *ccs_gt_vector_mia = ccs_binop_vector_mia('gt',\&PDL::gt); ##-- greater-than
246             *PDL::ccs_ge_vector_mia = *ccs_ge_vector_mia = ccs_binop_vector_mia('ge',\&PDL::ge); ##-- greater-than-or-equal
247             *PDL::ccs_lt_vector_mia = *ccs_lt_vector_mia = ccs_binop_vector_mia('lt',\&PDL::lt); ##-- less-than
248             *PDL::ccs_le_vector_mia = *ccs_le_vector_mia = ccs_binop_vector_mia('le',\&PDL::le); ##-- less-than-or-equal
249             *PDL::ccs_eq_vector_mia = *ccs_eq_vector_mia = ccs_binop_vector_mia('eq',\&PDL::eq); ##-- equality
250             *PDL::ccs_ne_vector_mia = *ccs_ne_vector_mia = ccs_binop_vector_mia('ne',\&PDL::ne); ##-- inequality
251             *PDL::ccs_spaceship_vector_mia = *ccs_spaceship_vector_mia = ccs_binop_vector_mia('spaceship',\&PDL::spaceship); ##-- <=>
252              
253             ##-- Logic & Bitwise
254             *PDL::ccs_and2_vector_mia = *ccs_and2_vector_mia = ccs_binop_vector_mia('and',\&PDL::and2); ##-- logical AND (and2)
255             *PDL::ccs_or2_vector_mia = *ccs_or2_vector_mia = ccs_binop_vector_mia('or',\&PDL::or2); ##-- logical OR (or2)
256             *PDL::ccs_xor_vector_mia = *ccs_xor_vector_mia = ccs_binop_vector_mia('xor',\&PDL::xor); ##-- binary XOR (xor)
257             *PDL::ccs_shiftleft_vector_mia = *ccs_shiftleft_vector_mia = ccs_binop_vector_mia('shiftleft',\&PDL::shiftleft); ##-- <<
258             *PDL::ccs_shiftright_vector_mia = *ccs_shiftright_vector_mia = ccs_binop_vector_mia('shiftright',\&PDL::shiftright); ##-- >>
259              
260             ##======================================================================
261             ## Sorting
262             =pod
263              
264             =head1 Sorting
265              
266             =head2 ccs_qsort
267              
268             =for sig
269              
270             Signature: (indx which(Ndims,Nnz); nzvals(Nnz); missing(); Dim0(); indx [o]nzix(Nnz); indx [o]nzenum(Nnz))
271              
272             Underlying guts for PDL::CCS::Nd::qsort() and PDL::CCS::Nd::qsorti().
273             Given a set of $Nnz items $i each associated with a vector-key C<$which(:,$i)>
274             and a value C<$nzvals($i)>, returns a vector of $Nnz item indices C<$nzix()>
275             such that C<$which(:,$nzix)> is vector-sorted in ascending order and
276             C<$nzvals(:,$nzix)> are sorted in ascending order for each unique key-vector in
277             C<$which()>, and an enumeration C<$nzenum()> of items for each unique key-vector
278             in terms of the sorted data: C<$nzenum($j)> is the logical position of the item
279             C<$nzix($j)>.
280              
281             If C<$missing> and C<$Dim0> are defined,
282             items C<$i=$nzix($j)> with values C<$nzvals($i) E $missing>
283             will be logically enumerated at the end of the range [0,$Dim0-1]
284             and there will be a gap between C<$nzenum()> values for a C<$which()>-key
285             with fewer than $Dim0 instances; otherwise $nzenum() values will be
286             enumerated in ascending order starting from 0.
287              
288             For an unsorted index+value dataset C<($which0,$nzvals0)> with
289              
290             ($nzix,$nzenum) = ccs_qsort($which0("1:-1,"),$nzvals0,$missing,$which0("0,")->max+1)
291              
292             qsort() can be implemented as:
293              
294             $which = $nzenum("*1,")->glue(0,$which0("1:-1,")->dice_axis(1,$nzix));
295             $nzvals = $nzvals0->index($nzix);
296              
297             and qsorti() as:
298              
299             $which = $nzenum("*1,")->glue(0,$which0("1:-1,")->dice_axis(1,$nzix));
300             $nzvals = $which0("(0),")->index($nzix);
301              
302             =cut
303              
304             ## $bool = _checkdims(\@dims1,\@dims2,$label); ##-- match @dims1 ~ @dims2
305             ## $bool = _checkdims( $pdl1, $pdl2,$label); ##-- match $pdl1->dims ~ $pdl2->dims
306             sub _checkdims {
307             #my ($dims1,$dims2,$label) = @_;
308             #my ($pdl1,$pdl2,$label) = @_;
309 0 0   0     my $d0 = UNIVERSAL::isa($_[0],'PDL') ? pdl(ccs_indx(),$_[0]->dims) : pdl(ccs_indx(),$_[0]);
310 0 0         my $d1 = UNIVERSAL::isa($_[1],'PDL') ? pdl(ccs_indx(),$_[1]->dims) : pdl(ccs_indx(),$_[0]);
311 0 0 0       barf(__PACKAGE__ . "::_checkdims(): dimension mismatch for ".($_[2]||'pdl').": $d0!=$d1")
      0        
312             if (($d0->nelem!=$d1->nelem) || !all($d0==$d1));
313 0           return 1;
314             }
315              
316             sub ccs_qsort {
317 0     0 1   my ($which,$nzvals, $missing,$dim0, $nzix,$nzenum) = @_;
318              
319             ##-- prepare: $nzix
320 0 0         $nzix = zeroes(ccs_indx(),$nzvals->dims) if (!defined($nzix));
321 0 0         $nzix->reshape($nzvals) if ($nzix->isempty);
322 0           _checkdims($nzvals,$nzix,'ccs_qsort: nzvals~nzix');
323             ##
324             ##-- prepare: $nzenum
325 0 0         $nzenum = zeroes(ccs_indx(),$nzvals->dims) if (!defined($nzenum));
326 0 0         $nzenum->reshape($nzvals) if ($nzenum->isempty);
327 0           _checkdims($nzenum,$nzvals,'ccs_qsort: nzvals~nzenum');
328              
329             ##-- collect and sort base data (unsorted indices + values)
330 0           my $vdata = $which->glue(0,$nzvals->slice("*1,"));
331 0           $vdata->vv_qsortveci($nzix);
332              
333             ##-- get logical enumeration
334 0 0 0       if (!defined($missing) || !defined($dim0)) {
335             ##-- ... flat enumeration
336 0           $which->dice_axis(1,$nzix)->enumvec($nzenum);
337             } else {
338             ##-- ... we have $missing and $dim0: split enumeration around $missing()
339 0           my $whichx = $which->dice_axis(1,$nzix);
340 0           my $nzvalsx = $nzvals->index($nzix);
341 0           my ($nzii_l,$nzii_r) = which_both($nzvalsx <= $missing);
342             #$nzenum .= -1; ##-- debug
343 0 0         $whichx->dice_axis(1,$nzii_l)->enumvec($nzenum->index($nzii_l)) if (!$nzii_l->isempty); ##-- enum: <=$missing
344 0 0         if (!$nzii_r->isempty) {
345             ##-- enum: >$missing
346 0           my $nzenum_r = $nzenum->index($nzii_r);
347 0           $whichx->dice_axis(1,$nzii_r)->slice(",-1:0")->enumvec($nzenum_r->slice("-1:0"));
348 0           $nzenum_r *= -1;
349 0           $nzenum_r += ($dim0-1);
350             }
351             }
352              
353             ##-- all done
354 0 0         return wantarray ? ($nzix,$nzenum) : $nzix;
355             }
356              
357              
358             ##======================================================================
359             ## Vector Operations: Generic
360              
361              
362             ##======================================================================
363             ## POD: footer
364             =pod
365              
366             =head1 ACKNOWLEDGEMENTS
367              
368             Perl by Larry Wall.
369              
370             PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others.
371              
372             =cut
373              
374              
375             ##---------------------------------------------------------------------
376             =pod
377              
378             =head1 AUTHOR
379              
380             Bryan Jurish Emoocow@cpan.orgE
381              
382             =head2 Copyright Policy
383              
384             Copyright (C) 2007-2018, Bryan Jurish. All rights reserved.
385              
386             This package is free software, and entirely without warranty.
387             You may redistribute it and/or modify it under the same terms
388             as Perl itself.
389              
390             =head1 SEE ALSO
391              
392             perl(1),
393             PDL(3perl),
394             PDL::CCS::Nd(3perl),
395              
396              
397             =cut
398              
399              
400             1; ##-- make perl happy