PDL-CCS-1.24.1/0000755000175000017500000000000014736165776012404 5ustar moocowbovinesPDL-CCS-1.24.1/CCS.pm0000644000175000017500000001204414736165363013343 0ustar moocowbovines## File: PDL::CCS.pm ## Author: Bryan Jurish ## Description: top-level PDL::CCS (also pulls in compatibility code) package PDL::CCS; use PDL; use PDL::CCS::Config; use PDL::CCS::Compat; use PDL::CCS::Functions; use PDL::CCS::Utils; use PDL::CCS::Ufunc; use PDL::CCS::Ops; use PDL::CCS::MatrixOps; use PDL::CCS::Nd; use PDL::CCS::IO::FastRaw; use strict; our $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module our @ISA = ('PDL::Exporter'); our @EXPORT_OK = ( @PDL::CCS::Config::EXPORT_OK, @PDL::CCS::Compat::EXPORT_OK, @PDL::CCS::Functions::EXPORT_OK, @PDL::CCS::Utils::EXPORT_OK, @PDL::CCS::Ufunc::EXPORT_OK, @PDL::CCS::Ops::EXPORT_OK, @PDL::CCS::MatrixOps::EXPORT_OK, @PDL::CCS::Nd::EXPORT_OK, @PDL::CCS::IO::FastRaw::EXPORT_OK, ); our %EXPORT_TAGS = ( Func => [ @{$PDL::CCS::Config::EXPORT_TAGS{Func}}, @{$PDL::CCS::Compat::EXPORT_TAGS{Func}}, @{$PDL::CCS::Functions::EXPORT_TAGS{Func}}, @{$PDL::CCS::Utils::EXPORT_TAGS{Func}}, @{$PDL::CCS::Ufunc::EXPORT_TAGS{Func}}, @{$PDL::CCS::Ops::EXPORT_TAGS{Func}}, @{$PDL::CCS::MatrixOps::EXPORT_TAGS{Func}}, @{$PDL::CCS::Nd::EXPORT_TAGS{Func}}, @{$PDL::CCS::IO::FastRaw::EXPORT_TAGS{Func}}, ], ##-- respect PDL conventions (hopefully) ); our @EXPORT = @{$EXPORT_TAGS{Func}}; 1; ##-- make perl happy ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS - Sparse N-dimensional PDLs with compressed column storage =head1 SYNOPSIS use PDL; use PDL::CCS; ## ... stuff happens ... =cut ##====================================================================== ## DESCRIPTION ##====================================================================== =pod =head1 DESCRIPTION PDL::CCS is now just a wrapper package which pulls in a number of submodules. See the documentation of the respective modules for details. =cut ##====================================================================== ## Submodules ##====================================================================== =pod =head2 Modules =over 4 =item L Perl class for representing large sparse N-dimensional numeric structures using sorted index vector-vectors and a flat vector of non-missing values. Supports a subset of the perl-side PDL API. =item L Backwards-compatibility module for Harwell-Boeing compressed row- or column-storage. =item L Some useful generic pure-perl functions for dealing directly with CCS-, CRS-, and index-encoded PDLs. =item L Low-level generic PDL::PP utilities for Harwell-Boeing encoding and decoding "pointers" along arbitrary dimensions of a sparse PDL given an index list. =item L Low-level generic PDL::PP utilities for blockwise alignment of pairs of sparse index-encoded PDLs, useful for implementing binary operations. =item L Various low-level ufunc (accumulator) utilities for index-encoded PDLs. =item L Low-level generic PDL::PP utilities for matrix operations on index-encoded PDLs. =item L PDL::IO::FastRaw wrappers for PDL::CCS::Nd objects. =back =cut ##====================================================================== ## Footer Administrivia ##====================================================================== ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. Original inspiration and algorithms from the SVDLIBC C library by Douglas Rohde; which is itself based on SVDPACKC by Michael Berry, Theresa Do, Gavin O'Brien, Vijay Krishna and Sowmini Varadhan. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS =over 4 =item * PDL::CCS::Nd supports only a subset of the PDL API (i.e. is not really a PDL). =item * Binary operations via alignment only work correctly when missing values are annihilators. =item * Misleading module name: PDL::CCS::Nd objects actually use a native COO (full coordinate list) format rather than CRS (compressed row storage) or CCS (compressed column storage); see L for a discussion. =back =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2005-2024 by Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl), PDL::CCS::Nd(3perl), PDL::SVDLIBC(3perl), L. =cut PDL-CCS-1.24.1/MANIFEST.SKIP0000644000175000017500000000067014734512720014264 0ustar moocowbovines~$ \.sw.$ ^PDL$ ^PDL-CCS- \bMYMETA\. \.svn \.gz$ \.\# \# CCS/.*\.bin$ #CCS/Config.pm CCS/Ops/Ops\.(c|pm|xs)$ CCS/Ufunc/Ufunc\.(c|pm|xs)$ CCS/Utils/Utils\.(c|pm|xs)$ CCS/MatrixOps/MatrixOps\.(c|pm|xs)$ pp-[^/]*\.c$ CCS/IO/t/(?:ccs|dense)3?\. \bppgen.perl$ \.gz$ \.bs$ \.o$ \.old$ \bpm_to_blib$ \bblib\b ^pdl-core$ ^xs-cookbook$ \bMakefile$ \btestme\.perl$ \bREADME\.(?:r?)pod$ \.html$ \btmp\b ^#Makefile#$ ^reversion.sh$ ^\.git ^svntag\.rc$ PDL-CCS-1.24.1/META.json0000644000175000017500000000266714736165776014040 0ustar moocowbovines{ "abstract" : "Sparse N-dimensional PDLs with compressed column storage", "author" : [ "Bryan Jurish" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "PDL-CCS", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "Data::Dumper" : "0", "ExtUtils::MakeMaker" : "0", "File::Basename" : "0", "PDL" : "2.081", "PDL::VectorValued" : "v1.0.4" } }, "runtime" : { "requires" : { "File::Basename" : "0", "PDL" : "2.081", "PDL::VectorValued" : "v1.0.4" } }, "test" : { "requires" : { "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/moocow-the-bovine/PDL-CCS.git", "web" : "https://github.com/moocow-the-bovine/PDL-CCS" } }, "version" : "v1.24.1", "x_serialization_backend" : "JSON::PP version 4.16" } PDL-CCS-1.24.1/README.txt0000644000175000017500000000244314735715730014073 0ustar moocowbovines README for PDL::CCS ABSTRACT PDL::CCS - Sparse N-dimensional PDLs with Harwell-Boeing compressed column storage REQUIREMENTS * PDL >= v2.4.2 Tested version(s) 2.4.2, 2.4.3, 2.4.7_001, 2.4.9_015, 2.4.10, 2.019, 2.039 * PDL::VectorValued >= v0.07001 DESCRIPTION PDL::CCS is a set of perl modules for representation and manipulation of large sparse n-dimensional numeric arrays using PDL. It includes a perl class implementing a subset of the PDL API for memory-efficient storage and operations on large sparse arrays, as well as utilities for extracting Harwell-Boeing compressed column- and/or row-storage "pointers" from/to indexND() vector lists. BUILDING Build this module as you would any perl module, by doing something akin to the following: gzip -dc PDL-CCS-XYZ.tar.gz | tar -xof - cd PDL-CCS-XYZ/ perl Makefile.PL make make test # optional make install See perlmodinstall(1) for details. AUTHOR Bryan Jurish COPYRIGHT Copyright (c) 2005-2024 by Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. PDL-CCS-1.24.1/t/0000755000175000017500000000000014736165776012647 5ustar moocowbovinesPDL-CCS-1.24.1/t/03_ops.t0000644000175000017500000000613714735713775014143 0ustar moocowbovines# -*- Mode: CPerl -*- # t/03_ops.t: test ccs native operations use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::Bad; use PDL::CCS; ##-- setup my $a = pdl(double, [ [10,0,0,0,-2,0], [3,9,0,0,0,3], [0,7,8,7,0,0], [3,0,8,7,5,0], [0,8,0,9,9,13], [0,4,0,0,2,-1], ]); my ($ptr,$rowids,$nzvals) = ccsencode($a); ##-- 1: transpose() my ($ptrT,$rowidsT,$nzvalsT) = ccstranspose($ptr,$rowids,$nzvals); my $aT = ccsdecode($ptrT,$rowidsT,$nzvalsT)->xchg(0,1); pdlok("transpose()", $a,$aT); ##-- 2-3: whichND() my ($ccols,$crows) = ccswhichND($ptr,$rowids,$nzvals); my ($acols,$arows) = $a->whichND->xchg(0,1)->dog; pdlok("whichND():cols", $acols->qsort, $ccols->qsort); pdlok("whichND():rows", $arows->qsort, $crows->qsort); ##-- 4: which() my $awhich = which($a)->qsort; my $cwhich = ccswhich($ptr,$rowids,$nzvals)->qsort; pdlok("which():flat", $awhich, $cwhich); ##-- 5: get(): some missing (zero) my $allai = sequence(long,$a->nelem); my $allavals = $a->flat->index($allai); my $allcvals = ccsget($ptr,$rowids,$nzvals, $allai,0); pdlok("get():some_missing:zero", $allavals, $allcvals); ##-- 6: get(): some missing (bad) my $unless_bad = $PDL::Bad::Status ? '' : "your PDL doesn't support bad values"; skipok("get():some_missing:bad", $unless_bad, sub { my $badval = pdl(0)->setvaltobad(0); my $allbcvals = ccsget($ptr,$rowids,$nzvals, $allai,$badval); return (all($allbcvals->where($allbcvals->isgood) == $allavals->where($allbcvals->isgood)) && all($allavals->where($allbcvals->isbad) == 0)); }); ##-- 7: get2d(): some missing (zero) my ($acoli,$arowi) = ($a->xvals->flat, $a->yvals->flat); $allavals = $a->index2d($acoli,$arowi); $allcvals = ccsget2d($ptr,$rowids,$nzvals, $acoli,$arowi,0); pdlok("index2d():some_missing:zero", $allavals, $allcvals); ##-- 8: index2d(): some missing (bad) skipok("get():some_missing:bad", $unless_bad, sub { my $badval = pdl(0)->setvaltobad(0); my $allbcvals = ccsget2d($ptr,$rowids,$nzvals, $acoli,$arowi,$badval); return (all($allbcvals->where($allbcvals->isgood) == $allavals->where($allbcvals->isgood)) && all($allavals->where($allbcvals->isbad) == 0)); }); ##-- 9: ccsmult_rv (row vector) my $rv=10**(sequence($a->dim(0))+1); my $nzvals_rv = ccsmult_rv($ptr,$rowids,$nzvals, $rv); pdlok("ccsmult_rv()", ($a * $rv), ccsdecode($ptr,$rowids,$nzvals_rv)); ##-- 10: ccsmult_cv (col vector) my $cv=10**(sequence($a->dim(1))+1); my $nzvals_cv = ccsmult_cv($ptr,$rowids,$nzvals, $cv); pdlok("ccsmult_cv()", ($a * $cv->slice("*1,")), ccsdecode($ptr,$rowids,$nzvals_cv)); done_testing; PDL-CCS-1.24.1/t/common.plt0000644000175000017500000000737314734512720014651 0ustar moocowbovines# -*- Mode: CPerl -*- # File: t/common.plt # Description: re-usable test subs; requires Test::More BEGIN { $| = 1; } use strict; # isok($label,@_) -- prints helpful label sub isok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $label = shift; if (@_==1) { ok($_[0],$label); } elsif (@_==2) { is($_[0],$_[1], $label); } else { die("isok(): expected 1 or 2 non-label arguments, but got ", scalar(@_)); } } # skipok($label,$skip_if_true,@_) -- prints helpful label # skipok($label,$skip_if_true,\&CODE) -- prints helpful label sub skipok { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$skip_if_true) = splice(@_,0,2); if ($skip_if_true) { subtest $label => sub { plan skip_all => $skip_if_true; }; } else { if (@_==1 && ref($_[0]) && ref($_[0]) eq 'CODE') { isok($label, $_[0]->()); } else { isok($label,@_); } } } # skipordo($label,$skip_if_true,sub { ok ... },@args_for_sub) sub skipordo { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$skip_if_true) = splice(@_,0,2); if ($skip_if_true) { subtest $label => sub { plan skip_all => $skip_if_true; }; } else { $_[0]->(@_[1..$#_]); } } # ulistok($label,\@got,\@expect) # --> ok() for unsorted lists sub ulistok { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$l1,$l2) = @_; is_deeply([sort @$l1],[sort @$l2],$label); } # matchpdl($a,$b) : returns pdl identity check, including BAD sub matchpdl { my ($a,$b) = map {PDL->topdl($_)->setnantobad} @_[0,1]; return ($a==$b)->setbadtoval(0) | ($a->isbad & $b->isbad) | ($a->isfinite->not & $b->isfinite->not); } # matchpdl($a,$b,$eps) : returns pdl approximation check, including BAD sub matchpdla { my ($a,$b) = map {$_->setnantobad} @_[0,1]; my $eps = $_[2]; $eps = 1e-5 if (!defined($eps)); return $a->approx($b,$eps)->setbadtoval(0) | ($a->isbad & $b->isbad) | ($a->isfinite->not & $b->isfinite->not); } # cmp_dims($got_pdl,$expect_pdl) sub cmp_dims { my ($p1,$p2) = @_; return $p1->ndims==$p2->ndims && all(pdl(PDL::long(),[$p1->dims])==pdl(PDL::long(),[$p2->dims])); } sub pdlstr { my $a = shift; return '(undef)' if (!defined($a)); my $typ = UNIVERSAL::can($a,'type') ? $a->type : 'NOTYPE'; my $str = "($typ) $a"; #$str =~ s/\n/ /g; return $str; } sub labstr { my ($label,$ok,$got,$want) = @_; $label .= "\n : got=".pdlstr($got)."\n : wanted=".pdlstr($want) if (!$ok); return $label; } # pdlok($label, $got, $want) sub pdlok { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$got,$want) = @_; $got = PDL->topdl($got) if (defined($got)); $want = PDL->topdl($want) if (defined($want)); my $ok = (defined($got) && defined($want) && cmp_dims($got,$want) && all(matchpdl($want,$got)) ); isok(labstr($label,$ok,$got,$want), $ok); } # pdlok_nodims($label, $got, $want) # + ignores dimensions sub pdlok_nodims { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$got,$want) = @_; $got = PDL->topdl($got) if (defined($got)); $want = PDL->topdl($want) if (defined($want)); my $ok = (defined($got) && defined($want) #&& cmp_dims($got,$want) && all(matchpdl($want,$got))); isok(labstr($label,$ok,$got,$want), $ok); } # pdlapprox($label, $got, $want, $eps=1e-5) sub pdlapprox { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$got,$want,$eps) = @_; $got = PDL->topdl($got) if (defined($got)); $want = PDL->topdl($want) if (defined($want)); $eps = 1e-5 if (!defined($eps)); my $ok = (defined($got) && defined($want) && cmp_dims($got,$want) && all(matchpdla($want,$got,$eps))); isok(labstr($label,$ok,$got,$want), $ok) or diag "got=$got\nwant=$want"; } print "loaded ", __FILE__, "\n"; 1; PDL-CCS-1.24.1/t/02_encode.t0000644000175000017500000001065414735713775014575 0ustar moocowbovines# -*- Mode: CPerl -*- # t/02_encode.t: test ccs encoding use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::CCS; ##-- setup my $p = pdl(double, [ [10,0,0,0,-2,0], [3,9,0,0,0,3], [0,7,8,7,0,0], [3,0,8,7,5,0], [0,8,0,9,9,13], [0,4,0,0,2,-1], ]); my $nnz = $p->flat->nnz; my $want_ptr=pdl(long,[0,3,7,9,12,16]); my $want_rowids=pdl(long,[0,1,3,1,2,4,5,2,3,2,3,4,0,3,4,5,1,4,5]); my $want_nzvals=pdl(long,[10,3,3,9,7,8,4,8,8,7,7,9,-2,5,9,2,3,13,-1]); ##-- 1--3: test ccsencodefull() my ($ptr,$rowids,$nzvals); ccsencodefull($p, $ptr=zeroes(long,$p->dim(0)), $rowids=zeroes(long,$nnz), $nzvals=zeroes($p->type, $nnz)); pdlok("encodefull():ptr", $ptr, $want_ptr); pdlok("encodefull():rowids", $rowids, $want_rowids); pdlok("encodefull():nzvals", $nzvals, $want_nzvals); ##-- 4--6: test ccsencode() ($ptr,$rowids,$nzvals) = ccsencode($p); pdlok("encode():ptr", $ptr, $want_ptr); pdlok("encode():rowids", $rowids, $want_rowids); pdlok("encode():nzvals", $nzvals, $want_nzvals); ##-- 7--9: test ccsencodefulla() my $eps=2.5; my $want_ptr_a=pdl(long,[0,3,7,9,12,14]); my $want_rowids_a=pdl(long,[0,1,3,1,2,4,5,2,3,2,3,4,3,4,1,4]); my $want_nzvals_a=pdl(long,[10,3,3,9,7,8,4,8,8,7,7,9,5,9,3,13]); $nnz = $p->flat->nnza($eps); ccsencodefulla($p, $eps, $ptr=zeroes(long,$p->dim(0)), $rowids=zeroes(long,$nnz), $nzvals=zeroes($p->type, $nnz)); pdlok("encodefulla():ptr", $ptr, $want_ptr_a); pdlok("encodefulla():rowids", $rowids, $want_rowids_a); pdlok("encodefulla():nzvals", $nzvals, $want_nzvals_a); ##-- 10--12: : test ccsencodea() ($ptr,$rowids,$nzvals) = ccsencodea($p,$eps); pdlok("encodea():ptr", $ptr, $want_ptr_a); pdlok("encodea():rowids", $rowids, $want_rowids_a); pdlok("encodea():nzvals", $nzvals, $want_nzvals_a); ##-- 13..15 : test ccsencodefull_i2d() #($pwcols,$pwrows) = $p->whichND; ##-- in pdl-2.4.9_014: WARNING - deprecated list context for whichND (may switch to scalar case soon) my ($pwcols,$pwrows) = $p->whichND->xchg(0,1)->dog; my $pwvals = $p->index2d($pwcols,$pwrows); $nnz = $pwvals->nelem; ccsencodefull_i2d($pwcols,$pwrows,$pwvals, $ptr=zeroes(long,$p->dim(0)), $rowids=zeroes(long,$nnz), $nzvals=zeroes($p->type, $nnz)); pdlok("encodefull_i2d():ptr", $ptr, $want_ptr); pdlok("encodefull_i2d():rowids", $rowids, $want_rowids); pdlok("encodefull_i2d():nzvals", $nzvals, $want_nzvals); ##-- 16..18 : test ccsencode_i2d() ($ptr,$rowids,$nzvals) = ccsencode_i2d($pwcols,$pwrows,$pwvals); pdlok("encode_i2d():ptr", $ptr,$want_ptr); pdlok("encode_i2d():rowids", $rowids,$want_rowids); pdlok("encode_i2d():nzvals", $nzvals,$want_nzvals); ##-- 19..21 : test ccsencodefull_i() my $pwhich = $p->which; $pwvals = $p->flat->index($pwhich); $nnz = $pwvals->nelem; ccsencodefull_i($pwhich, $pwvals, $ptr =zeroes(long,$p->dim(0)), $rowids=zeroes(long,$nnz), $nzvals=zeroes($p->type, $nnz)); pdlok("encodefull_i():ptr", $ptr,$want_ptr); pdlok("encodefull_i():rowids", $rowids,$want_rowids); pdlok("encodefull_i():nzvals", $nzvals,$want_nzvals); ##-- 22..24 : test ccsencode_i() my $N = $p->dim(0); ($ptr,$rowids,$nzvals) = ccsencode_i($pwhich, $pwvals, $N); pdlok("encode_i():ptr", $ptr,$want_ptr); pdlok("encode_i():rowids", $rowids,$want_rowids); pdlok("encode_i():nzvals", $nzvals,$want_nzvals); ##-- 25 : test ccsdecodecols (single col) my $M = $p->dim(1); ($ptr,$rowids,$nzvals) = ccsencode($p); my $col0 = ccsdecodecols($ptr,$rowids,$nzvals, 0,0); pdlok("decodecols(0)", $col0,$p->slice("0,")); ##-- 26 : test ccsdecodecols (full) my $dense = ccsdecodecols($ptr,$rowids,$nzvals, sequence($p->dim(0)),0); pdlok("decodecols(all)", $dense,$p); ##-- 27 : test decodefull() my $p2 = zeroes($p->type,$p->dims); ccsdecodefull($ptr,$rowids,$nzvals, $p2); pdlok("decodefull()", $p,$p2); ##-- 28 : test decode() $p2 = ccsdecode($ptr,$rowids,$nzvals); pdlok("decode()", $p,$p2); done_testing; PDL-CCS-1.24.1/CCS/0000755000175000017500000000000014736165776013014 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/IO/0000755000175000017500000000000014736165776013323 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/IO/t/0000755000175000017500000000000014736165776013566 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/IO/t/01_io.t0000644000175000017500000000625714735713775014671 0ustar moocowbovines##-*- Mode: CPerl -*- use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../../.. ../.. ..)); #do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::CCS; BEGIN { use_ok('PDL::CCS::IO::Common'); use_ok('PDL::CCS::IO::FastRaw'); use_ok('PDL::CCS::IO::FITS'); use_ok('PDL::CCS::IO::MatrixMarket'); use_ok('PDL::CCS::IO::LDAC'); use_ok('PDL::CCS::IO::PETSc'); $| = 1; } ##-- basic data my $a = pdl(double, [ [10,0,0,0,-2], [3,9,0,0,0], [0,7,8,7,0], [3,0,8,7,5], [0,8,0,9,9], [0,4,0,0,2], ]); my $ccs = $a->toccs(); ##-- pdl equality sub pdleq { my ($a,$b) = @_; return 0 if (!$a->ndims == $b->ndims || !all(pdl(long,[$a->dims])==pdl(long,[$b->dims]))); if (UNIVERSAL::isa($a,'PDL::CCS::Nd')) { return 0 if ($a->_nnz_p != $b->_nnz_p); return all($a->_whichND==$b->_whichND) && all($a->_vals==$b->_vals); } else { return all($a==$b); } } ##-- *6: i/o testing sub iotest { my ($p, $file, $reader,$writer, $opts) = @_; my ($q); $reader = $p->can($reader) if (!ref($reader)); $writer = $p->can($writer) if (!ref($writer)); ok(defined($writer), "$file - writer sub"); ok(defined($reader), "$file - reader sub"); ok($writer->($p,"$TEST_DIR/$file",$opts), "$file - write"); ok(defined($q = $reader->("$TEST_DIR/$file",$opts)), "$file - read"); is(ref($q), ref($p), "$file - ref"); ok(pdleq($p,$q), "$file - data"); ##-- unlink test data #unlink($_) foreach (glob("$TEST_DIR/$file*")); } ##-- x1 : raw iotest($ccs, 'ccs.raw', qw(readfraw writefraw)); ##-- x2 : fits iotest($ccs, 'ccs.fits', qw(rfits wfits)); ##-- x3-x8 : mm do { iotest($ccs, 'ccs.mm', qw(readmm writemm)); ##-- mm: sparse iotest($ccs, 'ccs.mm0', qw(readmm writemm), {header=>0}); ##-- mm: sparse, no header iotest($a, 'dense.mm', qw(readmm writemm)); ##-- mm: dense my $a3 = $a->cat($a->rotate(1)); my $ccs3 = $a3->toccs; iotest($ccs3, 'ccs3.mm', qw(readmm writemm)); ##-- mm3: sparse iotest($ccs3, 'ccs3.mm0', qw(readmm writemm), {header=>0}); ##-- mm3: sparse, no header iotest($a3, 'dense3.mm', qw(readmm writemm)); ##-- mm3: dense }; ##-- x9-x12 : ldac do { iotest($ccs, 'ccs.ldac', qw(readldac writeldac)); ##-- ldac: natural iotest($ccs, 'ccs.ldac0', qw(readldac writeldac), {header=>0}); ##-- ldac: natural, no-header iotest($ccs, 'ccs.ldact', qw(readldac writeldac), {transpose=>1}); ##-- ldac: transposed iotest($ccs, 'ccs.ldact0', qw(readldac writeldac), {header=>0,transpose=>1}); ##-- ldac: transposed, no-header }; ##-- x13-x14: petsc do { iotest($ccs, 'ccs.petsc', qw(rpetsc wpetsc)); ##-- petsc: bin iotest($ccs, 'ccs.petscb', qw(rpetsc wpetsc), {ioblock=>2}); ##-- petsc: bin, with block i/o }; done_testing; PDL-CCS-1.24.1/CCS/IO/PETSc.pm0000644000175000017500000002137414736165363014576 0ustar moocowbovines## File: PDL::CCS::IO::PETSc.pm ## Author: Bryan Jurish ## Description: LDA-C wrappers for PDL::CCS::Nd package PDL::CCS::IO::PETSc; use PDL::CCS::Version; use PDL::CCS::Config qw(ccs_indx); use PDL::CCS::Nd; use PDL::CCS::IO::Common qw(:intern); ##-- for e.g. _ccsio_open(), _ccsio_close() use PDL; use Fcntl qw(:seek); ##-- for rewinding use Carp qw(confess); use strict; our $VERSION = '1.24.1'; our @ISA = ('PDL::Exporter'); our @EXPORT_OK = ( qw(ccs_wpetsc ccs_rpetsc), ); our %EXPORT_TAGS = ( Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully) ); our $PETSC_ASCII_HEADER = "Matrix Object: 1 MPI processes\n type: seqaij\n"; ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS::IO::PETSc - PETSc-compatible I/O for PDL::CCS::Nd =head1 SYNOPSIS use PDL; use PDL::CCS::Nd; use PDL::CCS::IO::PETSc; ##-- sparse 2d matrix $ccs = PDL::CCS::Nd->newFromWhich($which,$nzvals); ccs_wpetsc($ccs,"ccs.petsc"); # write a sparse binary PETSc file $ccs2 = ccs_rpetsc("ccs.petsc"); # read a sparse binary PETSc file =cut ##====================================================================== ## I/O Utilities =pod =head1 I/O Utilities =cut ##--------------------------------------------------------------- ## ccs_wpetsc =pod =head2 ccs_wpetsc Write a 2d L matrix in PETSc sparse binary format. ccs_wpetsc($ccs,$filename_or_fh) ccs_wpetsc($ccs,$filename_or_fh,\%opts) Options %opts: class_id => $int, ##-- PETSc MAT_FILE_CLASSID (default=1211216; see petsc/include/petscmat.h) pack_int => $pack, ##-- pack template for PETSc integers (default='N') pack_val => $pack, ##-- pack template for PETSc values (default='d>') ioblock => $size, ##-- I/O block size (default=8192) =cut *PDL::ccs_wpetsc = *PDL::CCS::Nd::wpetsc = \&ccs_wpetsc; sub ccs_wpetsc { my ($ccs,$file,$opts) = @_; my %opts = %{$opts||{}}; my $class_id = $opts{class_id} // 1211216; my $pack_int = $opts{pack_int} // 'N'; my $pack_val = $opts{pack_val} // 'd>'; my $ioblock = $opts{ioblock} || 8192; ##-- sanity check(s) confess("ccs_wpetsc(): input matrix must be physically indexed 2d!") if ($ccs->pdims->nelem != 2 || !$ccs->is_physically_indexed); ##-- open output file my $fh = _ccsio_open($file,'>') or confess("ccs_wpetsc(): open failed for output file '$file': $!"); binmode($fh,':raw'); local $,=''; ##-- write output data: header # + Format (see file:///usr/share/doc/petsc3.4.2-doc/docs/manualpages/Mat/MatLoad.html#MatLoad) # int MAT_FILE_CLASSID # int number of rows # int number of columns # int total number of nonzeros # int *number nonzeros in each row # int *column indices of all nonzeros (starting index is zero) # PetscScalar *values of all nonzeros my ($m,$n,$nnz) = ($ccs->pdims->list,$ccs->_nnz_p); $fh->print(pack("($pack_int)[4]", $class_id, $m,$n,$nnz)); ##-- compute row-lengths my $ptr = $ccs->ptr(0); my $plen = $ptr->slice("1:-1") - $ptr->slice("0:-2"); ###-- write output data: ptr lens my ($i,$j); for ($i=0; $i < $m; $i = $j+1) { $j = $i+$ioblock; $j = $m-1 if ($j >= $m); $fh->print(pack("($pack_int)*", $plen->slice("$i:$j")->list)); } undef $plen; undef $ptr; ##-- write output data: colids my $ix = $ccs->_whichND; for ($i=0; $i < $nnz; $i = $j+1) { $j = $i+$ioblock; $j = $nnz-1 if ($j >= $nnz); $fh->print(pack("($pack_int)*", $ix->slice("(1),$i:$j")->list)); } ##-- write output data: nzvals my $nz = $ccs->_nzvals; for ($i=0; $i < $nnz; $i = $j+1) { $j = $i+$ioblock; $j = $nnz-1 if ($j >= $nnz); $fh->print(pack("($pack_val)*", $nz->slice("$i:$j")->list)); } ##-- cleanup _ccsio_close($file,$fh) or confess("ccs_wpetsc(): close failed for output file '$file': $!"); return 1; } ##--------------------------------------------------------------- ## ccs_rpetsc =pod =head2 ccs_rpetsc REad a 2d L matrix from PETSc sparse binary format. $ccs = ccs_rpetsc($filename_or_fh) $ccs = ccs_rpetsc($filename_or_fh,\%opts) Options %opts: pack_int => $pack, ##-- pack template for PETSc integers (default='N') pack_val => $pack, ##-- pack template for PETSc values (default='d>') ioblock => $size, ##-- I/O block size (default=8192) type => $type, ##-- value type to return (default: double) sorted => $bool, ##-- assume input is lexicographically sorted (only if not transposted; default=do) flags => $flags, ##-- flags for new ccs object (default=$PDL::CCS::Nd::CCSND_FLAGS_DEFAULT) =cut *PDL::ccs_rpetsc = *PDL::CCS::Nd::rpetsc = \&ccs_rpetsc; sub ccs_rpetsc { shift if (UNIVERSAL::isa($_[0],'PDL') || UNIVERSAL::isa($_[0],'PDL::CCS::Nd')); my ($file,$opts) = @_; my %opts = %{$opts||{}}; my $pack_int = $opts{pack_int} // 'N'; my $pack_val = $opts{pack_val} // 'd>'; my $ioblock = $opts{ioblock} || 8192; my $type = $opts{type}; $type = PDL->can($type)->() if (defined($type) && !ref($type) && PDL->can($type)); $type = double if (!ref($type)); $opts{sorted} //= 1; $opts{flags} //= $PDL::CCS::Nd::CCSND_FLAGS_DEFAULT; ##-- open input file my $fh = _ccsio_open($file,'<') or confess("ccs_rpetsc(): open failed for input file '$file': $!"); binmode($fh,':raw'); local $,=''; use bytes; ##-- read input data: header # + Format (see file:///usr/share/doc/petsc3.4.2-doc/docs/manualpages/Mat/MatLoad.html#MatLoad) # int MAT_FILE_CLASSID # int number of rows # int number of columns # int total number of nonzeros my $ilen = length(pack($pack_int,0)); my $buf; read($fh,$buf,$ilen*4)==($ilen*4) or confess("ccs_rpetsc(): failed to read ", $ilen*4, " bytes of header data from '$file': $!"); my ($magic,$m,$n,$nnz) = unpack("($pack_int)[4]", $buf); ##-- read input data: row-lengths # int *number nonzeros in each row my $plen = zeroes(ccs_indx(), $m); my ($i,$j,$blen,$tmp); for ($i=0; $i < $m; $i=$j+1) { $j = $i+$ioblock; $j = $m-1 if ($j >= $m); $blen = $ilen * (1+$j-$i); read($fh,$buf,$blen)==$blen or confess("ccs_rpetsc(): failed to read $blen bytes of length data from '$file': $!"); ($tmp=$plen->slice("$i:$j")) .= pdl(ccs_indx(), [unpack("($pack_int)*", $buf)]); } ##-- setup index pdl my $ix = zeroes(ccs_indx(),2,$nnz); $plen->rld($plen->sequence, $ix->slice("(0),")); undef $plen; ##-- read input data: column-indices # int *column indices of all nonzeros (starting index is zero) for ($i=0; $i < $nnz; $i=$j+1) { $j = $i+$ioblock; $j = $nnz-1 if ($j >= $nnz); $blen = $ilen * (1+$j-$i); read($fh,$buf,$blen)==$blen or confess("ccs_rpetsc(): failed to read $blen bytes of column-index data from '$file': $!"); ($tmp=$ix->slice("(1),$i:$j")) .= pdl(ccs_indx(), [unpack("($pack_int)*", $buf)]); } ##-- read input data: nzvals # PetscScalar *values of all nonzeros my $vlen = length(pack($pack_val,0)); my $nz = zeroes($type, $nnz+1); for ($i=0; $i < $nnz; $i = $j+1) { $j = $i+$ioblock; $j = $nnz-1 if ($j >= $nnz); $blen = $vlen * (1+$j-$i); read($fh,$buf,$blen)==$blen or confess("ccs_rpetsc(): failed to read $vlen bytes of nonzero-value data from '$file': $!"); ($tmp=$nz->slice("$i:$j")) .= pdl($type, [unpack("($pack_val)*", $buf)]); } ##-- cleanup _ccsio_close($file,$fh) or confess("ccs_wpetsc(): close failed for output file '$file': $!"); ##-- construct and return return PDL::CCS::Nd->newFromWhich($ix,$nz, pdims=>[$m,$n], flags=>$opts{flags}, sorted=>$opts{sorted}, steal=>1, ); } 1; ##-- be happy ##====================================================================== ## POD: footer =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2015-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, L, L, L, the PETSc binary matrix format definition at L, the PETSc homepage at L. ... =cut 1; ##-- make perl happy PDL-CCS-1.24.1/CCS/IO/LDAC.pm0000644000175000017500000002021514736165363014354 0ustar moocowbovines## File: PDL::CCS::IO::LDAC.pm ## Author: Bryan Jurish ## Description: LDA-C wrappers for PDL::CCS::Nd package PDL::CCS::IO::LDAC; use PDL::CCS::Version; use PDL::CCS::Config qw(ccs_indx); use PDL::CCS::Nd; use PDL::CCS::IO::Common qw(:intern); ##-- for e.g. _ccsio_header_lines(), _ccsio_parse_header() use PDL; use PDL::IO::Misc; ##-- for rcols(), wcols(), $PDL::IO::Misc::deftype use Fcntl qw(:seek); ##-- for rewinding use Carp qw(confess); use strict; our $VERSION = '1.24.1'; our @ISA = ('PDL::Exporter'); our @EXPORT_OK = ( qw(ccs_writeldac ccs_readldac), ); our %EXPORT_TAGS = ( Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully) ); ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS::IO::LDAC - LDA-C format text I/O for PDL::CCS::Nd =head1 SYNOPSIS use PDL; use PDL::CCS::Nd; use PDL::CCS::IO::LDAC; ##-- (Document x Term) matrix $dtm = PDL::CCS::Nd->newFromWhich($which,$nzvals); ccs_writeldac($dtm,"dtm.ldac"); # write a sparse LDA-C text file $dtm2 = ccs_readldac("dtm.ldac"); # read a sparse LDA-C text file ###-- (Term x Document) matrix in document-primary format $tdm = $dtm->xchg(0,1)->make_physically_indexed(); ccs_writeldac($tdm,"tdm.ldac", {transpose=>1}); $dtm2 = ccs_readldac("tdm.ldac", {transpose=>1}); =cut ##====================================================================== ## I/O utilities =pod =head1 I/O Utilities =cut ##--------------------------------------------------------------- ## ccs_writeldac =pod =head2 ccs_writeldac Write a 2d L (Document x Term) matrix as an LDA-C text file. If the C option is specified and true, the input matrix C<$ccs> is treated as as a (Term x Document) matrix, and output lines correspond to logical dimension 1 of C<$ccs>. Otherwise, output lines correspond to logical dimension 0 of C<$ccs>, which is expected to be a (Document x Term) matrix. ccs_writeldac($ccs,$filename_or_fh) ccs_writeldac($ccs,$filename_or_fh,\%opts) Options %opts: header => $bool, ##-- do/don't write a header to the output file (default=do) transpose => $bool, ##-- treat input $ccs as (Term x Document) matrix (default=don't) =cut *PDL::ccs_writeldac = *PDL::CCS::Nd::writeldac = \&ccs_writeldac; sub ccs_writeldac { my ($ccs,$file,$opts) = @_; my %opts = %{$opts||{}}; $opts{header} = 1 if (!defined($opts{header})); ##-- sanity check(s) confess("ccs_writeldac(): input matrix must be physically indexed 2d!") if ($ccs->pdims->nelem != 2); ##-- open output file my $fh = _ccsio_open($file,'>') or confess("ccs_writeldac(): open failed for output file '$file': $!"); #binmode($fh,':raw'); local $,=''; ##-- maybe print header if ($opts{header}) { print $fh ("%%LDA-C sparse matrix file; see http://www.cs.princeton.edu/~blei/lda-c/readme.txt\n", (map {("%", __PACKAGE__, " $_")} @{_ccsio_header_lines($ccs)}), ); } ##-- transpose? my ($ddim,$tdim) = $opts{transpose} ? (1,0) : (0,1); ##-- convert to lda-c format: use ptr() my ($ptr,$pi2nzi) = $ccs->ptr($ddim); my $nd = $ptr->nelem-1; my $ix = $ccs->_whichND; my $nz = $ccs->_nzvals; my ($di,$i,$j,$nzi); for ($di=0; $di < $nd; ++$di) { ($i,$j) = ($ptr->at($di),$ptr->at($di+1)); $nzi = $pi2nzi->slice("$i:".($j-1)); print $fh join(' ', ($j-$i), map {$ix->at($tdim,$_).":".$nz->at($_)} $nzi->list), "\n"; } ##-- cleanup _ccsio_close($file,$fh) or confess("ccs_writeldac(): close failed for output file '$file': $!"); return 1; } ##--------------------------------------------------------------- ## ccs_readldac =pod =head2 ccs_readldac Read a 2d (Document x Term) matrix from an LDA-C text file as a L object. If the C option is specified and true, the output matrix C<$ccs> will be a (Term x Document) matrix, and input lines correspond to logical dimension 1 of C<$ccs>. Otherwise, input lines correspond to logical dimension 0 of C<$ccs>, which will be returned as a (Document x Term) matrix. $ccs = ccs_readldac($filename_or_fh) $ccs = ccs_readldac($filename_or_fh,\%opts) Options %opts: header => $bool, ##-- do/don't try to read header data from the output file (default=do) type => $type, ##-- value datatype (default: from header or $PDL::IO::Misc::deftype) transpose => $bool, ##-- generate a (Term x Document) matrix (default=don't) sorted => $bool, ##-- assume input is lexicographically sorted (only if not transposed; default=don't) =cut *PDL::ccs_readldac = *PDL::CCS::Nd::readldac = \&ccs_readldac; sub ccs_readldac { shift if (UNIVERSAL::isa($_[0],'PDL') || UNIVERSAL::isa($_[0],'PDL::CCS::Nd')); my ($file,$opts) = @_; my %opts = %{$opts||{}}; $opts{header} = 1 if (!defined($opts{header})); ##-- open input file my $fh = _ccsio_open($file,'<') or confess("ccs_readldac(): open failed for input file '$file': $!"); ##-- maybe scan for ccs header my $header; if ($opts{header}) { ##-- scan initial comments for CCS header my @hlines = qw(); while (defined($_=<$fh>)) { chomp; if (/^[%\#](\S+) (.*)$/) { push(@hlines,$2) if (substr($_,1,length(__PACKAGE__)) eq __PACKAGE__); } elsif (!/^[%\#]/) { last; } } $header = _ccsio_parse_header(\@hlines); } else { $header = {}; } ##-- get value datatype my $type = $opts{type} || $header->{iotype} || $PDL::IO::Misc::deftype; $type = PDL->can($type)->() if (defined($type) && !ref($type) && PDL->can($type)); $type = $PDL::IO::Misc::deftype if (!ref($type)); ##-- get nnz (per doc) seek($fh,0,SEEK_SET) or confess("ccs_readldac(): seek() failed for input file '$file': $!"); my $nnz0 = PDL->rcols($fh, [0], { TYPES=>[ccs_indx()], IGNORE=>qr{^\s*[^0-9]} }); my $nnz = $nnz0->sum; my $nlines = $nnz0->nelem; undef($nnz0); ##-- allocate output pdls my $ix = zeroes(ccs_indx(), 2,$nnz); my $nz = zeroes($type, $nnz+1); ##-- process input seek($fh,0,SEEK_SET) or confess("ccs_readldac(): seek() failed for input file '$file': $!"); my ($dim0,$dim1) = $opts{transpose} ? (1,0) : (0,1); my ($nzi,$i0,$i1,$f); for ($nzi=$i0=0; $i0 < $nlines && $nzi < $nnz && defined($_=<$fh>); ) { chomp; next if (/^\s*(?:$|[^0-9])/); while (/\b([0-9]+)\s*:\s*(\S+)/g) { ($i1,$f) = ($1,$2); $ix->set($dim1,$nzi => $i1); $ix->set($dim0,$nzi => $i0); $nz->set($nzi => $f); ++$nzi; } ++$i0; } ##-- cleanup _ccsio_close($file,$fh) or confess("ccs_readldac(): close failed for input file '$file': $!"); ##-- guess header data if (!defined($header->{pdims})) { $header->{pdims} = []; $header->{pdims}[$dim0] = $nlines; $header->{pdims}[$dim1] = $ix->slice("($dim1),")->max+1; } $header->{flags} = $PDL::CCS::Nd::CCSND_FLAGS_DEFAULT if (!defined($header->{flags})); ##-- construct and return return PDL::CCS::Nd->newFromWhich($ix,$nz, pdims=>$header->{pdims}, vdims=>$header->{vdims}, flags=>$header->{flags}, sorted=>($opts{sorted} && !$opts{transpose}), steal=>1, ); } 1; ##-- be happy ##====================================================================== ## POD: footer =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. LDA-C package by by David M. Blei. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2015-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, L, L, the LDA-C package documentation at L ... =cut 1; ##-- make perl happy PDL-CCS-1.24.1/CCS/IO/Makefile.PL0000644000175000017500000000125614735713775015276 0ustar moocowbovinesuse ExtUtils::MakeMaker; require "../../pdlmaker.plm"; pdlmaker_init(); WriteMakefile( NAME=>'PDL::CCS::IO::FastRaw', VERSION_FROM => '../../CCS.pm', LICENSE => 'perl', #PM => { (map {$_=>"\$(INST_LIBDIR)/CCS/$_"} <*.pm>), }, DIR =>[], PREREQ_PM => { 'PDL' => 0, }, CONFIGURE_REQUIRES => { 'PDL'=>0, 'ExtUtils::MakeMaker'=>0, }, clean => { FILES => "t/ccs.* t/ccs3.* t/dense.* t/dense3.*" }, ); PDL-CCS-1.24.1/CCS/IO/FastRaw.pm0000644000175000017500000002006514736165363015223 0ustar moocowbovines## File: PDL::CCS::IO::FastRaw.pm ## Author: Bryan Jurish ## Description: PDL::IO::FastRaw wrappers for PDL::CCS::Nd package PDL::CCS::IO::FastRaw; use PDL::CCS::Version; use PDL::CCS::Config qw(ccs_indx); use PDL::CCS::Nd; use PDL::CCS::IO::Common qw(:intern); use PDL; use PDL::IO::FastRaw; use Carp qw(confess); use strict; our $VERSION = '1.24.1'; our @ISA = ('PDL::Exporter'); our @EXPORT_OK = qw(ccs_writefraw ccs_readfraw ccs_mapfraw); our %EXPORT_TAGS = ( Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully) ); ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS::IO::FastRaw - PDL::IO::FastRaw wrappers for PDL::CCS::Nd =head1 SYNOPSIS use PDL; use PDL::CCS::Nd; use PDL::CCS::IO::FastRaw; $ccs = PDL::CCS::Nd->newFromWhich($which,$nzvals); ccs_writefraw($ccs,$fname); # write a pair of raw files $ccs2 = ccs_readfraw($fname); # read a pair of raw files $ccs3 = ccs_mapfraw($fname,{ReadOnly=>1}); # mmap a pair of files, don't read yet =cut ##====================================================================== ## I/O utilities =pod =head1 I/O Utilities =cut ##--------------------------------------------------------------- ## ccs_writefraw =pod =head2 ccs_writefraw Write a pair of raw binary files using PDL::IO::FastRaw::writefraw(). ccs_writefraw($ccs,$fname) ccs_writefraw($ccs,$fname,\%opts) Options %opts: Header => $Header, ##-- default="$fname.hdr" ixFile => $ixFile, ##-- default="$fname.ix" ixHeader => $ixHeader, ##-- default="$ixFile.hdr" nzFile => $nzFile, ##-- default="$fname.nz" nzHeader => $nzHeader, ##-- default="$nzFile.hdr" =cut *PDL::ccs_writefraw = *PDL::CCS::Nd::writefraw = \&ccs_writefraw; sub ccs_writefraw { my ($ccs,$fname,$opts) = @_; ##-- get filenames my $hFile = $opts->{Header} // "$fname.hdr"; my $ixFile = $opts->{ixFile} // "$fname.ix"; my $nzFile = $opts->{nzFile} // "$fname.nz"; ##-- write header _ccsio_write_header($ccs, $hFile) or confess("ccs_writefraw(): failed to write header-file $hFile: $!"); ##-- write pdls PDL::writefraw($ccs->_whichND, $ixFile, _ccsio_opts_ix($opts)) or confess("ccs_writefraw(): failed to write index-file $ixFile: $!"); PDL::writefraw($ccs->_vals, $nzFile, _ccsio_opts_nz($opts)) or confess("ccs_writefraw(): failed to write values-file $nzFile: $!"); return 1; } ##--------------------------------------------------------------- ## ccs_readfraw =pod =head2 ccs_readfraw Read a pair of raw binary files using PDL::IO::FastRaw::readfraw(). $ccs = ccs_readfraw($fname) $ccs = ccs_readfraw($fname,\%opts) Options %opts: Header => $Header, ##-- default="$fname.hdr" ixFile => $ixFile, ##-- default="$fname.ix" ixHeader => $ixHeader, ##-- default="$ixFile.hdr" nzFile => $nzFile, ##-- default="$fname.nz" nzHeader => $nzHeader, ##-- default="$nzFile.hdr" sorted => $bool, ##-- is data on disk already sorted? (default=1) =cut *PDL::ccs_readfraw = *PDL::CCS::Nd::readfraw = \&ccs_readfraw; sub ccs_readfraw { shift if (UNIVERSAL::isa($_[0],'PDL') || UNIVERSAL::isa($_[0],'PDL::CCS::Nd')); my ($file,$opts) = @_; ##-- get filenames my $hFile = $opts->{Header} // "$file.hdr"; my $ixFile = $opts->{ixFile} // "$file.ix"; my $nzFile = $opts->{nzFile} // "$file.nz"; ##-- read header my $header = _ccsio_read_header($hFile) or confess("ccs_readfraw(): failed to read header-file $hFile: $!"); ##-- read pdls defined(my $ix = PDL->readfraw($ixFile, _ccsio_opts_ix($opts))) or confess("ccs_readfraw(): failed to read index-file $ixFile: $!"); defined(my $nz = PDL->readfraw($nzFile, _ccsio_opts_nz($opts))) or confess("ccs_readfraw(): failed to read values-file $nzFile: $!"); ##-- construct and return return PDL::CCS::Nd->newFromWhich($ix,$nz, pdims=>$header->{pdims}, vdims=>$header->{vdims}, flags=>$header->{flags}, sorted=>($opts->{sorted}//1), steal=>1); } ##--------------------------------------------------------------- ## ccs_mapfraw =pod =head2 ccs_mapfraw Read a pair of raw binary files using PDL::IO::FastRaw::readfraw(). $ccs = ccs_mapfraw($fname) $ccs = ccs_mapfraw($fname,\%opts) Global options in %opts: Header => $Header, ##-- default="$fname.hdr" ReadOnly => $bool, ##-- read-only mode? Dims => \@dims, ##-- logical dimensions (~ \@pdims) Datatype => $type, ##-- CCS::Nd datatype Creat => $bool, ##-- create file(s)? Trunc => $bool, ##-- truncate file(s)? CCS::Nd options in %opts: flags => $flags, ##-- CCS::Nd flags nnz => $nnz, ##-- CCS::Nd nnz pdims => \@pdims, ##-- CCS::Nd physical dimensions vdims => \@vdims, ##-- CCS::Nd virtual dimensions sorted => $bool, ##-- is data on disk sorted? (default=1) Component options in %opts, for ${c} in qw(ix nz): "${c}${opt}" => $cValue, ##-- override global option ${opt} "${c}File" => $cFile, ##-- default="$fname.${c}" "${c}Header" => $cHeader, ##-- default="$cFile.hdr" =cut *PDL::ccs_mapfraw = *PDL::CCS::Nd::mapfraw = \&ccs_mapfraw; sub ccs_mapfraw { shift if (UNIVERSAL::isa($_[0],'PDL') || UNIVERSAL::isa($_[0],'PDL::CCS::Nd')); my ($file,$opts) = @_; ##-- get filenames my $hFile = $opts->{Header} // "$file.hdr"; my $ixFile = $opts->{ixFile} // "$file.ix"; my $nzFile = $opts->{nzFile} // "$file.nz"; ##-- get ccs header my $header = { pdims => ($opts->{pdims} // $opts->{Dims}), vdims => $opts->{vdims}, flags => ($opts->{flags} // $PDL::CCS::Nd::CCSND_FLAGS_DEFAULT), }; if (!defined($header->{pdims})) { my $hdr = _ccsio_read_header($hFile) or confess("ccs_mapfraw(): failed to read header-file $hFile: $!"); $header->{$_} //= $hdr->{$_} foreach (keys %$hdr); } $header->{pdims} = PDL->topdl(ccs_indx(),$header->{pdims}) if (!ref($header->{pdims})); $header->{vdims} = $header->{pdims}->sequence if (!defined($header->{vdims})); $header->{vdims} = PDL->topdl(ccs_indx(),$header->{vdims}) if (!ref($header->{vdims})); ##-- get component options my %defaults = (map {($_=>$opts->{$_})} grep {exists($opts->{$_})} qw(Creat Trunc ReadOnly)); my $nnz = $opts->{nnz}; my $ixopts = _ccsio_opts_ix($opts, {%defaults, (defined($nnz) ? (Dims=>[$header->{pdims}->ndims,$nnz]) : qw())}); my $nzopts = _ccsio_opts_nz($opts, {%defaults, (defined($nnz) ? (Dims=>[$nnz+1]) : qw()), (defined($opts->{Datatype}) ? (Datatype=>$opts->{Datatype}) : qw())}); ##-- map pdls defined(my $ix = PDL->mapfraw($ixFile, $ixopts)) or confess("ccs_mapfraw(): failed to map ix-file $ixFile: $!"); defined(my $nz = PDL->mapfraw($nzFile, $nzopts)) or confess("ccs_mapfraw(): failed to map values-file $nzFile: $!"); ##-- construct and return return PDL::CCS::Nd->newFromWhich($ix,$nz, pdims=>$header->{pdims}, vdims=>$header->{vdims}, flags=>$header->{flags}, sorted=>($opts->{sorted}//1), steal=>1); } 1; ##-- be happy ##====================================================================== ## POD: footer =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2015-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, L, L, ... =cut 1; ##-- make perl happy PDL-CCS-1.24.1/CCS/IO/Common.pm0000644000175000017500000001234514736165363015106 0ustar moocowbovines## File: PDL::CCS::IO::Common.pm ## Author: Bryan Jurish ## Description: common routines for PDL::CCS::Nd I/O package PDL::CCS::IO::Common; use PDL::CCS::Config qw(ccs_indx); use PDL::CCS::Nd; use PDL; use Carp qw(confess); use strict; our $VERSION = '1.24.1'; our @ISA = ('PDL::Exporter'); our @EXPORT_OK = ( qw(_ccsio_open _ccsio_close), qw(_ccsio_read_header _ccsio_parse_header), qw(_ccsio_write_header _ccsio_header_lines), qw(_ccsio_opts_ix _ccsio_opts_nz), ); our %EXPORT_TAGS = ( Func => [], ##-- respect PDL conventions (hopefully) intern => [@EXPORT_OK], ); ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS::IO::Common - Common pseudo-private routines for PDL::CCS::Nd I/O =head1 SYNOPSIS use PDL; use PDL::CCS::Nd; use PDL::CCS::IO::Common qw(:intern); #... stuff happens =cut ##====================================================================== ## private utilities ## \%ixOpts = _ccsio_opts_ix(\%opts) ## \%ixOpts = _ccsio_opts_ix(\%opts,\%defaults) ## + extracts 'ixX' options from \%opts as 'X' options in \%ixOpts sub _ccsio_opts_ix { my $opts = { map {s/^ix//; ($_=>$_[0]{$_})} grep {/^ix/} keys %{$_[0]//{}} }; $opts->{$_} //= $_[1]{$_} foreach (keys %{$_[1]//{}}); return $opts; } ## \%nzOpts = _ccsio_opts_nz(\%opts) ## \%nzOpts = _ccsio_opts_nz(\%opts,\%defaults) ## + extracts 'nzX' options from \%opts as 'X' options in \%nzOpts sub _ccsio_opts_nz { my $opts = { map {s/^nz//; ($_=>$_[0]{$_})} grep {/^nz/} keys %{$_[0]//{}} }; $opts->{$_} //= $_[1]{$_} foreach (keys %{$_[1]//{}}); return $opts; } ## $fh_or_undef = _ccsio_open($filename_or_handle,$mode) sub _ccsio_open { my ($file,$mode) = @_; return $file if (ref($file)); $mode = '<' if (!defined($mode)); open(my $fh, $mode, $file); return $fh; } ## $fh_or_undef = _ccsio_close($filename_or_handle,$fh) sub _ccsio_close { my ($file,$fh) = @_; return 1 if (ref($file)); ##-- don't close if we got a handle return close($fh); } ## \%header = _ccsio_read_header( $hfile) sub _ccsio_read_header { my $hFile = shift; my $hfh = _ccsio_open($hFile,'<') or confess("_ccsio_read_header(): open failed for header-file $hFile: $!"); binmode($hfh,':raw'); my @hlines = <$hfh>; _ccsio_close($hFile,$hfh) or confess("_ccsio_read_header(): close failed for header-file $hFile: $!"); return _ccsio_parse_header(\@hlines); } ## \%header = _ccsio_parse_header(\@hlines) sub _ccsio_parse_header { my $hlines = shift; my ($magic,$pdims,$vdims,$flags,$iotype) = map {chomp;$_} @$hlines; return { magic=>$magic, (defined($pdims) && $pdims ne '' ? (pdims=>pdl(ccs_indx(),[split(' ',$pdims)])) : qw()), (defined($vdims) && $vdims ne '' ? (vdims=>pdl(ccs_indx(),[split(' ',$vdims)])) : qw()), (defined($flags) && $flags ne '' ? (flags=>$flags) : qw()), (defined($iotype) && $iotype ne '' ? (iotype=>$iotype) : qw()), ##-- added in v1.22.6 }; } ## $bool = _ccsio_write_header(\%header, $hfile) ## $bool = _ccsio_write_header( $ccs, $hfile) sub _ccsio_write_header { my ($header,$hFile) = @_; my $hfh = _ccsio_open($hFile,'>') or confess("_ccsio_write_header(): open failed for header-file $hFile: $!"); binmode($hfh,':raw'); local $, = ''; print $hfh @{_ccsio_header_lines($header)}; _ccsio_close($hFile,$hfh) or confess("_ccsio_write_header(): close failed for header-file $hFile: $!"); return 1; } ## \@header_lines = _ccsio_header_lines(\%header) ## \@header_lines = _ccsio_header_lines( $ccs) sub _ccsio_header_lines { my $header = shift; $header = _ccsio_header($header) if (UNIVERSAL::isa($header,'PDL::CCS::Nd')); return [ map {"$_\n"} (defined($header->{magic}) ? $header->{magic} : ''), (defined($header->{pdims}) ? (join(' ', $header->{pdims}->list)) : ''), (defined($header->{vdims}) ? (join(' ', $header->{vdims}->list)) : ''), (defined($header->{flags}) ? $header->{flags} : $PDL::CCS::Nd::CCSND_FLAGS_DEFAULT), (defined($header->{iotype}) ? $header->{iotype} : $PDL::IO::Misc::deftype), ]; } ## \%header = _ccsio_header( $ccs) ## \%header = _ccsio_header(\%header) sub _ccsio_header { my $ccs = shift; return $ccs if (!UNIVERSAL::isa($ccs,'PDL::CCS::Nd')); return { magic=>(ref($ccs)." $VERSION"), pdims=>$ccs->pdims, vdims=>$ccs->vdims, flags=>$ccs->flags, iotype=>$ccs->type, }; } 1; ##-- be happy ##====================================================================== ## POD: footer =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2015-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, L, L, L, ... =cut PDL-CCS-1.24.1/CCS/IO/FITS.pm0000644000175000017500000001163514736165363014424 0ustar moocowbovines## File: PDL::CCS::IO::FITS.pm ## Author: Bryan Jurish ## Description: PDL::IO::FITS wrappers for PDL::CCS::Nd package PDL::CCS::IO::FITS; use PDL::CCS::Version; use PDL::CCS::Nd; use PDL; use PDL::CCS::IO::Common qw(:intern); ##-- for e.g. _ccsio_write_header, _ccsio_read_header use Carp qw(confess); use strict; our $VERSION = '1.24.1'; our @ISA = ('PDL::Exporter'); our @EXPORT_OK = ( qw(ccs_wfits ccs_rfits), ); our %EXPORT_TAGS = ( Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully) ); ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS::IO::FITS - PDL::IO::FITS wrappers for PDL::CCS::Nd =head1 SYNOPSIS use PDL; use PDL::CCS::Nd; use PDL::CCS::IO::FITS; $ccs = PDL::CCS::Nd->newFromWhich($which,$nzvals); ccs_wfits($ccs,$fname); # write a pair of FITS files $ccs2 = ccs_readfits($fname); # read a pair of FITS files =cut ##====================================================================== ## I/O utilities =pod =head1 I/O Utilities =cut ##--------------------------------------------------------------- ## ccs_wfits =pod =head2 ccs_wfits Write a pair of FITS files using L. Piddles of type L will be implicitly converted to L, since they are not currently supported by L in PDL v2.014. ccs_wfits($ccs,$fname) ccs_wfits($ccs,$fname,\%opts) Options %opts: Header => $Header, ##-- default="$fname.hdr" ixFile => $ixFile, ##-- default="$fname.ix.fits" nzFile => $nzFile, ##-- default="$fname.nz.fits" =cut *PDL::ccs_wfits = *PDL::CCS::Nd::wfits = \&ccs_wfits; sub ccs_wfits { my ($ccs,$fname,$opts) = @_; ##-- get filenames my $hFile = $opts->{Header} // "$fname.hdr"; my $ixFile = $opts->{ixFile} // "$fname.ix.fits"; my $nzFile = $opts->{nzFile} // "$fname.nz.fits"; ##-- write header _ccsio_write_header($ccs, $hFile) or confess("ccs_wfits(): failed to write header-file $hFile: $!"); ##-- write pdls ## + hack: treat 'indx' as 'long' until PDL::IO::FITS supports it (PDL v2.014 .. v2.016) my $ix = $ccs->_whichND->type->ioname eq 'indx' ? $ccs->_whichND->long : $ccs->_whichND; my $vals = $ccs->_vals->type->ioname eq 'indx' ? $ccs->_vals->long : $ccs->_vals; PDL::wfits($ix, $ixFile) or confess("ccs_wfits(): failed to write index-file $ixFile: $!"); PDL::wfits($vals, $nzFile) or confess("ccs_wfits(): failed to write values-file $nzFile: $!"); return 1; } ##--------------------------------------------------------------- ## ccs_rfits =pod =head2 ccs_rfits Read a pair of FITS files using L. $ccs = ccs_rfits($fname) $ccs = ccs_rfits($fname,\%opts) Options %opts: Header => $Header, ##-- default="$fname.hdr" ixFile => $ixFile, ##-- default="$fname.ix.fits" nzFile => $nzFile, ##-- default="$fname.nz.fits" sorted => $bool, ##-- is data on disk already sorted? (default=1) =cut *PDL::ccs_rfits = *PDL::CCS::Nd::rfits = \&ccs_rfits; sub ccs_rfits { shift if (UNIVERSAL::isa($_[0],'PDL') || UNIVERSAL::isa($_[0],'PDL::CCS::Nd')); my ($fname,$opts) = @_; ##-- get filenames my $hFile = $opts->{Header} // "$fname.hdr"; my $ixFile = $opts->{ixFile} // "$fname.ix.fits"; my $nzFile = $opts->{nzFile} // "$fname.nz.fits"; ##-- read header my $header = _ccsio_read_header($hFile) or confess("ccs_rfits(): failed to read header-file $hFile: $!"); ##-- read pdls defined(my $ix = PDL->rfits($ixFile)) or confess("ccs_rfits(): failed to read index-file $ixFile: $!"); defined(my $nz = PDL->rfits($nzFile)) or confess("ccs_rfits(): failed to read values-file $nzFile: $!"); ##-- construct and return return PDL::CCS::Nd->newFromWhich($ix,$nz, pdims=>$header->{pdims}, vdims=>$header->{vdims}, flags=>$header->{flags}, sorted=>($opts->{sorted}//1), steal=>1); } 1; ##-- be happy ##====================================================================== ## POD: footer =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2015-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, L, L, ... =cut 1; ##-- make perl happy PDL-CCS-1.24.1/CCS/IO/MatrixMarket.pm0000644000175000017500000002452714736165363016273 0ustar moocowbovines## File: PDL::CCS::IO::MatrixMarket.pm ## Author: Bryan Jurish ## Description: MatrixMarket I/O wrappers for PDL::CCS::Nd package PDL::CCS::IO::MatrixMarket; use PDL::CCS::Version; use PDL::CCS::Config qw(ccs_indx); use PDL::CCS::Nd; use PDL::CCS::IO::Common qw(:intern); ##-- for e.g. _ccsio_header_lines(), _ccsio_parse_header() use PDL; use PDL::IO::Misc; ##-- for rcols(), wcols(), $PDL::IO::Misc::deftype use Fcntl qw(:seek); ##-- for rewinding use Carp qw(confess); use strict; our $VERSION = '1.24.1'; our @ISA = ('PDL::Exporter'); our @EXPORT_OK = ( qw(ccs_writemm ccs_readmm writemm readmm), ); our %EXPORT_TAGS = ( Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully) ); ##-- matrix market magic header line, sparse my $MMAGIC = '%%MatrixMarket matrix coordinate real general'; ##-- matrix market magic header line, dense my $DMAGIC = '%%MatrixMarket matrix array real general'; ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS::IO::MatrixMarket - Matrix Market Exchange Format text I/O for PDL::CCS::Nd =head1 SYNOPSIS use PDL; use PDL::CCS::Nd; use PDL::CCS::IO::MatrixMarket; $ccs = PDL::CCS::Nd->newFromWhich($which,$nzvals); ccs_writemm($ccs,"ccs.mm"); # write a sparse matrix market text file $ccs2 = ccs_readmm("ccs.mm"); # read a sparse matrix market text file $dense = random(10,10); # ... also supported for dense piddles writemm($dense, "file.mm"); # write a dense matrix market text file $dense2 = readmm("file.mm"); # read a dense matrix market text file =cut ##====================================================================== ## I/O utilities =pod =head1 I/O Utilities =cut ##--------------------------------------------------------------- ## ccs_writemm =pod =head2 ccs_writemm Write a L object as a MatrixMarket sparse coordinate text file. ccs_writemm($ccs,$filename_or_fh) ccs_writemm($ccs,$filename_or_fh,\%opts) Options %opts: start => $i, ##-- index of first element (like perl $[); default=1 for MatrixMarket compatibility header => $bool, ##-- write embedded PDL::CCS::Nd header? (default=do) =cut *PDL::ccs_writemm = *PDL::CCS::Nd::writemm = \&ccs_writemm; sub ccs_writemm { my ($ccs,$file,$opts) = @_; my %opts =%{$opts||{}}; $opts{start} = 1 if (!defined($opts{start})); $opts{header} = 1 if (!defined($opts{header})); ##-- write MatrixMarket magic header my $fh = _ccsio_open($file,'>') or confess("ccs_writemm(): open failed for output file '$file': $!"); #binmode($fh,':raw'); local $,=''; print $fh "$MMAGIC\n"; ##-- write ccs header to output file if ($opts{header}) { print $fh map {("%", __PACKAGE__, " $_")} @{_ccsio_header_lines($ccs)}; } ##-- write mm dimensions to output file print $fh join(' ', '',$ccs->pdims->list,$ccs->_nnz_p), "\n"; ##-- write mm data to output file my $ix = $ccs->_whichND; $ix = ($ix+$opts{start}) if ($opts{start} != 0); wcols($ix->xchg(0,1), $ccs->_nzvals, $fh) or confess("ccs_writemm(): failed to write data to '$file': $!"); ##-- cleanup _ccsio_close($file,$fh) or confess("ccs_writemm(): close failed for output file '$file': $!"); return 1; } ##--------------------------------------------------------------- ## writemm (dense) =pod =head2 writemm Write a dense PDL as a MatrixMarket array text file. writemm($pdl,$filename_or_handle) writemm($pdl,$filename_or_handle,\%opts) Options %opts: (none yet) =cut *PDL::writemm = \&writemm; sub writemm { my ($pdl,$file,$opts) = @_; ##-- dispatch for PDL::CCS::Nd objects return ccs_writemm($pdl,$file,$opts) if (UNIVERSAL::isa($pdl,'PDL::CCS::Nd')); ##-- write MatrixMarket magic header my $fh = _ccsio_open($file,'>') or confess("writemm(): open failed for output file '$file': $!"); #binmode($fh,':raw'); local $,=''; print $fh "$DMAGIC\n"; ##-- print administrative data print $fh "%", __PACKAGE__, " type ", $pdl->type, "\n"; ##-- write mm dimensions to output file print $fh " ", join(' ', $pdl->dims), "\n"; ##-- write flat data to output file wcols($pdl->flat, $fh) or confess("writemm(): failed to write data to '$file': $!"); ##-- cleanup _ccsio_close($file,$fh) or confess("writemm(): close failed for output file '$file': $!"); return 1; } ##--------------------------------------------------------------- ## ccs_readmm =pod =head2 ccs_readmm Read a Matrix Market sparse coordinate text file as a L object using L. $ccs = ccs_readmm($filename_or_fh) $ccs = ccs_readmm($filename_or_fh,\%opts) Options %opts: start => $i, ##-- index of first element (like perl $[); default=1 for MatrixMarket compatibility header => $bool, ##-- attempt to read embedded CCS header from file (default=do) sorted => $bool, ##-- assume input data is sorted (default=0) nomagic => $bool, ##-- don't check for matrix market magic header (default:do) =cut *PDL::ccs_readmm = *PDL::CCS::Nd::readmm = \&ccs_readmm; sub ccs_readmm { shift if (UNIVERSAL::isa($_[0],'PDL') || UNIVERSAL::isa($_[0],'PDL::CCS::Nd')); my ($file,$opts) = @_; my %opts = %{$opts||{}}; $opts{start} = 1 if (!defined($opts{start})); $opts{header} = 1 if (!defined($opts{header})); ##-- open input file my $fh = _ccsio_open($file,'<') or confess("ccs_readmm(): open failed for input file '$file': $!"); ##-- get matrix market magic header if (!$opts{nomagic}) { my $mmagic = <$fh>; chomp($mmagic); if ($mmagic eq $DMAGIC) { ##-- dense input file, read as dense PDL _ccsio_close($file,$fh); return readmm($file,{%opts,nomagic=>1}); } elsif ($mmagic ne $MMAGIC) { confess("ccs_readmm(): bad magic header line in input file, should be '$MMAGIC'"); } } ##-- scan initial comments, extracting CCS header my @hlines = qw(); while (defined($_=<$fh>)) { chomp; if (/^%(\S+) (.*)$/) { push(@hlines,$2) if ($opts{header} && substr($_,1,length(__PACKAGE__)) eq __PACKAGE__); } elsif (!/^%/) { last; } } ##-- parse embedded CCS header if requested my $header = _ccsio_parse_header($opts{header} ? \@hlines : []); ##-- we now have 1st non-comment line in $_: scan for mm dimension list while ($_ =~ /^\s*$/) { $_ = <$fh>; chomp; } my @dims = split(' ',$_); my $nnz = pop(@dims); ##-- update ccs header if required my $mmdims = pdl(ccs_indx(),\@dims); if (defined($header->{pdims}) && ($header->{pdims}->nelem != $mmdims->nelem || !all($header->{pdims}==$mmdims))) { $header->{pdims} = $mmdims; $header->{vdims} = undef; } ##-- read data: indices my $offset = tell($fh); my $ix = PDL->rcols($fh, [0..$#dims], { IGNORE=>qr{^%}, TYPES=>[ccs_indx()] }); $ix -= $opts{start} if ($opts{start} != 0); $ix = $ix->xchg(0,1); ##-- read data: values seek($fh,$offset,SEEK_SET) or confess("ccs_readmm(): seek() failed for input file '$file': $!"); my $iotype = $header->{iotype}; $iotype = PDL->can($iotype)->() if (defined($iotype) && !ref($iotype) && PDL->can($iotype)); $iotype = $PDL::IO::Misc::deftype if (!ref($iotype)); my $nz = PDL->rcols($fh, [$#dims+1], { IGNORE=>qr{^%}, TYPES=>[$iotype] }); $nz = $nz->append(0); ##-- missing value ##-- cleanup _ccsio_close($file,$fh) or confess("ccs_readmm(): close failed for input file '$file': $!"); ##-- construct and return return PDL::CCS::Nd->newFromWhich($ix,$nz, pdims=>$header->{pdims}, vdims=>$header->{vdims}, flags=>$header->{flags}, sorted=>$opts{sorted}, steal=>1); } ##--------------------------------------------------------------- ## readmm (dense) =pod =head2 readmm Read a Matrix Market dense array text file as a dense pdl using L. $pdl = readmm($fname) $pdl = readmm($fname,\%opts) Options %opts: nomagic => $bool, ##-- don't check for matrix market magic header (default:do) =cut *PDL::readmm = \&readmm; sub readmm { shift if (UNIVERSAL::isa($_[0],'PDL') || UNIVERSAL::isa($_[0],'PDL::CCS::Nd')); my ($file,$opts) = @_; my %opts = %{$opts||{}}; ##-- open input file my $fh = _ccsio_open($file,'<') or confess("readmm(): open failed for input file '$file': $!"); ##-- get matrix market magic header if (!$opts{nomagic}) { my $dmagic = <$fh>; chomp($dmagic); if ($dmagic eq $MMAGIC) { ##-- sparse input file, read as PDL::CCS::Nd _ccsio_close($file,$fh); return ccs_readmm($file,{%opts,nomagic=>1}); } elsif ($dmagic ne $DMAGIC) { confess("readmm(): bad magic header line in input file, should be '$DMAGIC'") } } ##-- scan for header my $iotype = $PDL::IO::Misc::deftype; while (defined($_=<$fh>)) { if (!/^%/) { if (/^%(\S+) type (\S+)/ && $1 eq __PACKAGE__) { $iotype = PDL->can($_)->() if (PDL->can($_)); } } elsif (!/^\s*$/) { next; } last; } ##-- parse dims my @dims = split(' ',$_); ##-- read data my $pdl = rcols($fh, [], { IGNORE=>qr{^%}, TYPES=>[$iotype] }); ##-- cleanup _ccsio_close($file,$fh) or confess("ccs_readmm(): close failed for input file '$file': $!"); ##-- construct and return #$pdl = $pdl->reshape(@dims); ##-- pdl v2.014 chokes on this my $out = zeroes($pdl->type, @dims); (my $tmp = $out->flat) .= $pdl->flat; return $out; } 1; ##-- be happy ##====================================================================== ## POD: footer =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2015-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, L, L, the matrix market format documentation at L ... =cut 1; ##-- make perl happy PDL-CCS-1.24.1/CCS/Ufunc/0000755000175000017500000000000014736165776014074 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/Ufunc/Ufunc.pm0000644000175000017500000007730014736165675015517 0ustar moocowbovines# # GENERATED WITH PDL::PP! Don't modify! # package PDL::CCS::Ufunc; our @EXPORT_OK = qw(ccs_accum_prod ccs_accum_dprod ccs_accum_sum ccs_accum_dsum ccs_accum_or ccs_accum_and ccs_accum_bor ccs_accum_band ccs_accum_maximum ccs_accum_minimum ccs_accum_maximum_nz_ind ccs_accum_minimum_nz_ind ccs_accum_nbad ccs_accum_ngood ccs_accum_nnz ccs_accum_average ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our $VERSION = '1.24.1'; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::CCS::Ufunc $VERSION; #line 13 "ccsufunc.pd" =pod =head1 NAME PDL::CCS::Ufunc - Ufuncs for compressed storage sparse PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::Ufunc; ##--------------------------------------------------------------------- ## ... stuff happens =cut #line 43 "Ufunc.pm" =head1 FUNCTIONS =cut #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_prod =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated product over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, then the quantity: $missing ** ($N - (rlevec($ixIn))[0]) is multiplied into $nzvalsOut: this is probably What You Want if you are computing the product over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_prod processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 106 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_prod { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_prod_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 129 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_prod = \&PDL::ccs_accum_prod; #line 136 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_dprod =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); double [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated double-precision product over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, then the quantity: $missing ** ($N - (rlevec($ixIn))[0]) is multiplied into $nzvalsOut: this is probably What You Want if you are computing the product over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_dprod processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 189 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_dprod { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_dprod_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 212 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_dprod = \&PDL::ccs_accum_dprod; #line 219 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_sum =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated sum over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, then the quantity: $missing * ($N - (rlevec($ixIn))[0]) is added to $nzvalsOut: this is probably What You Want if you are summing over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_sum processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 272 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_sum { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_sum_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 295 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_sum = \&PDL::ccs_accum_sum; #line 302 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_dsum =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); double [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated double-precision sum over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, then the quantity: $missing * ($N - (rlevec($ixIn))[0]) is added to $nzvalsOut: this is probably What You Want if you are summing over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_dsum processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 355 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_dsum { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_dsum_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 378 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_dsum = \&PDL::ccs_accum_dsum; #line 385 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_or =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated logical "or" over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, $missing() is logically (or)ed into each result value at each output index with a run length of less than $N() in $ixIn(). This is probably What You Want. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_or processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 435 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_or { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_or_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 458 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_or = \&PDL::ccs_accum_or; #line 465 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_and =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated logical "and" over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, $missing() is logically (and)ed into each result value at each output index with a run length of less than $N() in $ixIn(). This is probably What You Want. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_and processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 515 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_and { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_and_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 538 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_and = \&PDL::ccs_accum_and; #line 545 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_bor =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated bitwise "or" over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, $missing() is bitwise (or)ed into each result value at each output index with a run length of less than $N() in $ixIn(). This is probably What You Want. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_bor processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 595 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_bor { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_bor_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 618 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_bor = \&PDL::ccs_accum_bor; #line 625 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_band =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated bitwise "and" over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, $missing() is bitwise (and)ed into each result value at each output index with a run length of less than $N() in $ixIn(). This is probably What You Want. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_band processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 675 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_band { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_band_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 698 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_band = \&PDL::ccs_accum_band; #line 705 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_maximum =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated maximum over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, and if $missing() is greater than any listed value for a vector key with a run-length of less than $N(), then $missing() is used as the output value for that key. This is probably What You Want. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_maximum processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 756 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_maximum { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_maximum_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 779 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_maximum = \&PDL::ccs_accum_maximum; #line 786 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_minimum =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated minimum over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, and if $missing() is less than any listed value for a vector key with a run-length of less than $N(), then $missing() is used as the output value for that key. This is probably What You Want. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_minimum processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 837 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_minimum { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_minimum_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 860 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_minimum = \&PDL::ccs_accum_minimum; #line 867 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_maximum_nz_ind =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); indx [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated maximum_nz_ind over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. Output indices index $nzvalsIn, -1 indicates that the missing value is maximal. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_maximum_nz_ind processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 915 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_maximum_nz_ind { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_maximum_nz_ind_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 938 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_maximum_nz_ind = \&PDL::ccs_accum_maximum_nz_ind; #line 945 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_minimum_nz_ind =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); indx [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated minimum_nz_ind over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. Output indices index $nzvalsIn, -1 indicates that the missing value is minimal. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_minimum_nz_ind processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 993 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_minimum_nz_ind { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_minimum_nz_ind_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 1016 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_minimum_nz_ind = \&PDL::ccs_accum_minimum_nz_ind; #line 1023 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_nbad =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); indx [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated number of bad values over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. Should handle missing values appropriately. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_nbad processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1071 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_nbad { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_nbad_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 1094 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_nbad = \&PDL::ccs_accum_nbad; #line 1101 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_ngood =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); indx [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated number of good values over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. Should handle missing values appropriately. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_ngood processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1149 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_ngood { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_ngood_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 1172 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_ngood = \&PDL::ccs_accum_ngood; #line 1179 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_nnz =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); indx [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated number of non-zero values over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. Should handle missing values appropriately. Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_nnz processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1227 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_nnz { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_nnz_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 1250 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_nnz = \&PDL::ccs_accum_nnz; #line 1257 "Ufunc.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_accum_average =for sig Signature: ( indx ixIn(Ndims,NnzIn); nzvalsIn(NnzIn); missing(); indx N(); indx [o]ixOut(Ndims,NnzOut); float+ [o]nzvalsOut(NnzOut); indx [o]nOut(); ) Accumulated average over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. If $N() is specified and greater than zero, then the quantity: $missing * ($N - (rlevec($ixIn))[0]) / $N is added to $nzvalsOut: this is probably What You Want if you are averaging over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). =for bad ccs_accum_average processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1310 "Ufunc.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_accum_average { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_average_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } #line 1333 "Ufunc.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_accum_average = \&PDL::ccs_accum_average; #line 1340 "Ufunc.pm" #line 558 "ccsufunc.pd" =pod =head1 TODO / NOT YET IMPLEMENTED =over 4 =item extrema indices maximum_ind, minimum_ind: not quite compatible... =item statistical aggregates daverage, medover, oddmedover, pctover, ... =item cumulative functions cumusumover, cumuprodover, ... =item other stuff zcover, intover, minmaximum =back =cut #line 1372 "Ufunc.pm" #line 594 "ccsufunc.pd" ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS Probably many. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2007-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl) =cut #line 1420 "Ufunc.pm" # Exit with OK status 1; PDL-CCS-1.24.1/CCS/Ufunc/t/0000755000175000017500000000000014736165776014337 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/Ufunc/t/01_ufunc.t0000644000175000017500000001104014735713775016135 0ustar moocowbovines# -*- Mode: CPerl -*- # t/01_ufunc.t use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../../.. ../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::CCS::Ufunc; use PDL::VectorValued; use version; ##-- basic data my $a = pdl(double, [ [10,0,0,0,-2], [3,9,0,0,0], [0,7,8,7,0], [3,0,8,7,5], [0,8,0,9,9], [0,4,0,0,2], ]); my $agood = ($a!=0); my $abad = !$agood; my $awhich = $a->whichND; my $awhich1 = $awhich->slice("(1)")->qsort->slice("*1,"); my $awhich1i = $awhich->slice("(1)")->qsorti; my $avals = $a->indexND($awhich)->index($awhich1i); ##-- i..(i+2): test_ufunc($pdl_ufunc_name, $ccs_ufunc_name, $missing_val) sub test_ufunc { my ($pdl_ufunc_name, $ccs_ufunc_name, $missing_val) = @_; print "test_ufunc($pdl_ufunc_name, $ccs_ufunc_name, $missing_val)\n"; my $ccs_ufunc = PDL->can("ccs_accum_${ccs_ufunc_name}") or die("no CCS Ufunc ccs_accum_${ccs_ufunc_name} defined!"); my $pdl_ufunc = PDL->can("${pdl_ufunc_name}") or die("no PDL Ufunc ${pdl_ufunc_name} defined!"); $missing_val = 0 if (!defined($missing_val)); $missing_val = PDL->topdl($missing_val); if ($missing_val->isbad) { $a = $a->setbadif($abad); } else { $a->where($abad) .= $missing_val; $a->badflag(0); } $missing_val = $missing_val->convert($a->type); my @amissing = $missing_val->isbad && $ccs_ufunc_name !~ /^n(?:bad|good)/ ? (0,0) : ($missing_val,$a->dim(0)); my $dense_rc = $pdl_ufunc->($a); my ($which_rc,$nzvals_rc) = $ccs_ufunc->($awhich1, $avals, @amissing); my $decoded_rc = $dense_rc->zeroes; $decoded_rc .= $missing_val; $decoded_rc->indexND($which_rc) .= $nzvals_rc; my $label = "${pdl_ufunc_name}:missing=$missing_val"; ##-- exceptions SKIP: { ##-- RT bug #126294 (see also analogous tests in CCS/t/03_ufuncs.t) ## - maybe test ($Config{stdchar}=~/unsigned/) or ($Config{stdchar} eq 'unsigned char') instead skip("RT #126294 - PDL::borover() appears to be broken", 1) if ($label eq 'borover:missing=BAD' && pdl([10,0,-2])->setvaltobad(0)->borover->sclr != -2); ##-- actual test pdlok("${label}:vals", $decoded_rc, $dense_rc); } } my $BAD = pdl(0)->setvaltobad(0); ##---------------------------------------------------------------------- ## generic tests for my $missing (0,1,31,$BAD) { for my $pdl_ufunc_name ( #qw(sumover), qw(sumover prodover dsumover dprodover), qw(andover orover bandover borover), qw(maximum minimum), qw(nbadover ngoodover), #nnz qw(average), ) { my $ccs_ufunc_name = $pdl_ufunc_name; $ccs_ufunc_name =~ s/over$//; test_ufunc($pdl_ufunc_name, $ccs_ufunc_name, $missing); } } ##---------------------------------------------------------------------- ## specific tests ##-- test explicit output allocation my $dense_rv = $a->sumover; my $which_prealloc = zeroes(indx, 1, 6); my $nzvals_prealloc = zeroes($a->type, 6); foreach ( [null, null], [null, $nzvals_prealloc], [$which_prealloc, null], [$which_prealloc, $nzvals_prealloc], ) { my $label = "sumover with explicit output PDLs (".join(', ', map {$_->isnull ? 'null' : 'pre-allocated'} @$_).")"; my ($tmp_which, $tmp_nzvals) = @$_; my ($which_rv,$nzvals_rv) = ccs_accum_sum($awhich1, $avals, 0, 0, $tmp_which, $tmp_nzvals); my $decoded_rv = $dense_rv->zeroes; $decoded_rv->indexND($which_rv) .= $nzvals_rv; pdlok($label, $decoded_rv, $dense_rv); } ##-- test unexpected output type: https://github.com/moocow-the-bovine/PDL-CCS/issues/18 sub test_borover_output_type { my ($label, $missing) = @_; PDL::_ccs_accum_bor_int( my $ixIn=PDL->pdl(indx, [[0]]), my $nzvalsIn=pdl(double, [65536]), $missing, 0, my $ixOut=null, my $nzvalsOut=null, my $nOut=null ); SKIP: { skip("expect the unexpected if missing is passed as a scalar", 1) if (!ref($missing) && version->parse($PDL::VERSION) >= version->parse('2.096')); isok("test_borover_output_type:$label:type", $nzvalsOut->type, longlong); pdlok("test_borover_output_type:$label:vals", $nzvalsOut, $nzvalsIn); } } test_borover_output_type('missing=double', pdl(double, 0)); test_borover_output_type('missing=scalar', 0); print "\n"; done_testing; PDL-CCS-1.24.1/CCS/Ufunc/t/common.plt0000644000175000017500000000053014054377273016334 0ustar moocowbovines# -*- Mode: CPerl -*- # File: t/common.plt # Description: re-usable test subs for Math::PartialOrder ##-- common subs BEGIN { use File::Basename; use Cwd; my $topdir = Cwd::abs_path(dirname(__FILE__)."/../../.."); do "$topdir/t/common.plt" or die("$0: failed to load $topdir/t/common.plt: $@"); } print "loaded ", __FILE__, "\n"; 1; PDL-CCS-1.24.1/CCS/Ufunc/ccsufunc.pd0000644000175000017500000005760214736165363016234 0ustar moocowbovines##-*- Mode: CPerl -*- ##====================================================================== ## Header Administrivia ##====================================================================== use PDL::VectorValued::Dev; my $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module pp_setversion($VERSION); ##------------------------------------------------------ ## pm headers pp_addpm({At=>'Top'},<<'EOPM'); =pod =head1 NAME PDL::CCS::Ufunc - Ufuncs for compressed storage sparse PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::Ufunc; ##--------------------------------------------------------------------- ## ... stuff happens =cut EOPM ## /pm headers ##------------------------------------------------------ ##------------------------------------------------------ ## Exports: None #pp_export_nothing(); ##------------------------------------------------------ ## Includes / defines pp_addhdr(<<'EOH'); #include #include "../Utils/ccsutils.h" #ifndef INFINITY # define INFINITY (1.0/0.0) #endif EOH ##------------------------------------------------------ ## integer types etc. require "../Config.pm"; ##====================================================================== ## C Utilities ##====================================================================== # (none) ##====================================================================== ## PDL::PP Wrappers ##====================================================================== ##====================================================================== ## Operations: Accumulators (Ufuncs) ##====================================================================== ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): Generic ## %vvpp_def_hash = ccs_accum_hash($op_codename, $op_docname, %args) ## + known %args ## out_type => $pptype_or_undef, ##-- set type of output $nzvals (default: match input $nzvals) ## init_missingOut => $ppcode_or_undef, ##-- sets value missingOut: default: 'missingOut=missingVal;' ## init_code => $ppcode_or_undef, ##-- misc initialization ## tmp_type => $ppcode_or_undef, ##-- default: $GENERIC(nzvalsOut) ## tmp_addmissing => $ppcode_or_undef, ##-- updates C var 'tmp' before insertion (may reference nMissing) ## tmp_addval => $ppcode_or_undef, ##-- add PP value $nzvalsIn(NnzIn=>nnzii) to tmp ## tmp_reset => $ppcode_or_undef, ##-- reset tmp on index change (default: tmp=$nzvalsIn(NnzIn=>nnzii)) --> QUITE USELESS ## tmp_init => $ppcode_or_undef, ##-- special case for $tmp_reset with nzii==0; default CROAKs if NnzIn==0 ## doc_addmissing => $addmissing_doc, ##-- doc for 'addmissing' ## setbad => $ppcode_or_undef, ##-- post-broadcastloop bad-handling code ## extra => \%extraPPArgs, ##-- extra args for vvpp_def() sub ccs_accum_hash { my ($op_codename,$op_docname,%args) = @_; return ( Pars => ("\n " .join(";\n ", "indx ixIn(Ndims,NnzIn)", ##-- sorted nz-indices of projected dimensions (1..Ndims), with repeats ' nzvalsIn(NnzIn)', ##-- all nz-values ' missing()', ##-- missing value "indx N()", ##-- size of 0th dimension (<=0 to ignore missing values) "indx [o]ixOut(Ndims,NnzOut)", ##-- unique indices of projected dimensions ( ($args{out_type} ? ($args{out_type}.' ') : ' ').'[o]nzvalsOut(NnzOut)' ), ##-- unique nz-values of projected dims which contain >=1 input nz "indx [o]nOut()", ##-- number of unique output index-vectors '')), HandleBad => ($args{HandleBad} // 1), ##-- pmcode PMCode => q( sub PDL::ccs_accum_).${op_codename}.q( { my ($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut) = @_; $nOut //= PDL->null; $ixOut //= PDL->null; $nzvalsOut //= PDL->null; &PDL::_ccs_accum_).${op_codename}.q(_int($ixIn,$nzvalsIn, $missing,$N, $ixOut,$nzvalsOut,$nOut); ## ##-- auto-trim my $trim_slice = "0:".($nOut->max-1); $ixOut = $ixOut->slice(",$trim_slice"); $nzvalsOut = $nzvalsOut->slice($trim_slice); ## ##-- return return wantarray ? ($ixOut,$nzvalsOut,$nOut) : $nzvalsOut; } ), ##-- dimension-twiddling via RedoDimsCode RedoDimsCode => q{ if ( CCS_PDL_IS_NULL($PDL(ixOut)) && CCS_PDL_IS_NULL($PDL(nzvalsOut)) ) { /*-- strangely, SIZE(NnzOut)==1 here if both ixOut and nzvalsOut are passed as null --*/ $SIZE(NnzOut) = $SIZE(NnzIn); } }, ##-- pp code Code => q( int cmpval, carp_unsorted=0; broadcastloop %{ PDL_Indx nnzii_prev=-1, nnzii=0, nnzoi=0; PDL_Indx sizeNnzIn=$SIZE(NnzIn), sizeNnzOut=$SIZE(NnzOut), nMissing, nMissingInit; PDL_Indx ival1,ival2; $GENERIC(nzvalsOut) missingOut; $GENERIC(nzvalsIn) missingVal = $missing(); ).($args{decls} ? $args{decls} : '').q( ).($args{tmp_type} ? $args{tmp_type} : '$GENERIC(nzvalsOut)').q( tmp; // //-- init ).($args{init_code}||'').q( ).($args{init_missingOut} || 'missingOut = missingVal;').q( nMissingInit = $N()-1; nMissing = nMissingInit; ).(defined($args{tmp_init}) ? $args{tmp_init} : (defined($args{tmp_reset}) ? $args{tmp_reset} : 'if ($SIZE(NnzIn) == 0) $CROAK("called with empty nzvalsIn"); tmp = $nzvalsIn(NnzIn=>0);') ).q( /* initialize tmp */ // //-- loop for (nnzii_prev=0,nnzii=1; nnziinnzii)','$ixIn(NnzIn=>nnzii_prev)','Ndims','cmpval',var1=>'ival1',var2=>'ival2'); if (cmpval > 0) { //-- CASE: ix > ix_prev : insert accumulated value ).($args{tmp_addmissing}||"").q( //-- always insert output value loop (Ndims) %{ $ixOut(NnzOut=>nnzoi) = $ixIn(NnzIn=>nnzii_prev); %} $nzvalsOut(NnzOut=>nnzoi) = tmp; nnzoi++; // // ... and reset temps ).(defined($args{tmp_reset}) ? $args{tmp_reset} : 'tmp = $nzvalsIn(NnzIn=>nnzii);').q( /* reset tmp */ nMissing = nMissingInit; } else if (cmpval <= 0) { // CASE: ix >= ix_prev : accumulate to temps ).($args{tmp_addval}||'').q(; nMissing--; if (cmpval < 0) { carp_unsorted=1; } /*-- CASE: ix < ix_prev : GARBAGE (treat as equal) --*/ } } // //-- sanity check).' if (nnzii= 0 && nnzii_prev < $SIZE(NnzIn)) { loop (Ndims) %{ $ixOut(NnzOut=>nnzoi) = $ixIn(NnzIn=>nnzii_prev); %} } if ($SIZE(NnzOut) > nnzoi) { $nzvalsOut(NnzOut=>nnzoi) = tmp; nnzoi++; } $nOut() = nnzoi; // //-- set any remaining output values to 0 (indices) or "N*missing" (values) for ( ; nnzoinnzoi) = 0; %} $nzvalsOut(NnzOut=>nnzoi) = missingOut; } %} // //-- carp?).' if (carp_unsorted) { warn("PDL::ccs_accum_'.${op_codename}.'(): unsorted input vector list detected: output will be incorrect"); }'.q( // //-- set BAD-flags ).($args{setbad} || q( if ($PDLSTATEISBAD(ixIn)) { $PDLSTATESETBAD(ixOut); } else { $PDLSTATESETGOOD(ixOut); } if ($PDLSTATEISBAD(nzvalsIn)) { $PDLSTATESETBAD(nzvalsOut); } else { $PDLSTATESETGOOD(nzvalsOut); } )).q( //-- END ), ##-- docs Doc => q( Accumulated ).${op_docname}.q( over values $nzvalsIn() associated with non-missing vector-valued keys $ixIn(). On return, $ixOut() holds the unique non-"missing" values of $ixIn(), $nzvalsOut() holds the associated values, and $nOut() stores the number of unique non-missing values computed. ).($args{doc_addmissing}||'').q( Returned PDLs are implicitly sliced such that NnzOut==$nOut(). In scalar context, returns only $nzvalsOut(). ), ($args{extra} ? %{$args{extra}} : qw()), ); ##--/ccs_accum_hash: return } ##--/ccs_accum_hash: sub sub ccs_accum_def { vvpp_def(('ccs_accum_'.$_[0]), ccs_accum_hash(@_)); } ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): prod ccs_accum_def('prod', 'product', init_missingOut=>'if ($N() > 0) { missingOut = pow(missingVal, $N()); } else { missingOut = missingVal; }', tmp_init => 'tmp = $SIZE(NnzIn) == 0 ? 1 : $nzvalsIn(NnzIn=>0);', tmp_addmissing =>'if (nMissing > 0) { tmp *= pow(missingVal, nMissing); }', tmp_addval =>'tmp *= $nzvalsIn(NnzIn=>nnzii);', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, then the quantity: $missing ** ($N - (rlevec($ixIn))[0]) is multiplied into $nzvalsOut: this is probably What You Want if you are computing the product over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): dprod ccs_accum_def('dprod', 'double-precision product', out_type =>'double', init_missingOut=>'if ($N() > 0) { missingOut = pow(missingVal, $N()); } else { missingOut = missingVal; }', tmp_init => 'tmp = $SIZE(NnzIn) == 0 ? 1 : $nzvalsIn(NnzIn=>0);', tmp_addmissing =>'if (nMissing > 0) { tmp *= pow(missingVal, nMissing); }', tmp_addval =>'tmp *= $nzvalsIn(NnzIn=>nnzii);', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, then the quantity: $missing ** ($N - (rlevec($ixIn))[0]) is multiplied into $nzvalsOut: this is probably What You Want if you are computing the product over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): sum ccs_accum_def('sum', 'sum', init_missingOut=>'if ($N() > 0) { missingOut = $N() * missingVal; } else { missingOut = missingVal; }', tmp_init => 'tmp = $SIZE(NnzIn) == 0 ? 0 : $nzvalsIn(NnzIn=>0);', tmp_addmissing =>'if (nMissing > 0) { tmp += nMissing * missingVal; }', tmp_addval =>'tmp += $nzvalsIn(NnzIn=>nnzii);', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, then the quantity: $missing * ($N - (rlevec($ixIn))[0]) is added to $nzvalsOut: this is probably What You Want if you are summing over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): dsum ccs_accum_def('dsum', 'double-precision sum', out_type =>'double', init_missingOut=>'if ($N() > 0) { missingOut = $N() * missingVal; } else { missingOut = missingVal; }', tmp_init => 'tmp = $SIZE(NnzIn) == 0 ? 0.0 : $nzvalsIn(NnzIn=>0);', tmp_addmissing =>'if (nMissing > 0) { tmp += nMissing * missingVal; }', tmp_addval =>'tmp += $nzvalsIn(NnzIn=>nnzii);', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, then the quantity: $missing * ($N - (rlevec($ixIn))[0]) is added to $nzvalsOut: this is probably What You Want if you are summing over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): or ccs_accum_def('or', 'logical "or"', tmp_type => 'signed char', init_missingOut=>'missingOut = missingVal;', tmp_addmissing =>'if (nMissing > 0) { tmp = tmp || missingVal; } tmp = !!tmp; /* canonicalize */', tmp_addval =>'tmp = tmp || $nzvalsIn(NnzIn=>nnzii);', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, $missing() is logically (or)ed into each result value at each output index with a run length of less than $N() in $ixIn(). This is probably What You Want. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): and ccs_accum_def('and', 'logical "and"', tmp_type => 'signed char', init_missingOut=>'missingOut = missingVal;', tmp_addmissing =>'if (nMissing > 0) { tmp = tmp && missingVal; } tmp = !!tmp; /* canonicalize */', tmp_addval =>'tmp = tmp && $nzvalsIn(NnzIn=>nnzii);', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, $missing() is logically (and)ed into each result value at each output index with a run length of less than $N() in $ixIn(). This is probably What You Want. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): bor ccs_accum_def('bor', 'bitwise "or"', extra => { GenericTypes=>$PDL::CCS::Config::ccsConfig{INT_TYPE_CHRS} }, init_missingOut=>'missingOut = missingVal;', tmp_addmissing =>'if (nMissing > 0) { tmp |= missingVal; }', tmp_addval =>'tmp |= $nzvalsIn(NnzIn=>nnzii);', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, $missing() is bitwise (or)ed into each result value at each output index with a run length of less than $N() in $ixIn(). This is probably What You Want. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): band ccs_accum_def('band', 'bitwise "and"', extra => { GenericTypes=>$PDL::CCS::Config::ccsConfig{INT_TYPE_CHRS} }, init_missingOut=>'missingOut = missingVal;', tmp_addmissing =>'if (nMissing > 0) { tmp &= missingVal; }', tmp_addval =>'tmp &= $nzvalsIn(NnzIn=>nnzii);', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, $missing() is bitwise (and)ed into each result value at each output index with a run length of less than $N() in $ixIn(). This is probably What You Want. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): maximum ccs_accum_def('maximum', 'maximum', decls =>'$GENERIC(nzvalsIn) curval;', init_missingOut=>'missingOut = missingVal;', tmp_addmissing =>'if (nMissing > 0 && missingVal > tmp) { tmp = missingVal; }', tmp_addval =>'curval=$nzvalsIn(NnzIn=>nnzii); if (curval>tmp) tmp=curval;', doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, and if $missing() is greater than any listed value for a vector key with a run-length of less than $N(), then $missing() is used as the output value for that key. This is probably What You Want. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): minimum ccs_accum_def('minimum', 'minimum', decls =>'$GENERIC(nzvalsIn) curval;', init_missingOut=>'missingOut = missingVal;', tmp_addmissing =>'if (nMissing > 0 && missingVal < tmp) { tmp = missingVal; }', tmp_addval =>'curval=$nzvalsIn(NnzIn=>nnzii); if (curval <<'EOMD', If $N() is specified and greater than zero, and if $missing() is less than any listed value for a vector key with a run-length of less than $N(), then $missing() is used as the output value for that key. This is probably What You Want. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): maximum_nz_ind ~ maximum_ind ccs_accum_def('maximum_nz_ind', 'maximum_nz_ind', out_type =>'indx', out_type_perl =>'indx', decls =>'$GENERIC(nzvalsIn) curval, bestval;', init_missingOut=>'missingOut = -1;', tmp_addmissing =>'if (nMissing > 0 && $ISGOOD(missing()) && missingVal > bestval) { tmp=missingOut; }', tmp_addval =>'curval=$nzvalsIn(NnzIn=>nnzii); if (curval>bestval) { bestval=curval; tmp=nnzii; }', tmp_reset =>'curval=$nzvalsIn(NnzIn=>nnzii); bestval=curval; tmp=nnzii;', doc_addmissing => <<'EOMD', Output indices index $nzvalsIn, -1 indicates that the missing value is maximal. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): minimum_nz_ind ~ minimum_ind ccs_accum_def('minimum_nz_ind', 'minimum_nz_ind', out_type =>'indx', out_type_perl =>'indx', decls =>'$GENERIC(nzvalsIn) curval, bestval;', init_missingOut=>'missingOut = -1;', tmp_addmissing =>'if (nMissing > 0 && $ISGOOD(missing()) && missingVal < bestval) { tmp=missingOut; }', tmp_addval =>'curval=$nzvalsIn(NnzIn=>nnzii); if (curval'curval=$nzvalsIn(NnzIn=>nnzii); bestval=curval; tmp=nnzii;', doc_addmissing => <<'EOMD', Output indices index $nzvalsIn, -1 indicates that the missing value is minimal. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): nbad require PDL::Bad; ccs_accum_def('nbad', 'number of bad values', out_type =>'indx', # #init_missingOut=>'missingOut=$N();', init_missingOut=>'missingOut=missingVal;', ##-- not really right, but compatible ($PDL::Bad::Status ? ( tmp_addmissing =>'if (nMissing > 0 && $ISBAD(missing())) { tmp += nMissing; } /* bad support available */', tmp_addval =>'if ( $ISBAD(nzvalsIn(NnzIn=>nnzii)) ) tmp++;', tmp_reset =>'tmp = ( $ISBAD(nzvalsIn(NnzIn=>nnzii)) ) ? 1 : 0;', ) : ( tmp_addmissing =>';/* NO bad support available */', tmp_addval =>';', tmp_reset =>'tmp = 0;', )), setbad => q{ if ($PDLSTATEISBAD(ixIn)) { $PDLSTATESETBAD(ixOut); } else { $PDLSTATESETGOOD(ixOut); } $PDLSTATESETGOOD(nzvalsOut); /*-- nzvalsOut state is always good --*/ }, doc_addmissing => <<'EOMD', Should handle missing values appropriately. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): ngood ccs_accum_def('ngood', 'number of good values', out_type =>'indx', max_type_perl =>'indx', #$PDL::CCS::Config::ccsConfig{INT_TYPE_MAX_IONAME}, init_missingOut=>'missingOut=missingVal;', ##-- not really right, but compatible ($PDL::Bad::Status ? ( tmp_addmissing =>'if (nMissing > 0 && $ISGOOD(missing())) { tmp += nMissing; } /* bad support available */', tmp_addval =>'if ( $ISGOOD(nzvalsIn(NnzIn=>nnzii)) ) tmp++;', tmp_reset =>'tmp = ( $ISGOOD(nzvalsIn(NnzIn=>nnzii)) ) ? 1 : 0;', ) : ( tmp_addmissing =>';/* NO bad support available */', tmp_addval =>'tmp++;', tmp_reset =>'tmp=1;' )), setbad => q{ if ($PDLSTATEISBAD(ixIn)) { $PDLSTATESETBAD(ixOut); } else { $PDLSTATESETGOOD(ixOut); } $PDLSTATESETGOOD(nzvalsOut); /*-- nzvalsOut state is always good --*/ }, doc_addmissing => <<'EOMD', Should handle missing values appropriately. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): nnz ccs_accum_def('nnz', 'number of non-zero values', out_type =>'indx', init_missingOut=>'missingOut=missingVal;', ##-- not really right, but compatible tmp_addmissing =>'if (nMissing > 0 && missingVal != 0) { tmp += nMissing; }', tmp_addval =>'if ($nzvalsIn(NnzIn=>nnzii) != 0) tmp++;', tmp_reset =>'tmp = ( $nzvalsIn(NnzIn=>nnzii) != 0 ) ? 1 : 0;', setbad => q{ if ($PDLSTATEISBAD(ixIn)) { $PDLSTATESETBAD(ixOut); } else { $PDLSTATESETGOOD(ixOut); } $PDLSTATESETGOOD(nzvalsOut); /*-- nzvalsOut state is always good --*/ }, doc_addmissing => <<'EOMD', Should handle missing values appropriately. EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): average ccs_accum_def('average', 'average', decls => 'PDL_Indx ntmp;', out_type => 'float+', init_missingOut=>'if ($N() > 0) { missingOut=missingVal; } else { missingOut=INFINITY; }', tmp_reset =>'tmp = $nzvalsIn(NnzIn=>nnzii); ntmp=1;', tmp_addval =>'tmp += $nzvalsIn(NnzIn=>nnzii); ntmp++;', tmp_addmissing =>( 'if (nMissing > 0) { tmp += nMissing * missingVal; } if ($N() > 0) { tmp /= $N(); } else { tmp /= ntmp; }' ), doc_addmissing => <<'EOMD', If $N() is specified and greater than zero, then the quantity: $missing * ($N - (rlevec($ixIn))[0]) / $N is added to $nzvalsOut: this is probably What You Want if you are averaging over a virtual dimension in a sparse index-encoded PDL (see PDL::CCS::Nd for a wrapper class). EOMD ); ##-------------------------------------------------------------- ## Operations: Accumulators (Ufuncs): NYI pp_addpm(<<'EOPM'); =pod =head1 TODO / NOT YET IMPLEMENTED =over 4 =item extrema indices maximum_ind, minimum_ind: not quite compatible... =item statistical aggregates daverage, medover, oddmedover, pctover, ... =item cumulative functions cumusumover, cumuprodover, ... =item other stuff zcover, intover, minmaximum =back =cut EOPM ##====================================================================== ## Footer Administrivia ##====================================================================== ##------------------------------------------------------ ## pm additions: footer pp_addpm(<<'EOPM'); ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS Probably many. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2007-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl) =cut EOPM # Always make sure that you finish your PP declarations with # pp_done pp_done(); ##---------------------------------------------------------------------- PDL-CCS-1.24.1/CCS/Ufunc/Makefile.PL0000644000175000017500000000102214735713775016036 0ustar moocowbovinesuse PDL::Core::Dev; use ExtUtils::MakeMaker; PDL::Core::Dev->import(); require "../../pdlmaker.plm"; $package = ["ccsufunc.pd", 'Ufunc', 'PDL::CCS::Ufunc']; %hash = pdlmaker_init($package); $hash{AUTHOR} = 'Bryan Jurish'; $hash{ABSTRACT} = 'Ufuncs for compressed storage sparse PDLs'; $hash{VERSION_FROM} = '../../CCS.pm'; $hash{LICENSE} = 'perl'; $hash{PREREQ_PM}{PDL} = $hash{CONFIGURE_REQUIRES}{PDL} = 0; push(@{$hash{LIBS}}, '-lm'); $hash{DIR} = []; $hash{realclean}{FILES} .= '*~ *.tmp README.txt'; WriteMakefile(%hash); PDL-CCS-1.24.1/CCS/Utils/0000755000175000017500000000000014736165776014114 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/Utils/ccsutils.h0000644000175000017500000000071714735713775016120 0ustar moocowbovines#include "pdl.h" /* null-detection adapted from PDL_MAYBE_SIZE macro; see also * - https://github.com/PDLPorters/pdl-linearalgebra/blob/f789c4100d04ba9d1b50f8c18249bdef29338496/Real/real.pd#L63-L75 * - https://github.com/moocow-the-bovine/PDL-CCS/issues/16#issuecomment-2566952192 * - https://github.com/moocow-the-bovine/PDL-CCS/issues/16#issuecomment-2567084731 */ #define CCS_PDL_IS_NULL(pdl) \ ((pdl)->nvals==0 && ((pdl)->state & PDL_MYDIMS_TRANS)) PDL-CCS-1.24.1/CCS/Utils/t/0000755000175000017500000000000014736165776014357 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/Utils/t/common.plt0000644000175000017500000000053014054377273016354 0ustar moocowbovines# -*- Mode: CPerl -*- # File: t/common.plt # Description: re-usable test subs for Math::PartialOrder ##-- common subs BEGIN { use File::Basename; use Cwd; my $topdir = Cwd::abs_path(dirname(__FILE__)."/../../.."); do "$topdir/t/common.plt" or die("$0: failed to load $topdir/t/common.plt: $@"); } print "loaded ", __FILE__, "\n"; 1; PDL-CCS-1.24.1/CCS/Utils/t/03_decode.t0000644000175000017500000000671014735713775016272 0ustar moocowbovines# -*- Mode: CPerl -*- # t/03_encode.t: test ccs pointer-decoding use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../../.. ../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::CCS::Utils; use PDL::VectorValued; ##-- setup my $a = pdl(double, [ [10,0,0,0,-2], [3,9,0,0,0], [0,7,8,7,0], [3,0,8,7,5], [0,8,0,9,9], [0,4,0,0,2], ]); ##-- test: decode_pointer my $awhich = $a->whichND; my $awhich0 = $awhich->slice("(0)"); my $awhich1 = $awhich->slice("(1)"); my $avals = $a->indexND($awhich); ##-- 1..2: decode_pointer: dim=0: full my ($aptr0,$anzi0) = ccs_encode_pointers($awhich0); my $aproj0 = sequence(long,$a->dim(0)); my ($aproj0d,$apnzi0d) = ccs_decode_pointer($aptr0,$aproj0); pdlok("ccs_decode_pointer:full:dim=0:proj", $aproj0d, $awhich0->qsort); pdlok("ccs_decode_pointer:full:dim=0:nzi", $apnzi0d, $apnzi0d->sequence); ##-- 3..4: decode_pointer: dim=1: full my ($aptr1,$anzi1) = ccs_encode_pointers($awhich1); my $aproj1 = sequence(long,$a->dim(1)); my ($aproj1d,$apnzi1d) = ccs_decode_pointer($aptr1,$aproj1); pdlok("ccs_decode_pointer:full:dim=1:proj", $aproj1d, $awhich1->qsort); pdlok("ccs_decode_pointer:full:dim=1:nzi", $apnzi1d, $apnzi1d->sequence); ##-- 5..6: decode_pointer: dim=0: partial $aproj0 = pdl(long,[1,2,4]); my $aslice0 = $a->dice_axis(0,$aproj0); ($aproj0d,$apnzi0d) = ccs_decode_pointer($aptr0,$aproj0); my $apnzi = $anzi0->index($apnzi0d); my $which_proj = $aproj0d->slice("*1,")->append($awhich->slice("1")->dice_axis(1,$apnzi)); my $vals_proj = $avals->index($apnzi); pdlok("ccs_decode_pointer:partial:dim=0:which", $which_proj->vv_qsortvec, $aslice0->whichND->vv_qsortvec); pdlok("ccs_decode_pointer:partial:dim=0:vals", $vals_proj, $aslice0->indexND($which_proj)); ##-- 7..8: decode_pointer: dim=1: partial $aproj1 = pdl(long,[2,3,5]); my $aslice1 = $a->dice_axis(1,$aproj1); ($aproj1d,$apnzi1d) = ccs_decode_pointer($aptr1,$aproj1); $apnzi = $anzi1->index($apnzi1d); $which_proj = $aproj1d->slice("*1,")->append($awhich->slice("0")->dice_axis(1,$apnzi))->slice("-1:0"); $vals_proj = $avals->index($apnzi); pdlok("ccs_decode_pointer:partial:dim=1:which", $which_proj->vv_qsortvec, $aslice1->whichND->vv_qsortvec); pdlok("ccs_decode_pointer:partial:dim=1:vals", $vals_proj, $aslice1->indexND($which_proj)); ##-- test Compat::ccswhichND-style usage with pre-allocated outputs sub test_decode_args { my ($label, @args) = @_; print "# test_decode_args:$label\n"; my $aptr = pdl(indx, [0,3,7,9,12,16, 19]); # == $ptr0->append(19) my $aproj = sequence(indx, $aptr->nelem - 1); my ($projix, $nzix) = ccs_decode_pointer($aptr, $aproj, @args); pdlok("test_decode_args:$label:projix", $projix, pdl(indx, [0,0,0,1,1,1,1,2,2,3,3,3,4,4,4,4,5,5,5])); pdlok("test_decode_args:$label:nzix", $nzix, sequence(indx, 19)); } test_decode_args('no-outputs'); test_decode_args('null-outputs', null, null); test_decode_args('prealloc-projix', zeroes(indx, 19), null); test_decode_args('prealloc-nzix', null, zeroes(indx, 19)); test_decode_args('prealloc-all', zeroes(indx, 19), zeroes(indx, 19)); done_testing; PDL-CCS-1.24.1/CCS/Utils/t/01_nnz.t0000644000175000017500000000143414734512720015632 0ustar moocowbovines# -*- Mode: CPerl -*- # t/01_nnz.t: test n nonzeros use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../../.. ../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::CCS::Utils; ## 1--4: test nnz my $p = pdl(double, [ [0,1,2], [0,0,1e-7], [0,1,0], [1,1,1] ]); isok("nnz(0)", $p->slice(",(0)")->nnz, 2); isok("nnz(flat)", $p->flat->nnz, 7); isok("nnza(flat,1e-8)", $p->flat->nnza(1e-8), 7); isok("nnza(flat,1e-5)", $p->flat->nnza(1e-5), 6); isok("nnza(flat:long,1)", $p->flat->long->nnza(1), 1); done_testing; PDL-CCS-1.24.1/CCS/Utils/t/02_encode.t0000644000175000017500000000340014735713775016274 0ustar moocowbovines# -*- Mode: CPerl -*- # t/02_encode.t: test ccs encoding use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../../.. ../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::CCS::Utils; use PDL::VectorValued; ##-- setup my $a = pdl(double, [ [10,0,0,0,-2], [3,9,0,0,0], [0,7,8,7,0], [3,0,8,7,5], [0,8,0,9,9], [0,4,0,0,2], ]); ##-- test: encode_pointers my $awhich = $a->whichND()->vv_qsortvec; my $avals = $a->indexND($awhich); my ($aptr0,$awi0) = ccs_encode_pointers($awhich->slice("(0),")); my ($aptr1,$awi1) = ccs_encode_pointers($awhich->slice("(1),")); ##-- 1..2 my $awhich_want = pdl(long, [[0,0],[0,1],[0,3],[1,1],[1,2],[1,4],[1,5],[2,2],[2,3],[3,2],[3,3],[3,4],[4,0],[4,3],[4,4],[4,5]]); #my $avals_want = pdl([10,3,3,9,7,8,4,8,8,7,7,9,-2,5,9,2]); # this is what we expect to expect my $avals_want = $a->indexND($awhich_want); # ... but what we actually expect is whatever PDL::indexND() does pdlok("whichND", $awhich,$awhich_want); pdlok("vals", $avals, $avals_want); ##-- 3..4: ptr0 pdlok("ccs_encode_pointers:ptr0", $aptr0, pdl(long,[0,3,7,9,12,16])); pdlok("ccs_encode_pointers:awi0", $awi0, $awi0->sequence); ##-- 5..6: ptr1 pdlok("ccs_encode_pointers:ptr1", $aptr1, pdl(long,[0,2,4,7,11,14,16])); my $awi1x = $awhich->slice("(1),")->index($awi1); pdlok("ccs_encode_pointers:awi1", $awi1x, $awi1x->qsort); done_testing; PDL-CCS-1.24.1/CCS/Utils/Utils.pm0000644000175000017500000002453014736165667015555 0ustar moocowbovines# # GENERATED WITH PDL::PP! Don't modify! # package PDL::CCS::Utils; our @EXPORT_OK = qw(nnz nnza ccs_encode_pointers ccs_decode_pointer ccs_xindex1d ccs_xindex2d ccs_dump_which ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our $VERSION = '1.24.1'; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::CCS::Utils $VERSION; #line 13 "ccsutils.pd" #use PDL::CCS::Config; use strict; =pod =head1 NAME PDL::CCS::Utils - Low-level utilities for compressed storage sparse PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::Utils; ##--------------------------------------------------------------------- ## ... stuff happens =cut #line 46 "Utils.pm" =head1 FUNCTIONS =cut #line 52 "ccsutils.pd" *ccs_indx = \&PDL::indx; ##-- typecasting for CCS indices (deprecated) #line 63 "Utils.pm" #line 70 "ccsutils.pd" =pod =head1 Non-missing Value Counts =cut #line 75 "Utils.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 nnz =for sig Signature: (a(N); indx [o]nnz()) Get number of non-zero values in a PDL $a(); For 1d PDLs, should be equivalent to: $nnz = nelem(which($a!=0)); For k>1 dimensional PDLs, projects via number of nonzero elements to N-1 dimensions by computing the number of nonzero elements along the the 1st dimension. =for bad The output PDL $nnz() never contains BAD values. =cut #line 105 "Utils.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *nnz = \&PDL::nnz; #line 112 "Utils.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 nnza =for sig Signature: (a(N); eps(); indx [o]nnz()) Like nnz() using tolerance constant $eps(). For 1d PDLs, should be equivalent to: $nnz = nelem(which(!$a->approx(0,$eps))); =for bad The output PDL $nnz() never contains BAD values. =cut #line 138 "Utils.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *nnza = \&PDL::nnza; #line 145 "Utils.pm" #line 156 "ccsutils.pd" =pod =head1 Encoding Utilities =cut #line 157 "Utils.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_encode_pointers =for sig Signature: (indx ix(Nnz); indx N(); indx [o]ptr(Nplus1); indx [o]ixix(Nnz)) General CCS encoding utility. Get a compressed storage "pointer" vector $ptr for a dimension of size $N with non-missing values at indices $ix. Also returns a vector $ixix() which may be used as an index for $ix() to align its elements with $ptr() along the compressed dimension. The induced vector $ix-Eindex($ixix) is guaranteed to be stably sorted along dimension $N(): \forall $i,$j with 1 <= $i < $j <= $Nnz : $ix->index($ixix)->at($i) < $ix->index($ixix)->at($j) ##-- primary sort on $ix() or $ixix->at($i) < $ixix->at($j) ##-- ... stable =for bad ccs_encode_pointers does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 196 "Utils.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_encode_pointers { my ($ix,$N,$ptr,$ixix) = @_; barf("Usage: ccs_encode_pointers(ix(Nnz), N(), [o]ptr(N+1), [o]ixix(Nnz)") if (!defined($ix)); &PDL::_ccs_encode_pointers_int($ix, ($N // $ix->max+1), ($ptr //= null), ($ixix //= null)); return ($ptr,$ixix); } #line 210 "Utils.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_encode_pointers = \&PDL::ccs_encode_pointers; #line 217 "Utils.pm" #line 239 "ccsutils.pd" =pod =head1 Decoding Utilities =cut #line 229 "Utils.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_decode_pointer =for sig Signature: (indx ptr(Nplus1); indx proj(Nproj); indx [o]projix(NnzProj); indx [o]nzix(NnzProj); PDL_Indx nnzProj) General CCS decoding utility. Project indices $proj() from a compressed storage "pointer" vector $ptr(). If unspecified, $proj() defaults to: sequence($ptr->dim(0) - 1) =for bad ccs_decode_pointer does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 259 "Utils.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_decode_pointer { my ($ptr,$proj,$projix,$nzix,$nnzproj) = @_; barf("Usage: ccs_decode_pointer(ptr(N+1), proj(Nproj), [o]projix(NnzProj), [o]nzix(NnzProj), NnzProj?") if (!defined($ptr)); if (!defined($proj)) { $proj = PDL->sequence(ccs_indx(), $ptr->dim(0)-1); $nnzproj //= $ptr->at(-1); } $projix //= null; $nzix //= null; $nnzproj //= ($projix->isnull && $nzix->isnull ? ($ptr->index($proj+1)-$ptr->index($proj))->sum : -1); return (null,null) if (!$nnzproj); &PDL::_ccs_decode_pointer_int($ptr,$proj, $projix,$nzix, $nnzproj); return ($projix,$nzix); } #line 284 "Utils.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_decode_pointer = \&PDL::ccs_decode_pointer; #line 291 "Utils.pm" #line 311 "ccsutils.pd" =pod =head1 Indexing Utilities =cut #line 303 "Utils.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_xindex1d =for sig Signature: (indx which(Ndims,Nnz); indx a(Na); indx [o]nzia(NnzA); indx [o]nnza(); PDL_Indx sizeNnzA) Compute indices $nzai() along dimension C of $which() whose initial values $which(0,$nzai) match some element of $a(). Appropriate for indexing a sparse encoded PDL with non-missing entries at $which() along the 0th dimension, a la L. $which((0),) and $a() must be both sorted in ascending order. In list context, returns a list ($nzai,$nnza), where $nnza() is the number of indices found, and $nzai are those C indices. In scalar context, trims the output vector $nzai() to $nnza() elements. =for bad ccs_xindex1d does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 336 "Utils.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_xindex1d { my ($which,$a,$nzia,$nnza) = @_; barf("Usage: ccs_xindex2d(which(Ndims,Nnz), a(Na), [o]nzia(NnzA), [o]nnza()") if ((grep {!defined($_)} @_[0..1]) || $which->ndims < 2 || $which->dim(0) < 1); $nzia //= null; $nnza //= null; &PDL::_ccs_xindex1d_int($which,$a,$nzia,$nnza, ($nnza ? $nnza->sclr : -1)); return wantarray ? ($nzia,$nnza) : $nzia->reshape($nnza->sclr); } #line 353 "Utils.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_xindex1d = \&PDL::ccs_xindex1d; #line 360 "Utils.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_xindex2d =for sig Signature: (indx which(Ndims,Nnz); indx a(Na); indx b(Nb); indx [o]ab(Nab); indx [o]nab()) Compute indices along dimension C of $which() corresponding to any combination of values in the Cartesian product of $a() and $b(). Appropriate for indexing a 2d sparse encoded PDL with non-missing entries at $which() via the ND-index piddle $a-Eslice("*1,")-Ecat($b)-Eclump(2)-Exchg(0,1), i.e. all pairs $ai,$bi with $ai in $a() and $bi in $b(). $a() and $b() values must be be sorted in ascending order In list context, returns a list ($ab,$nab), where $nab() is the number of indices found, and $ab are those C indices. In scalar context, trims the output vector $ab() to $nab() elements. =for bad ccs_xindex2d does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 393 "Utils.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_xindex2d { my ($which,$a,$b,$ab,$nab) = @_; barf("Usage: ccs_xindex2d(which(2,Nnz), a(Na), b(Nb), [o]nab(), [o]ab(Nab)") if ((grep {!defined($_)} @_[0..2]) || $which->ndims != 2 || $which->dim(0) < 2); &PDL::_ccs_xindex2d_int($which,$a,$b, ($ab//=null), ($nab//=null)); return wantarray ? ($ab,$nab) : $ab->reshape($nab->sclr); } #line 408 "Utils.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_xindex2d = \&PDL::ccs_xindex2d; #line 415 "Utils.pm" #line 487 "ccsutils.pd" =pod =head1 Debugging Utilities =cut #line 427 "Utils.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_dump_which =for sig Signature: (indx which(Ndims,Nnz); SV *HANDLE; char *fmt; char *fsep; char *rsep) Print a text dump of an index PDL to the filehandle C, which default to C. C<$fmt> is a printf() format to use for output, which defaults to "%td". C<$fsep> and C<$rsep> are field-and record separators, which default to a single space and C<$/>, respectively. =for bad ccs_dump_which does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 455 "Utils.pm" #line 950 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" sub PDL::ccs_dump_which { my ($which,$fh,$fmt,$fsep,$rsep) = @_; $fmt = '%td' if (!defined($fmt) || $fmt eq ''); $fsep = " " if (!defined($fsep) || $fsep eq ''); $rsep = "$/" if (!defined($rsep) || $rsep eq ''); $fh = \*STDOUT if (!defined($fh)); &PDL::_ccs_dump_which_int($which,$fh,$fmt,$fsep,$rsep); } #line 471 "Utils.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_dump_which = \&PDL::ccs_dump_which; #line 478 "Utils.pm" #line 558 "ccsutils.pd" ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS Probably many. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2007-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl) =cut #line 526 "Utils.pm" # Exit with OK status 1; PDL-CCS-1.24.1/CCS/Utils/Makefile.PL0000644000175000017500000000103714735713775016064 0ustar moocowbovinesuse PDL::Core::Dev; use ExtUtils::MakeMaker; PDL::Core::Dev->import(); require "../../pdlmaker.plm"; $package = ["ccsutils.pd", 'Utils', 'PDL::CCS::Utils']; %hash = pdlmaker_init($package); $hash{AUTHOR} = 'Bryan Jurish'; $hash{ABSTRACT} = 'Low-level utilities for compressed storage sparse PDLs'; $hash{VERSION_FROM} = '../../CCS.pm'; $hash{LICENSE} = 'perl'; $hash{PREREQ_PM}{PDL} = $hash{CONFIGURE_REQUIRES}{PDL} = 0; push(@{$hash{LIBS}}, '-lm'); $hash{DIR} = []; $hash{realclean}{FILES} .= '*~ *.tmp README.txt'; WriteMakefile(%hash); PDL-CCS-1.24.1/CCS/Utils/ccsutils.pd0000644000175000017500000004203514736165363016266 0ustar moocowbovines##-*- Mode: CPerl -*- ##====================================================================== ## Header Administrivia ##====================================================================== use PDL::VectorValued::Dev; my $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module pp_setversion($VERSION); ##------------------------------------------------------ ## pm headers pp_addpm({At=>'Top'},<<'EOPM'); #use PDL::CCS::Config; use strict; =pod =head1 NAME PDL::CCS::Utils - Low-level utilities for compressed storage sparse PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::Utils; ##--------------------------------------------------------------------- ## ... stuff happens =cut EOPM ## /pm additions ##------------------------------------------------------ ##------------------------------------------------------ ## Exports: None #pp_export_nothing(); ##------------------------------------------------------ ## Includes / defines pp_addhdr(<<'EOH'); #include "ccsutils.h" EOH ##------------------------------------------------------ ## index datatype require "../Config.pm"; our $INDX = $PDL::CCS::Config::ccsConfig{INDX_SIG}; pp_addpm( $PDL::CCS::Config::ccsConfig{INDX_FUNCDEF} ); pp_addhdr( $PDL::CCS::Config::ccsConfig{INDX_TYPEDEF} ); ##====================================================================== ## C Utilities ##====================================================================== # (none) ##====================================================================== ## PDL::PP Wrappers ##====================================================================== ##====================================================================== ## Non-missing Value Counts ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Non-missing Value Counts =cut EOPM ##------------------------------------------------------ ## nnz() : get number of nonzero values pp_def( 'nnz', Pars => "a(N); $INDX\ [o]nnz()", HandleBad => 1, Code => q{ broadcastloop %{ $nnz()=0; loop (N) %{ if ($a()!=0) ++$nnz(); %} %} $PDLSTATESETGOOD(nnz); /*-- output is always good --*/ }, Doc => <<'EOD', Get number of non-zero values in a PDL $a(); For 1d PDLs, should be equivalent to: $nnz = nelem(which($a!=0)); For k>1 dimensional PDLs, projects via number of nonzero elements to N-1 dimensions by computing the number of nonzero elements along the the 1st dimension. EOD BadDoc=> 'The output PDL $nnz() never contains BAD values.', ); ##------------------------------------------------------ ## nnza() : get number of non-approximate zero values use PDL; my %absfunc = ( map { my $typ = PDL->can($_); ($typ ? ($typ->()->ppsym => ($typ->()->ctype eq 'long' ? "labs" : "llabs")) : qw()) } qw (longlong indx) ); pp_def( 'nnza', Pars => "a(N); eps(); $INDX\ [o]nnz();", HandleBad => 1, Code => ' broadcastloop %{ $nnz()=0; loop (N) %{ types(BSUL) %{ if ( abs($a()) > $eps()) ++$nnz(); %} '.join("\n ", map {"types($_) %{ if ($absfunc{$_}(\$a()) > \$eps()) ++\$nnz(); %}"} sort keys(%absfunc)).' types(F) %{ if (fabsf($a()) > $eps()) ++$nnz(); %} types(D) %{ if (fabs ($a()) > $eps()) ++$nnz(); %} %} %} $PDLSTATESETGOOD(nnz); /*-- output is always good --*/ ', Doc => <<'EOD', Like nnz() using tolerance constant $eps(). For 1d PDLs, should be equivalent to: $nnz = nelem(which(!$a->approx(0,$eps))); EOD BadDoc=> 'The output PDL $nnz() never contains BAD values.', ); ##====================================================================== ## Encoding ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Encoding Utilities =cut EOPM ##------------------------------------------------------ ## ccs_encode_pointers() : get encoded pointer & index translation PDL pp_def( 'ccs_encode_pointers', Pars => "$INDX\ ix(Nnz); $INDX\ N(); $INDX\ [o]ptr(Nplus1); $INDX\ [o]ixix(Nnz);", PMCode=> q{ sub PDL::ccs_encode_pointers { my ($ix,$N,$ptr,$ixix) = @_; barf("Usage: ccs_encode_pointers(ix(Nnz), N(), [o]ptr(N+1), [o]ixix(Nnz)") if (!defined($ix)); &PDL::_ccs_encode_pointers_int($ix, ($N // $ix->max+1), ($ptr //= null), ($ixix //= null)); return ($ptr,$ixix); } }, RedoDimsCode => q{ if ($SIZE(Nplus1) < 0) { $SIZE(Nplus1) = $N() + 1; } else if ($SIZE(Nplus1) <= $N()) { $CROAK("dimension Nplus1 (=%td) must be greater than N (=%td)", $SIZE(Nplus1), $N()); } }, Code => q{ /*-- Local variables --*/ CCS_Indx ixval, ixval_next, ixval_prev, nzi, nzj, sizeN=$SIZE(Nplus1)-1, sizeNnz=$SIZE(Nnz); // /*-- Count number of NZs in each column; store in ptr[N=>ixval] --*/ loop (Nplus1) %{ $ptr()=0; %} loop (Nnz) %{ ixval=$ix(); ++$ptr(Nplus1=>ixval); %} // /*-- tweak ptr(): fill each cell with the starting point of the previous row --*/ ixval_prev = sizeN-1; $ptr(Nplus1=>sizeN) = sizeNnz - $ptr(Nplus1=>ixval_prev); for (ixval_next=sizeN, ixval=ixval_prev; ixval > 0; ixval_next=ixval--) { ixval_prev = ixval-1; $ptr(Nplus1=>ixval) = $ptr(Nplus1=>ixval_next) - $ptr(Nplus1=>ixval_prev); } $ptr(Nplus1=>0) = 0; // /*-- Assign columns and values --*/ for (nzi=0; nzi < sizeNnz; nzi++) { ixval = $ix(Nnz=>nzi); ixval_next = ixval+1; nzj = $ptr(Nplus1=>ixval_next)++; $ixix(Nnz=>nzj) = nzi; } }, Doc => <<'EOD' General CCS encoding utility. Get a compressed storage "pointer" vector $ptr for a dimension of size $N with non-missing values at indices $ix. Also returns a vector $ixix() which may be used as an index for $ix() to align its elements with $ptr() along the compressed dimension. The induced vector $ix-Eindex($ixix) is guaranteed to be stably sorted along dimension $N(): \forall $i,$j with 1 <= $i < $j <= $Nnz : $ix->index($ixix)->at($i) < $ix->index($ixix)->at($j) ##-- primary sort on $ix() or $ixix->at($i) < $ixix->at($j) ##-- ... stable EOD ); ##====================================================================== ## Decoding ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Decoding Utilities =cut EOPM ##------------------------------------------------------ ## ccs_decode_pointer() : decode a CCS-encoded pointer pp_def( 'ccs_decode_pointer', Pars => "$INDX ptr(Nplus1); $INDX proj(Nproj); $INDX\ [o]projix(NnzProj); $INDX\ [o]nzix(NnzProj)", OtherPars => 'PDL_Indx nnzProj;', PMCode=> q{ sub PDL::ccs_decode_pointer { my ($ptr,$proj,$projix,$nzix,$nnzproj) = @_; barf("Usage: ccs_decode_pointer(ptr(N+1), proj(Nproj), [o]projix(NnzProj), [o]nzix(NnzProj), NnzProj?") if (!defined($ptr)); if (!defined($proj)) { $proj = PDL->sequence(ccs_indx(), $ptr->dim(0)-1); $nnzproj //= $ptr->at(-1); } $projix //= null; $nzix //= null; $nnzproj //= ($projix->isnull && $nzix->isnull ? ($ptr->index($proj+1)-$ptr->index($proj))->sum : -1); return (null,null) if (!$nnzproj); &PDL::_ccs_decode_pointer_int($ptr,$proj, $projix,$nzix, $nnzproj); return ($projix,$nzix); } }, RedoDimsCode => q{ if ($SIZE(NnzProj) < 0) { $SIZE(NnzProj) = $COMP(nnzProj); } }, Code => q{ /*-- Local variables --*/ CCS_Indx ni,ni_next, nzi,nzi_next, ixi=0, sizeNproj=$SIZE(Nproj), sizeNnzProj=$SIZE(NnzProj); loop (Nproj) %{ ni = $proj(); ni_next = ni+1; nzi = $ptr(Nplus1=>ni); nzi_next = $ptr(Nplus1=>ni_next); for ( ; nzi < nzi_next && ixi < sizeNnzProj; nzi++, ixi++) { $projix(NnzProj=>ixi) = Nproj; $nzix(NnzProj=>ixi) = nzi; } %} }, Doc=><<'EOD' General CCS decoding utility. Project indices $proj() from a compressed storage "pointer" vector $ptr(). If unspecified, $proj() defaults to: sequence($ptr->dim(0) - 1) EOD ); ##====================================================================== ## Indexing ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Indexing Utilities =cut EOPM ##------------------------------------------------------ ## ccs_xindex1d() ## + optimized dice_axis on 0th dimension, no pointer required vvpp_def( 'ccs_xindex1d', Pars => "$INDX which(Ndims,Nnz); $INDX a(Na); $INDX\ [o]nzia(NnzA); $INDX\ [o]nnza()", OtherPars => 'PDL_Indx sizeNnzA;', PMCode=> q{ sub PDL::ccs_xindex1d { my ($which,$a,$nzia,$nnza) = @_; barf("Usage: ccs_xindex2d(which(Ndims,Nnz), a(Na), [o]nzia(NnzA), [o]nnza()") if ((grep {!defined($_)} @_[0..1]) || $which->ndims < 2 || $which->dim(0) < 1); $nzia //= null; $nnza //= null; &PDL::_ccs_xindex1d_int($which,$a,$nzia,$nnza, ($nnza ? $nnza->sclr : -1)); return wantarray ? ($nzia,$nnza) : $nzia->reshape($nnza->sclr); } }, RedoDimsCode => q( if ($SIZE(NnzA) < 0) { $SIZE(NnzA) = $COMP(sizeNnzA) >= 0 ? $COMP(sizeNnzA) : $SIZE(Nnz); } ), Code => q{ CCS_Indx a_min=0, a_max=$SIZE(Nnz); CCS_Indx a_lb, a_ub, a_ubmax=a_max; CCS_Indx nnzai = 0; #if 0 /*-- DEBUG --*/ CCS_Indx size_nnz = $SIZE(Nnz); CCS_Indx size_na = $SIZE(Na); CCS_Indx size_nnza = $SIZE(NnzA); printf("Nnz=%td, Na=%td [%td:%td], NnzA=%td\n", size_nnz, size_na,$a(Na=>0),$a(Na=>size_na-1), size_nnza); #endif loop (Na) %{ a_ubmax = a_max; $LB('$a()', '$which(Ndims=>0,Nnz=>$_)', 'a_min','a_max', 'a_lb',ubmaxvar=>'a_ubmax'); if ($which(Ndims=>0,Nnz=>a_lb) != $a()) { a_min=a_lb; continue; } $LB('$a()+1', '$which(Ndims=>0,Nnz=>$_)', 'a_lb' ,'a_ubmax', 'a_ub'); if ($which(Ndims=>0,Nnz=>a_ub) <= $a()) ++a_ub; for ( ; a_lb < a_ub && nnzai < $SIZE(NnzA); ++a_lb, ++nnzai ) { $nzia(NnzA=>nnzai) = a_lb; } if (nnzai >= $SIZE(NnzA)) break; if (a_ub < a_max) a_min = a_ub; %} $nnza() = nnzai; for ( ; nnzai < $SIZE(NnzA); ++nnzai) { $nzia(NnzA=>nnzai) = -1; } }, Doc=><<'EOD' Compute indices $nzai() along dimension C of $which() whose initial values $which(0,$nzai) match some element of $a(). Appropriate for indexing a sparse encoded PDL with non-missing entries at $which() along the 0th dimension, a la L. $which((0),) and $a() must be both sorted in ascending order. In list context, returns a list ($nzai,$nnza), where $nnza() is the number of indices found, and $nzai are those C indices. In scalar context, trims the output vector $nzai() to $nnza() elements. EOD ); ##------------------------------------------------------ ## ccs_xindex2d() ## + Cartesian-product index vvpp_def( 'ccs_xindex2d', Pars => "$INDX which(Ndims,Nnz); $INDX a(Na); $INDX b(Nb); $INDX\ [o]ab(Nab); $INDX\ [o]nab()", PMCode=> q{ sub PDL::ccs_xindex2d { my ($which,$a,$b,$ab,$nab) = @_; barf("Usage: ccs_xindex2d(which(2,Nnz), a(Na), b(Nb), [o]nab(), [o]ab(Nab)") if ((grep {!defined($_)} @_[0..2]) || $which->ndims != 2 || $which->dim(0) < 2); &PDL::_ccs_xindex2d_int($which,$a,$b, ($ab//=null), ($nab//=null)); return wantarray ? ($ab,$nab) : $ab->reshape($nab->sclr); } }, RedoDimsCode => q{ if ($SIZE(Nab) < 0) { if ($PDL(nab)->nvals > 0) { $SIZE(Nab) = $nab(); } else { $SIZE(Nab) = ($SIZE(Na)*$SIZE(Nb)) < $SIZE(Nnz) ? ($SIZE(Na)*$SIZE(Nb)) : $SIZE(Nnz); } } }, Code => q{ CCS_Indx a_min=0, a_max=$SIZE(Nnz); CCS_Indx a_lb, a_ub, a_ubmax=a_max; CCS_Indx b_min, b_max, b_lb; CCS_Indx abi = 0; #if 0 /*-- DEBUG --*/ CCS_Indx size_nnz = $SIZE(Nnz); CCS_Indx size_na = $SIZE(Na); CCS_Indx size_nb = $SIZE(Nb); CCS_Indx size_nab = $SIZE(Nab); printf("Nnz=%td, Na=%td [%td:%td], Nb=%td [%td:%td], Nab=%td\n", size_nnz, size_na,$a(Na=>0),$a(Na=>size_na-1), size_nb,$b(Nb=>0),$b(Nb=>size_nb-1), size_nab); #endif loop (Na) %{ a_ubmax = a_max; $LB('$a()', '$which(Ndims=>0,Nnz=>$_)', 'a_min','a_max', 'a_lb',ubmaxvar=>'a_ubmax'); //printf("a:LB(a=%td,min=%td,max=%td)=%td --> %td (ubmax=%td)\n", $a(),a_min,a_max,a_lb, $which(Ndims=>0,Nnz=>a_lb), a_ubmax); fflush(stdout); if ($which(Ndims=>0,Nnz=>a_lb) != $a()) { a_min=a_lb; continue; } // $LB('$a()+1', '$which(Ndims=>0,Nnz=>$_)', 'a_lb' ,'a_ubmax', 'a_ub'); if ($which(Ndims=>0,Nnz=>a_ub) <= $a()) ++a_ub; //printf("a:UB(a=%td,min=%td,max=%td)=%td --> %td\n", $a(),a_lb,a_ubmax,a_ub, $which(Ndims=>0,Nnz=>a_ub)); fflush(stdout); // b_min = a_lb; b_max = a_ub; loop (Nb) %{ if (b_min >= b_max) break; //printf("+ b:LB(a=%td,b=%td,min=%td,max=%td)=", $a(),$b(),b_min,b_max); fflush(stdout); $LB('$b()', '$which(Ndims=>1,Nnz=>$_)', 'b_min','b_max', 'b_lb'); //printf("%td --> %td", b_lb, $which(Ndims=>1,Nnz=>b_lb)); if ($which(Ndims=>1,Nnz=>b_lb) == $b()) { //printf(" *[%td]", abi); fflush(stdout); $ab(Nab=>abi) = b_lb; ++abi; ++b_lb; if (abi >= $SIZE(Nab)) break; } b_min = b_lb; //printf("\n"); fflush(stdout); %} if (abi >= $SIZE(Nab)) break; if (a_ub < a_max) a_min = a_ub; %} $nab() = abi; for ( ; abi < $SIZE(Nab); ++abi) { $ab(Nab=>abi) = -1; } }, Doc=><<'EOD' Compute indices along dimension C of $which() corresponding to any combination of values in the Cartesian product of $a() and $b(). Appropriate for indexing a 2d sparse encoded PDL with non-missing entries at $which() via the ND-index piddle $a-Eslice("*1,")-Ecat($b)-Eclump(2)-Exchg(0,1), i.e. all pairs $ai,$bi with $ai in $a() and $bi in $b(). $a() and $b() values must be be sorted in ascending order In list context, returns a list ($ab,$nab), where $nab() is the number of indices found, and $ab are those C indices. In scalar context, trims the output vector $ab() to $nab() elements. EOD ); ##====================================================================== ## Debugging ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Debugging Utilities =cut EOPM ##------------------------------------------------------ ## ccs_dump_which() ## + prints a text dump of an index pp_def( 'ccs_dump_which', Pars => "$INDX which(Ndims,Nnz)", OtherPars => 'SV *HANDLE; char *fmt; char *fsep; char *rsep', PMCode=> q{ sub PDL::ccs_dump_which { my ($which,$fh,$fmt,$fsep,$rsep) = @_; $fmt = '%td' if (!defined($fmt) || $fmt eq ''); $fsep = " " if (!defined($fsep) || $fsep eq ''); $rsep = "$/" if (!defined($rsep) || $rsep eq ''); $fh = \*STDOUT if (!defined($fh)); &PDL::_ccs_dump_which_int($which,$fh,$fmt,$fsep,$rsep); } }, Code => q{ CCS_Indx dimi, sizeNdims=$SIZE(Ndims); char *fmt_str = $COMP(fmt); char *fsep_str = $COMP(fsep); char *rsep_str = $COMP(rsep); PerlIO *pio; IO *io; /*-- get PerlIO from SV (lifted from _rasc() n PDL_SRC_ROOT/IO/Misc/misc.pd) --*/ io = sv_2io($COMP(HANDLE)); if (!io || !(pio = IoIFP(io))) { croak("can\'t get PerlIO pointer from HANDLE"); } loop (Nnz) %{ PerlIO_printf(pio, fmt_str, $which(Ndims=>0)); for (dimi=1; dimidimi)); } PerlIO_puts(pio,rsep_str); %} }, Doc=><<'EOD' Print a text dump of an index PDL to the filehandle C, which default to C. C<$fmt> is a printf() format to use for output, which defaults to "%td". C<$fsep> and C<$rsep> are field-and record separators, which default to a single space and C<$/>, respectively. EOD ); ##====================================================================== ## Footer Administrivia ##====================================================================== ##------------------------------------------------------ ## pm additions: footer pp_addpm(<<'EOPM'); ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS Probably many. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2007-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl) =cut EOPM # Always make sure that you finish your PP declarations with # pp_done pp_done(); ##---------------------------------------------------------------------- PDL-CCS-1.24.1/CCS/t/0000755000175000017500000000000014736165776013257 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/t/01_encode.t0000644000175000017500000000567514734512720015175 0ustar moocowbovines# -*- Mode: CPerl -*- # t/01_encode.t use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } our ($a, $abad, $agood, $awhich, $avals, $BAD); ##-- common modules use PDL; use PDL::CCS::Nd; use PDL::VectorValued; ## (i+1)..(i+9): basic properites (missing==0) sub test_basic { my ($label,$a,$ccs,$missing) = @_; isok("${label}:defined", defined($ccs)); isok("${label}:dims", all(pdl($ccs->dims)==pdl($a->dims))); isok("${label}:nelem", $ccs->nelem==$a->nelem); ##-- check missing $missing = 0 if (!defined($missing)); $missing = PDL->topdl($missing); my $awhichND = whichND($missing->isbad ? !isbad($a) : $a!=$missing); isok("${label}:_nnz", $ccs->_nnz==$awhichND->dim(1)); pdlok("${label}:whichND", $ccs->whichND->vv_qsortvec, $awhichND->vv_qsortvec); pdlok("${label}:nzvals", $ccs->whichVals, $a->indexND(scalar($ccs->whichND))); pdlok_nodims("${label}:missing:value", $ccs->missing, $missing); ##-- testdecode pdlok("${label}:decode", $ccs->decode,$a); pdlok("${label}:todense", $ccs->todense,$a); } ##-------------------------------------------------------------- ## missing==0 ##-- 1*nbasic: newFromDense(): basic properties my $ccs = PDL::CCS::Nd->newFromDense($a); test_basic("newFromDense:missing=0", $a, $ccs, 0); ##-- 2*nbasic: toccs(): basic properties $ccs = $a->toccs; test_basic("toccs:missing=0", $a, $ccs, 0); ##-- 3*nbasic: newFromWhich() $ccs = PDL::CCS::Nd->newFromWhich($awhich,$avals,missing=>0); test_basic("newFromWhich:missing=0", $a, $ccs, 0); ##-------------------------------------------------------------- ## missing==BAD ##-- 5*nbasic: newFromDense(...BAD): basic properties $a = $a->setbadif($abad); $avals = $a->indexND($awhich); test_basic("newFromDense:missing=BAD:explicit", $a, PDL::CCS::Nd->newFromDense($a,$BAD), $BAD); test_basic("newFromDense:missing=BAD:implicit", $a, PDL::CCS::Nd->newFromDense($a), $BAD); ##-- 7*nbasic: toccs(...BAD): basic properties test_basic("toccs:missing=BAD:explicit", $a, $a->toccs($BAD), $BAD); test_basic("toccs:missing=BAD:implicit", $a, $a->toccs(), $BAD); ##-- 9*nbasic: newFromWhich(...BAD) test_basic("newFromWhich:missing=BAD:explicit", $a, PDL::CCS::Nd->newFromWhich($awhich,$avals,missing=>$BAD), $BAD); test_basic("newFromWhich:missing=BAD:implicit", $a, PDL::CCS::Nd->newFromWhich($awhich,$avals), $BAD); ##-------------------------------------------------------------- ## global tests ## (9*nbasic)..((9*nbasic)+2) ## 1..2: PDL->todense, PDL::CCS::Nd->toccs isok("PDL::todense():no-copy", overload::StrVal($a) eq overload::StrVal($a->todense)); isok("CCS::toccs():no-copy", overload::StrVal($ccs) eq overload::StrVal($ccs->toccs)); done_testing; PDL-CCS-1.24.1/CCS/t/06_matops.t0000644000175000017500000002114614735713775015255 0ustar moocowbovines# -*- Mode: CPerl -*- # t/06_matops.t use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } our ($a, $abad, $agood, $awhich, $avals, $BAD); ##-- common modules use PDL; use PDL::CCS::Nd; ##-------------------------------------------------------------- ## hacks ##-- x1 sub test_matmult2d_sdd { my ($lab,$a,$b,$az) = @_; ##-- dense args $az = $a->toccs if (!defined($az)); my $c = $a x $b; ##-- dense output (desired) my $cz = $az->matmult2d_sdd($b); pdlok("${lab}:matmult2d_sdd:obj:missing=".($az->missing->sclr), $cz, $c); } ##-- x1 sub test_matmult2d_zdd { my ($lab,$a,$b,$az) = @_; ##-- dense args $az = $a->toccs if (!defined($az)); my $c = $a x $b; ##-- dense output (desired) my $cz = $az->matmult2d_zdd($b); pdlok("${lab}:matmult2d_zdd:obj:missing=".($az->missing->sclr), $cz,$c); } ##-- +2*sdd +1*zdd = +3 sub test_matmult2d_all { my ($M,$N,$O) = (2,3,4); my $a = sequence($M,$N); my $b = (sequence($O,$M)+1)*10; test_matmult2d_sdd('m0',$a,$b, $a->toccs); test_matmult2d_zdd('m0',$a,$b, $a->toccs); my $a1 = $a->pdl; $a1->where(($a%2)==0) .= 1; test_matmult2d_sdd('m1',$a,$b, $a->toccs(1)); ##-- test non-missing BAD values (expect warnings from older PDLs which don't support BAD in matmult) $a1 = $a + 1; test_matmult2d_zdd('m0:a-has-bad', $a1->pdl->setvaltobad(1), $b, $a1->toccs(0)->setvaltobad(1)); test_matmult2d_sdd('m0:a-has-bad', $a1->pdl->setvaltobad(1), $b, $a1->toccs(0)->setvaltobad(1)); test_matmult2d_zdd('m0:b-has-bad', $a1, $b->pdl->setvaltobad(20), $a1->toccs(0)); test_matmult2d_sdd('m0:b-has-bad', $a1, $b->pdl->setvaltobad(20), $a1->toccs(0)); } test_matmult2d_all(); ##-- +8 sub test_vcos_zdd { my $a = pdl([[1,2,3,4],[1,2,2,1],[-1,-2,-3,-4]])->xchg(0,1); my $ax = $a->xchg(0,1); my $b = pdl([1,2,3,4]); my $ccs = $a->toccs; ##-- test: vnorm my $anorm0 = $ccs->vnorm(0); my $anorm0_want = ($a**2)->xchg(0,1)->sumover->sqrt; pdlapprox("vnorm(0)", $anorm0, $anorm0_want, 1e-5); ## my $anorm1 = $ccs->vnorm(1); my $anorm1_want = ($a**2)->sumover->sqrt; pdlapprox("vnorm(1)", $anorm1, $anorm1_want, 1e-5); ##-- test: vcos_zdd my $vcos = $ccs->vcos_zdd($b); my $vcos_want = pdl([1,0.8660254,-1]); pdlapprox("vcos_zdd", $vcos, $vcos_want, 1e-4); ## my $b3 = $b->slice(",*3"); my $vcos3 = $ccs->vcos_zdd($b3); pdlapprox("vcos_zdd:threaded", $vcos3, $vcos_want->slice(",*3"), 1e-4); ##-- test: vcos_pzd $vcos = $ccs->vcos_pzd($b->toccs); pdlapprox("vcos_pzd", $vcos, $vcos_want, 1e-4); ##-- test: vcos_zdd: nullvec:a my $a0 = $a->pdl; (my $tmp=$a0->slice("(1),")) .= 0; my $ccs0 = $a0->toccs; my $vcos0 = $ccs0->vcos_zdd($b); my $nan = $^O =~ /MSWin32/i ? ((99**99)**99) - ((99**99)**99) : 'nan'; my $vcos0_want = pdl([1,$nan,-1]); pdlapprox("vcos_zdd:nullvec:a:nan", $vcos0, $vcos0_want, 1e-4); ##-- test: vcos_zdd: nullvec:b my $b0 = $b->zeroes; $vcos0 = $ccs->vcos_zdd($b0); $vcos0_want = pdl([$nan, $nan, $nan]); pdlok("vcos_zdd:nullvec:b:nan", $vcos0, $vcos0_want); ##-- test: vcos_zdd: bad:b my $b1 = $b->pdl->setbadif($b->xvals==2); my $vcos1 = $ccs->vcos_zdd($b1); my $vcos1_want = pdl([0.8366,0.6211,-0.8366]); pdlapprox("vcos_zdd:bad:b", $vcos1, $vcos1_want, 1e-4); } test_vcos_zdd(); ##-------------------------------------------------------------- ## matrix operation test (manual swap) ## + "$as" is $a->toccs($missing_val); ## + always tests ## + for $swap==0 ## $PDL_FUNC->($a,$b) ~ $CCS_FUNC->($as,($b|$bs)) ## ($a OP $b) ~ ($as OP ($bs|$b)) ## + for $swap==1 ## $PDL_FUNC->($b,$a) ~ $CCS_FUNC->($bs,($a|$as)) ## ($b OP $a) ~ ($bs OP ($a|$as)) sub test_matop { my ($lab, $op_name, $op_op, $swap, $missing_val, $a,$abad,$b,$bs) = @_; print "test_matop(lab=$lab, name=$op_name, op=", ($op_op||'NONE'), ", swap=$swap, missing=$missing_val)\n"; my $pdl_func = PDL->can("${op_name}") or die("no PDL method ${op_name} defined!"); my $ccs_func = PDL::CCS::Nd->can("${op_name}") or die("no CCS method PDL::CCS::Nd::${op_name} defined!"); $missing_val = 0 if (!defined($missing_val)); $missing_val = PDL->topdl($missing_val); if ($missing_val->isbad) { $a = $a->setbadif($abad); } else { $a->where($abad) .= $missing_val; $a->badflag(0); } my $as = $a->toccs($missing_val); $b = PDL->topdl($b); $bs = $b->toccs($missing_val) if (!defined($bs)); if ($op_name eq 'matmult') { if ($lab eq 'mat.mat' && $b->ndims > 1 && $b->dim(1) != 1) { ##-- hack: mat.mat $b = $b->xchg(0,1); $bs = $bs->xchg(0,1); } elsif ($lab eq 'mat.rv' && $b->ndims >= 1 && $b->dim(0)==$a->dim(0)) { ##-- hack: mat.rv --> rv.mat ($a,$as, $b,$bs) = ($b,$bs, $a,$as); $b = $b->xchg(0,1); $bs = $bs->xchg(0,1); $swap = 0; } elsif ($lab eq 'mat.cv' && $b->ndims > 1 && $b->dim(0) == 1) { ##-- hack: mat.cv $a = $a->xchg(0,1); $as = $as->xchg(0,1); $swap = 0; } elsif ($lab eq 'rv.cv') { $a = $a->xchg(0,1); $as = $as->xchg(0,1); $b = $b->xchg(0,1); $bs = $bs->xchg(0,1); $swap = 0; } } ##-- test: function syntax my ($c,$css,$csb); if (!$swap) { $pdl_func->($a, $b, $c=null); $css = $ccs_func->($as, $bs); $csb = $ccs_func->($as, $b); } else { $pdl_func->($b, $a, $c=null); $css = $ccs_func->($bs, $as); $csb = $ccs_func->($bs, $a); } ##-- actual test case isok("$lab:${op_name}:func:b=sparse:missing=$missing_val:swap=$swap:type", $css->type, $c->type); pdlok("$lab:${op_name}:func:b=sparse:missing=$missing_val:swap=$swap:vals", $css->decode, $c); isok("$lab:${op_name}:func:b=dense:missing=$missing_val:swap=$swap:type", $c->type, $csb->type); pdlok("$lab:${op_name}:func:b=dense:missing=$missing_val:swap=$swap:vals", $csb->decode, $c); if (defined($op_op)) { if (!$swap) { eval "\$c = (\$a $op_op \$b);"; eval "\$css = (\$as $op_op \$bs);"; eval "\$csb = (\$as $op_op \$b);"; } else { eval "\$c = (\$b $op_op \$a);"; eval "\$css = (\$bs $op_op \$as);"; eval "\$csb = (\$bs $op_op \$a);"; } isok("$lab:${op_name}:op=$op_op:b=sparse:missing=$missing_val:swap=$swap:type", $css->type, $c->type); pdlok("$lab:${op_name}:op=$op_op:b=sparse:missing=$missing_val:swap=$swap:vals", $css->decode, $c); isok("$lab:${op_name}:op=$op_op:b=dense:missing=$missing_val:swap=$swap:type", $csb->type, $c->type); pdlok("$lab:${op_name}:op=$op_op:b=dense:missing=$missing_val:swap=$swap:vals", $csb->decode, $c); } } my @matops = ( ##-- Matrix operations 'inner', [qw(matmult x)], ); #my @missing = (0,127,'BAD'); my @missing = (0); my $b; my @tuples = ( [ 'mat.mat', $a,$abad,$a->flat->rotate(1)->pdl->reshape($a->dims) ], ##-- Block 1 : mat * mat (rotated) [ 'mat.sclr', $a,$abad,PDL->topdl(42) ], ##-- Block 2 : mat * scalar [ 'mat.rv', $a,$abad,sequence($a->dim(0),1)+1, undef, 1 ], ##-- Block 3 : mat * row [ 'mat.cv', $a,$abad,$b=sequence(1,$a->dim(1))+1, $b->flat->toccs->dummy(0,1) ], ##-- Block 4 : mat * col [ 'rv.cv', $a=sequence($a->dim(0),1), ($a==0), $b=sequence(1,$a->dim(1))+1, $b->flat->toccs->dummy(0,1) ], ##-- Block 5 : col * row ); for my $tuple (@tuples) { my ($lab, $a, $abad, $b, $bs, $swap_override) = @$tuple; for my $missing (@missing) { ##-- *NMISSING for my $swap (0,1) { ##-- *NSWAP=2 for my $op (@matops) { ##-- *1 test_matop( $lab, @{ref $op ? $op : [$op, undef]}, (ref $op && $swap_override) ? 1 : $swap, $missing, $a, $abad, $b, $bs ); } } } } ##-------------------------------------------------------------- ## specific tests ##-- matmult with empty row -- https://github.com/moocow-the-bovine/PDL-CCS/issues/14 my $m = identity(3)->set(2,2,0); # [[1,0,0],[0,1,0],[0,0,0]] my $v = zeroes(1,3)->set(0,2,1); # [[0],[0],[1]] pdlok('matmult with empty row', ($m->toccs x $v)->decode, ($m x $v)); ##-- no more type conversion support for null PDLs -- https://github.com/moocow-the-bovine/PDL-CCS/issues/14#issuecomment-2556862635 my $u = zeroes(1, 3); my $z = ones(1, 3); pdlok('u*z all missing', ($u->toccs * $z->toccs)->decode, ($u * $z)); pdlok('z*u all missing', ($z->toccs * $u->toccs)->decode, ($z * $u)); done_testing; PDL-CCS-1.24.1/CCS/t/04_unops.t0000644000175000017500000000427514735713775015120 0ustar moocowbovines# -*- Mode: CPerl -*- # t/04_unops.t use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } our ($a, $abad, $agood, $awhich, $avals, $BAD); ##-- common modules use PDL; use PDL::CCS::Nd; ##-------------------------------------------------------------- ## basic test ##-- i..(i+4): test_unop($unop_name, $unop_op_or_undef, $missing_val) sub test_unop { my ($op_name, $op_op, $missing_val) = @_; print "test_unop($op_name, ", ($op_op||'NONE'), ", $missing_val)\n"; my $pdl_func = PDL->can("${op_name}") or die("no PDL Ufunc ${op_name} defined!"); my $ccs_func = PDL::CCS::Nd->can("${op_name}") or die("no CCS Ufunc PDL::CCS::Nd::${op_name} defined!"); $missing_val = 0 if (!defined($missing_val)); $missing_val = PDL->topdl($missing_val); if ($missing_val->isbad) { $a = $a->setbadif($abad); } else { $a->where($abad) .= $missing_val; $a->badflag(0); } my $ccs = $a->toccs($missing_val); my $dense_rc = $pdl_func->($a); my $ccs_rc = $ccs_func->($ccs); isok("${op_name}:func:missing=$missing_val:type", $ccs_rc->type, $dense_rc->type); pdlok("${op_name}:func:missing=$missing_val:vals", $ccs_rc->decode, $dense_rc); if (defined($op_op)) { eval "\$dense_rc = $op_op \$a"; eval "\$ccs_rc = $op_op \$ccs"; isok("${op_name}:op=$op_op:missing=$missing_val:type", $ccs_rc->type, $dense_rc->type); pdlok("${op_name}:op=$op_op:missing=$missing_val:vals", $ccs_rc->decode, $dense_rc); } else { isok("${op_name}:op=NONE:missing=$missing_val:type (dummy)", 1); isok("${op_name}:op=NONE:missing=$missing_val:vals (dummy)", 1); } } for my $missing (0,1,255,$BAD) { ##-- *4 for my $op ( [qw(bitnot ~)], [qw(not !)], qw(sqrt abs sin cos log log10), 'exp' ##-- *9 ) { if (ref($op)) { test_unop(@$op, $missing); } else { test_unop($op, undef, $missing); } } } done_testing; PDL-CCS-1.24.1/CCS/t/02_indexing.t0000644000175000017500000000614414734512720015536 0ustar moocowbovines# -*- Mode: CPerl -*- # t/02_indexing.t use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::CCS::Nd; use PDL::VectorValued; ##-------------------------------------------------------------- ## missing==0 my $ccs = $a->toccs; ##-- 1: which pdlok("which:flat", $ccs->which->qsort, $a->which->qsort); ##-- 2: index (flat) ------------------> NO PSEUDO-THREADING! my $find = pdl(long(2,4,6,8)); pdlok("index:flat", $ccs->index($find), $a->flat->index($find)); ##-- 3: indexND $find = pdl(long,[[0,0],[1,0],[1,1]]); pdlok("indexND", $ccs->indexND($find), $a->indexND($find)); ##-- 4..5: dice_axis my $axisi = pdl(long,[2,4]); pdlok("dice_axis(0)", $a->dice_axis(0,$axisi), $ccs->dice_axis(0,$axisi)->decode); pdlok("dice_axis(1)", $a->dice_axis(1,$axisi), $ccs->dice_axis(1,$axisi)->decode); ##-- 6..8: at,set my @nzindex = (4,3); my @zindex = (3,1); isok("at():nz", $ccs->at(@nzindex), $a->at(@nzindex)); isok("at:z", $ccs->at(@zindex), $a->at(@zindex)); pdlok("set():nz", $ccs->set(@nzindex,42)->decode, $a->set(@nzindex,42)); ##-- 9..10: reorder pdlok("reorder(1,0)", $ccs->reorder(1,0)->decode, $a->reorder(1,0)); pdlok("post-reorder(1,0):decode", $ccs->decode, $a); ##-- 11..12: xchg(0,1) pdlok("xchg(0,1)", $ccs->xchg(0,1)->decode, $a->xchg(0,1)); pdlok("post-xchg(0,1):decode", $ccs->decode, $a); ##-- 13..14: xchg(0,-1) pdlok("xchg(0,-1)", $ccs->xchg(0,-1)->decode, $a->xchg(0,-1)); pdlok("post-xchg(0,-1):decode", $ccs->decode, $a); ##-- 15..16: mv(0,1) pdlok("mv(0,1)", $ccs->mv(0,1)->decode, $a->mv(0,1)); pdlok("post-mv(0,1):decode", $ccs->decode, $a); ##-- 17..18: mv(1,0) pdlok("mv(1,0)", $ccs->mv(1,0)->decode, $a->mv(1,0)); pdlok("post-mv(1,0):decode", $ccs->decode, $a); ##-- 19..22: xsubset2d my $ai = pdl(long, [1,2,4]); my $bi = pdl(long, [2,4]); my $wnd = $ai->slice("*".$bi->nelem.",")->cat($bi)->clump(2)->xchg(0,1); my $abi = $wnd->vsearchvec($ccs->_whichND); my $abi_mask = ($wnd==$ccs->_whichND->dice_axis(1,$abi))->andover; $abi = $abi->where($abi_mask); my $absub = $ccs->xsubset2d($ai,$bi); isok("xsubset2d:defined", defined($absub)); pdlok("xsubset2d:which", $absub->_whichND, $ccs->_whichND->dice_axis(1,$abi)); pdlok("xsubset2d:nzvals", $absub->_nzvals, $ccs->_nzvals->index($abi)); pdlok("xsubset2d:missing", $absub->missing, $ccs->missing); ##-- 23..24: xsubset1d my $xi = pdl(long, [0,2]); my $sub1 = $ccs->xsubset1d($xi); isok("xsubset1d:defined", defined($sub1)); pdlok("xsubset1d:vals", $sub1->decode->dice_axis(0,$xi), $a->dice_axis(0,$xi)); ##-- 25..26: pxsubset1d my $yi = pdl(long, [1,3]); my $sub2 = $ccs->pxsubset1d(1,$yi); isok("pxsubset1d:defined", defined($sub2)); pdlok("pxsubset1d:vals", $sub2->decode->dice_axis(1,$yi), $a->dice_axis(1,$yi)); done_testing; PDL-CCS-1.24.1/CCS/t/03_ufuncs.t0000644000175000017500000000704614735713775015255 0ustar moocowbovines# -*- Mode: CPerl -*- # t/03_ufuncs.t use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } our ($a, $abad, $agood, $awhich, $avals, $BAD); ##-- common modules use PDL; use PDL::CCS::Nd; ##-------------------------------------------------------------- ## ufunc test ##-- i..(i+2): test_ufunc($ufunc_name, $missing_val) sub test_ufunc { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($ufunc_name, $missing_val) = @_; print "test_ufunc($ufunc_name, $missing_val)\n"; my $pdl_ufunc = PDL->can("${ufunc_name}") or die("no PDL Ufunc ${ufunc_name} defined!"); my $ccs_ufunc = PDL::CCS::Nd->can("${ufunc_name}") or die("no CCS Ufunc PDL::CCS::Nd::${ufunc_name} defined!"); $missing_val = 0 if (!defined($missing_val)); $missing_val = PDL->topdl($a->type, $missing_val); if ($missing_val->isbad) { $a = $a->setbadif($abad); } else { $a->where($abad) .= $missing_val; $a->badflag(0); } ##-- sorting with bad values doesn't work right in PDL-2.015 ; ccs/vv sorts BAD as minimal, PDL sort BAD as maximal: wtf? if ($ufunc_name =~ /qsort/ && $missing_val->isbad) { my $inf = $^O =~ /MSWin32/i ? (99**99)**99 : 'inf'; $missing_val = PDL->topdl($inf); $a->inplace->setbadtoval($inf); } my $ccs = $a->toccs($missing_val->convert($a->type)); $ccs->_whichND($ccs->_whichND->ccs_indx()) if ($ccs->_whichND->type != PDL::ccs_indx()); my $dense_rc = $pdl_ufunc->($a); my $ccs_rc = $ccs_ufunc->($ccs); if ($ufunc_name =~ /_ind$/) { ##-- hack: adjust $dense_rc for maximum_ind, minimum_ind $dense_rc->where( $a->index2d($dense_rc,sequence($a->dim(1))) == $missing_val ) .= indx(-1); } elsif ($ufunc_name =~ /qsorti$/) { ##-- hack: adjust $dense_rc for qsorti() my $ccs_mask = $dense_rc->zeroes; $ccs_mask->indexND( scalar($ccs_rc->whichND) ) .= indx(1); $dense_rc->where( $ccs_mask->not ) .= $ccs_rc->missing; } my $label = "${ufunc_name}:missing=$missing_val"; ##-- check output type SKIP: { isok("${label}:type", $ccs_rc->type, $dense_rc->type) or diag "ccs_rc(", $ccs_rc->info, ")=$ccs_rc\n", "dense_rc(", $dense_rc->info, ")=$dense_rc\n"; } ##-- check output values SKIP: { ##-- RT bug #126294 (see also analogous tests in CCS/Ufunc/t/01_ufunc.t) skip("RT #126294 - PDL::borover() appears to be broken", 1) if ($label eq 'borover:missing=BAD' && pdl([10,0,-2])->setvaltobad(0)->borover->sclr != -2); pdlok("${label}:vals", $ccs_rc->decode, $dense_rc); } } ##-------------------------------------------------------------- ## generic tests for my $missing (0,1,255,$BAD) { ##-- *4 for my $ufunc ( qw(sumover prodover dsumover dprodover), ## *17 qw(andover orover bandover borover), qw(maximum minimum), qw(maximum_ind minimum_ind), qw(nbadover ngoodover), #nnz qw(average), qw(qsort qsorti) ) { test_ufunc($ufunc,$missing); } } ##-------------------------------------------------------------- ## specific tests ##-- sumover empty nzValsIn: https://github.com/moocow-the-bovine/PDL-CCS/issues/14 my $pdl = zeroes(3,1,3); pdlok("sumover(empty)", $pdl->toccs->sumover->decode, $pdl->sumover); done_testing; PDL-CCS-1.24.1/CCS/t/common.plt0000644000175000017500000000126414054377273015261 0ustar moocowbovines# -*- Mode: CPerl -*- # File: CCS/t/common.plt # Description: common subs & data for PDL/CCS/t/*.t ##-- common subs BEGIN { use File::Basename; use Cwd; my $topdir = Cwd::abs_path(dirname(__FILE__)."/../.."); do "$topdir/t/common.plt" or die("$0: failed to load $topdir/t/common.plt: $@"); } ##-- common modules use PDL; #-- common data our $a = pdl(double, [ [10,0,0,0,-2], [3,9,0,0,0], [0,7,8,6,0], [3,0,8,7,5], [0,8,0,9,7], [0,4,0,0,2], ]); our $abad = ($a==0); our $agood = !$abad; our $awhich = $a->whichND; our $avals = $a->indexND($awhich); our $BAD = pdl(0)->setvaltobad(0); print "loaded ", __FILE__, "\n"; 1; PDL-CCS-1.24.1/CCS/t/05_binops.t0000644000175000017500000001534214735713775015244 0ustar moocowbovines# -*- Mode: CPerl -*- # t/05_binops.t use Test::More; use strict; use warnings; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(../.. ..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } our ($a, $abad, $agood, $awhich, $avals, $BAD); ##-- common modules use PDL; use PDL::CCS::Nd; ##-------------------------------------------------------------- ## basic test ##-- i..(i+8): test_binop($label, $binop_name, $binop_op_or_undef, $swap, $missing_val, $b,$bs) ## + globals "$a" and "$abad" must always be defined ## + "$as" is $a->toccs($missing_val); ## + always tests $PDL_FUNC->($a,$b,$swap) ~ $CCS_FUNC->($as,($b|$bs),$swap) ## + tests ($a OP $b) ~ ($as OP $(bs|b)) for $swap==0 ## + tests ($b OP $a) ~ ($bs OP $(as|a)) for $swap==1 sub test_binop { my ($lab, $op_name, $op_op, $swap, $missing_val, $b,$bs) = @_; print "test_binop(name=$op_name, op=", ($op_op||'NONE'), ", swap=$swap, missing=$missing_val)\n"; my $pdl_func = PDL->can("${op_name}") or die("no PDL Ufunc ${op_name} defined!"); my $ccs_func = PDL::CCS::Nd->can("${op_name}") or die("no CCS Ufunc PDL::CCS::Nd::${op_name} defined!"); $missing_val = 0 if (!defined($missing_val)); $missing_val = PDL->topdl($missing_val); if ($missing_val->isbad) { $a = $a->setbadif($abad); } else { ##-- the .= line failes under debugger for perl<5.15.1 with: ## : Can't return a temporary from lvalue subroutine at /home/moocow/work/diss/perl/PDL-CCS/CCS/t/05_binops.t line $LINE_NUMBER ## + workaround: assgn($missing_val, $a->where($abad)); ## + ... but that's a serious PITA for runtime debugging ## + see https://rt.perl.org/rt3/Public/Bug/Display.html?id=71172 for a perl patch $a->where($abad) .= $missing_val; $a->badflag(0); } $b = PDL->topdl($b); my $as = $a->toccs($missing_val); $bs = $b->toccs($missing_val) if (!defined($bs)); ##-- test: function syntax my $dense_rc = $pdl_func->($a, $b, $swap); my $ccs_bs = $ccs_func->($as, $bs, $swap); my $ccs_b = $ccs_func->($as, $b, $swap); isok("$lab:${op_name}:func:b=sparse:missing=$missing_val:swap=$swap:type", $ccs_bs->type, $dense_rc->type); pdlok("$lab:${op_name}:func:b=sparse:missing=$missing_val:swap=$swap:nzvals", $ccs_bs->_nzvals, $dense_rc->indexND($ccs_bs->_whichND)); isok("$lab:${op_name}:func:b=dense:missing=$missing_val:swap=$swap:type", $ccs_b->type, $dense_rc->type); pdlok("$lab:${op_name}:func:b=dense:missing=$missing_val:swap=$swap:nzvals", $ccs_b->_nzvals, $dense_rc->indexND($ccs_b->_whichND)); if (defined($op_op)) { if (!$swap) { eval "\$dense_rc = (\$a $op_op \$b);"; eval "\$ccs_bs = (\$as $op_op \$bs);"; eval "\$ccs_b = (\$as $op_op \$b);"; } else { eval "\$dense_rc = (\$b $op_op \$a);"; eval "\$ccs_bs = (\$bs $op_op \$as);"; eval "\$ccs_b = (\$bs $op_op \$a);"; } isok("$lab:${op_name}:op=$op_op:b=sparse:missing=$missing_val:swap=$swap:type", $ccs_bs->type, $dense_rc->type); pdlok("$lab:${op_name}:op=$op_op:b=sparse:missing=$missing_val:swap=$swap:nzvals", $ccs_bs->_nzvals, $dense_rc->indexND(scalar $ccs_bs->_whichND)); isok("$lab:${op_name}:op=$op_op:b=dense:missing=$missing_val:swap=$swap:type", $ccs_b->type, $dense_rc->type); pdlok("$lab:${op_name}:op=$op_op:b=dense:missing=$missing_val:swap=$swap:nzvals", $ccs_b->_nzvals, $dense_rc->indexND(scalar $ccs_b->_whichND)); } else { isok("$lab:${op_name}:op=NONE:b=sparse:missing=$missing_val:swap=$swap:type (dummy)", 1); isok("$lab:${op_name}:op=NONE:b=sparse:missing=$missing_val:swap=$swap:vals (dummy)", 1); isok("$lab:${op_name}:op=NONE:b=dense:missing=$missing_val:swap=$swap:type (dummy)", 1); isok("$lab:${op_name}:op=NONE:b=dense:missing=$missing_val:swap=$swap:vals (dummy)", 1); } } my @binops = ( ##-- *20 ##-- Arithmetic ['plus','+'], ['minus','-'], ['mult','*'], ['divide','/'], ['modulo','%'], ['power','**'], ##-- Comparisons [qw(gt >)], [qw(lt <)], [qw(ge >=)], [qw(le <=)], [qw(eq ==)], [qw(ne !=)], [qw(spaceship <=>)], ##-- Logical & bitwise [qw(and2 &)], [qw(or2 |)], [qw(xor ^)], [qw(shiftleft <<)], [qw(shiftright >>)], ); my ($b); ##-- Block 1 : mat * mat $b = $a->flat->rotate(1)->pdl->reshape($a->dims); ##-- extra pdl() before reshape() avoids realloc() crashes in PDL-2.0.14 for my $missing (0,127,$BAD) { ##-- *3 for my $swap (0,1) { ##-- *2 for my $op (@binops) { ##-- *NBINOPS if (ref($op)) { test_binop('mat.mat', $op->[0], $op->[1], $swap, $missing, $b); } else { test_binop('mat.mat', $op, undef, $swap, $missing, $b); } } } } ##-- Block 2 : mat * scalar $b = PDL->topdl(42); for my $missing (0,127,$BAD) { ##-- *3 for my $swap (0,1) { ##-- *2 for my $op (@binops) { ##-- *NBINOPS if (ref($op)) { test_binop('mat.sclr', $op->[0], $op->[1], $swap, $missing, $b); } else { test_binop('mat.sclr', $op, undef, $swap, $missing, $b); } } } } ##-- Block 3 : mat * row $b = sequence($a->dim(0))+1; for my $missing (0,127,$BAD) { ##-- *3 for my $swap (0,1) { ##-- *2 for my $op (@binops) { ##-- *NBINOPS if (ref($op)) { test_binop('mat.rv', $op->[0], $op->[1], $swap, $missing, $b); } else { test_binop('mat.rv', $op, undef, $swap, $missing, $b); } } } } ##-- Block 4 : mat * col $b = sequence(1,$a->dim(1))+1; my $bs = $b->flat->toccs->dummy(0,1); for my $missing (0,127,$BAD) { ##-- *3 for my $swap (0,1) { ##-- *2 for my $op (@binops) { ##-- *NBINOPS if (ref($op)) { test_binop('mat.cv', $op->[0], $op->[1], $swap, $missing, $b,$bs); } else { test_binop('mat.cv', $op, undef, $swap, $missing, $b,$bs); } } } } ##-- Block 5 : col * row my @save = ($a,$abad); $b = sequence(1,$a->dim(1))+1; $bs = $b->flat->toccs->dummy(0,1); $a = sequence($a->dim(0),1); $abad = ($a==0); for my $missing (0,127,$BAD) { ##-- *3 for my $swap (0,1) { ##-- *2 for my $op (@binops) { ##-- *NBINOPS if (ref($op)) { test_binop('rv.cv', $op->[0], $op->[1], $swap, $missing, $b,$bs); } else { test_binop('rv.cv', $op, undef, $swap, $missing, $b,$bs); } } } } done_testing; PDL-CCS-1.24.1/CCS/Version.pm0000644000175000017500000000034714736165363014773 0ustar moocowbovines## File: PDL::CCS::Version.pm ## Author: Bryan Jurish ## Description: set version for PDL::CCS package PDL::CCS::Version; our $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module 1; ##-- make perl happy PDL-CCS-1.24.1/CCS/Ops/0000755000175000017500000000000014736165776013555 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/Ops/ccsops.pd0000644000175000017500000002131214736165363015363 0ustar moocowbovines##-*- Mode: CPerl -*- ##====================================================================== ## Header Administrivia ##====================================================================== use PDL::VectorValued::Dev; my $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module pp_setversion($VERSION); ##------------------------------------------------------ ## pm headers pp_addpm({At=>'Top'},<<'EOPM'); #use PDL::CCS::Version; use strict; =pod =head1 NAME PDL::CCS::Ops - Low-level binary operations for compressed storage sparse PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::Utils; ##--------------------------------------------------------------------- ## ... stuff happens =cut EOPM ## /pm additions ##------------------------------------------------------ ##------------------------------------------------------ ## Exports: None #pp_export_nothing(); ##------------------------------------------------------ ## Includes / defines pp_addhdr(<<'EOH'); EOH ##------------------------------------------------------ ## index datatype require "../Config.pm"; our $INDX = $PDL::CCS::Config::ccsConfig{INDX_SIG}; pp_addpm( $PDL::CCS::Config::ccsConfig{INDX_FUNCDEF} ); pp_addhdr( $PDL::CCS::Config::ccsConfig{INDX_TYPEDEF} ); ##====================================================================== ## C Utilities ##====================================================================== # (none) ##====================================================================== ## PDL::PP Wrappers ##====================================================================== ##====================================================================== ## Operations: Binary: ALIGN: missing-is-annihilator ##====================================================================== vvpp_def ('ccs_binop_align_block_mia', Pars => ("\n " .join("\n ", "$INDX\ ixa(Ndims,NnzA); $INDX\ ixb(Ndims,NnzB); $INDX\ istate(State);", "$INDX\ [o]nzai(NnzC); $INDX\ [o]nzbi(NnzC); $INDX\ [o]ostate(State);", '')), Code => (q( CCS_Indx sizeNnzA=$SIZE(NnzA), sizeNnzB=$SIZE(NnzB), sizeNnzC=$SIZE(NnzC); CCS_Indx nnzai=0, nnzbi=0,nnzbi0, nnzci=0, nnzai_nxt=0,nnzbi_nxt=0,nnzci_nxt=0; CCS_Indx cmpme1,cmpme2; int cmpval=0; // //-- initialize: parse istate() [ nnzai,nnzai_nxt, nnzbi,nnzbi_nxt, nnzci,nnzci_nxt, cmpval ] if ($SIZE(State) >= 7) { nnzai = $istate(State=>0); nnzai_nxt = $istate(State=>1); nnzbi = $istate(State=>2); nnzbi_nxt = $istate(State=>3); nnzci = $istate(State=>4); nnzci_nxt = $istate(State=>5); cmpval = $istate(State=>6); } // //-- main loop: start at current nnzai,nnzbi,nnzci for ( ; nnzai (ixa(,ai) . -1) ); INCR(ai); //-- increment ai: detect next run-length for (nnzai=nnzai_nxt, nnzai_nxt=nnzai+1; nnzai_nxtnnzai)','$ixa(NnzA=>nnzai_nxt)','Ndims','cmpval',var1=>'cmpme1',var2=>'cmpme2'); if (cmpval != 0) break; } } else if (cmpval > 0) { //-- CASE ixa(,ai) > ixb(,bi) : INSERT ( ixb(,bi) => (-1 . ixb(,bi)) ); INCR(bi); //-- increment bi: detect next run-length for (nnzbi=nnzbi_nxt, nnzbi_nxt=nnzbi+1; nnzbi_nxtnnzbi)','$ixb(NnzB=>nnzbi_nxt)','Ndims','cmpval',var1=>'cmpme1',var2=>'cmpme2'); if (cmpval != 0) break; } } else { //-- CASE ixa(,ai) == ixb(,bi) : INSERT ( ixa(,ai) => (ixa(,ai) . ixb(,bi)) ); INCR(ai); INCR(bi); for (nnzbi0=nnzbi; nnzainnzci) = nnzai; $nzbi(NnzC=>nnzci) = nnzbi; } } //-- increment ai,bi: detect next run-lengths for (nnzai_nxt=nnzai+1; nnzai_nxtnnzai)','$ixa(NnzA=>nnzai_nxt)','Ndims','cmpval',var1=>'cmpme1',var2=>'cmpme2'); if (cmpval != 0) break; } for (nnzbi_nxt=nnzbi+1; nnzbi_nxtnnzbi)','$ixb(NnzB=>nnzbi_nxt)','Ndims','cmpval',var1=>'cmpme1',var2=>'cmpme2'); if (cmpval != 0) break; } } // //-- compare current index-run values $CMPVEC('$ixa(NnzA=>nnzai)','$ixb(NnzB=>nnzbi)','Ndims','cmpval',var1=>'cmpme1',var2=>'cmpme2'); if (cmpval < 0) { nnzci_nxt = nnzci + (nnzai_nxt-nnzai); } else if (cmpval > 0) { nnzci_nxt = nnzci + (nnzbi_nxt-nnzbi); } else { nnzci_nxt = nnzci + (nnzai_nxt-nnzai)*(nnzbi_nxt-nnzbi); } } //-- end main loop // //-- gobble leftovers if (nnzci_nxt < sizeNnzC) { nnzai = nnzai_nxt = sizeNnzA; nnzbi = nnzbi_nxt = sizeNnzB; nnzci_nxt = nnzci; } // //-- save state if ($SIZE(State) >= 7) { $ostate(State=>0) = nnzai; $ostate(State=>1) = nnzai_nxt; $ostate(State=>2) = nnzbi; $ostate(State=>3) = nnzbi_nxt; $ostate(State=>4) = nnzci; $ostate(State=>5) = nnzci_nxt; $ostate(State=>6) = cmpval; } )), Doc => (q{ Partially aligns a pair of lexicographically sorted index-vector lists C<$ixa()> and C<$ixb()>, e.g. for block-wise incremental computation of binary operations over sparse index-encoded PDLs, assuming missing indices correspond to annihilators. On return, the vectors C<$nzai> and C<$nzbi> hold indices into C and C respectively, and are constructed such that: ($ixa(,$nzai->slice("0:$nzci_max")) == $ixb(,$nzbi->slice("0:$nzci_max")) At most C alignments are performed, and alignment ceases as soon as any of the PDLs C<$ixa()>, C<$ixb()>, C<$nzai()>, or C<$nzbi()> has been exhausted. The parameters C<$istate()> and C<$ostate()> hold the state of the algorithm, for incremental block-wise computation at the perl level. Each state PDL is a 7-element PDL containing the following values: INDEX LABEL DESCRIPTION ----------------------------------------------------------------------- 0 nnzai minimum offset in NnzA of current $ixa() value 1 nnzai_nxt minimum offset in NnzA of next $ixa() value 2 nnzbi minimum offset in NnzB of current $ixb() value 3 nnzbi_nxt minimum offset in NnzB of next $ixb() value 4 nnzci minimum offset in NnzC of current ($ixa(),$ixb()) value pair 5 nnzci_nxt minimum offset in NnzC of next ($ixa(),$ixb()) value pair 6 cmpval 3-way comparison value for current ($ixa(),$ixb()) value pair For computation of the first block, $istate() can be safely set to C. Repetitions may occur in input index PDLs C<$ixa()> and C<$ixb()>. If an index-match occurs on such a "run", I of matching values are added to the output PDLs. All alignments have been performed if: $ostate(0)==$NnzA && $ostate(1)==$NnzB B this alignment method ignores index-vectors which are not present in I C<$ixa()> and C<$ixb()>, which is a Good Thing if your are feeding the aligned values into an operation for which missing values are annihilators: $missinga * $bval == ($missinga * $missingb) for each $bval \in $b, and $aval * $missingb == ($missinga * $missingb) for each $aval \in $a This ought to be the case for all operations if missing values are C (see L), but might cause unexpected results if e.g. missing values are zero and the operation in question is addition. }), ); ##--/ccs_binop_align_block_mia ##====================================================================== ## Footer Administrivia ##====================================================================== ##------------------------------------------------------ ## pm additions: footer pp_addpm(<<'EOPM'); ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS No support for (pseudo)-threading. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy All other parts Copyright (C) 2007-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl) =cut EOPM # Always make sure that you finish your PP declarations with # pp_done pp_done(); ##---------------------------------------------------------------------- PDL-CCS-1.24.1/CCS/Ops/Makefile.PL0000644000175000017500000000126514734467507015526 0ustar moocowbovinesuse PDL::Core::Dev; use ExtUtils::MakeMaker; PDL::Core::Dev->import(); require "../../pdlmaker.plm"; $package = ["ccsops.pd", 'Ops', 'PDL::CCS::Ops']; %hash = pdlmaker_init($package); $hash{AUTHOR} = 'Bryan Jurish'; $hash{ABSTRACT} = 'Low-level binary operations for compressed storage sparse PDLs'; $hash{VERSION_FROM} = '../../CCS.pm'; $hash{LICENSE} = 'perl'; $hash{PREREQ_PM}{PDL} = $hash{CONFIGURE_REQUIRES}{PDL} = 0; push(@{$hash{LIBS}}, '-lm'); $hash{DIR} = []; #$hash{INC} .= ''; #$hash{OBJECT} .= ''; $hash{realclean}{FILES} .= '*~ *.tmp README.txt'; #my $pmfile = $package[0]; #$pmfile =~ s/\.pd$/\.pm/; #$hash{PM}{$pmfile} = "\$(INST_LIBDIR)/CCS/$pmfile"; WriteMakefile(%hash); PDL-CCS-1.24.1/CCS/Ops/Ops.pm0000644000175000017500000001104514736165722014644 0ustar moocowbovines# # GENERATED WITH PDL::PP! Don't modify! # package PDL::CCS::Ops; our @EXPORT_OK = qw(ccs_binop_align_block_mia ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our $VERSION = '1.24.1'; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::CCS::Ops $VERSION; #line 13 "ccsops.pd" #use PDL::CCS::Version; use strict; =pod =head1 NAME PDL::CCS::Ops - Low-level binary operations for compressed storage sparse PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::Utils; ##--------------------------------------------------------------------- ## ... stuff happens =cut #line 46 "Ops.pm" =head1 FUNCTIONS =cut #line 51 "ccsops.pd" *ccs_indx = \&PDL::indx; ##-- typecasting for CCS indices (deprecated) #line 63 "Ops.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_binop_align_block_mia =for sig Signature: ( indx ixa(Ndims,NnzA); indx ixb(Ndims,NnzB); indx istate(State); indx [o]nzai(NnzC); indx [o]nzbi(NnzC); indx [o]ostate(State); ) Partially aligns a pair of lexicographically sorted index-vector lists C<$ixa()> and C<$ixb()>, e.g. for block-wise incremental computation of binary operations over sparse index-encoded PDLs, assuming missing indices correspond to annihilators. On return, the vectors C<$nzai> and C<$nzbi> hold indices into C and C respectively, and are constructed such that: ($ixa(,$nzai->slice("0:$nzci_max")) == $ixb(,$nzbi->slice("0:$nzci_max")) At most C alignments are performed, and alignment ceases as soon as any of the PDLs C<$ixa()>, C<$ixb()>, C<$nzai()>, or C<$nzbi()> has been exhausted. The parameters C<$istate()> and C<$ostate()> hold the state of the algorithm, for incremental block-wise computation at the perl level. Each state PDL is a 7-element PDL containing the following values: INDEX LABEL DESCRIPTION ----------------------------------------------------------------------- 0 nnzai minimum offset in NnzA of current $ixa() value 1 nnzai_nxt minimum offset in NnzA of next $ixa() value 2 nnzbi minimum offset in NnzB of current $ixb() value 3 nnzbi_nxt minimum offset in NnzB of next $ixb() value 4 nnzci minimum offset in NnzC of current ($ixa(),$ixb()) value pair 5 nnzci_nxt minimum offset in NnzC of next ($ixa(),$ixb()) value pair 6 cmpval 3-way comparison value for current ($ixa(),$ixb()) value pair For computation of the first block, $istate() can be safely set to C. Repetitions may occur in input index PDLs C<$ixa()> and C<$ixb()>. If an index-match occurs on such a "run", I of matching values are added to the output PDLs. All alignments have been performed if: $ostate(0)==$NnzA && $ostate(1)==$NnzB B this alignment method ignores index-vectors which are not present in I C<$ixa()> and C<$ixb()>, which is a Good Thing if your are feeding the aligned values into an operation for which missing values are annihilators: $missinga * $bval == ($missinga * $missingb) for each $bval \in $b, and $aval * $missingb == ($missinga * $missingb) for each $aval \in $a This ought to be the case for all operations if missing values are C (see L), but might cause unexpected results if e.g. missing values are zero and the operation in question is addition. =for bad ccs_binop_align_block_mia does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 138 "Ops.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_binop_align_block_mia = \&PDL::ccs_binop_align_block_mia; #line 145 "Ops.pm" #line 220 "ccsops.pd" ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS No support for (pseudo)-threading. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy All other parts Copyright (C) 2007-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl) =cut #line 193 "Ops.pm" # Exit with OK status 1; PDL-CCS-1.24.1/CCS/Functions.pm0000644000175000017500000002453014736165363015316 0ustar moocowbovines## File: PDL::CCS::Functions.pm ## Author: Bryan Jurish ## Description: useful perl-level functions for PDL::CCS package PDL::CCS::Functions; use PDL::CCS::Config qw(ccs_indx); use PDL::CCS::Utils; use PDL::VectorValued; use PDL; use strict; my @ccs_binops = qw( plus minus mult divide modulo power gt ge lt le eq ne spaceship and2 or2 xor shiftleft shiftright ); our $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module our @ISA = ('PDL::Exporter'); our @EXPORT_OK = ( ## ##-- Decoding qw(ccs_decode), #ccs_pointerlen ## ##-- Vector Operations (compat) qw(ccs_binop_vector_mia), (map "ccs_${_}_vector_mia", @ccs_binops), ## ##-- qsort qw(ccs_qsort), ); our %EXPORT_TAGS = ( Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully) ); ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS::Functions - Useful perl-level functions for PDL::CCS =head1 SYNOPSIS use PDL; use PDL::CCS::Functions; ##--------------------------------------------------------------------- ## ... stuff happens =cut ##====================================================================== ## Decoding =pod =head1 Decoding =cut ##-- DEPRECATED STEALTH METHOD: formerly a PDL::PP function in PDL::CCS::Utils #*PDL::ccs_pointerlen = \&ccs_pointerlen; sub ccs_pointerlen :lvalue { my ($ptr,$len) = @_; if (!defined($len)) { $len = $ptr->slice("1:-1") - $ptr->slice("0:-2"); } else { $len .= $ptr->slice("1:-1"); $len -= $ptr->slice("0:-2"); } return $len; } ##--------------------------------------------------------------- ## Decoding: generic =pod =head2 ccs_decode =for sig Signature: (indx whichnd(Ndims,Nnz); nzvals(Nnz); missing(); \@Dims; [o]a(@Dims)) Decode a CCS-encoded matrix (no dataflow). =cut ;#-- emacs *PDL::ccs_decode = \&ccs_decode; sub ccs_decode :lvalue { my ($aw,$nzvals,$missing,$dims,$a) = @_; $missing = $PDL::undefval if (!defined($missing)); if (!defined($dims)) { barf("PDL::CCS::ccs_decode(): whichnd() is empty; you must specify \@Dims!") if ($aw->isempty); $dims = [ map {$aw->slice("($_),")->max+1} (0..($aw->dim(0)-1))]; } $a = zeroes($nzvals->type, @$dims) if (!defined($a)); $a .= $missing; (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) ##-- workaround for missing empty pdl support in PDL 2.4.10 release candidates (pdl bug #3462924), fixed in 2.4.9_993 #$a->indexND($aw) .= $nzvals if (!$nzvals->isempty); #if (!$nzvals->isempty) { # my $tmp = $a->indexND($aw); # $tmp .= $nzvals; #} return $a; } ##====================================================================== ## Scalar Operations =pod =head1 Scalar Operations Scalar operations can be performed in parallel directly on C<$nzvals> (and if applicable on C<$missing> as well): $c = 42; $nzvals2 = $nzvals + $c; $missing2 = $missing + $c; $nzvals2 = $nzvals - $c; $missing2 = $missing - $c; $nzvals2 = $nzvals * $c; $missing2 = $missing * $c; $nzvals2 = $nzvals / $c; $missing2 = $missing / $c; $nzvals2 = $nzvals ** $c; $missing2 = $missing ** $c; $nzvals2 = log($nzvals); $missing2 = log($missing); $nzvals2 = exp($nzvals); $missing2 = exp(missing); $nzvals2 = $nzvals->and2($c,0); $missing2 = $missing->and($c,0); $nzvals2 = $nzvals->or2($c,0); $missing2 = $missing->or2($c,0); $nzvals2 = $nzvals->not(); $missing2 = $missing->not(); Nothing prevents scalar operations from producing new "missing" values (e.g. $nzvals*0), so you might want to re-encode your compressed data after applying the operation. =cut ##====================================================================== ## Vector Operations =pod =head1 Vector Operations =head2 ccs_OP_vector_mia =for sig Signature: (indx whichDimV(Nnz); nzvals(Nnz); vec(V); [o]nzvals_out(Nnz)) A number of row- and column-vector operations may be performed directly on encoded Nd-PDLs, without the need for decoding to a (potentially huge) dense temporary. These operations assume that "missing" values are annihilators with respect to the operation in question, i.e. that it holds for all C<$x> in C<$vec> that: ($missing __OP__ $x) == $missing This is in line with the usual PDL semantics if your C<$missing> value is C, but may produce unexpected results when e.g. adding a vector to a sparse PDL with C<$missing>==0. If you really need to do something like the latter, then you're probably better off decoding to a dense PDL anyway. Predefined function names for encoded-PDL vector operations are all of the form: C, where ${OPNAME} is the base name of the operation: plus ##-- addition minus ##-- subtraction mult ##-- multiplication (NOT matrix-multiplication) divide ##-- division modulo ##-- modulo power ##-- potentiation gt ##-- greater-than ge ##-- greater-than-or-equal lt ##-- less-than le ##-- less-than-or-equal eq ##-- equality ne ##-- inequality spaceship ##-- 3-way comparison and2 ##-- binary AND or2 ##-- binary OR xor ##-- binary XOR shiftleft ##-- left-shift shiftright ##-- right-shift =head2 \&CODE = ccs_binop_vector_mia($opName, \&PDLCODE); Returns a generic vector-operation subroutine which reports errors as C<$opName> and uses \&PDLCODE to perform underlying computation. =cut ##====================================================================== ## Vector Operations: Generic *PDL::ccs_binop_vector_mia = \&ccs_binop_vector_mia; sub ccs_binop_vector_mia { my ($opName,$pdlCode) = @_; return sub :lvalue { my ($wi, $nzvals_in, $vec) = @_; my $tmp = $pdlCode->($nzvals_in, $vec->index($wi), 0); # $tmp for perl -d }; } for (@ccs_binops) { no strict 'refs'; *{"PDL::ccs_${_}_vector_mia"} = *{"ccs_${_}_vector_mia"} = ccs_binop_vector_mia($_, PDL->can($_)); } ##====================================================================== ## Sorting =pod =head1 Sorting =head2 ccs_qsort =for sig Signature: (indx which(Ndims,Nnz); nzvals(Nnz); missing(); Dim0(); indx [o]nzix(Nnz); indx [o]nzenum(Nnz)) Underlying guts for PDL::CCS::Nd::qsort() and PDL::CCS::Nd::qsorti(). Given a set of $Nnz items $i each associated with a vector-key C<$which(:,$i)> and a value C<$nzvals($i)>, returns a vector of $Nnz item indices C<$nzix()> such that C<$which(:,$nzix)> is vector-sorted in ascending order and C<$nzvals(:,$nzix)> are sorted in ascending order for each unique key-vector in C<$which()>, and an enumeration C<$nzenum()> of items for each unique key-vector in terms of the sorted data: C<$nzenum($j)> is the logical position of the item C<$nzix($j)>. If C<$missing> and C<$Dim0> are defined, items C<$i=$nzix($j)> with values C<$nzvals($i) E $missing> will be logically enumerated at the end of the range [0,$Dim0-1] and there will be a gap between C<$nzenum()> values for a C<$which()>-key with fewer than $Dim0 instances; otherwise $nzenum() values will be enumerated in ascending order starting from 0. For an unsorted index+value dataset C<($which0,$nzvals0)> with ($nzix,$nzenum) = ccs_qsort($which0("1:-1,"),$nzvals0,$missing,$which0("0,")->max+1) qsort() can be implemented as: $which = $nzenum("*1,")->glue(0,$which0("1:-1,")->dice_axis(1,$nzix)); $nzvals = $nzvals0->index($nzix); and qsorti() as: $which = $nzenum("*1,")->glue(0,$which0("1:-1,")->dice_axis(1,$nzix)); $nzvals = $which0("(0),")->index($nzix); =cut ## $bool = _checkdims(\@dims1,\@dims2,$label); ##-- match @dims1 ~ @dims2 ## $bool = _checkdims( $pdl1, $pdl2,$label); ##-- match $pdl1->dims ~ $pdl2->dims sub _checkdims { #my ($dims1,$dims2,$label) = @_; #my ($pdl1,$pdl2,$label) = @_; my $d0 = UNIVERSAL::isa($_[0],'PDL') ? pdl(ccs_indx(),$_[0]->dims) : pdl(ccs_indx(),$_[0]); my $d1 = UNIVERSAL::isa($_[1],'PDL') ? pdl(ccs_indx(),$_[1]->dims) : pdl(ccs_indx(),$_[0]); barf(__PACKAGE__ . "::_checkdims(): dimension mismatch for ".($_[2]||'pdl').": $d0!=$d1") if (($d0->nelem!=$d1->nelem) || !all($d0==$d1)); return 1; } sub ccs_qsort { my ($which,$nzvals, $missing,$dim0, $nzix,$nzenum) = @_; ##-- prepare: $nzix $nzix = zeroes(ccs_indx(),$nzvals->dims) if (!defined($nzix)); $nzix->reshape($nzvals) if ($nzix->isempty); _checkdims($nzvals,$nzix,'ccs_qsort: nzvals~nzix'); ## ##-- prepare: $nzenum $nzenum = zeroes(ccs_indx(),$nzvals->dims) if (!defined($nzenum)); $nzenum->reshape($nzvals) if ($nzenum->isempty); _checkdims($nzenum,$nzvals,'ccs_qsort: nzvals~nzenum'); ##-- collect and sort base data (unsorted indices + values) my $vdata = $which->glue(0,$nzvals->slice("*1,")); $vdata->vv_qsortveci($nzix); ##-- get logical enumeration if (!defined($missing) || !defined($dim0)) { ##-- ... flat enumeration $which->dice_axis(1,$nzix)->enumvec($nzenum); } else { ##-- ... we have $missing and $dim0: split enumeration around $missing() my $whichx = $which->dice_axis(1,$nzix); my $nzvalsx = $nzvals->index($nzix); my ($nzii_l,$nzii_r) = which_both($nzvalsx <= $missing); #$nzenum .= -1; ##-- debug $whichx->dice_axis(1,$nzii_l)->enumvec($nzenum->index($nzii_l)) if (!$nzii_l->isempty); ##-- enum: <=$missing if (!$nzii_r->isempty) { ##-- enum: >$missing my $nzenum_r = $nzenum->index($nzii_r); $whichx->dice_axis(1,$nzii_r)->slice(",-1:0")->enumvec($nzenum_r->slice("-1:0")); $nzenum_r *= -1; $nzenum_r += ($dim0-1); } } ##-- all done return wantarray ? ($nzix,$nzenum) : $nzix; } ##====================================================================== ## Vector Operations: Generic ##====================================================================== ## POD: footer =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2007-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl), PDL::CCS::Nd(3perl), =cut 1; ##-- make perl happy PDL-CCS-1.24.1/CCS/Makefile.PL0000644000175000017500000000154214735713775014765 0ustar moocowbovinesuse ExtUtils::MakeMaker; require "../pdlmaker.plm"; pdlmaker_init(); WriteMakefile( NAME=>'PDL::CCS::Nd', VERSION_FROM => '../CCS.pm', LICENSE => 'perl', #PM => { (map {$_=>"\$(INST_LIBDIR)/CCS/$_"} <*.pm>), }, DIR =>[ #'Old', 'Utils', 'Ufunc', 'Ops', 'MatrixOps', 'IO', ], ##-- debug#2 PREREQ_PM => { 'PDL' => 0, 'PDL::VectorValued' => '1.0.4', }, CONFIGURE_REQUIRES => { 'PDL'=>0, 'ExtUtils::MakeMaker'=>0, }, ); PDL-CCS-1.24.1/CCS/MatrixOps/0000755000175000017500000000000014736165776014742 5ustar moocowbovinesPDL-CCS-1.24.1/CCS/MatrixOps/MatrixOps.pm0000644000175000017500000002123714736165726017226 0ustar moocowbovines# # GENERATED WITH PDL::PP! Don't modify! # package PDL::CCS::MatrixOps; our @EXPORT_OK = qw(ccs_matmult2d_sdd ccs_matmult2d_zdd ccs_vnorm ccs_vcos_zdd _ccs_vcos_zdd ccs_vcos_pzd ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our $VERSION = '1.24.1'; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::CCS::MatrixOps $VERSION; #line 20 "ccsmatops.pd" #use PDL::CCS::Version; use strict; =pod =head1 NAME PDL::CCS::MatrixOps - Low-level matrix operations for compressed storage sparse PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::MatrixOps; ##--------------------------------------------------------------------- ## ... stuff happens =cut #line 46 "MatrixOps.pm" =head1 FUNCTIONS =cut #line 60 "ccsmatops.pd" *ccs_indx = \&PDL::indx; ##-- typecasting for CCS indices (deprecated) #line 63 "MatrixOps.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_matmult2d_sdd =for sig Signature: ( indx ixa(Two=2,NnzA); nza(NnzA); missinga(); b(O,M); zc(O); [o]c(O,N) ; PDL_Indx sizeN) Two-dimensional matrix multiplication of a sparse index-encoded PDL $a() with a dense pdl $b(), with output to a dense pdl $c(). The sparse input PDL $a() should be passed here with 0th dimension "M" and 1st dimension "N", just as for the built-in PDL::Primitive::matmult(). "Missing" values in $a() are treated as $missinga(), which shouldn't be BAD or infinite, but otherwise ought to be handled correctly. The input pdl $zc() is used to pass the cached contribution of a $missinga()-row ("M") to an output column ("O"), i.e. $zc = ((zeroes($M,1)+$missinga) x $b)->flat; $SIZE(Two) must be 2. =for bad ccs_matmult2d_sdd processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 107 "MatrixOps.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_matmult2d_sdd = \&PDL::ccs_matmult2d_sdd; #line 114 "MatrixOps.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_matmult2d_zdd =for sig Signature: ( indx ixa(Two=2,NnzA); nza(NnzA); b(O,M); [o]c(O,N) ; PDL_Indx sizeN) Two-dimensional matrix multiplication of a sparse index-encoded PDL $a() with a dense pdl $b(), with output to a dense pdl $c(). The sparse input PDL $a() should be passed here with 0th dimension "M" and 1st dimension "N", just as for the built-in PDL::Primitive::matmult(). "Missing" values in $a() are treated as zero. $SIZE(Two) must be 2. =for bad ccs_matmult2d_zdd processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 151 "MatrixOps.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_matmult2d_zdd = \&PDL::ccs_matmult2d_zdd; #line 158 "MatrixOps.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_vnorm =for sig Signature: ( indx acols(NnzA); avals(NnzA); float+ [o]vnorm(M); ; PDL_Indx sizeM=>M) Computes the Euclidean lengths of each column-vector $a(i,*) of a sparse index-encoded pdl $a() of logical dimensions (M,N), with output to a dense piddle $vnorm(). "Missing" values in $a() are treated as zero, and $acols() specifies the (unsorted) indices along the logical dimension M of the corresponding non-missing values in $avals(). This is basically the same thing as: $vnorm = ($a**2)->xchg(0,1)->sumover->sqrt; ... but should be must faster to compute for sparse index-encoded piddles. =for bad ccs_vnorm() always clears the bad-status flag on $vnorm(). =cut #line 193 "MatrixOps.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_vnorm = \&PDL::ccs_vnorm; #line 200 "MatrixOps.pm" #line 269 "ccsmatops.pd" =pod =head2 ccs_vcos_zdd =for sig Signature: ( indx ixa(2,NnzA); nza(NnzA); b(N); float+ [o]vcos(M); float+ [t]anorm(M); PDL_Indx sizeM=>M; ) Computes the vector cosine similarity of a dense row-vector $b(N) with respect to each column $a(i,*) of a sparse index-encoded PDL $a() of logical dimensions (M,N), with output to a dense piddle $vcos(M). "Missing" values in $a() are treated as zero, and magnitudes for $a() are passed in the optional parameter $anorm(), which will be implicitly computed using L if the $anorm() parameter is omitted or empty. This is basically the same thing as: $anorm //= ($a**2)->xchg(0,1)->sumover->sqrt; $vcos = ($a * $b->slice("*1,"))->xchg(0,1)->sumover / ($anorm * ($b**2)->sumover->sqrt); ... but should be must faster to compute. Output values in $vcos() are cosine similarities in the range [-1,1], except for zero-magnitude vectors which will result in NaN values in $vcos(). If you need non-negative distances, follow this up with a: $vcos->minus(1,$vcos,1) $vcos->inplace->setnantobad->inplace->setbadtoval(0); ##-- minimum distance for NaN values to get distances values in the range [0,2]. You can use PDL threading to batch-compute distances for multiple $b() vectors simultaneously: $bx = random($N, $NB); ##-- get $NB random vectors of size $N $vcos = ccs_vcos_zdd($ixa,$nza, $bx, $M); ##-- $vcos is now ($M,$NB) =for bad ccs_vcos_zdd() always clears the bad status flag on the output piddle $vcos. =cut sub ccs_vcos_zdd { my ($ixa,$nza,$b) = @_; barf("Usage: ccs_vcos_zdd(ixa, nza, b, vcos?, anorm?, M?)") if (grep {!defined($_)} ($ixa,$nza,$b)); my ($anorm,$vcos,$M); foreach (@_[3..$#_]) { if (!defined($M) && !UNIVERSAL::isa($_,"PDL")) { $M=$_; } elsif (!defined($vcos)) { $vcos = $_; } ##-- compat: pass $vcos() in first elsif (!defined($anorm)) { $anorm = $_; } } ##-- get M $M = $vcos->dim(0) if (!defined($M) && defined($vcos) && !$vcos->isempty); $M = $anorm->dim(0) if (!defined($M) && defined($anorm) && !$anorm->isempty); $M = $ixa->slice("(0),")->max+1 if (!defined($M)); ##-- compat: implicitly compute anorm() if required $anorm = $ixa->slice("(0),")->ccs_vnorm($nza, $M) if (!defined($anorm) || $anorm->isempty); ##-- guts $ixa->_ccs_vcos_zdd($nza,$b, $anorm, ($vcos//=PDL->null)); return $vcos; } *PDL::ccs_vcos_zdd = \&ccs_vcos_zdd; #line 280 "MatrixOps.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 _ccs_vcos_zdd =for sig Signature: ( indx ixa(Two=2,NnzA); nza(NnzA); b(N); float+ anorm(M); float+ [o]vcos(M);) =for ref Guts for L, with slightly different calling conventions. =for bad Always clears the bad status flag on the output piddle $vcos. =cut #line 307 "MatrixOps.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *_ccs_vcos_zdd = \&PDL::_ccs_vcos_zdd; #line 314 "MatrixOps.pm" #line 949 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" =head2 ccs_vcos_pzd =for sig Signature: ( indx aptr(Nplus1); indx acols(NnzA); avals(NnzA); indx brows(NnzB); bvals(NnzB); anorm(M); float+ [o]vcos(M);) Computes the vector cosine similarity of a sparse index-encoded row-vector $b() of logical dimension (N) with respect to each column $a(i,*) a sparse Harwell-Boeing row-encoded PDL $a() of logical dimensions (M,N), with output to a dense piddle $vcos(M). "Missing" values in $a() are treated as zero, and magnitudes for $a() are passed in the obligatory parameter $anorm(). Usually much faster than L if a CRS pointer over logical dimension (N) is available for $a(). =for bad ccs_vcos_pzd() always clears the bad status flag on the output piddle $vcos. =cut #line 347 "MatrixOps.pm" #line 951 "/usr/lib/x86_64-linux-gnu/perl5/5.36/PDL/PP.pm" *ccs_vcos_pzd = \&PDL::ccs_vcos_pzd; #line 354 "MatrixOps.pm" #line 486 "ccsmatops.pd" ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS We should really implement matrix multiplication in terms of inner product, and have a good sparse-matrix only implementation of the former. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy All other parts Copyright (C) 2009-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl) =cut #line 404 "MatrixOps.pm" # Exit with OK status 1; PDL-CCS-1.24.1/CCS/MatrixOps/ccsmatops.pd0000644000175000017500000003763614736165363017272 0ustar moocowbovines##-*- Mode: CPerl -*- ##====================================================================== ## Header Administrivia ##====================================================================== use PDL::VectorValued::Dev; my $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module pp_setversion($VERSION); ##-- for integer-type keys require "../Config.pm"; my $INT_TYPES = join('',@{$PDL::CCS::Config::ccsConfig{INT_TYPE_CHRS}}); ##-- PDL::PP debugging #$::PP_VERBOSE = 1; ##------------------------------------------------------ ## pm headers pp_addpm({At=>'Top'},<<'EOPM'); #use PDL::CCS::Version; use strict; =pod =head1 NAME PDL::CCS::MatrixOps - Low-level matrix operations for compressed storage sparse PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::MatrixOps; ##--------------------------------------------------------------------- ## ... stuff happens =cut EOPM ## /pm additions ##------------------------------------------------------ ##------------------------------------------------------ ## Exports: None #pp_export_nothing(); ##------------------------------------------------------ ## Includes / defines pp_addhdr(<<'EOH'); #include /*-- for NAN --*/ #include "../Utils/ccsutils.h" EOH ##------------------------------------------------------ ## index datatype require "../Config.pm"; our $INDX = $PDL::CCS::Config::ccsConfig{INDX_SIG}; pp_addpm( $PDL::CCS::Config::ccsConfig{INDX_FUNCDEF} ); pp_addhdr( $PDL::CCS::Config::ccsConfig{INDX_TYPEDEF} ); ##====================================================================== ## C Utilities ##====================================================================== # (none) ##====================================================================== ## PDL::PP Wrappers ##====================================================================== ##====================================================================== ## Operations: matmult2d ##====================================================================== # TODO: support BAD values in ccs_matmult2d_sdd (especially missing==BAD). # + Problematic because we use $zc() as an initializer, which for missing==BAD # winds up setting the entire result to BAD. # + missing==BAD support might need a temporary to count the number # of (non-)missing "N" values per "O", and only add in $zc() if required (in which # case we wouldn't want/need to pass in $zc() at all) # + probably doable with an 'indx [t]nnzc(N)' temporary ##-------------------------------------------------------------- pp_def ('ccs_matmult2d_sdd', Pars => ("\n " .join("\n ", "$INDX ixa(Two=2,NnzA); nza(NnzA); missinga();", ## a(M,N) (M~i, N~x): formerly here as a(N,M) 'b(O,M);', ## b(O,M) (O~z, M~i) 'zc(O);', ## zc(O) '[o]c(O,N)', ## c(O,N) (O~z, N~x) '')), HandleBad => 1, OtherPars => "PDL_Indx sizeN;", RedoDimsCode => q{ /*-- we're getting SIZE(N)==1 if c() is passed in as null here too --*/ if ( CCS_PDL_IS_NULL($PDL(c)) ) $SIZE(N) = $COMP(sizeN); }, Code => q{ broadcastloop %{ //-- initialize: set output to zc() loop (O) %{ $GENERIC(zc) zc_o = $zc(); loop (N) %{ $c() = zc_o; %} %} // //-- main loop loop (NnzA) %{ CCS_Indx mi = $ixa(Two=>0); CCS_Indx ni = $ixa(Two=>1); loop (O) %{ //--# c(o,n) = sum for m=1 to M [a(m,n) * b(o,m)] $c(N=>ni) += $b(M=>mi) * ($nza() - $missinga()); %} %} %} if ($PDLSTATEISBAD(nza) || $PDLSTATEISBAD(missinga) || $PDLSTATEISBAD(b) || $PDLSTATEISBAD(zc)) { $PDLSTATESETBAD(c); } else { $PDLSTATESETGOOD(c); } }, Doc => (q{ Two-dimensional matrix multiplication of a sparse index-encoded PDL $a() with a dense pdl $b(), with output to a dense pdl $c(). The sparse input PDL $a() should be passed here with 0th dimension "M" and 1st dimension "N", just as for the built-in PDL::Primitive::matmult(). "Missing" values in $a() are treated as $missinga(), which shouldn't be BAD or infinite, but otherwise ought to be handled correctly. The input pdl $zc() is used to pass the cached contribution of a $missinga()-row ("M") to an output column ("O"), i.e. $zc = ((zeroes($M,1)+$missinga) x $b)->flat; $SIZE(Two) must be 2. }), ); ##--/ccs_matmult2d_sdd ##-------------------------------------------------------------- pp_def ('ccs_matmult2d_zdd', Pars => ("\n " .join("\n ", "$INDX ixa(Two=2,NnzA); nza(NnzA);", ## a(M,N) (M~i, N~x) 'b(O,M);', ## b(O,M) (O~z, M~i) '[o]c(O,N)', ## c(O,N) (O~z, N~x) '')), OtherPars => "PDL_Indx sizeN;", RedoDimsCode => q{ /*-- we're getting SIZE(N)==1 if c() is passed in as null here too --*/ if ( CCS_PDL_IS_NULL($PDL(c)) ) $SIZE(N) = $COMP(sizeN); }, HandleBad => 1, Code => q{ broadcastloop %{ //-- initialize output to zero loop (N) %{ loop (O) %{ $c()=0; %} %} // //-- main loop over CCS-encoded a() loop (NnzA) %{ CCS_Indx Mi = $ixa(Two=>0); CCS_Indx Ni = $ixa(Two=>1); loop (O) %{ PDL_IF_BAD( if ($ISBAD(nza()) || $ISBAD(b(M=>Mi)) || $ISBAD(c(N=>Ni))) { $SETBAD(c(N=>Ni)); continue; }, ) $c(N=>Ni) += $nza() * $b(M=>Mi); %} %} %} if ( $PDLSTATEISBAD(nza) || $PDLSTATEISBAD(b) ) { $PDLSTATESETBAD(c); } else { $PDLSTATESETGOOD(c); } }, Doc => q{ Two-dimensional matrix multiplication of a sparse index-encoded PDL $a() with a dense pdl $b(), with output to a dense pdl $c(). The sparse input PDL $a() should be passed here with 0th dimension "M" and 1st dimension "N", just as for the built-in PDL::Primitive::matmult(). "Missing" values in $a() are treated as zero. $SIZE(Two) must be 2. }, ); ##--/ccs_matmult2d_zdd ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## ccs_vnorm: pp_def pp_def ('ccs_vnorm', Pars => ("\n " .join("\n ", "$INDX acols(NnzA); avals(NnzA);", ##-- logical (M,N)~(T,D) with acols~Mi "float+ [o]vnorm(M);", ##-- (M)~(T) '' )), OtherPars => "PDL_Indx sizeM=>M;", HandleBad => 1, Code => q{ broadcastloop %{ CCS_Indx am; $GENERIC(avals) av; /*-- initialize --*/ loop (M) %{ $vnorm() = 0; %} /*-- guts: compute vnorm[mi] = \sum_{ni=1}^N a[mi,ni]**2 --*/ loop (NnzA) %{ PDL_IF_BAD(if ($ISBAD(avals())) continue;,) am = $acols(); av = $avals(); $vnorm(M=>am) += av * av; %} /*-- finalize: set vnorm[*] = sqrt(vnorm[*]) --*/ loop (M) %{ $vnorm() = sqrt($vnorm()); %} %} $PDLSTATESETGOOD(vnorm); }, Doc=> q{ Computes the Euclidean lengths of each column-vector $a(i,*) of a sparse index-encoded pdl $a() of logical dimensions (M,N), with output to a dense piddle $vnorm(). "Missing" values in $a() are treated as zero, and $acols() specifies the (unsorted) indices along the logical dimension M of the corresponding non-missing values in $avals(). This is basically the same thing as: $vnorm = ($a**2)->xchg(0,1)->sumover->sqrt; ... but should be must faster to compute for sparse index-encoded piddles. }, BadDoc => q{ccs_vnorm() always clears the bad-status flag on $vnorm().}, ); ##-- /ccs_vnorm ##-------------------------------------------------------------- ## ccs_vcos_zdd : ccs-matrix vs. dense-vector, output=dense, anorm=optional ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## ccs_vcos_zdd: pmcode pp_add_exported('', "ccs_vcos_zdd"); pp_addpm <<'EOPM'; =pod =head2 ccs_vcos_zdd =for sig Signature: ( indx ixa(2,NnzA); nza(NnzA); b(N); float+ [o]vcos(M); float+ [t]anorm(M); PDL_Indx sizeM=>M; ) Computes the vector cosine similarity of a dense row-vector $b(N) with respect to each column $a(i,*) of a sparse index-encoded PDL $a() of logical dimensions (M,N), with output to a dense piddle $vcos(M). "Missing" values in $a() are treated as zero, and magnitudes for $a() are passed in the optional parameter $anorm(), which will be implicitly computed using L if the $anorm() parameter is omitted or empty. This is basically the same thing as: $anorm //= ($a**2)->xchg(0,1)->sumover->sqrt; $vcos = ($a * $b->slice("*1,"))->xchg(0,1)->sumover / ($anorm * ($b**2)->sumover->sqrt); ... but should be must faster to compute. Output values in $vcos() are cosine similarities in the range [-1,1], except for zero-magnitude vectors which will result in NaN values in $vcos(). If you need non-negative distances, follow this up with a: $vcos->minus(1,$vcos,1) $vcos->inplace->setnantobad->inplace->setbadtoval(0); ##-- minimum distance for NaN values to get distances values in the range [0,2]. You can use PDL threading to batch-compute distances for multiple $b() vectors simultaneously: $bx = random($N, $NB); ##-- get $NB random vectors of size $N $vcos = ccs_vcos_zdd($ixa,$nza, $bx, $M); ##-- $vcos is now ($M,$NB) =for bad ccs_vcos_zdd() always clears the bad status flag on the output piddle $vcos. =cut sub ccs_vcos_zdd { my ($ixa,$nza,$b) = @_; barf("Usage: ccs_vcos_zdd(ixa, nza, b, vcos?, anorm?, M?)") if (grep {!defined($_)} ($ixa,$nza,$b)); my ($anorm,$vcos,$M); foreach (@_[3..$#_]) { if (!defined($M) && !UNIVERSAL::isa($_,"PDL")) { $M=$_; } elsif (!defined($vcos)) { $vcos = $_; } ##-- compat: pass $vcos() in first elsif (!defined($anorm)) { $anorm = $_; } } ##-- get M $M = $vcos->dim(0) if (!defined($M) && defined($vcos) && !$vcos->isempty); $M = $anorm->dim(0) if (!defined($M) && defined($anorm) && !$anorm->isempty); $M = $ixa->slice("(0),")->max+1 if (!defined($M)); ##-- compat: implicitly compute anorm() if required $anorm = $ixa->slice("(0),")->ccs_vnorm($nza, $M) if (!defined($anorm) || $anorm->isempty); ##-- guts $ixa->_ccs_vcos_zdd($nza,$b, $anorm, ($vcos//=PDL->null)); return $vcos; } *PDL::ccs_vcos_zdd = \&ccs_vcos_zdd; EOPM ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## ccs_vcos_zdd pp_def ('_ccs_vcos_zdd', Pars => ("\n " .join("\n ", "$INDX ixa(Two=2,NnzA); nza(NnzA);", ##-- logical (M,N) "b(N);", ##-- logical (1,N) "float+ anorm(M);", ##-- dense (required) "float+ [o]vcos(M);", )), HandleBad => 1, Code => q{ CCS_Indx an,am, bm; $GENERIC(anorm) bnorm; $GENERIC(nza) av; broadcastloop %{ /*-- cache bnorm as \sum_{i=1}^N b[i]**2 --*/ bnorm = 0; loop (N) %{ PDL_IF_BAD(if ($ISBAD(b())) continue;,) bnorm += $b() * $b(); %} bnorm = sqrt(bnorm); if (bnorm == 0) { /*-- pathological case: return all NaN --*/ loop(M) %{ $vcos() = NAN; %} } else { /*-- guts: initialize --*/ loop (M) %{ $vcos() = 0; %} /*-- guts: compute \sum_{i=1}^N (a[i]*b[i]) in vcos() --*/ loop (NnzA) %{ am = $ixa(Two=>0); an = $ixa(Two=>1); PDL_IF_BAD(if ($ISBAD(nza()) || $ISBAD(b(N=>an))) continue;,) $vcos(M=>am) += $nza() * $b(N=>an); %} /*-- guts: factor out vector magnitudes (Euclidean norms ||a||*||b||), cached in anorm(), bnorm --*/ loop (M) %{ if ($anorm() != 0) { $vcos() /= ($anorm() * bnorm); } else { /*-- bogus anorm(), return NaN --*/ $vcos() = NAN; } %} } %} $PDLSTATESETGOOD(vcos); }, Doc=> q{Guts for L, with slightly different calling conventions.}, BadDoc=> q{Always clears the bad status flag on the output piddle $vcos.}, ); ##-- /_ccs_vcos_zdd ##-------------------------------------------------------------- ## ccs_vcos_pzd : ptr(1)-matrix vs. dense-vector, output=dense, anorm=optional ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## ccs_vcos_pzd pp_def( 'ccs_vcos_pzd', Pars => ("\n " .join("\n ", "$INDX aptr(Nplus1); $INDX acols(NnzA); avals(NnzA);", ##-- logical (M,N)~(T,D) with ptr(1) "$INDX brows(NnzB); bvals(NnzB);", ##-- logical (1,N)~(1,D) "anorm(M);", ##-- (M)~(T) "float+ [o]vcos(M);", ##-- (M)~(T) )), HandleBad => 1, Code => q{ CCS_Indx bn,bn1, alo,ahi, am,anzi; $GENERIC(anorm) bnorm; broadcastloop %{ /*-- guts: initialize --*/ bnorm = 0; loop (M) %{ $vcos() = 0; %} /*-- guts: compute \sum_{i=1}^N (a[i]*b[i]) in vcos(), caching bnorm as \sum_{i=1}^N b[i]**2 --*/ loop (NnzB) %{ bn = $brows(); bn1 = bn + 1; alo = $aptr(Nplus1=>bn); ahi = $aptr(Nplus1=>bn1); PDL_IF_BAD(if ($ISBAD(bvals())) continue;,) bnorm += $bvals() * $bvals(); for (anzi=alo; anzi < ahi; ++anzi) { am = $acols(NnzA=>anzi); PDL_IF_BAD(if ($ISBAD(avals(NnzA=>anzi))) continue;,) $vcos(M=>am) += $avals(NnzA=>anzi) * $bvals(); } %} /*-- guts: finalize: factor out vector magnitudes (Euclidean norms ||a||*||b||), cached in anorm(), bnorm --*/ bnorm = sqrt(bnorm); if (bnorm == 0) { /*-- bogus bnorm, return all NaN --*/ loop (M) %{ $vcos() = NAN; %} } else { loop (M) %{ if ($anorm() != 0 PDL_IF_BAD(&& $ISGOOD(anorm()),)) { $vcos() /= ($anorm() * bnorm); } else { /*-- bogus anorm(), return NaN --*/ $vcos() = NAN; } %} } %} $PDLSTATESETGOOD(vcos); }, BadDoc=> q{ccs_vcos_pzd() always clears the bad status flag on the output piddle $vcos.}, Doc => q{ Computes the vector cosine similarity of a sparse index-encoded row-vector $b() of logical dimension (N) with respect to each column $a(i,*) a sparse Harwell-Boeing row-encoded PDL $a() of logical dimensions (M,N), with output to a dense piddle $vcos(M). "Missing" values in $a() are treated as zero, and magnitudes for $a() are passed in the obligatory parameter $anorm(). Usually much faster than L if a CRS pointer over logical dimension (N) is available for $a(). }, ); ##-- /_ccs_vcos_pzd ##====================================================================== ## Footer Administrivia ##====================================================================== ##------------------------------------------------------ ## pm additions: footer pp_addpm(<<'EOPM'); ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS We should really implement matrix multiplication in terms of inner product, and have a good sparse-matrix only implementation of the former. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy All other parts Copyright (C) 2009-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl) =cut EOPM # Always make sure that you finish your PP declarations with # pp_done pp_done(); ##---------------------------------------------------------------------- PDL-CCS-1.24.1/CCS/MatrixOps/Makefile.PL0000644000175000017500000000130414734467507016705 0ustar moocowbovinesuse PDL::Core::Dev; use ExtUtils::MakeMaker; PDL::Core::Dev->import(); require "../../pdlmaker.plm"; $package = ["ccsmatops.pd", 'MatrixOps', 'PDL::CCS::MatrixOps']; %hash = pdlmaker_init($package); $hash{AUTHOR} = 'Bryan Jurish'; $hash{ABSTRACT} = 'Low-level matrix operations for compressed storage sparse PDLs'; $hash{VERSION_FROM} = '../../CCS.pm'; $hash{LICENSE} = 'perl'; $hash{PREREQ_PM}{PDL} = $hash{CONFIGURE_REQUIRES}{PDL} = 0; push(@{$hash{LIBS}}, '-lm'); $hash{DIR} = []; #$hash{INC} .= ''; #$hash{OBJECT} .= ''; $hash{realclean}{FILES} .= '*~ *.tmp README.txt'; #my $pmfile = $package[0]; #$pmfile =~ s/\.pd$/\.pm/; #$hash{PM}{$pmfile} = "\$(INST_LIBDIR)/CCS/$pmfile"; WriteMakefile(%hash); PDL-CCS-1.24.1/CCS/Nd.pm0000644000175000017500000032255314736165363013715 0ustar moocowbovines## File: PDL::CCS::Nd.pm ## Author: Bryan Jurish ## Description: N-dimensional CCS-encoded pseudo-PDL package PDL::CCS::Nd; use PDL::Lite qw(); use PDL::VectorValued; use PDL::CCS::Config qw(ccs_indx); use PDL::CCS::Functions qw(ccs_decode ccs_qsort); use PDL::CCS::Utils qw(ccs_encode_pointers ccs_decode_pointer); use PDL::CCS::Ufunc; use PDL::CCS::Ops; use PDL::CCS::MatrixOps; use Carp; use strict; BEGIN { *isa = \&UNIVERSAL::isa; *can = \&UNIVERSAL::can; } our $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module our @ISA = qw(); our %EXPORT_TAGS = ( ##-- respect PDL conventions (hopefully) Func => [ ##-- Encoding/Decoding qw(toccs todense), ], vars => [ qw($PDIMS $VDIMS $WHICH $VALS $PTRS $FLAGS $USER), qw($BINOP_BLOCKSIZE_MIN $BINOP_BLOCKSIZE_MAX), ], flags => [ qw($CCSND_BAD_IS_MISSING $CCSND_NAN_IS_MISSING $CCSND_INPLACE $CCSND_FLAGS_DEFAULT), ], ); $EXPORT_TAGS{all} = [map {@$_} values(%EXPORT_TAGS)]; our @EXPORT = @{$EXPORT_TAGS{Func}}; our @EXPORT_OK = @{$EXPORT_TAGS{all}}; ##-------------------------------------------------------------- ## Global variables for block-wise computation of binary operations ##-- some (hopefully sensible) defaults #our $BINOP_BLOCKSIZE_MIN = 64; #our $BINOP_BLOCKSIZE_MAX = undef; ##-- undef or zero: no maximum ##-- debug/devel defaults our $BINOP_BLOCKSIZE_MIN = 1; our $BINOP_BLOCKSIZE_MAX = 0; ##====================================================================== ## Globals our $PDIMS = 0; our $VDIMS = 1; our $WHICH = 2; our $VALS = 3; our $PTRS = 4; our $FLAGS = 5; our $USER = 6; ##-- flags our $CCSND_BAD_IS_MISSING = 1; our $CCSND_NAN_IS_MISSING = 2; our $CCSND_INPLACE = 4; our $CCSND_FLAGS_DEFAULT = 0; ##-- default flags ##-- pdl constants our $P_BYTE = PDL::byte(); our $P_LONG = PDL::long(); our $P_INDX = ccs_indx(); sub _min2 ($$) { $_[0]<$_[1] ? $_[0] : $_[1]; } sub _max2 ($$) { $_[0]>$_[1] ? $_[0] : $_[1]; } ##====================================================================== ## Constructors etc. ## $obj = $class_or_obj->newFromDense($denseND); ## $obj = $class_or_obj->newFromDense($denseND,$missing); ## $obj = $class_or_obj->newFromDense($denseND,$missing,$flags); ## + object structure: ARRAY ## $PDIMS => $pdims, ##-- pdl(indx,$NPdims) : physical dimension sizes : $pdim_i => $dimSize_i ## $VDIMS => $vdims, ##-- pdl(indx,$NVdims) : virtual dimension sizes ## ## + $vdim_i => / -$vdimSize_i if $vdim_i is dummy ## ## \ $pdim_i otherwise ## ## + s.t. $whichND_logical_physical = $whichND->dice_axis(0,$vdims->where($vdims>=0)); ## $WHICH => $whichND, ##-- pdl(indx,$NPdims,$Nnz) ~ $dense_orig->whichND ## ## + guaranteed to be sorted as for qsortvec() specs ## ## + NOT changed by dimension-shuffling transformations ## $VALS => $vals, ##-- pdl( ? ,$Nnz+1) ~ $dense->where($dense)->append($missing) ## $PTRS => \@PTRS, ##-- array of ccsutils-pointers by physical dimension number ## $FLAGS => $flags, ##-- integer holding some flags ## ## + each element of @PTRS is itself an array: ## $PTRS[$i] => [ $PTR, $NZI ] ## sub newFromDense :lvalue { my $that = shift; return my $tmp=(bless [], ref($that)||$that)->fromDense(@_); } ## $obj = $obj->fromDense($denseND,$missing,$flags) sub fromDense :lvalue { my ($obj,$p,$missing,$flags) = @_; $p = PDL->topdl($p); $p = $p->slice("*1") if (!$p->dims); $missing = (defined($missing) ? PDL->pdl($p->type,$missing) : ($p->badflag ? PDL->pdl($p->type,0)->setvaltobad(0) : PDL->pdl($p->type,0))); $flags = $CCSND_FLAGS_DEFAULT if (!defined($flags)); my $pwhichND = ($missing->isbad ? $p->isgood() : ($p != $missing))->whichND->vv_qsortvec; my $pnz = $p->indexND($pwhichND)->append($missing); $pnz->sever; ##-- always sever nzvals ? my $pdims = PDL->pdl($P_INDX,[$p->dims]); $obj->[$PDIMS] = $pdims; $obj->[$VDIMS] = $pdims->isempty ? $pdims->pdl : $pdims->sequence; $obj->[$WHICH] = $pwhichND; $obj->[$VALS] = $pnz; $obj->[$PTRS] = []; ##-- do we really need this ... yes $obj->[$FLAGS] = $flags; return $obj; } ## $obj = $class_or_obj->newFromWhich($whichND,$nzvals,%options); ## $obj = $class_or_obj->newFromWhich($whichND,$nzvals); ## + %options: see $obj->fromWhich() sub newFromWhich :lvalue { my $that = shift; return my $tmp=bless([],ref($that)||$that)->fromWhich(@_); } ## $obj = $obj->fromWhich($whichND,$nzvals,%options); ## $obj = $obj->fromWhich($whichND,$nzvals); ## + %options: ## sorted => $bool, ##-- if true, $whichND is assumed to be pre-sorted ## steal => $bool, ##-- if true, $whichND and $nzvals are used literally (formerly implied 'sorted') ## ## + in this case, $nzvals should really be: $nzvals->append($missing) ## pdims => $pdims, ##-- physical dimension list; default guessed from $whichND (alias: 'dims') ## missing => $missing, ##-- default: BAD if $nzvals->badflag, 0 otherwise ## vdims => $vdims, ##-- virtual dims (default: sequence($nPhysDims)); alias: 'xdims' ## flags => $flags, ##-- flags sub fromWhich :lvalue { my ($obj,$wnd,$nzvals,%opts) = @_; my $missing = (defined($opts{missing}) ? PDL->pdl($nzvals->type,$opts{missing}) : ($nzvals->badflag ? PDL->pdl($nzvals->type,0)->setvaltobad(0) : PDL->pdl($nzvals->type,0))); ##-- get dims my $pdims = $opts{pdims} // $opts{dims} // PDL->pdl($P_INDX, [($wnd->xchg(0,1)->maximum+1)->list]); $pdims = PDL->pdl($P_INDX, $pdims) if (!UNIVERSAL::isa($pdims,'PDL')); my $vdims = $opts{vdims} // $opts{xdims} // $pdims->sequence; $vdims = PDL->pdl($P_INDX, $vdims) if (!UNIVERSAL::isa($vdims,'PDL')); ##-- maybe sort & copy if (!$opts{steal}) { ##-- not stolen: copy or sever if (!$opts{sorted}) { my $wi = $wnd->qsortveci; $wnd = $wnd->dice_axis(1,$wi); $nzvals = $nzvals->index($wi); } $wnd->sever; ##-- sever (~ copy) $nzvals = $nzvals->append($missing); ##-- copy (b/c append) } elsif (!$opts{sorted}) { ##-- "stolen" but un-sorted: we have "missing" value in $vals my $wi = PDL->zeroes(ccs_indx, $wnd->dim(1)+1); $wnd->vv_qsortveci($wi->slice("0:-2")); $wi->set($wnd->dim(1) => $nzvals->nelem-1); $wnd = $wnd->dice_axis(1,$wi->slice("0:-2")); $nzvals = $nzvals->index($wi); } ##-- setup and return $obj->[$PDIMS] = $pdims; $obj->[$VDIMS] = $vdims; $obj->[$WHICH] = $wnd; $obj->[$VALS] = $nzvals; $obj->[$PTRS] = []; $obj->[$FLAGS] = defined($opts{flags}) ? $opts{flags} : $CCSND_FLAGS_DEFAULT; return $obj; } ## DESTROY : avoid PDL inheritance sub DESTROY { ; } ## $ccs = $ccs->insertWhich($whichND,$whichVals) ## + set or insert $whichND=>$whichVals ## + implicitly calls make_physically_indexed sub insertWhich :lvalue { my ($ccs,$which,$vals) = @_; $ccs->make_physically_indexed(); ##-- sanity check if ($which->dim(0) != $ccs->[$WHICH]->dim(0)) { PDL::Lite::barf(ref($ccs)."::insertWhich(): wrong number of index dimensions in whichND argument:", " is ", $which->dim(0), ", should be ", $ccs->[$WHICH]->dim(0)); } ##-- check for existing indices (potentially slow) my $nzi = $ccs->indexNDi($which); my ($nzi_new,$nzi_old) = ($nzi==$ccs->[$WHICH]->dim(1))->which_both; ##-- just set values for existing indices $ccs->[$VALS]->index($nzi->index($nzi_old)) .= $vals->index($nzi_old); ##-- delegate insertion of new values to appendWhich() my ($tmp); return $tmp=$ccs->sortwhich if ($nzi_new->isempty); return $tmp=$ccs->appendWhich($which->dice_axis(1,$nzi_new), $vals->index($nzi_new)); } ## $ccs = $ccs->appendWhich($whichND,$whichVals) ## + inserts $whichND=>$whichVals into $ccs which are assumed NOT to be already present ## + implicitly calls make_physically_indexed sub appendWhich :lvalue { my ($ccs,$which,$vals) = @_; $ccs->make_physically_indexed(); ##-- sanity check #if ($which->dim(0) != $ccs->[$WHICH]->dim(0)) if ($which->dim(0) != $ccs->[$PDIMS]->nelem) { PDL::Lite::barf(ref($ccs)."::appendWhich(): wrong number of index dimensions in whichND argument:", " is ", $which->dim(0), ", should be ", $ccs->[$PDIMS]->nelem); } ##-- append: which if (!$which->isempty) { $ccs->[$WHICH] = $ccs->[$WHICH]->reshape($which->dim(0), $ccs->[$WHICH]->dim(1)+$which->dim(1)); $ccs->[$WHICH]->slice(",-".$which->dim(1).":-1") .= $which; } ##-- append: vals if (!$vals->isempty) { my $missing = $ccs->missing; $ccs->[$VALS] = $ccs->[$VALS]->reshape($ccs->[$VALS]->dim(0) + $vals->dim(0)); $ccs->[$VALS]->slice("-".($vals->dim(0)+1).":-2") .= $vals; $ccs->[$VALS]->slice("-1") .= $missing; } return $ccs->sortwhich(); } ## $ccs = $pdl->toccs() ## $ccs = $pdl->toccs($missing) ## $ccs = $pdl->toccs($missing,$flags) *PDL::toccs = \&toccs; sub toccs :lvalue { return $_[0] if (isa($_[0],__PACKAGE__)); return my $tmp=__PACKAGE__->newFromDense(@_); } ## $ccs = $ccs->copy() BEGIN { *clone = \© } sub copy :lvalue { my $ccs1 = shift; my $ccs2 = bless [], ref($ccs1); $ccs2->[$PDIMS] = $ccs1->[$PDIMS]->pdl; $ccs2->[$VDIMS] = $ccs1->[$VDIMS]->pdl; $ccs2->[$WHICH] = $ccs1->[$WHICH]->pdl; $ccs2->[$VALS] = $ccs1->[$VALS]->pdl; $ccs2->[$PTRS] = [ map {defined($_) ? [map {$_->pdl} @$_] : undef} @{$ccs1->[$PTRS]} ]; ##-- copy pointers? $ccs2->[$FLAGS] = $ccs1->[$FLAGS]; return $ccs2; } ## $ccs2 = $ccs->copyShallow() ## + a very shallow version of copy() ## + Copied : $PDIMS, @$PTRS, @{$PTRS->[*]}, $FLAGS ## + Referenced: $VDIMS, $WHICH, $VALS, $PTRS->[*][*] sub copyShallow :lvalue { my $ccs = bless [@{$_[0]}], ref($_[0]); ## ##-- do copy some of it $ccs->[$PDIMS] = $ccs->[$PDIMS]->pdl; #$ccs->[$VDIMS] = $ccs->[$VDIMS]->pdl; $ccs->[$PTRS] = [ map {defined($_) ? [@$_] : undef} @{$ccs->[$PTRS]} ]; $ccs; } ## $ccs2 = $ccs->shadow(%args) ## + args: ## to => $ccs2, ##-- default: new ## pdims => $pdims2, ##-- default: $pdims1->pdl (alias: 'dims') ## vdims => $vdims2, ##-- default: $vdims1->pdl (alias: 'xdims') ## ptrs => \@ptrs2, ##-- default: [] ## which => $which2, ##-- default: undef ## vals => $vals2, ##-- default: undef ; if specified, should include final 'missing' element ## flags => $flags, ##-- default: $flags1 sub shadow :lvalue { my ($ccs,%args) = @_; my $ccs2 = defined($args{to}) ? $args{to} : bless([], ref($ccs)||$ccs); $ccs2->[$PDIMS] = (defined($args{pdims}) ? $args{pdims} : (defined($args{dims}) ? $args{dims} : $ccs->[$PDIMS]->pdl)); $ccs2->[$VDIMS] = (defined($args{vdims}) ? $args{vdims} : (defined($args{xdims}) ? $args{xdims} : $ccs->[$VDIMS]->pdl)); $ccs2->[$PTRS] = $args{ptrs} ? $args{ptrs} : []; $ccs2->[$WHICH] = $args{which}; $ccs2->[$VALS] = $args{vals}; $ccs2->[$FLAGS] = defined($args{flags}) ? $args{flags} : $ccs->[$FLAGS]; return $ccs2; } ##-------------------------------------------------------------- ## Maintenance ## $ccs = $ccs->recode() ## + recodes object, removing any missing values from $nzvals sub recode :lvalue { my $ccs = shift; my $nz = $ccs->_nzvals; my $z = $ccs->[$VALS]->slice("-1"); ##-- get mask of "real" non-zero values my ($nzmask, $nzmask1); if ($z->isbad) { $nzmask = $nz->isgood; } else { $nzmask = $nz != $z; if ($ccs->[$FLAGS] & $CCSND_BAD_IS_MISSING) { $nzmask1 = $nz->isgood; $nzmask &= $nzmask1; } } if ($ccs->[$FLAGS] & $CCSND_NAN_IS_MISSING) { $nzmask1 = $nzmask->pdl if (!defined($nzmask1)); $nz->isfinite($nzmask1); $nzmask &= $nzmask1; } ##-- maybe recode if (!$nzmask->all) { my $nzi = $nzmask->which; $ccs->[$WHICH] = $ccs->[$WHICH]->dice_axis(1,$nzi); $ccs->[$VALS] = $ccs->[$VALS]->index($nzi)->append($z); @{$ccs->[$PTRS]} = qw(); ##-- clear pointers } return $ccs; } ## $ccs = $ccs->sortwhich() ## + sorts on $ccs->[$WHICH] ## + may be DANGEROUS to indexing methods, b/c it alters $VALS ## + clears pointers sub sortwhich :lvalue { return $_[0] if ($_[0][$WHICH]->isempty); my $sorti = $_[0][$WHICH]->vv_qsortveci; $_[0][$WHICH] = $_[0][$WHICH]->dice_axis(1,$sorti); $_[0][$VALS] = $_[0][$VALS]->index($sorti->append($_[0][$WHICH]->dim(1))); # #-- DANGEROUS: pointer copy # foreach (grep {defined($_)} @{$_[0][$PTRS]}) { # $_->[1]->index($sorti) .= $_->[1]; # } #--/DANGEROUS: pointer copy # @{$_[0][$PTRS]} = qw() if (! ($sorti==PDL->sequence($P_INDX,$sorti->dims))->all ); return $_[0]; } ##-------------------------------------------------------------- ## Decoding ## $dense = $ccs->decode() ## $dense = $ccs->decode($dense) sub decode :lvalue { ##-- decode physically stored index+value pairs my $dense = ccs_decode($_[0][$WHICH], $_[0]->_nzvals, $_[0]->missing, [ $_[0][$PDIMS] ], ); ##-- map physical dims with reorder() my $porder = $_[0][$VDIMS]->where($_[0][$VDIMS]>=0); $dense = $dense->reorder($porder->list); #if (($porder!=$_[0][$PDIMS]->sequence)->any); ##-- map virtual dims with dummy() my @vdims = $_[0][$VDIMS]->list; foreach (grep {$vdims[$_]<0} (0..$#vdims)) { $dense = $dense->dummy($_, -$vdims[$_]); } ##-- assign if $dense was specified by the user if (defined($_[1])) { $_[1] .= $dense; return $_[1]; } return $dense; } ## $dense = $ccs_or_dense->todense() *PDL::todense = \&todense; sub todense :lvalue { isa($_[0],__PACKAGE__) ? (my $tmp=$_[0]->decode(@_[1..$#_])) : $_[0]; } ##-------------------------------------------------------------- ## PDL API: Basic Properties ## $type = $obj->type() sub type { $_[0][$VALS]->type; } sub info { $_[0][$VALS]->info; } ## $obj2 = $obj->convert($type) ## + unlike PDL function, respects 'inplace' flag sub convert :lvalue { if ($_[0][$FLAGS] & $CCSND_INPLACE) { $_[0][$VALS] = $_[0][$VALS]->convert($_[1]); $_[0][$FLAGS] &= ~$CCSND_INPLACE; return $_[0]; } return my $tmp=$_[0]->shadow(which=>$_[0][$WHICH]->pdl, vals=>$_[0][$VALS]->convert($_[1])); } ## byte,short,ushort,long,double,... sub _pdltype_sub { my $pdltype = shift; return sub { return $pdltype if (!@_); convert(@_,$pdltype); }; } foreach my $pdltype (map {$_->{convertfunc}} values %PDL::Types::typehash) { no strict 'refs'; #qw(byte short ushort long longlong indx float double) *$pdltype = _pdltype_sub("PDL::${pdltype}"->()); } ## $dimpdl = $obj->dimpdl() ## + values in $dimpdl are negative for virtual dimensions sub dimpdl :lvalue { my $dims = $_[0][$VDIMS]->pdl; my $physi = ($_[0][$VDIMS]>=0)->which; (my $tmp=$dims->index($physi)) .= $_[0][$PDIMS]->index($_[0][$VDIMS]->index($physi)); return $dims; } ## @dims = $obj->dims() sub dims { $_[0]->dimpdl->abs->list; } ## $dim = $obj->dim($dimi) sub dim { $_[0]->dimpdl->abs->at($_[1]); } *getdim = \&dim; ## $ndims = $obj->ndims() sub ndims { $_[0][$VDIMS]->nelem; } *getndims = \&ndims; ## $nelem = $obj->nelem sub nelem { $_[0]->dimpdl->abs->dprod; } ## $bool = $obj->isnull sub isnull { $_[0][$VALS]->isnull; } ## $bool = $obj->isempty sub isempty { $_[0]->nelem==0; } ##-------------------------------------------------------------- ## Low-level CCS access ## $bool = $ccs->is_physically_indexed() ## + returns true iff only physical dimensions are present sub is_physically_indexed { ( $_[0][$VDIMS]->ndims==$_[0][$PDIMS]->ndims && ($_[0][$VDIMS]==$_[0][$VDIMS]->sequence)->all ); } ## $ccs2 = $ccs->to_physically_indexed() ## + ensures that all non-missing elements are physically indexed ## + just returns $ccs if all non-missing elements are already physically indexed sub to_physically_indexed { return $_[0] if ($_[0]->is_physically_indexed); my $ccs = shift; my $which = $ccs->whichND; my $vals = $ccs->whichVals; my $sorti = $which->vv_qsortveci; return $ccs->shadow( pdims=>$ccs->dimpdl->abs, vdims=>$ccs->[$VDIMS]->sequence, which=>$which->dice_axis(1,$sorti), vals =>$vals->index($sorti)->append($ccs->missing), )->sever; } ## $ccs = $ccs->make_physically_indexed() *make_physical = \&make_physically_indexed; sub make_physically_indexed { return $_[0] if ($_[0]->is_physically_indexed); @{$_[0]} = @{$_[0]->to_physically_indexed}; return $_[0]; } ## $pdims = $obj->pdims() ## $vdims = $obj->vdims() sub pdims :lvalue { $_[0][$PDIMS]; } sub vdims :lvalue { $_[0][$VDIMS]; } ## $nelem_p = $obj->nelem_p : maximum number of physically addressable elements ## $nelem_v = $obj->nelem_v : maximum number of virtually addressable elements sub nelem_p { $_[0][$PDIMS]->dprod; } *nelem_v = \&nelem; ## $v_per_p = $obj->_ccs_nvperp() : number of virtual elements per physical element sub _ccs_nvperp { $_[0][$VDIMS]->where($_[0][$VDIMS]<0)->abs->dprod; } ## $nstored_p = $obj->nstored_p : actual number of physically stored elements ## $nstored_v = $obj->nstored_v : actual number of physically+virtually stored elements sub nstored_p { $_[0][$WHICH]->dim(1); } sub nstored_v { $_[0][$WHICH]->dim(1) * $_[0]->_ccs_nvperp; } *nstored = \&nstored_v; ## $nnz = $obj->_nnz_p : returns actual $obj->[$VALS]->dim(0)-1 ## $nnz = $obj->_nnz_v : returns virtual $obj->[$VALS]->dim(0)-1 sub _nnz_p { $_[0][$VALS]->dim(0)-1; } sub _nnz_v { ($_[0][$VALS]->dim(0)-1) * $_[0]->_ccs_nvperp; } *_nnz = \&_nnz_v; ## $nmissing_p = $obj->nmissing_p() ## $nmissing_v = $obj->nmissing_v() sub nmissing_p { $_[0]->nelem_p - $_[0]->nstored_p; } sub nmissing_v { $_[0]->nelem_v - $_[0]->nstored_v; } *nmissing = \&nmissing_v; ## $bool = $obj->allmissing ## + true if no non-missing values are stored sub allmissing { $_[0][$VALS]->nelem <= 1; } ## $missing = $obj->missing() ## $missing = $obj->missing($missing) sub missing { $_[0][$VALS]->set(-1,$_[1]) if (@_>1); $_[0][$VALS]->slice("-1"); } ## $obj = $obj->_missing($missingVal) sub _missing :lvalue { $_[0][$VALS]->set(-1,$_[1]) if (@_>1); $_[0]; } ## $whichND_stored = $obj->_whichND() ## $whichND_stored = $obj->_whichND($whichND) sub _whichND :lvalue { $_[0][$WHICH] = $_[1] if (@_>1); $_[0][$WHICH]; } ## $_nzvals = $obj->_nzvals() ## $_nzvals = $obj->_nzvals($nzvals) ## + physical storage only BEGIN { *_whichVals = \&_nzvals; } sub _nzvals :lvalue { my ($tmp); $_[0][$VALS]=$_[1]->append($_[0][$VALS]->slice("-1")) if (@_ > 1); return $tmp=$_[0][$VALS]->index(PDL->zeroes(ccs_indx(), 0)) if ($_[0][$VALS]->dim(0)<=1); return $tmp=$_[0][$VALS]->slice("0:-2"); } ## $vals = $obj->_vals() ## $vals = $obj->_vals($storedvals) ## + physical storage only sub _vals :lvalue { $_[0][$VALS]=$_[1] if (@_ > 1); $_[0][$VALS]; } ## $ptr = $obj->ptr($dim_p); ##-- scalar context ## ($ptr,$pi2nzi) = $obj->ptr($dim_p); ##-- list context ## + returns cached value in $ccs->[$PTRS][$dim_p] if present ## + caches value in $ccs->[$PTRS][$dim_p] otherwise ## + $dim defaults to zero, for compatibility ## + if $dim is zero, all($pi2nzi==sequence($obj->nstored)) ## + physical dimensions ONLY sub ptr { my ($ccs,$dim) = @_; $dim = 0 if (!defined($dim)); $ccs->[$PTRS][$dim] = [$ccs->getptr($dim)] if (!$ccs->hasptr($dim)); return wantarray ? @{$ccs->[$PTRS][$dim]} : $ccs->[$PTRS][$dim][0]; } ## $bool = $obj->hasptr($dim_p) ## + returns true iff $obj has a cached pointer for physical dim $dim_p sub hasptr { my ($ccs,$dim) = @_; $dim = 0 if (!defined($dim)); return defined($ccs->[$PTRS][$dim]) ? scalar(@{$ccs->[$PTRS][$dim]}) : 0; } ## ($ptr,$pi2nzi) = $obj->getptr($dim_p); ## + as for ptr(), but does NOT cache anything, and does NOT check the cache ## + physical dimensions ONLY sub getptr { ccs_encode_pointers($_[0][$WHICH]->slice("($_[1]),"), $_[0][$PDIMS]->index($_[1])); } ## ($ptr,$pi2nzi) = $obj->setptr($dim_p, $ptr,$pi2nzi ); ## + low-level: set pointer for $dim_p sub setptr { if (UNIVERSAL::isa($_[2],'ARRAY')) { $_[0][$PTRS][$_[1]] = $_[2]; } else { $_[0][$PTRS][$_[1]] = [$_[2],$_[3]]; } return $_[0]->ptr($_[1]); } ## $obj = $obj->clearptrs() sub clearptrs :lvalue { @{$_[0][$PTRS]}=qw(); return $_[0]; } ## $obj = $obj->clearptr($dim_p) ## + low-level: clear pointer(s) for $dim_p sub clearptr :lvalue { my ($ccs,$dim) = @_; return $ccs->clearptrs() if (!defined($dim)); $ccs->[$PTRS][$dim] = undef; return $ccs; } ## $flags = $obj->flags() ## $flags = $obj->flags($flags) ## + get local flags sub flags { $_[0][$FLAGS] = $_[1] if (@_ > 1); $_[0][$FLAGS]; } ## $bool = $obj->bad_is_missing() ## $bool = $obj->bad_is_missing($bool) sub bad_is_missing { if (@_ > 1) { if ($_[1]) { $_[0][$FLAGS] |= $CCSND_BAD_IS_MISSING; } else { $_[0][$FLAGS] &= ~$CCSND_BAD_IS_MISSING; } } $_[0][$FLAGS] & $CCSND_BAD_IS_MISSING; } ## $obj = $obj->badmissing() sub badmissing { $_[0][$FLAGS] |= $CCSND_BAD_IS_MISSING; $_[0]; } ## $bool = $obj->nan_is_missing() ## $bool = $obj->nan_is_missing($bool) sub nan_is_missing { if (@_ > 1) { if ($_[1]) { $_[0][$FLAGS] |= $CCSND_NAN_IS_MISSING; } else { $_[0][$FLAGS] &= ~$CCSND_NAN_IS_MISSING; } } $_[0][$FLAGS] & $CCSND_NAN_IS_MISSING; } ## $obj = $obj->nanmissing() sub nanmissing { $_[0][$FLAGS] |= $CCSND_NAN_IS_MISSING; $_[0]; } ## undef = $obj->set_inplace($bool) ## + sets local inplace flag sub set_inplace ($$) { if ($_[1]) { $_[0][$FLAGS] |= $CCSND_INPLACE; } else { $_[0][$FLAGS] &= ~$CCSND_INPLACE; } } ## $bool = $obj->is_inplace() sub is_inplace ($) { ($_[0][$FLAGS] & $CCSND_INPLACE) ? 1 : 0; } ## $obj = $obj->inplace() ## + sets local inplace flag sub inplace ($) { $_[0][$FLAGS] |= $CCSND_INPLACE; $_[0]; } ## $bool = $obj->badflag() ## $bool = $obj->badflag($bool) ## + wraps $obj->[$WHICH]->badflag, $obj->[$VALS]->badflag() sub badflag { if (@_ > 1) { $_[0][$WHICH]->badflag($_[1]); $_[0][$VALS]->badflag($_[1]); } return $_[0][$WHICH]->badflag || $_[0][$VALS]->badflag; } ## $obj = $obj->sever() ## + severs all sub-pdls sub sever { $_[0][$PDIMS]->sever; $_[0][$VDIMS]->sever; $_[0][$WHICH]->sever; $_[0][$VALS]->sever; foreach (grep {defined($_)} (@{$_[0][$PTRS]})) { $_->[0]->sever; $_->[1]->sever; } $_[0]; } ## \&code = _setbad_sub($pdlcode) ## + returns a sub implementing setbadtoval(), setvaltobad(), etc. sub _setbad_sub { my $pdlsub = shift; return sub { if ($_[0]->is_inplace) { $pdlsub->($_[0][$VALS]->inplace, @_[1..$#_]); $_[0]->set_inplace(0); return $_[0]; } $_[0]->shadow( which=>$_[0][$WHICH]->pdl, vals=>$pdlsub->($_[0][$VALS],@_[1..$#_]), ); }; } ## $obj = $obj->setnantobad() foreach my $badsub (qw(setnantobad setbadtonan setbadtoval setvaltobad)) { no strict 'refs'; *$badsub = _setbad_sub(PDL->can($badsub)); } ##-------------------------------------------------------------- ## Dimension Shuffling ## $ccs = $ccs->setdims_p(@dims) ## + sets physical dimensions *setdims = \&setdims_p; sub setdims_p { $_[0][$PDIMS] = PDL->pdl($P_INDX,@_[1..$#_]); } ## $ccs2 = $ccs->dummy($vdim_index) ## $ccs2 = $ccs->dummy($vdim_index, $vdim_size) sub dummy :lvalue { my ($ccs,$vdimi,$vdimsize) = @_; my @vdims = $ccs->[$VDIMS]->list; $vdimsize = 1 if (!defined($vdimsize)); $vdimi = 0 if (!defined($vdimi)); $vdimi = @vdims + $vdimi + 1 if ($vdimi < 0); if ($vdimi < 0) { PDL::Lite::barf(ref($ccs). "::dummy(): negative dimension number ", ($vdimi+@vdims), " exceeds number of dims ", scalar(@vdims)); } splice(@vdims,$vdimi,0,-$vdimsize); my $ccs2 = $ccs->copyShallow; $ccs2->[$VDIMS] = PDL->pdl($P_INDX,\@vdims); return $ccs2; } ## $ccs2 = $ccs->reorder_pdl($vdim_index_pdl) sub reorder_pdl :lvalue { my $ccs2 = $_[0]->copyShallow; $ccs2->[$VDIMS] = $ccs2->[$VDIMS]->index($_[1]); $ccs2->[$VDIMS]->sever; $ccs2; } ## $ccs2 = $ccs->reorder(@vdim_list) sub reorder :lvalue { $_[0]->reorder_pdl(PDL->pdl($P_INDX,@_[1..$#_])); } ## $ccs2 = $ccs->xchg($vdim1,$vdim2) sub xchg :lvalue { my $dimpdl = PDL->sequence($P_INDX,$_[0]->ndims); my $tmp = $dimpdl->at($_[1]); $dimpdl->set($_[1], $dimpdl->at($_[2])); $dimpdl->set($_[2], $tmp); return $tmp=$_[0]->reorder_pdl($dimpdl); } ## $ccs2 = $ccs->mv($vDimFrom,$vDimTo) sub mv :lvalue { my ($d1,$d2) = @_[1,2]; my $ndims = $_[0]->ndims; $d1 = $ndims+$d1 if ($d1 < 0); $d2 = $ndims+$d2 if ($d2 < 0); return my $tmp=$_[0]->reorder($d1 < $d2 ? ((0..($d1-1)), (($d1+1)..$d2), $d1, (($d2+1)..($ndims-1))) : ((0..($d2-1)), $d1, ($d2..($d1-1)), (($d1+1)..($ndims-1))) ); } ## $ccs2 = $ccs->transpose() ## + always copies sub transpose :lvalue { my ($tmp); if ($_[0]->ndims==1) { return $tmp=$_[0]->dummy(0,1)->copy; } else { return $tmp=$_[0]->xchg(0,1)->copy; } } ##-------------------------------------------------------------- ## PDL API: Indexing sub slice { #:lvalue PDL::Lite::barf(ref($_[0])."::slice() is not implemented yet (try dummy, dice_axis, indexND, etc.)"); } ## $nzi = $ccs->indexNDi($ndi) ## + returns Nnz indices for virtual ND-index PDL $ndi ## + index values in $ndi which are not present in $ccs are returned in $nzi as: ## $ccs->[$WHICH]->dim(1) == $ccs->_nnz_p sub indexNDi :lvalue { my ($ccs,$ndi) = @_; ## ##-- get physical dims my $dims = $ccs->[$VDIMS]; my $whichdimp = ($dims>=0)->which; my $pdimi = $dims->index($whichdimp); ## #$ndi = $ndi->dice_axis(0,$whichdimp) ##-- BUG?! $ndi = $ndi->dice_axis(0,$pdimi) if ( $ndi->dim(0)!=$ccs->[$WHICH]->dim(0) || ($pdimi!=PDL->sequence($ccs->[$WHICH]->dim(0)))->any ); ## my $foundi = $ndi->vsearchvec($ccs->[$WHICH]); my $foundi_mask = ($ndi==$ccs->[$WHICH]->dice_axis(1,$foundi))->andover; $foundi_mask->inplace->not; (my $tmp=$foundi->where($foundi_mask)) .= $ccs->[$WHICH]->dim(1); return $foundi; } ## $vals = $ccs->indexND($ndi) sub indexND :lvalue { my $tmp=$_[0][$VALS]->index($_[0]->indexNDi($_[1])); } ## $vals = $ccs->index2d($xi,$yi) sub index2d :lvalue { my $tmp=$_[0]->indexND($_[1]->cat($_[2])->xchg(0,1)); } ## $nzi = $ccs->xindex1d($xi) ## + nzi indices for dice_axis(0,$xi) ## + physically indexed only sub xindex1d :lvalue { my ($ccs,$xi) = @_; $ccs->make_physically_indexed; my $nzi = $ccs->[$WHICH]->ccs_xindex1d($xi); $nzi->sever; return $nzi; } ## $subset = $ccs->xsubset1d($xi) ## + subset object like dice_axis(0,$xi) without $xi-renumbering ## + returned object should participate in dataflow ## + physically indexed only sub xsubset1d :lvalue { my ($ccs,$xi) = @_; my $nzi = $ccs->xindex1d($xi); return $ccs->shadow(which=>$ccs->[$WHICH]->dice_axis(1,$nzi), vals =>$ccs->[$VALS]->index($nzi->append($ccs->_nnz))); } ## $nzi = $ccs->pxindex1d($dimi,$xi) ## + nzi indices for dice_axis($dimi,$xi), using ptr($dimi) ## + physically indexed only sub pxindex1d :lvalue { my ($ccs,$dimi,$xi) = @_; $ccs->make_physically_indexed(); my ($ptr,$pix) = $ccs->ptr($dimi); my $xptr = $ptr->index($xi); my $xlen = $ptr->index($xi+1) - $xptr; my $nzi = defined($pix) ? $pix->index($xlen->rldseq($xptr))->qsort : $xlen->rldseq($xptr); $nzi->sever; return $nzi; } ## $subset = $ccs->pxsubset1d($dimi,$xi) ## + subset object like dice_axis($dimi,$xi) without $xi-renumbering, using ptr($dimi) ## + returned object should participate in dataflow ## + physically indexed only sub pxsubset1d { my ($ccs,$dimi,$xi) = @_; my $nzi = $ccs->pxindex1d($dimi,$xi); return $ccs->shadow(which=>$ccs->[$WHICH]->dice_axis(1,$nzi), vals =>$ccs->[$VALS]->index($nzi->append($ccs->_nnz))); } ## $nzi = $ccs->xindex2d($xi,$yi) ## + returns nz-index piddle matching any index-pair in Cartesian product ($xi x $yi) ## + caller object must be a ccs-encoded 2d matrix ## + physically indexed only sub xindex2d :lvalue { my ($ccs,$xi,$yi) = @_; $ccs->make_physically_indexed; my $nzi = $ccs->[$WHICH]->ccs_xindex2d($xi,$yi); $nzi->sever; return $nzi; } ## $subset = $ccs->xsubset2d($xi,$yi) ## + returns a subset CCS object for all index-pairs in $xi,$yi ## + caller object must be a ccs-encoded 2d matrix ## + returned object should participate in dataflow ## + physically indexed only sub xsubset2d :lvalue { my ($ccs,$xi,$yi) = @_; my $nzi = $ccs->xindex2d($xi,$yi); return $ccs->shadow(which=>$ccs->[$WHICH]->dice_axis(1,$nzi), vals =>$ccs->[$VALS]->index($nzi->append($ccs->_nnz))); } ## $vals = $ccs->index($flati) sub index :lvalue { my ($ccs,$i) = @_; my $dummy = PDL->pdl(0)->slice(join(',', map {"*$_"} $ccs->dims)); my @coords = $dummy->one2nd($i); my $ind = PDL->zeroes($P_INDX,$ccs->ndims,$i->dims); my ($tmp); ($tmp=$ind->slice("($_),")) .= $coords[$_] foreach (0..$#coords); return $tmp=$ccs->indexND($ind); } ## $ccs2 = $ccs->dice_axis($axis_v, $axisi) ## + returns a new ccs object, should participate in dataflow sub dice_axis :lvalue { my ($ccs,$axis_v,$axisi) = @_; ## ##-- get my $ndims = $ccs->ndims; $axis_v = $ndims + $axis_v if ($axis_v < 0); PDL::Lite::barf(ref($ccs)."::dice_axis(): axis ".($axis_v<0 ? ($axis_v+$ndims) : $axis_v)." out of range: should be 0<=dim<$ndims") if ($axis_v < 0 || $axis_v >= $ndims); my $axis = $ccs->[$VDIMS]->at($axis_v); my $asize = $axis < 0 ? -$axis : $ccs->[$PDIMS]->at($axis); $axisi = PDL->topdl($axisi); my ($aimin,$aimax) = $axisi->minmax; PDL::Lite::barf(ref($ccs)."::dice_axis(): invalid index $aimin (valid range 0..".($asize-1).")") if ($aimin < 0); PDL::Lite::barf(ref($ccs)."::dice_axis(): invalid index $aimax (valid range 0..".($asize-1).")") if ($aimax >= $asize); ## ##-- check for virtual if ($axis < 0) { ##-- we're dicing a virtual axis: ok, but why? my $naxisi = $axisi->nelem; my $ccs2 = $ccs->copyShallow(); $ccs2->[$VDIMS] = $ccs->[$VDIMS]->pdl; $ccs2->[$VDIMS]->set($axis_v, -$naxisi); return $ccs2; } ##-- ok, we're dicing on a real axis my ($ptr,$pi2nzi) = $ccs->ptr($axis); my ($ptrix,$pi2nzix) = $ptr->ccs_decode_pointer($axisi); my $nzix = defined($pi2nzi) ? $pi2nzi->index($pi2nzix) : $pi2nzix; my $which = $ccs->[$WHICH]->dice_axis(1,$nzix); $which->sever; (my $tmp=$which->slice("($axis),")) .= $ptrix if (!$which->isempty); ##-- isempty() fix: v1.12 my $nzvals = $ccs->[$VALS]->index($nzix->append($ccs->[$WHICH]->dim(1))); ## ##-- construct output object my $ccs2 = $ccs->shadow(); $ccs2->[$PDIMS]->set($axis, $axisi->nelem); $ccs2->[$WHICH] = $which; $ccs2->[$VALS] = $nzvals; ## ##-- sort output object (if not dicing on 0th dimension) return $axis==0 ? $ccs2 : ($tmp=$ccs2->sortwhich()); } ## $onedi = $ccs->n2oned($ndi) ## + returns a pseudo-index sub n2oned :lvalue { my $dimsizes = PDL->pdl($P_INDX,1)->append($_[0]->dimpdl->abs)->slice("0:-2")->cumuprodover; return my $tmp=($_[1] * $dimsizes)->sumover; } ## $whichND = $obj->whichND ## + just returns the literal index PDL if possible: beware of dataflow! ## + indices are NOT guaranteed to be returned in any surface-logical order, ## although physically indexed dimensions should be sorted in physical-lexicographic order sub whichND :lvalue { my $vpi = ($_[0][$VDIMS]>=0)->which; my ($wnd); if ( $_[0][$VDIMS]->nelem==$_[0][$PDIMS]->nelem ) { if (($_[0][$VDIMS]->index($vpi)==$_[0][$PDIMS]->sequence)->all) { ##-- all literal & physically ordered $wnd=$_[0][$WHICH]; } else { ##-- all physical, but shuffled $wnd=$_[0][$WHICH]->dice_axis(0,$_[0][$VDIMS]->index($vpi)); } return wantarray ? $wnd->xchg(0,1)->dog : $wnd; } ##-- virtual dims are in the game: construct output pdl my $ccs = shift; my $nvperp = $ccs->_ccs_nvperp; my $nv = $ccs->nstored_v; $wnd = PDL->zeroes($P_INDX, $ccs->ndims, $nv); (my $tmp=$wnd->dice_axis(0,$vpi)->flat) .= $ccs->[$WHICH]->dummy(1,$nvperp)->flat; if (!$wnd->isempty) { my $nzi = PDL->sequence($P_INDX,$nv); my @vdims = $ccs->[$VDIMS]->list; my ($vdimi); foreach (grep {$vdims[$#vdims-$_]<0} (0..$#vdims)) { $vdimi = $#vdims-$_; $nzi->modulo(-$vdims[$vdimi], $wnd->slice("($vdimi),"), 0); } } return wantarray ? $wnd->xchg(0,1)->dog : $wnd; } ## $whichVals = $ccs->whichVals() ## + returns $VALS corresponding to whichND() indices ## + beware of dataflow! sub whichVals :lvalue { my $vpi = ($_[0][$VDIMS]>=0)->which; my ($tmp); return $tmp=$_[0]->_nzvals() if ( $_[0][$VDIMS]->nelem==$_[0][$PDIMS]->nelem ); ##-- all physical ## ##-- virtual dims are in the game: construct output pdl return $tmp=$_[0]->_nzvals->slice("*".($_[0]->_ccs_nvperp))->flat; } ## $which = $obj->which() ## + not guaranteed to be returned in any meaningful order sub which :lvalue { my $tmp=$_[0]->n2oned(scalar $_[0]->whichND); } ## $val = $ccs->at(@index) sub at { $_[0]->indexND(PDL->pdl($P_INDX,@_[1..$#_]))->sclr; } ## $val = $ccs->set(@index,$value) sub set { my $foundi = $_[0]->indexNDi(PDL->pdl($P_INDX,@_[1..($#_-1)])); if ( ($foundi==$_[0][$WHICH]->dim(1))->any ) { carp(ref($_[0]).": cannot set() a missing value!") } else { (my $tmp=$_[0][$VALS]->index($foundi)) .= $_[$#_]; } return $_[0]; } ##-------------------------------------------------------------- ## Mask Utilities ## $missing_mask = $ccs->ismissing() sub ismissing :lvalue { $_[0]->shadow(which=>$_[0][$WHICH]->pdl, vals=>$_[0]->_nzvals->zeroes->ccs_indx->append(1)); } ## $nonmissing_mask = $ccs->ispresent() sub ispresent :lvalue { $_[0]->shadow(which=>$_[0][$WHICH]->pdl, vals=>$_[0]->_nzvals->ones->ccs_indx->append(0)); } ##-------------------------------------------------------------- ## Ufuncs ## $ufunc_sub = _ufuncsub($subname, \&ccs_accum_sub, $allow_bad_missing) sub _ufuncsub { my ($subname,$accumsub,$allow_bad_missing) = @_; PDL::Lite::barf(__PACKAGE__, "::_ufuncsub($subname): no underlying CCS accumulator func!") if (!defined($accumsub)); return sub :lvalue { my $ccs = shift; ## ##-- preparation my $which = $ccs->whichND; my $vals = $ccs->whichVals; my $missing = $ccs->missing; my @dims = $ccs->dims; my ($which1,$vals1); if ($which->dim(0) <= 1) { ##-- flat sum $which1 = PDL->zeroes($P_INDX,1,$which->dim(1)); ##-- dummy $vals1 = $vals; } else { $which1 = $which->slice("1:-1,"); my $sorti = $which1->vv_qsortveci; $which1 = $which1->dice_axis(1,$sorti); $vals1 = $vals->index($sorti); } ## ##-- guts my ($which2,$nzvals2) = $accumsub->($which1,$vals1, ($allow_bad_missing || $missing->isgood ? ($missing, $dims[0]) : (PDL->pdl($vals1->type, 0), 0)) ); ## ##-- get output pdl shift(@dims); my ($tmp); return $tmp=$nzvals2->squeeze if (!@dims); ##-- just a scalar: return a plain PDL ## my $newdims = PDL->pdl($P_INDX,\@dims); return $tmp=$ccs->shadow( pdims =>$newdims, vdims =>$newdims->sequence, which =>$which2, vals =>$nzvals2->append($missing->convert($nzvals2->type)), ); }; } foreach my $ufunc ( qw(prod dprod sum dsum), qw(and or band bor), ) { no strict 'refs'; *{"${ufunc}over"} = _ufuncsub("${ufunc}over", PDL::CCS::Ufunc->can("ccs_accum_${ufunc}")); } foreach my $ufunc (qw(maximum minimum average)) { no strict 'refs'; *$ufunc = _ufuncsub($ufunc, PDL::CCS::Ufunc->can("ccs_accum_${ufunc}")); } *nbadover = _ufuncsub('nbadover', PDL::CCS::Ufunc->can('ccs_accum_nbad'), 1); *ngoodover = _ufuncsub('ngoodover', PDL::CCS::Ufunc->can('ccs_accum_ngood'), 1); *nnz = _ufuncsub('nnz', PDL::CCS::Ufunc->can('ccs_accum_nnz'), 1); sub average_nz :lvalue { my $ccs = shift; return my $tmp=($ccs->sumover / $ccs->nnz); } #sub average { # my $ccs = shift; # my $missing = $ccs->missing; # return $ccs->sumover / $ccs->dim(0) if ($missing==0); # return ($ccs->sumover + (-$ccs->nnz+$ccs->dim(0))*$missing) / $ccs->dim(0); #} sub sum { my $z=$_[0]->missing; $_[0]->_nzvals->sum + ($z->isgood ? ($z->sclr * $_[0]->nmissing) : 0); } sub dsum { my $z=$_[0]->missing; $_[0]->_nzvals->dsum + ($z->isgood ? ($z->sclr * $_[0]->nmissing) : 0); } sub prod { my $z=$_[0]->missing; $_[0]->_nzvals->prod * ($z->isgood ? ($z->sclr ** $_[0]->nmissing) : 1); } sub dprod { my $z=$_[0]->missing; $_[0]->_nzvals->dprod * ($z->isgood ? ($z->sclr ** $_[0]->nmissing) : 1); } sub min { $_[0][$VALS]->min; } sub max { $_[0][$VALS]->max; } sub minmax { $_[0][$VALS]->minmax; } sub nbad { my $z=$_[0]->missing; $_[0]->_nzvals->nbad + ($z->isbad ? $_[0]->nmissing : 0); } sub ngood { my $z=$_[0]->missing; $_[0]->_nzvals->ngood + ($z->isgood ? $_[0]->nmissing : 0); } sub any { $_[0][$VALS]->any; } sub all { $_[0][$VALS]->all; } sub avg { my $z=$_[0]->missing; return ($_[0]->_nzvals->sum + ($_[0]->nelem-$_[0]->_nnz)*$z->sclr) / $_[0]->nelem; } sub avg_nz { $_[0]->_nzvals->avg; } sub isbad { my ($a,$out) = @_; return $a->shadow(which=>$a->[$WHICH]->pdl,vals=>$a->[$VALS]->isbad,to=>$out); } sub isgood { my ($a,$out) = @_; return $a->shadow(which=>$a->[$WHICH]->pdl,vals=>$a->[$VALS]->isgood,to=>$out); } ##-------------------------------------------------------------- ## Index-Ufuncs sub _ufunc_ind_sub { my ($subname,$accumsub,$allow_bad_missing) = @_; PDL::Lite::barf(__PACKAGE__, "::_ufuncsub($subname): no underlying CCS accumulator func!") if (!defined($accumsub)); return sub :lvalue { my $ccs = shift; ## ##-- preparation my $which = $ccs->whichND; my $vals = $ccs->whichVals; my $missing = $ccs->missing; my @dims = $ccs->dims; my ($which0,$which1,$vals1); if ($which->dim(0) <= 1) { ##-- flat X_ind $which0 = $which->slice("(0),"); $which1 = PDL->zeroes($P_INDX,1,$which->dim(1)); ##-- dummy $vals1 = $vals; } else { my $sorti = $which->dice_axis(0, PDL->sequence($P_INDX,$which->dim(0))->rotate(-1))->vv_qsortveci; $which1 = $which->slice("1:-1,")->dice_axis(1,$sorti); $which0 = $which->slice("(0),")->index($sorti); $vals1 = $vals->index($sorti); } ## ##-- guts my ($which2,$nzvals2) = $accumsub->($which1,$vals1, ($allow_bad_missing || $missing->isgood ? ($missing,$dims[0]) : (0,0)) ); ## ##-- get output pdl shift(@dims); my $nzi2 = $nzvals2; my $nzi2_ok = ($nzvals2>=0); my ($tmp); ($tmp=$nzi2->where($nzi2_ok)) .= $which0->index($nzi2->where($nzi2_ok)); return $tmp=$nzi2->squeeze if (!@dims); ##-- just a scalar: return a plain PDL ## my $newdims = PDL->pdl($P_INDX,\@dims); return $tmp=$ccs->shadow( pdims =>$newdims, vdims =>$newdims->sequence, which =>$which2, vals =>$nzi2->append(ccs_indx(-1)), ); }; } *maximum_ind = _ufunc_ind_sub('maximum_ind', PDL::CCS::Ufunc->can('ccs_accum_maximum_nz_ind'),1); *minimum_ind = _ufunc_ind_sub('minimum_ind', PDL::CCS::Ufunc->can('ccs_accum_minimum_nz_ind'),1); ##-------------------------------------------------------------- ## Ufuncs: qsort (from CCS::Functions) ## ($which0,$nzVals0, $nzix,$nzenum, $whichOut) = $ccs->_qsort() ## ($which0,$nzVals0, $nzix,$nzenum, $whichOut) = $ccs->_qsort([o]nzix(NNz), [o]nzenum(Nnz)) sub _qsort { my $ccs = shift; my $which0 = $ccs->whichND; my $nzvals0 = $ccs->whichVals; return ($which0,$nzvals0, ccs_qsort($which0->slice("1:-1,"),$nzvals0, $ccs->missing,$ccs->dim(0), @_)); } ## $ccs_sorted = $ccs->qsort() ## $ccs_sorted = $ccs->qsort($ccs_sorted) sub qsort :lvalue { my $ccs = shift; my ($which0,$nzvals0,$nzix,$nzenum) = $ccs->_qsort(); my $newdims = PDL->pdl($P_INDX,[$ccs->dims]); return my $tmp=$ccs->shadow( to => $_[0], pdims =>$newdims, vdims =>$newdims->sequence, which =>$nzenum->slice("*1,")->glue(0,$which0->slice("1:-1,")->dice_axis(1,$nzix)), vals =>$nzvals0->index($nzix)->append($ccs->missing), ); } ## $ccs_sortedi = $ccs->qsorti() ## $ccs_sortedi = $ccs->qsorti($ccs_sortedi) sub qsorti :lvalue { my $ccs = shift; my ($which0,$nzvals0,$nzix,$nzenum) = $ccs->_qsort(); my $newdims = PDL->pdl($P_INDX,[$ccs->dims]); return my $tmp=$ccs->shadow( to => $_[0], pdims =>$newdims, vdims =>$newdims->sequence, which =>$nzenum->slice("*1,")->glue(0,$which0->slice("1:-1,")->dice_axis(1,$nzix)), vals =>$which0->slice("(0),")->index($nzix)->append(ccs_indx(-1)), ); } ##-------------------------------------------------------------- ## Unary Operations ## $sub = _unary_op($opname,$pdlsub) sub _unary_op { my ($opname,$pdlsub) = @_; return sub :lvalue { if ($_[0]->is_inplace) { $pdlsub->($_[0][$VALS]->inplace); $_[0]->set_inplace(0); return $_[0]; } return my $tmp=$_[0]->shadow(which=>$_[0][$WHICH]->pdl, vals=>$pdlsub->($_[0][$VALS])); }; } foreach my $unop (qw(bitnot sqrt abs sin cos not exp log log10)) { no strict 'refs'; *$unop = _unary_op($unop,PDL->can($unop)); } ##-------------------------------------------------------------- ## OLD (but still used): Binary Operations: missing-is-annihilator ## ($rdpdl,$pdimsc,$vdimsc,$apcp,$bpcp) = _ccsnd_binop_align_dims($pdimsa,$vdimsa, $pdimsb,$vdimsb, $opname) # + returns: ## $rdpdl : (indx,2,$nrdims) : [ [$vdimai,$vdimbi], ...] s.t. $vdimai should align with $vdimbi ## $pdimsc : (indx,$ndimsc) : physical dim-size pdl for CCS output $c() ## $vdimsc : (indx,$ndimsc) : virtual dim-size pdl for CCS output $c() ## $apcp : (indx,2,$nac) : [ [$apdimi,$cpdimi], ... ] s.t. $cpdimi aligns 1-1 with $apdimi ## $bpcp : (indx,2,$nbc) : [ [$bpdimi,$cpdimi], ... ] s.t. $cpdimi aligns 1-1 with $bpdimi sub _ccsnd_binop_align_dims { my ($pdimsa,$vdimsa,$pdimsb,$vdimsb, $opname) = @_; $opname = '_ccsnd_binop_relevant_dims' if (!defined($opname)); ##-- init my @pdimsa = $pdimsa->list; my @pdimsb = $pdimsb->list; my @vdimsa = $vdimsa->list; my @vdimsb = $vdimsb->list; ##-- get alignment-relevant dims my @rdims = qw(); my ($vdima,$vdimb, $dimsza,$dimszb); foreach (0..($#vdimsa < $#vdimsb ? $#vdimsa : $#vdimsb)) { $vdima = $vdimsa[$_]; $vdimb = $vdimsb[$_]; ##-- get (virtual) dimension sizes $dimsza = $vdima>=0 ? $pdimsa[$vdima] : -$vdima; $dimszb = $vdimb>=0 ? $pdimsb[$vdimb] : -$vdimb; ##-- check for (virtual) size mismatch next if ($dimsza==1 || $dimszb==1); ##... ignoring (virtual) dims of size 1 PDL::Lite::barf( __PACKAGE__ , "::$opname(): dimension size mismatch on dim($_): $dimsza != $dimszb") if ($dimsza != $dimszb); ##-- dims match: only align if both are physical push(@rdims, [$vdima,$vdimb]) if ($vdima>=0 && $vdimb>=0); } my $rdpdl = PDL->pdl($P_INDX,\@rdims); ##-- get output dimension sources my @_cdsrc = qw(); ##-- ( $a_or_b_for_dim0, ... ) foreach (0..($#vdimsa > $#vdimsb ? $#vdimsa : $#vdimsb)) { push(@vdimsa, -1) if ($_ >= @vdimsa); push(@vdimsb, -1) if ($_ >= @vdimsb); $vdima = $vdimsa[$_]; $vdimb = $vdimsb[$_]; $dimsza = $vdima>=0 ? $pdimsa[$vdima] : -$vdima; $dimszb = $vdimb>=0 ? $pdimsb[$vdimb] : -$vdimb; if ($vdima>=0) { if ($vdimb>=0) { push(@_cdsrc, $dimsza>=$dimszb ? 0 : 1); } ##-- a:p, b:p --> c:p[max2(sz(a),sz(b))] else { push(@_cdsrc, 0); } ##-- a:p, b:v --> c:p[a] } elsif ($vdimb>=0) { push(@_cdsrc, 1); } ##-- a:v, b:p --> c:p[b] else { push(@_cdsrc, $dimsza>=$dimszb ? 0 : 1); } ##-- a:v, b:v --> c:v[max2(sz(a),sz(b))] } my $_cdsrcp = PDL->pdl($P_INDX,@_cdsrc); ##-- get c() dimension pdls my @pdimsc = qw(); my @vdimsc = qw(); my @apcp = qw(); ##-- ([$apdimi,$cpdimi], ...) my @bpcp = qw(); ##-- ([$bpdimi,$bpdimi], ...) foreach (0..$#_cdsrc) { if ($_cdsrc[$_]==0) { ##-- source(dim=$_) == a if ($vdimsa[$_]<0) { $vdimsc[$_]=$vdimsa[$_]; } else { $vdimsc[$_] = @pdimsc; push(@apcp, [$vdimsa[$_],scalar(@pdimsc)]); push(@pdimsc, $pdimsa[$vdimsa[$_]]); } } else { ##-- source(dim=$_) == b if ($vdimsb[$_]<0) { $vdimsc[$_]=$vdimsb[$_]; } else { $vdimsc[$_] = @pdimsc; push(@bpcp, [$vdimsb[$_],scalar(@pdimsc)]); push(@pdimsc, $pdimsb [$vdimsb[$_]]); } } } my $pdimsc = PDL->pdl($P_INDX,\@pdimsc); my $vdimsc = PDL->pdl($P_INDX,\@vdimsc); my $apcp = PDL->pdl($P_INDX,\@apcp); my $bpcp = PDL->pdl($P_INDX,\@bpcp); return ($rdpdl,$pdimsc,$vdimsc,$apcp,$bpcp); } ##-- OLD (but still used) ## \&code = _ccsnd_binary_op_mia($opName, \&pdlSub, $defType, $noSwap) ## + returns code for wrapping a builtin PDL binary operation \&pdlSub under the name "$opName" ## + $opName is just used for error reporting ## + $defType (if specified) is the default output type of the operation (e.g. PDL::long()) sub _ccsnd_binary_op_mia { my ($opname,$pdlsub,$deftype,$noSwap) = @_; return sub :lvalue { my ($a,$b,$swap) = @_; my ($tmp); $swap=0 if (!defined($swap)); ##-- check for & dispatch scalar operations if (!ref($b) || $b->nelem==1) { if ($a->is_inplace) { $pdlsub->($a->[$VALS]->inplace, todense($b), ($noSwap ? qw() : $swap)); $a->set_inplace(0); return $tmp=$a->recode; } return $tmp=$a->shadow( which => $a->[$WHICH]->pdl, vals => $pdlsub->($a->[$VALS], todense($b), ($noSwap ? qw() : $swap)) )->recode; } ##-- convert b to CCS $b = toccs($b); ##-- align dimensions & determine output sources my ($rdpdl,$pdimsc,$vdimsc,$apcp,$bpcp) = _ccsnd_binop_align_dims(@$a[$PDIMS,$VDIMS], @$b[$PDIMS,$VDIMS], $opname); my $nrdims = $rdpdl->dim(1); ##-- get & sort relevant indices, vals my $ixa = $a->[$WHICH]; my $avals = $a->[$VALS]; my $nixa = $ixa->dim(1); my $ra = $rdpdl->slice("(0)"); my ($ixar,$avalsr); if ( $rdpdl->isempty ) { ##-- a: no relevant dims: align all pairs using a pseudo-dimension $ixar = PDL->zeroes($P_INDX, 1,$nixa); $avalsr = $avals; } elsif ( ($ra==PDL->sequence($P_INDX,$nrdims))->all ) { ##-- a: relevant dims are a prefix of physical dims, e.g. pre-sorted $ixar = $nrdims==$ixa->dim(0) ? $ixa : $ixa->slice("0:".($nrdims-1)); $avalsr = $avals; } else { $ixar = $ixa->dice_axis(0,$ra); my $ixar_sorti = $ixar->qsortveci; $ixa = $ixa->dice_axis(1,$ixar_sorti); $ixar = $ixar->dice_axis(1,$ixar_sorti); $avalsr = $avals->index($ixar_sorti); } ## my $ixb = $b->[$WHICH]; my $bvals = $b->[$VALS]; my $nixb = $ixb->dim(1); my $rb = $rdpdl->slice("(1)"); my ($ixbr,$bvalsr); if ( $rdpdl->isempty ) { ##-- b: no relevant dims: align all pairs using a pseudo-dimension $ixbr = PDL->zeroes($P_INDX, 1,$nixb); $bvalsr = $bvals; } elsif ( ($rb==PDL->sequence($P_INDX,$nrdims))->all ) { ##-- b: relevant dims are a prefix of physical dims, e.g. pre-sorted $ixbr = $nrdims==$ixb->dim(0) ? $ixb : $ixb->slice("0:".($nrdims-1)); $bvalsr = $bvals; } else { $ixbr = $ixb->dice_axis(0,$rb); my $ixbr_sorti = $ixbr->qsortveci; $ixb = $ixb->dice_axis(1,$ixbr_sorti); $ixbr = $ixbr->dice_axis(1,$ixbr_sorti); $bvalsr = $bvals->index($ixbr_sorti); } ##-- initialize: state vars my $blksz = $nixa > $nixb ? $nixa : $nixb; $blksz = $BINOP_BLOCKSIZE_MIN if ($BINOP_BLOCKSIZE_MIN && $blksz < $BINOP_BLOCKSIZE_MIN); $blksz = $BINOP_BLOCKSIZE_MAX if ($BINOP_BLOCKSIZE_MAX && $blksz > $BINOP_BLOCKSIZE_MAX); my $istate = PDL->zeroes($P_INDX,7); ##-- [ nnzai,nnzai_nxt, nnzbi,nnzbi_nxt, nnzci,nnzci_nxt, cmpval ] my $ostate = $istate->pdl; ##-- initialize: output vectors my $nzai = PDL->zeroes($P_INDX,$blksz); my $nzbi = PDL->zeroes($P_INDX,$blksz); my $nzc = PDL->zeroes((defined($deftype) ? $deftype : ($avals->type > $bvals->type ? $avals->type : $bvals->type)), $blksz); my $ixc = PDL->zeroes($P_INDX, $pdimsc->nelem, $blksz); my $nnzc = 0; my $zc = $pdlsub->($avals->slice("-1"), $bvals->slice("-1"), ($noSwap ? qw() : $swap))->convert($nzc->type); my $nanismissing = ($a->[$FLAGS]&$CCSND_NAN_IS_MISSING); my $badismissing = ($a->[$FLAGS]&$CCSND_BAD_IS_MISSING); $zc = $zc->setnantobad() if ($nanismissing && $badismissing); my $zc_isbad = $zc->isbad ? 1 : 0; ##-- block-wise variables ## + there are way too many of these... my ($nzai_prv,$nzai_pnx, $nzbi_prv,$nzbi_pnx, $nzci_prv,$nzci_pnx,$cmpval_prv); my ($nzai_cur,$nzai_nxt, $nzbi_cur,$nzbi_nxt, $nzci_cur,$nzci_nxt,$cmpval); my ($nzci_max, $blk_slice, $nnzc_blk,$nnzc_slice_blk); my ($nzai_blk,$nzbi_blk,$ixa_blk,$ixb_blk,$ixc_blk,$nzc_blk,$cimask_blk,$ciwhich_blk); my $nnzc_prev=0; do { ##-- align a block of data ccs_binop_align_block_mia($ixar,$ixbr,$istate, $nzai,$nzbi,$ostate); ##-- parse current alignment algorithm state ($nzai_prv,$nzai_pnx, $nzbi_prv,$nzbi_pnx, $nzci_prv,$nzci_pnx,$cmpval_prv) = $istate->list; ($nzai_cur,$nzai_nxt, $nzbi_cur,$nzbi_nxt, $nzci_cur,$nzci_nxt,$cmpval) = $ostate->list; $nzci_max = $nzci_cur-1; if ($nzci_max >= 0) { ##-- construct block output pdls: nzvals $blk_slice = "${nzci_prv}:${nzci_max}"; $nzai_blk = $nzai->slice($blk_slice); $nzbi_blk = $nzbi->slice($blk_slice); $nzc_blk = $pdlsub->($avalsr->index($nzai_blk), $bvalsr->index($nzbi_blk), ($noSwap ? qw() : $swap)); ##-- get indices of non-$missing c() values $cimask_blk = $zc_isbad || $nzc_blk->badflag ? $nzc_blk->isgood : ($nzc_blk!=$zc); $cimask_blk &= $nzc_blk->isgood if (!$zc_isbad && $badismissing); $cimask_blk &= $nzc_blk->isfinite if ($nanismissing); if ($cimask_blk->any) { $ciwhich_blk = $cimask_blk->which; $nzc_blk = $nzc_blk->index($ciwhich_blk); $nnzc_blk = $nzc_blk->nelem; $nnzc += $nnzc_blk; $nnzc_slice_blk = "${nnzc_prev}:".($nnzc-1); ##-- construct block output pdls: ixc $ixc_blk = $ixc->slice(",$nnzc_slice_blk"); if (!$apcp->isempty) { $ixa_blk = $ixa->dice_axis(1,$nzai_blk->index($ciwhich_blk)); ($tmp=$ixc_blk->dice_axis(0,$apcp->slice("(1),"))) .= $ixa_blk->dice_axis(0,$apcp->slice("(0),")); } if (!$bpcp->isempty) { $ixb_blk = $ixb->dice_axis(1,$nzbi_blk->index($ciwhich_blk)); ($tmp=$ixc_blk->dice_axis(0,$bpcp->slice("(1),"))) .= $ixb_blk->dice_axis(0,$bpcp->slice("(0),")); } ##-- construct block output pdls: nzc ($tmp=$nzc->slice($nnzc_slice_blk)) .= $nzc_blk; } } ##-- possibly allocate for another block if ($nzai_cur < $nixa || $nzbi_cur < $nixb) { $nzci_nxt -= $nzci_cur; $nzci_cur = 0; if ($nzci_nxt+$blksz > $nzai->dim(0)) { $nzai = $nzai->reshape($nzci_nxt+$blksz); $nzbi = $nzbi->reshape($nzci_nxt+$blksz); } $ixc = $ixc->reshape($ixc->dim(0), $ixc->dim(1)+$nzai->dim(0)); $nzc = $nzc->reshape($nzc->dim(0)+$nzai->dim(0)); ($tmp=$istate) .= $ostate; $istate->set(4, $nzci_cur); $istate->set(5, $nzci_nxt); } $nnzc_prev = $nnzc; } while ($nzai_cur < $nixa || $nzbi_cur < $nixb); ##-- trim output pdls if ($nnzc > 0) { ##-- usual case: some values are non-missing $ixc = $ixc->slice(",0:".($nnzc-1)); my $ixc_sorti = $ixc->vv_qsortveci; $nzc = $nzc->index($ixc_sorti)->append($zc->convert($nzc->type)); $nzc->sever; $ixc = $ixc->dice_axis(1,$ixc_sorti); $ixc->sever; } else { ##-- pathological case: all values are "missing" $ixc = $ixc->dice_axis(1,PDL->pdl([])); $ixc->sever; $nzc = $zc->convert($zc->type); } ##-- set up final output object my $c = $a->shadow( pdims => $pdimsc, vdims => $vdimsc, which => $ixc, vals => $nzc, ); if ($a->is_inplace) { @$a = @$c; $a->set_inplace(0); return $a; } return $c; }; } ##-------------------------------------------------------------- ## NEW (but unused): Binary Operations: missing-is-annihilator: alignment ## \@parsed = _ccsnd_parse_signature($sig) ## \@parsed = _ccsnd_parse_signature($sig, $errorName) ## + parses a PDL-style signature ## + returned array has the form: ## ( $parsed_arg1, $parsed_arg2, ..., $parsed_argN ) ## + where $parsed_arg$i = ## { name=>$argName, type=>$type, flags=>$flags, dims=>\@argDimNames, ... } ## + $flags is the string inside [] between type and arg name, if any sub _ccsnd_parse_signature { my ($sig,$errname) = @_; if ($sig =~ /^\s*\(/) { ##-- remove leading and trailing parentheses from signature $sig =~ s/^\s*\(\s*//; $sig =~ s/\s*\)\s*//; } my @args = ($sig =~ /[\s;]*([^\;]+)/g); my $parsed = []; my ($argName,$dimStr,$type,$flags,@dims); foreach (@args) { ($type,$flags) = ('',''); ##-- check for type if ($_ =~ s/^\s*(byte|short|ushort|int|long|longlong|indx|float|double)\s*//) { $type = $1; } ##-- check for []-flags if ($_ =~ s/^\s*\[([^\]]*)\]\s*//g) { $flags = $1; } ##-- create output list: $argNumber=>{name=>$argName, dims=>[$dimNumber=>$dimName]} if ($_ =~ /^\s*(\S+)\s*\(([^\)]*)\)\s*$/) { ($argName,$dimStr) = ($1,$2); @dims = grep {defined($_) && $_ ne ''} split(/\,\s*/, $dimStr); push(@$parsed,{type=>$type,flags=>$flags,name=>$argName,dims=>[@dims]}); } else { $errname = __PACKAGE__ . "::_ccsnd_parse_signature()" if (!defined($errname)); die("${errname}: could not parse argument string '$_' for signature '$sig'"); } } return $parsed; } ## \%dims = _ccsnd_align_dims(\@parsedSig, \@ccs_arg_pdls) ## \%dims = _ccsnd_align_dims(\@parsedSig, \@ccs_arg_pdls, $opName) ## + returns an dimension-alignment structure for @parsedSig with args @ccs_arg_pdls ## + returned %dims: ## ( $dimName => {size=>$dimSize, phys=>\@physical }, ... ) ## - dim names "__thread_dim_${i}" are reserved ## - \@physical = [ [$argi,$pdimi_in_argi], ... ] sub _ccsnd_align_dims { my ($sig,$args,$opName) = @_; $opName = __PACKAGE__ . "::_ccsnd_align_dims()" if (!defined($opName)); ##-- init: get virtual & physical dimension lists for arguments my @vdims = map { [$_->[$VDIMS]->list] } @$args; my @pdims = map { [$_->[$PDIMS]->list] } @$args; ##-- %dims = ($dimName => {size=>$dimSize, phys=>\@physical,... }) ## + dim names "__thread_dim_${i}" are reserved ## + \@physical = [ [$argi,$pdimi], ... ] my %dims = map {($_=>undef)} map {@{$_->{dims}}} @$sig; my $nthreads = 0; ##-- number of threaded dims ##-- iterate over signature arguments, getting & checking dimension sizes my ($threadi, $argi,$arg_sig,$arg_ccs, $maxdim,$dimi,$pdimi,$dim_sig,$dim_ccs,$dimName, $dimsize,$isvdim); foreach $argi (0..$#$sig) { $arg_sig = $sig->[$argi]; $arg_ccs = $args->[$argi]; ##-- check for unspecified args if (!defined($arg_ccs)) { next if ($arg_sig->{flags} =~ /[ot]/); ##-- ... but not output or temporaries croak("$opName: argument '$arg_sig->{name}' not specified!"); } ##-- reset thread counter $threadi=0; ##-- check dimension sizes $maxdim = _max2($#{$arg_sig->{dims}}, $#{$vdims[$argi]}); foreach $dimi (0..$maxdim) { if (defined($dim_sig = $arg_sig->{dims}[$dimi])) { ##-- explicit dimension: name it $dimName = $dim_sig; } else { $dimName = "__thread_dim_".($threadi++); } if ($#{$vdims[$argi]} >= $dimi) { $pdimi = $vdims[$argi][$dimi]; if ($pdimi >= 0) { $dimsize = $pdims[$argi][$pdimi]; $isvdim = 0; } else { $dimsize = -$pdimi; $isvdim = 1; } } else { $dimsize = 1; $isvdim = 1; } if (!defined($dims{$dimName})) { ##-- new dimension $dims{$dimName} = { size=>$dimsize, phys=>[] }; } elsif ($dims{$dimName}{size} != $dimsize) { if ($dims{$dimName}{size}==1) { ##-- ... we already had it, but as size=1 : override the stored size $dims{$dimName}{size} = $dimsize; } elsif ($dimsize != 1) { ##-- ... this is a non-trivial (size>1) dim which doesn't match: complain croak("$opName: size mismatch on dimension '$dimName' in argument '$arg_sig->{name}'", ": is $dimsize, should be $dims{$dimName}{size}"); } } if (!$isvdim) { ##-- physical dim: add to alignment structure push(@{$dims{$dimName}{phys}}, [$argi,$pdimi]); } } $nthreads = $threadi if ($threadi > $nthreads); } ##-- check for undefined dims foreach (grep {!defined($dims{$_})} keys(%dims)) { #croak("$opName: cannot determine size for dimension '$_'"); ## ##-- just set it to 1? $dims{$_} = {size=>1,phys=>[]}; } return \%dims; } ##-------------------------------------------------------------- ## Binary Operations: missing-is-annihilator: wrappers ##-- arithmetical & comparison operations foreach my $binop ( qw(plus minus mult divide modulo power), qw(gt ge lt le eq ne spaceship), ) { no strict 'refs'; *$binop = *{"${binop}_mia"} = _ccsnd_binary_op_mia($binop,PDL->can($binop)); die(__PACKAGE__, ": could not define binary operation $binop: $@") if ($@); } *pow = *pow_mia = _ccsnd_binary_op_mia('power',PDL->can('pow'),undef,1); ##-- integer-only operations foreach my $intop ( qw(and2 or2 xor shiftleft shiftright), ) { my $deftype = PDL->can($intop)->(PDL->pdl(0),PDL->pdl(0),0)->type->ioname; no strict 'refs'; *$intop = *{"${intop}_mia"} = _ccsnd_binary_op_mia($intop,PDL->can($intop),"PDL::${deftype}"->()); die(__PACKAGE__, ": could not define integer operation $intop: $@") if ($@); } ## rassgn_mia($to,$from): binary assignment operation with missing-annihilator assumption ## + argument order is REVERSE of PDL 'assgn()' argument order *rassgn_mia = _ccsnd_binary_op_mia('rassgn', sub { PDL::assgn($_[1],$_[0]); $_[1]; }); ## $to = $to->rassgn($from) ## + calls newFromDense() with $to flags if $from is dense ## + otherwise, copies $from to $to ## + argument order is REVERSED wrt PDL::assgn() sub rassgn :lvalue { my ($to,$from) = @_; if (!ref($from) || $from->nelem==1) { ##-- assignment from a scalar: treat the Nd object as a mask of available values (my $tmp=$to->[$VALS]) .= todense($from); return $to; } if (isa($from,__PACKAGE__)) { ##-- assignment from a CCS object: copy on a full dim match or an empty "$to" my $fromdimp = $from->dimpdl; my $todimp = $to->dimpdl; if ( $to->[$VALS]->dim(0)<=1 || $todimp->isempty || ($fromdimp==$todimp)->all ) { @$to = @{$from->copy}; return $to; } } ##-- $from is something else: pass it on to 'rassgn_mia': effectively treat $to->[$WHICH] as a mask for $from $to->[$FLAGS] |= $CCSND_INPLACE; return my $tmp=$to->rassgn_mia($from); } ## $to = $from->assgn($to) ## + obeys PDL conventions sub assgn :lvalue { return my $tmp=$_[1]->rassgn($_[0]); } ##-------------------------------------------------------------- ## CONTINUE HERE ## TODO: ## + virtual dimensions: clump ## + OPERATIONS: ## - accumulators: (some still missing: statistical, extrema-indices, atan2, ...) ##-------------------------------------------------------------- ## Matrix operations ## $c = $a->inner($b) ## + inner product (may produce a large temporary) sub inner :lvalue { $_[0]->mult_mia($_[1],0)->sumover; } ## $c = $a->matmult($b) ## + mostly ganked from PDL::Primitive::matmult sub matmult :lvalue { PDL::Lite::barf("Invalid number of arguments for ", __PACKAGE__, "::matmult") if ($#_ < 1); my ($a,$b,$c) = @_; ##-- no $c! $c = undef if (!ref($c) && defined($c) && $c eq ''); ##-- strangeness: getting $c='' $b=toccs($b); ##-- ensure 2nd arg is a CCS object ##-- promote if necessary while ($a->getndims < 2) {$a = $a->dummy(-1)} while ($b->getndims < 2) {$b = $b->dummy(-1)} ##-- vector multiplication (easy) if ( ($a->dim(0)==1 && $a->dim(1)==1) || ($b->dim(0)==1 && $b->dim(1)==1) ) { if (defined($c)) { @$c = @{$a*$b}; return $c; } return $c=($a*$b); } if ($b->dim(1) != $a->dim(0)) { PDL::Lite::barf(sprintf("Dim mismatch in ", __PACKAGE__ , "::matmult of [%dx%d] x [%dx%d]: %d != %d", $a->dim(0),$a->dim(1),$b->dim(0),$b->dim(1),$a->dim(0),$b->dim(1))); } my $_c = $a->dummy(1)->inner($b->xchg(0,1)->dummy(2)); ##-- ye olde guttes if (defined($c)) { @$c = @$_c; return $c; } return $_c; } ## $c_dense = $a->matmult2d_sdd($b_dense) ## $c_dense = $a->matmult2d_sdd($b_dense, $zc) ## + signature as for PDL::Primitive::matmult() ## + should handle missing values correctly (except for BAD, inf, NaN, etc.) ## + see PDL::CCS::MatrixOps(3pm) for details sub matmult2d_sdd :lvalue { my ($a,$b,$c, $zc) = @_; $c = undef if (!ref($c) && defined($c) && $c eq ''); ##-- strangeness: getting $c='' ##-- promote if necessary while ($a->getndims < 2) {$a = $a->dummy(-1)} while ($b->getndims < 2) {$b = $b->dummy(-1)} ##-- vector multiplication (easy) if ( ($a->dim(0)==1 && $a->dim(1)==1) || ($b->dim(0)==1 && $b->dim(1)==1) ) { if (defined($c)) { @$c = @{$a*$b}; return $c; } return $c=($a*$b); } ##-- check dim sizes if ($b->dim(1) != $a->dim(0)) { PDL::Lite::barf(sprintf("Dim mismatch in ", __PACKAGE__, "::matmult2d [%dx%d] x [%dx%d] : %d != %d", $a->dims,$b->dims, $a->dim(0),$b->dim(1))); } ##-- ensure $b dense, $a physically indexed ccs $b = todense($b) if ($b->isa(__PACKAGE__)); $a = $a->to_physically_indexed(); $c //= PDL->null; ##-- compute $zc if required if (!defined($zc)) { $zc = (($a->missing + PDL->zeroes($a->type, $a->dim(0), 1)) x $b)->flat; } ccs_matmult2d_sdd($a->_whichND,$a->_nzvals,$a->missing->squeeze, $b, $zc, $c, $a->dim(1)); return $c; } ## $c_dense = $a->matmult2d_zdd($b_dense) ## + signature as for PDL::Primitive::matmult() ## + assumes $a->missing==0 sub matmult2d_zdd :lvalue { my ($a,$b,$c) = @_; $c = undef if (!ref($c) && defined($c) && $c eq ''); ##-- strangeness: getting $c='' ##-- promote if necessary while ($a->getndims < 2) {$a = $a->dummy(-1)} while ($b->getndims < 2) {$b = $b->dummy(-1)} ##-- vector multiplication (easy) if ( ($a->dim(0)==1 && $a->dim(1)==1) || ($b->dim(0)==1 && $b->dim(1)==1) ) { if (defined($c)) { @$c = @{$a*$b}; return $c; } return $c=($a*$b); } ##-- check dim sizes if ($b->dim(1) != $a->dim(0)) { PDL::Lite::barf(sprintf("Dim mismatch in ", __PACKAGE__, "::matmult2d [%dx%d] x [%dx%d] : %d != %d", $a->dims,$b->dims, $a->dim(0),$b->dim(1))); } ##-- ensure $b dense, $a physically indexed ccs $b = todense($b) if ($b->isa(__PACKAGE__)); $a = $a->to_physically_indexed(); $c //= PDL->null; ccs_matmult2d_zdd($a->_whichND,$a->_nzvals, $b, $c, $a->dim(1)); return $c; } ## $vnorm_dense = $a->vnorm($pdimi, ?$vnorm_dense) ## + assumes $a->missing==0 sub vnorm { my ($a,$pdimi,$vnorm) = @_; $a = $a->to_physically_indexed(); ccs_vnorm($a->_whichND->slice("($pdimi),"), $a->_nzvals, ($vnorm//=PDL->null), $a->dim($pdimi)); return $vnorm; } ## $vcos_dense = $a->vcos_zdd($b_dense, ?$vcos_dense, ?$norm_dense) ## + assumes $a->missing==0 sub vcos_zdd { my $a = shift; my $b = shift; ##-- ensure $b dense, $a physically indexed ccs $b = todense($b) if (!UNIVERSAL::isa($b,__PACKAGE__)); $a = $a->to_physically_indexed(); ##-- guts return ccs_vcos_zdd($a->_whichND, $a->_nzvals, $b, $a->dim(0), @_); } ## $vcos_dense = $a->vcos_pzd($b_sparse, ?$norm_dense, ?$vcos_dense) ## + assumes $a->missing==0 ## + uses $a->ptr(1) sub vcos_pzd { my $a = shift; my $b = shift; ##-- ensure $b dense, $a physically indexed ccs $b = toccs($b) if (!UNIVERSAL::isa($b,__PACKAGE__)); $a = $a->to_physically_indexed(); $b = $b->to_physically_indexed(); ##-- get params my ($aptr,$aqsi) = $a->ptr(1); my $arows = $a->[$WHICH]->slice("(0),")->index($aqsi); my $avals = $a->[$VALS]->index($aqsi); my $anorm = @_ ? shift : $a->vnorm(0); my $brows = $b->[$WHICH]->slice("(0),"); my $bvals = $b->_nzvals; ##-- guts return ccs_vcos_pzd($aptr,$arows,$avals, $brows,$bvals, $anorm, @_); } ##-------------------------------------------------------------- ## Interpolation ## ($yi,$err) = $xi->interpolate($x,$y) ## + Signature: (xi(); x(n); y(n); [o] yi(); int [o] err()) ## + routine for 1D linear interpolation ## + Given a set of points "($x,$y)", use linear interpolation to find the values $yi at a set of points $xi. ## + see PDL::Primitive::interpolate() sub interpolate { my ($xi,$x,$y, $yi,$err) = @_; $yi = $xi->clone if (!defined($yi)); $err = $xi->clone if (!defined($err)); $xi->[$VALS]->interpolate($x,$y, $yi->[$VALS], $err->[$VALS]); return wantarray ? ($yi,$err) : $yi; } ## $yi = $xi->interpolate($x,$y) ## + Signature: (xi(); x(n); y(n); [o] yi()) ## + routine for 1D linear interpolation ## + see PDL::Primitive::interpol() sub interpol :lvalue { my ($xi,$x,$y, $yi) = @_; $yi = $xi->clone if (!defined($yi)); $xi->[$VALS]->interpol($x,$y, $yi->[$VALS]); return $yi; } ##-------------------------------------------------------------- ## General Information ## $density = $ccs->density() ## + returns PDL density as a scalar (lower is more sparse) sub density { $_[0][$WHICH]->dim(1) / $_[0]->nelem; } ## $compressionRate = $ccs->compressionRate() ## + higher is better ## + negative value indicates that dense storage would be more memory-efficient ## + pointers aren't included in the statistics: just which,nzvals,missing sub compressionRate { my $ccs = shift; my $dsize = PDL->pdl($ccs->nelem) * PDL::howbig($ccs->type); my $ccssize = (0 + PDL->pdl($ccs->[$WHICH]->nelem) * PDL::howbig($ccs->[$WHICH]->type) + PDL->pdl($ccs->[$VALS]->nelem) * PDL::howbig($ccs->[$VALS]->type) + PDL->pdl($ccs->[$PDIMS]->nelem) * PDL::howbig($ccs->[$PDIMS]->type) + PDL->pdl($ccs->[$VDIMS]->nelem) * PDL::howbig($ccs->[$VDIMS]->type) ); return (($dsize - $ccssize) / $dsize)->sclr; } ##-------------------------------------------------------------- ## Stringification & Viewing ## $dimstr = _dimstr($pdl) sub _dimstr { return $_[0]->type.'('.join(',',$_[0]->dims).')'; } sub _pdlstr { return _dimstr($_[0]).'='.$_[0]; } ## $str = $obj->string() sub string { my ($pdims,$vdims,$which,$vals) = @{$_[0]}[$PDIMS,$VDIMS,$WHICH,$VALS]; my $whichstr = ''.($which->isempty ? "Empty" : $which->xchg(0,1)); $whichstr =~ s/^([^A-Z])/ $1/mg; chomp($whichstr); return ( '' .ref($_[0]) . ':' . _dimstr($_[0]) ."\n" ." pdims:" . _pdlstr($pdims) ."\n" ." vdims:" . _pdlstr($vdims) ."\n" ." which:" . _dimstr($which)."^T=" . $whichstr . "\n" ." vals:" . _pdlstr($vals) ."\n" ." missing:" . _pdlstr($_[0]->missing) ."\n" ); } ## $pstr = $obj->lstring() ## + literal perl-type string sub lstring { return overload::StrVal($_[0]); } ##====================================================================== ## AUTOLOAD: pass to nonzero-PDL ## + doesn't seem to work well ##====================================================================== #our $AUTOLOAD; #sub AUTOLOAD { # my $d = shift; # return undef if (!defined($d) || !defined($d->[$VALS])); # (my $name = $AUTOLOAD) =~ s/.*:://; ##-- strip qualification # my ($sub); # if (!($sub=UNIVERSAL::can($d->[$VALS],$name))) { # croak( ref($d) , "::$name() not defined for nzvals in ", __PACKAGE__ , "::AUTOLOAD.\n"); # } # return $sub->($d->[$VALS],@_); #} ##-------------------------------------------------------------- ## Operator overloading use overload ( ##-- Binary ops: arithmetic "+" => \&plus_mia, "-" => \&minus_mia, "*" => \&mult_mia, "/" => \÷_mia, "%" => \&modulo_mia, "**" => \&power_mia, '+=' => sub { $_[0]->inplace->plus_mia(@_[1..$#_]); }, '-=' => sub { $_[0]->inplace->minus_mia(@_[1..$#_]); }, '*=' => sub { $_[0]->inplace->mult_mia(@_[1..$#_]); }, '%=' => sub { $_[0]->inplace->divide_mia(@_[1..$#_]); }, '**=' => sub { $_[0]->inplace->modulo_mia(@_[1..$#_]); }, ##-- Binary ops: comparisons ">" => \>_mia, "<" => \<_mia, ">=" => \&ge_mia, "<=" => \&le_mia, "<=>" => \&spaceship_mia, "==" => \&eq_mia, "!=" => \&ne_mia, #"eq" => \&eq_mia ##-- Binary ops: bitwise & logic "|" => \&or2_mia, "&" => \&and2_mia, "^" => \&xor_mia, "<<" => \&shiftleft_mia, ">>" => \&shiftright_mia, '|=' => sub { $_[0]->inplace->or2_mia(@_[1..$#_]); }, '&=' => sub { $_[0]->inplace->and2_mia(@_[1..$#_]); }, '^=' => sub { $_[0]->inplace->xor_mia(@_[1..$#_]); }, '<<=' => sub { $_[0]->inplace->shiftleft_mia(@_[1..$#_]); }, '>>=' => sub { $_[0]->inplace->shiftright_mia(@_[1..$#_]); }, ##-- Unary operations "!" => \¬, "~" => \&bitnot, "sqrt" => \&sqrt, "abs" => \&abs, "sin" => \&sin, "cos" => \&cos, "log" => \&log, "exp" => \&exp, ##-- assignment & assigning variants ".=" => \&rassgn, ##-- matrix operations 'x' => \&matmult, ##-- Stringification & casts 'bool' => sub { my $nelem = $_[0]->nelem; return 0 if ($nelem==0); croak("multielement ", __PACKAGE__, " pseudo-piddle in conditional expression") if ($nelem!=1); $_[0][$VALS]->at(0); }, "\"\"" => \&string, ); 1; ##-- make perl happy ##====================================================================== ## PODS: Header Administrivia ##====================================================================== =pod =head1 NAME PDL::CCS::Nd - N-dimensional sparse pseudo-PDLs =head1 SYNOPSIS use PDL; use PDL::CCS::Nd; ##--------------------------------------------------------------------- ## Example data $missing = 0; ##-- missing values $dense = random(@dims); ##-- densely encoded pdl $dense->where(random(@dims)<=0.95) .= $missing; ## ... made sparse $whichND = $dense->whichND; ##-- which values are present? $nzvals = $dense->indexND($whichND); ##-- ... and what are they? ##--------------------------------------------------------------------- ## Constructors etc. $ccs = PDL::CCS:Nd->newFromDense($dense,%args); ##-- construct from dense matrix $ccs = PDL::CCS:Nd->newFromWhich($whichND,$nzvals,%args); ##-- construct from index+value pairs $ccs = $dense->toccs(); ##-- ensure PDL::CCS::Nd-hood $ccs = $ccs->toccs(); ##-- ... analogous to PDL::topdl() $ccs = $dense->toccs($missing,$flags); ##-- ... with optional arguments $ccs2 = $ccs->copy(); ##-- copy constructor $ccs2 = $ccs->copyShallow(); ##-- shallow copy, mainly for internal use $ccs2 = $ccs->shadow(%args); ##-- flexible copy method, for internal use ##--------------------------------------------------------------------- ## Maintenance & Decoding $ccs = $ccs->recode(); ##-- remove missing values from stored VALS $ccs = $ccs->sortwhich(); ##-- internal use only $dense2 = $ccs->decode(); ##-- extract to a (new) dense matrix $dense2 = $ccs->todense(); ##-- ensure dense storage $dense2 = $dense2->todense(); ##-- ... analogous to PDL::topdl() ##--------------------------------------------------------------------- ## PDL API: Basic Properties ##--------------------------------------- ## Type conversion & Checking $ccs2 = $ccs->convert($type); $ccs2 = $ccs->byte; $ccs2 = $ccs->short; $ccs2 = $ccs->ushort; $ccs2 = $ccs->long; $ccs2 = $ccs->longlong; $ccs2 = $ccs->float; $ccs2 = $ccs->double; ##--------------------------------------- ## Dimensions @dims = $ccs->dims(); $ndims = $ccs->ndims(); $dim = $ccs->dim($dimi); $nelem = $ccs->nelem; $bool = $ccs->isnull; $bool = $ccs->isempty; ##--------------------------------------- ## Inplace & Dataflow $ccs = $ccs->inplace(); $bool = $ccs->is_inplace; $bool = $ccs->set_inplace($bool); $ccs = $ccs->sever; ##--------------------------------------- ## Bad Value Handling $bool = $ccs->bad_is_missing(); ##-- treat BAD values as missing? $bool = $ccs->bad_is_missing($bool); $ccs = $ccs->badmissing(); ##-- ... a la inplace() $bool = $ccs->nan_is_missing(); ##-- treat NaN values as missing? $bool = $ccs->nan_is_missing($bool); $ccs = $ccs->nanmissing(); ##-- ... a la inplace() $ccs2 = $ccs->setnantobad(); $ccs2 = $ccs->setbadtonan(); $ccs2 = $ccs->setbadtoval($val); $ccs2 = $ccs->setvaltobad($val); ##--------------------------------------------------------------------- ## PDL API: Dimension Shuffling $ccs2 = $ccs->dummy($vdimi,$size); $ccs2 = $ccs->reorder(@vdims); $ccs2 = $ccs->xchg($vdim1,$vdim2); $ccs2 = $ccs->mv($vdimFrom,$vdimTo); $ccs2 = $ccs->transpose(); ##--------------------------------------------------------------------- ## PDL API: Indexing $nzi = $ccs->indexNDi($ndi); ##-- guts for indexing methods $ndi = $ccs->n2oned($ndi); ##-- returns 1d pseudo-index for $ccs $ivals = $ccs->indexND($ndi); $ivals = $ccs->index2d($xi,$yi); $ivals = $ccs->index($flati); ##-- buggy: no pseudo-threading! $ccs2 = $ccs->dice_axis($vaxis,$vaxis_ix); $nzi = $ccs->xindex1d($xi); ##-- nz-indices along 0th dimension $nzi = $ccs->pxindex1d($dimi,$xi); ##-- ... or any dimension, using ptr() $nzi = $ccs->xindex2d($xi,$yi); ##-- ... or for Cartesian product on 2d matrix $ccs2 = $ccs->xsubset1d($xi); ##-- subset along 0th dimension $ccs2 = $ccs->pxsubset1d($dimi,$xi); ##-- ... or any dimension, using ptr() $ccs2 = $ccs->xsubset2d($xi,$yi); ##-- ... or for Cartesian product on 2d matrix $whichND = $ccs->whichND(); $vals = $ccs->whichVals(); ##-- like $ccs->indexND($ccs->whichND), but faster $which = $ccs->which() $value = $ccs->at(@index); $ccs = $ccs->set(@index,$value); ##--------------------------------------------------------------------- ## PDL API: Ufuncs $ccs2 = $ccs->prodover; $ccs2 = $ccs->dprodover; $ccs2 = $ccs->sumover; $ccs2 = $ccs->dsumover; $ccs2 = $ccs->andover; $ccs2 = $ccs->orover; $ccs2 = $ccs->bandover; $ccs2 = $ccs->borover; $ccs2 = $ccs->maximum; $ccs2 = $ccs->minimum; $ccs2 = $ccs->maximum_ind; ##-- -1 indicates "missing" value is maximal $ccs2 = $ccs->minimum_ind; ##-- -1 indicates "missing" value is minimal $ccs2 = $ccs->nbadover; $ccs2 = $ccs->ngoodover; $ccs2 = $ccs->nnz; $sclr = $ccs->prod; $sclr = $ccs->dprod; $sclr = $ccs->sum; $sclr = $ccs->dsum; $sclr = $ccs->nbad; $sclr = $ccs->ngood; $sclr = $ccs->min; $sclr = $ccs->max; $bool = $ccs->any; $bool = $ccs->all; ##--------------------------------------------------------------------- ## PDL API: Unary Operations (Overloaded) $ccs2 = $ccs->bitnot; $ccs2 = ~$ccs; $ccs2 = $ccs->not; $ccs2 = !$ccs; $ccs2 = $ccs->sqrt; $ccs2 = $ccs->abs; $ccs2 = $ccs->sin; $ccs2 = $ccs->cos; $ccs2 = $ccs->exp; $ccs2 = $ccs->log; $ccs2 = $ccs->log10; ##--------------------------------------------------------------------- ## PDL API: Binary Operations (missing is annihilator) ## + $b may be a perl scalar, a dense PDL, or a PDL::CCS::Nd object ## + $c is always returned as a PDL::CCS::Nd ojbect ##--------------------------------------- ## Arithmetic $c = $ccs->plus($b); $c = $ccs1 + $b; $c = $ccs->minus($b); $c = $ccs1 - $b; $c = $ccs->mult($b); $c = $ccs1 * $b; $c = $ccs->divide($b); $c = $ccs1 / $b; $c = $ccs->modulo($b); $c = $ccs1 % $b; $c = $ccs->power($b); $c = $ccs1 ** $b; ##--------------------------------------- ## Comparisons $c = $ccs->gt($b); $c = ($ccs > $b); $c = $ccs->ge($b); $c = ($ccs >= $b); $c = $ccs->lt($b); $c = ($ccs < $b); $c = $ccs->le($b); $c = ($ccs <= $b); $c = $ccs->eq($b); $c = ($ccs == $b); $c = $ccs->ne($b); $c = ($ccs != $b); $c = $ccs->spaceship($b); $c = ($ccs <=> $b); ##--------------------------------------- ## Bitwise Operations $c = $ccs->and2($b); $c = ($ccs & $b); $c = $ccs->or2($b); $c = ($ccs | $b); $c = $ccs->xor($b); $c = ($ccs ^ $b); $c = $ccs->shiftleft($b); $c = ($ccs << $b); $c = $ccs->shiftright($b); $c = ($ccs >> $b); ##--------------------------------------- ## Matrix Operations $c = $ccs->inner($b); $c = $ccs->matmult($b); $c = $ccs x $b; $c_dense = $ccs->matmult2d_sdd($b_dense, $zc); $c_dense = $ccs->matmult2d_zdd($b_dense); $vnorm = $ccs->vnorm($pdimi); $vcos = $ccs->vcos_zdd($b_dense); $vcos = $ccs->vcos_pzd($b_ccs); ##--------------------------------------- ## Other Operations $ccs->rassgn($b); $ccs .= $b; $str = $ccs->string(); $str = "$ccs"; ##--------------------------------------------------------------------- ## Indexing Utilities ##--------------------------------------------------------------------- ## Low-Level Object Access $num_v_per_p = $ccs->_ccs_nvperp; ##-- num virtual / num physical $pdims = $ccs->pdims; $vdims = $ccs->vdims; ##-- physical|virtual dim pdl $nelem = $ccs->nelem_p; $nelem = $ccs->nelem_v; ##-- physical|virtual nelem $nstored = $ccs->nstored_p; $nstored = $ccs->nstored_v; ##-- physical|virtual Nnz+1 $nmissing = $ccs->nmissing_p; $nmissing = $ccs->nmissing_v; ##-- physical|virtual nelem-Nnz $ccs = $ccs->make_physically_indexed(); ##-- ensure all dimensions are physically indexed $bool = $ccs->allmissing(); ##-- are all values missing? $missing_val = $ccs->missing; ##-- get missing value $missing_val = $ccs->missing($missing_val); ##-- set missing value $ccs = $ccs->_missing($missing_val); ##-- ... returning the object $whichND_phys = $ccs->_whichND(); ##-- get/set physical indices $whichND_phys = $ccs->_whichND($whichND_phys); $nzvals_phys = $ccs->_nzvals(); ##-- get/set physically indexed values $nzvals_phys = $ccs->_nzvals($vals_phys); $vals_phys = $ccs->_vals(); ##-- get/set physically indexed values $vals_phys = $ccs->_vals($vals_phys); $bool = $ccs->hasptr($pdimi); ##-- check for cached Harwell-Boeing pointer ($ptr,$ptrix) = $ccs->ptr($pdimi); ##-- ... get one, caching for later use ($ptr,$ptrix) = $ccs->getptr($pdimi); ##-- ... compute one, regardless of cache ($ptr,$ptrix) = $ccs->setptr($pdimi,$p,$pix); ##-- ... set a cached pointer $ccs->clearptr($pdimi); ##-- ... clear a cached pointer $ccs->clearptrs(); ##-- ... clear all cached pointers $flags = $ccs->flags(); ##-- get/set object-local flags $flags = $ccs->flags($flags); $density = $ccs->density; ##-- get object density $crate = $ccs->compressionRate; ##-- get compression rate =cut ##====================================================================== ## Description ##====================================================================== =pod =head1 DESCRIPTION PDL::CCS::Nd provides an object-oriented implementation of sparse N-dimensional vectors & matrices using a set of low-level PDLs to encode non-missing values. Currently, only a portion of the PDL API is implemented. =cut ##====================================================================== ## Globals ##====================================================================== =pod =head1 GLOBALS The following package-global variables are defined: =cut ##-------------------------------------------------------------- ## Globals: Block Sizes =pod =head2 Block Size Constants $BINOP_BLOCKSIZE_MIN = 1; $BINOP_BLOCKSIZE_MAX = 0; Minimum (maximum) block size for block-wise incremental computation of binary operations. Zero or undef indicates no minimum (maximum). =cut ##-------------------------------------------------------------- ## Globals: Object structure =pod =head2 Object Structure PDL::CCS::Nd object are implemented as perl ARRAY-references. For more intuitive access to object components, the following package-global variables can be used as array indices to access internal object structure: =over 4 =item $PDIMS Indexes a pdl(long,$NPdims) of physically indexed dimension sizes: $ccs->[$PDIMS]->at($pdim_i) == $dimSize_i =item $VDIMS Indexes a pdl(long,$NVdims) of "virtual" dimension sizes: $ccs->[$VDIMS]->at($vdim_i) == / -$vdimSize_i if $vdim_i is a dummy dimension \ $pdim_i otherwise The $VDIMS piddle is used for dimension-shuffling transformations such as xchg() and reorder(), as well as for dummy(). =item $WHICH Indexes a pdl(long,$NPdims,$Nnz) of the "physical indices" of all non-missing values in the non-dummy dimensions of the corresponding dense matrix. Vectors in $WHICH are guaranteed to be sorted in lexicographic order. If your $missing value is zero, and if your qsortvec() function works, it should be the case that: all( $ccs->[$WHICH] == $dense->whichND->qsortvec ) A "physically indexed dimension" is just a dimension corresponding tp a single column of the $WHICH pdl, whereas a dummy dimension does not correspond to any physically indexed dimension. =item $VALS Indexes a vector pdl($valType, $Nnz+1) of all values in the sparse matrix, where $Nnz is the number of non-missing values in the sparse matrix. Non-final elements of the $VALS piddle are interpreted as the values of the corresponding indices in the $WHICH piddle: all( $ccs->[$VALS]->slice("0:-2") == $dense->indexND($ccs->[$WHICH]) ) The final element of the $VALS piddle is referred to as "$missing", and represents the value of all elements of the dense physical matrix whose indices are not explicitly listed in the $WHICH piddle: all( $ccs->[$VALS]->slice("-1") == $dense->flat->index(which(!$dense)) ) =item $PTRS Indexes an array of arrays containing Harwell-Boeing "pointer" piddle pairs for the corresponding physically indexed dimension. For a physically indexed dimension $d of size $N, $ccs-E[$PTRS][$d] (if it exists) is a pair [$ptr,$ptrix] as returned by PDL::CCS::Utils::ccs_encode_pointers($WHICH,$N), which are such that: =over 4 =item $ptr $ptr is a pdl(long,$N+1) containing the offsets in $ptrix corresponding to the first non-missing value in the dimension $d. For all $i, 0 E= $i E $N, $ptr($i) contains the index of the first non-missing value (if any) from column $i of $dense(...,N,...) encoded in the $WHICH piddle. $ptr($N+1) contains the number of physically indexed cells in the $WHICH piddle. =item $ptrix Is an index piddle into dim(1) of $WHICH rsp. dim(0) of $VALS whose key positions correspond to the offsets listed in $ptr. The point here is that: $WHICH->dice_axis(1,$ptrix) is guaranteed to be primarily sorted along the pointer dimension $d, and stably sorted along all other dimensions, e.g. should be identical to: $WHICH->mv($d,0)->qsortvec->mv(0,$d) =back =item $FLAGS Indexes a perl scalar containing some object-local flags. See L<"Object Flags"> for details. =item $USER Indexes the first unused position in the object array. If you derive a class from PDL::CCS::Nd, you should use this position to place any new object-local data. =back =cut ##-------------------------------------------------------------- ## Globals: Object Flags =pod =head2 Object Flags The following object-local constants are defined as bitmask flags: =over 4 =item $CCSND_BAD_IS_MISSING Bitmask of the "bad-is-missing" flag. See the bad_is_missing() method. =item $CCSND_NAN_IS_MISSING Bitmask of the "NaN-is-missing" flag. See the nan_is_missing() method. =item $CCSND_INPLACE Bitmask of the "inplace" flag. See PDL::Core for details. =item $CCSND_FLAGS_DEFAULT Default flags for new objects. =back =cut ##====================================================================== ## Methods ##====================================================================== =pod =head1 METHODS =cut ##====================================================================== ## Methods: Constructors etc. ##====================================================================== =pod =head2 Constructors, etc. =over 4 =item $class_or_obj-EnewFromDense($dense,$missing,$flags) =for sig Signature ($class_or_obj; dense(N1,...,NNdims); missing(); int flags) Class method. Create and return a new PDL::CCS::Nd object from a dense N-dimensional PDL $dense. If specified, $missing is used as the value for "missing" elements, and $flags are used to initialize the object-local flags. $missing defaults to BAD if the bad flag of $dense is set, otherwise $missing defaults to zero. =item $ccs-EfromDense($dense,$missing,$flags) =for sig Signature ($ccs; dense(N1,...,NNdims); missing(); int flags) Object method. Populate a sparse matrix object from a dense piddle $dense. See newFromDense(). =item $class_or_obj-EnewFromWhich($whichND,$nzvals,%options) =for sig Signature ($class_or_obj; int whichND(Ndims,Nnz); nzvals(Nnz+1); %options) Class method. Create and return a new PDL::CCS::Nd object from a set of indices $whichND of non-missing elements in a (hypothetical) dense piddle and a vector $nzvals of the corresponding values. Known %options: sorted => $bool, ##-- if true, $whichND is assumed to be pre-sorted steal => $bool, ##-- if true, $whichND and $nzvals are used literally (formerly implied 'sorted') ## + in this case, $nzvals should really be: $nzvals->append($missing) pdims => $pdims, ##-- physical dimension list; default guessed from $whichND (alias: 'dims') vdims => $vdims, ##-- virtual dims (default: sequence($nPhysDims)); alias: 'xdims' missing => $missing, ##-- default: BAD if $nzvals->badflag, 0 otherwise flags => $flags ##-- flags =item $ccs-EfromWhich($whichND,$nzvals,%options) Object method. Guts for newFromWhich(). =item $a-Etoccs($missing,$flags) Wrapper for newFromDense(). Return a PDL::CCS::Nd object for any piddle or perl scalar $a. If $a is already a PDL::CCS::Nd object, just returns $a. This method gets exported into the PDL namespace for ease of use. =item $ccs = $ccs-Ecopy() Full copy constructor. =item $ccs2 = $ccs-EcopyShallow() Shallow copy constructor, used e.g. by dimension-shuffling transformations. Copied components: $PDIMS, @$PTRS, @{$PTRS->[*]}, $FLAGS Referenced components: $VDIMS, $WHICH, $VALS, $PTRS->[*][*] =item $ccs2 = $ccs1-Eshadow(%args) Flexible constructor for computed PDL::CCS::Nd objects. Known %args: to => $ccs2, ##-- default: new pdims => $pdims2, ##-- default: $pdims1->pdl (alias: 'dims') vdims => $vdims2, ##-- default: $vdims1->pdl (alias: 'xdims') ptrs => \@ptrs2, ##-- default: [] which => $which2, ##-- default: undef vals => $vals2, ##-- default: undef flags => $flags, ##-- default: $flags1 =back =cut ##====================================================================== ## Methods: Maintenance & Decoding ##====================================================================== =pod =head2 Maintenance & Decoding =over 4 =item $ccs = $ccs-Erecode() Recodes the PDL::CCS::Nd object, removing any missing values from its $VALS piddle. =item $ccs = $ccs-Esortwhich() Lexicographically sorts $ccs-E[$WHICH], altering $VALS accordingly. Clears $PTRS. =item $dense = $ccs-Edecode() =item $dense = $ccs-Edecode($dense) Decode a PDL::CCS::Nd object to a dense piddle. Dummy dimensions in $ccs should be created as dummy dimensions in $dense. =item $dense = $a-Etodense() Ensures that $a is not a PDL::CCS::Nd by wrapping decode(). For PDLs or perl scalars, just returns $a. =back =cut ##====================================================================== ## Methods: PDL API: Basic Properties ##====================================================================== =pod =head2 PDL API: Basic Properties The following basic PDL API methods are implemented and/or wrapped for PDL::CCS::Nd objects: =over 4 =item Type Checking & Conversion type, convert, byte, short, ushort, long, double Type-checking and conversion routines are passed on to the $VALS sub-piddle. =item Dimension Access dims, dim, getdim, ndims, getndims, nelem, isnull, isempty Note that nelem() returns the number of hypothetically addressable cells -- the number of cells in the corresponding dense matrix, rather than the number of non-missing elements actually stored. =item Inplace Operations set_inplace($bool), is_inplace(), inplace() =item Dataflow sever =item Bad Value Handling setnantobad, setbadtonan, setbadtoval, setvaltobad See also the bad_is_missing() and nan_is_missing() methods, below. =back =cut ##====================================================================== ## Methods: PDL API: Dimension Shuffling ##====================================================================== =pod =head2 PDL API: Dimension Shuffling The following dimension-shuffling methods are supported, and should be compatible to their PDL counterparts: =over 4 =item dummy($vdimi) =item dummy($vdimi, $size) Insert a "virtual" dummy dimension of size $size at dimension index $vdimi. =item reorder(@vdim_list) Reorder dimensions according to @vdim_list. =item xchg($vdim1,$vdim2) Exchange two dimensions. =item mv($vdimFrom, $vdimTo) Move a dimension to another position, shoving remaining dimensions out of the way to make room. =item transpose() Always copies, unlike xchg(). Also unlike xchg(), works for 1d row-vectors. =back =cut ##====================================================================== ## Methods: PDL API: Indexing ##====================================================================== =pod =head2 PDL API: Indexing =over 4 =item indexNDi($ndi) =for sig Signature: ($ccs; int ndi(NVdims,Nind); int [o]nzi(Nind)) Guts for indexing methods. Given an N-dimensional index piddle $ndi, return a 1d index vector into $VALS for the corresponding values. Missing values are returned in $nzi as $Nnz == $ccs-E_nnz_p; Uses PDL::VectorValues::vsearchvec() internally, so expect O(Ndims * log(Nnz)) complexity. Although the theoretical complexity is tough to beat, this method could be made much faster in the usual (read "sparse") case by an intelligent use of $PTRS if and when available. =item indexND($ndi) =item index2d($xi,$yi) Should be mostly compatible to the PDL functions of the same names, but without any boundary handling. =item index($flati) Implicitly flattens the source pdl. This ought to be fixed. =item dice_axis($axis_v, $axisi) Should be compatible with the PDL function of the same name. Returns a new PDL::CCS::Nd object which should participate in dataflow. =item xindex1d($xi) Get non-missing indices for any element of $xi along 0th dimension; $xi must be sorted in ascending order. =item pxindex1d($dimi,$xi) Get non-missing indices for any element of $xi along physically indexed dimension $dimi, using L. $xi must be sorted in ascending order. =item xindex2d($xi,$yi) Get non-missing indices for any element in Cartesian product ($xi x $yi) for 2d sparse matrix. $xi and $yi must be sorted in ascending order. =item xsubset1d($xi) Returns a subset object similar to L, but without renumbering of indices along the diced dimension; $xi must be sorted in ascending order. =item pxsubset1d($dimi,$xi) Returns a subset object similar to L, but without renumbering of indices along the diced dimension; $xi must be sorted in ascending order. =item xsubset2d($xi,$yi) Returns a subset object similar to indexND( $xi-Eslice("*1,")-Ecat($yi)-Eclump(2)-Exchg(0,1) ), but without renumbering of indices; $xi and $yi must be sorted in ascending order. =item n2oned($ndi) Returns a 1d pseudo-index, used for implementation of which(), etc. =item whichND() Should behave mostly like the PDL function of the same name. Just returns the literal $WHICH piddle if possible: beware of dataflow! Indices are NOT guaranteed to be returned in any surface-logical order, although physically indexed dimensions should be sorted in physical-lexicographic order. =item whichVals() Returns $VALS indexed to correspond to the indices returned by whichND(). The only reason to use whichND() and whichVals() rather than $WHICH and $VALS would be a need for physical representations of dummy dimension indices: try to avoid it if you can. =item which() As for the builtin PDL function. =item at(@index) Return a perl scalar corresponding to the Nd index @index. =item set(@index, $value) Set a non-missing value at index @index to $value. barf()s if @index points to a missing value. =back =cut ##====================================================================== ## Methods: Operations: Ufuncs ##====================================================================== =pod =head2 Ufuncs The following functions from PDL::Ufunc are implemented, and ought to handle missing values correctly (i.e. as their dense counterparts would): prodover prod dprodover dprod sumover sum dsumover dsum andover orover bandover borover maximum maximum_ind ##-- goofy if "missing" value is maximal max minimum minimum_ind ##-- goofy if "missing" value is minimal min nbadover nbad ngoodover ngood nnz any all Some Ufuncs are still unimplemented. see PDL::CCS::Ufunc for details. =cut ##====================================================================== ## Methods: Operations: Unary ##====================================================================== =pod =head2 Unary Operations The following unary operations are supported: FUNCTION OVERLOADS bitnot ~ not ! sqrt abs sin cos exp log log10 Note that any pointwise unary operation can be performed directly on the $VALS piddle. You can wrap such an operation MY_UNARY_OP on piddles into a PDL::CCS::Nd method using the idiom: package PDL::CCS::Nd; *MY_UNARY_OP = _unary_op('MY_UNARY_OP', PDL->can('MY_UNARY_OP')); Note also that unary operations may change the "missing" value associated with the sparse matrix. This is easily seen to be the Right Way To Do It if you consider unary "not" over a very sparse (say 99% missing) binary-valued matrix: is is much easier and more efficient to alter only the 1% of physically stored (non-missing) values as well as the missing value than to generate a new matrix with 99% non-missing values, assuming $missing==0. =cut ##====================================================================== ## Methods: Operations: Binary ##====================================================================== =pod =head2 Binary Operations A number of basic binary operations on PDL::CCS::Nd operations are supported, which will produce correct results only under the assumption that "missing" values C<$missing> are annihilators for the operation in question. For example, if we want to compute: $c = OP($a,$b) for a binary operation OP on PDL::CCS::Nd objects C<$a> and C<$b>, the current implementation will produce the correct result for $c only if for all values C<$av> in C<$a> and C<$bv> in C<$b>: OP($av,$b->missing) == OP($a->missing,$b->missing) , and OP($a->missing,$bv) == OP($a->missing,$b->missing) This is true in general for OP==\&mult and $missing==0, but not e.g. for OP==\&plus and $missing==0. It should always hold for $missing==BAD (except in the case of assignment, which is a funny kind of operation anyways). Currently, the only way to ensure that all values are computed correctly in the general case is for $a and $b to contain exactly the same physically indexed values, which rather defeats the purposes of sparse storage, particularly if implicit pseudo-threading is involved (because then we would likely wind up instantiating -- or at least inspecting -- the entire dense matrix). Future implementations may relax these restrictions somewhat. The following binary operations are implemented: =over 4 =item Arithmetic Operations FUNCTION OVERLOADS plus + minus - mult * divide / modulo % power ** =item Comparisons FUNCTION OVERLOADS gt > ge >= lt < le <= eq == ne != spaceship <=> =item Bitwise Operations FUNCTION OVERLOADS and2 & or2 | xor ^ shiftleft << shiftright >> =item Matrix Operations FUNCTION OVERLOADS inner (none) matmult x =item Other Operations FUNCTION OVERLOADS rassgn .= string "" =back All supported binary operation functions obey the PDL input calling conventions (i.e. they all accept a third argument C<$swap>), and delegate computation to the underlying PDL functions. Note that the PDL::CCS::Nd methods currently do B support a third "output" argument. To wrap a new binary operation MY_BINOP into a PDL::CCS::Nd method, you can use the following idiom: package PDL::CCS::Nd; *MY_BINOP = _ccsnd_binary_op_mia('MY_BINOP', PDL->can('MY_BINOP')); The low-level alignment of physically indexed values for binary operations is performed by the function PDL::CCS::ccs_binop_align_block_mia(). Computation is performed block-wise at the perl level to avoid over- rsp. underflow of the space requirements for the output PDL. =cut ##====================================================================== ## Methods: Low-Level Object Access ##====================================================================== =pod =head2 Low-Level Object Access The following methods provide low-level access to PDL::CCS::Nd object structure: =over 4 =item insertWhich =for sig Signature: ($ccs; int whichND(Ndims,Nnz1); vals(Nnz1)) Set or insert values in C<$ccs> for the indices in C<$whichND> to C<$vals>. C<$whichND> need not be sorted. Implicitly makes C<$ccs> physically indexed. Returns the (destructively altered) C<$ccs>. =item appendWhich =for sig Signature: ($ccs; int whichND(Ndims,Nnz1); vals(Nnz1)) Like insertWhich(), but assumes that no values for any of the $whichND indices are already present in C<$ccs>. This is faster (because indexNDi need not be called), but less safe. =item is_physically_indexed() Returns true iff only physical dimensions are present. =item to_physically_indexed() Just returns the calling object if all non-missing elements are already physically indexed. Otherwise, returns a new PDL::CCS::Nd object identical to the caller except that all non-missing elements are physically indexed. This may gobble a large amount of memory if the calling element has large dummy dimensions. Also ensures that physical dimension order is identical to logical dimension order. =item make_physically_indexed Wrapper for to_physically_indexed() which eliminates dummy dimensions destructively in the calling object. Alias: make_physical(). =item pdims() Returns the $PDIMS piddle. See L<"Object Structure">, above. =item vdims() Returns the $VDIMS piddle. See L<"Object Structure">, above. =item setdims_p(@dims) Sets $PDIMS piddle. See L<"Object Structure">, above. Returns the calling object. Alias: setdims(). =item nelem_p() Returns the number of physically addressable elements. =item nelem_v() Returns the number of virtually addressable elements. Alias for nelem(). =item _ccs_nvperp() Returns number of virtually addressable elements per physically addressable element, which should be a positive integer. =item nstored_p() Returns actual number of physically addressed stored elements (aka $Nnz aka $WHICH-Edim(1)). =item nstored_v() Returns actual number of physically+virtually addressed stored elements. =item nmissing_p() Returns number of physically addressable elements minus the number of physically stored elements. =item nmissing_v() Returns number of physically+virtually addressable elements minus the number of physically+virtually stored elements. =item allmissing() Returns true iff no non-missing values are stored. =item missing() =item missing($missing) Get/set the value to use for missing elements. Returns the (new) value for $missing. =item _whichND() =item _whichND($whichND) Get/set the underlying $WHICH piddle. =item _nzvals() =item _nzvals($storedvals) Get/set the slice of the underlying $VALS piddle corresponding for non-missing values only. Alias: whichVals(). =item _vals() =item _vals($storedvals) Get/set the underlying $VALS piddle. =item hasptr($pdimi) Returns true iff a pointer for physical dim $pdimi is cached. =item ptr($pdimi) Get a pointer pair for a physically indexed dimension $pdimi. Uses cached piddles in $PTRS if present, computes & caches otherwise. $pdimi defaults to zero. If $pdimi is zero, then it should hold that: all( $pi2nzi==sequence($ccs->nstored_p) ) =item getptr($pdimi) Guts for ptr(). Does not check $PTRS and does not cache anything. =item clearptr($pdimi) Clears any cached Harwell-Boeing pointers for physically indexed dimension $pdimi. =item clearptrs() Clears any cached Harwell-Boeing pointers. =item flags() =item flags($flags) Get/set object-local $FLAGS. =item bad_is_missing() =item bad_is_missing($bool) Get/set the value of the object-local "bad-is-missing" flag. If this flag is set, BAD values in $VALS are considered "missing", regardless of the current value of $missing. =item badmissing() Sets the "bad-is-missing" flag and returns the calling object. =item nan_is_missing() =item nan_is_missing($bool) Get/set the value of the object-local "NaN-is-missing" flag. If this flag is set, NaN (and +inf, -inf) values in $VALS are considered "missing", regardless of the current value of $missing. =item nanmissing() Sets the "nan-is-missing" flag and returns the calling object. =back =cut ##====================================================================== ## Methods: General Information ##====================================================================== =pod =head2 General Information =over 4 =item density() Returns the number of non-missing values divided by the number of indexable values in the sparse object as a perl scalar. =item compressionRate() Returns the compression rate of the PDL::CCS::Nd object compared to a dense piddle of the physically indexable dimensions. Higher values indicate better compression (e.g. lower density). Negative values indicate that dense storage would be more memory-efficient. Pointers are not included in the computation of the compression rate. =back =cut ##====================================================================== ## Footer Administrivia ##====================================================================== ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS Many. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2007-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl), PDL::SVDLIBC(3perl), PDL::CCS::Nd(3perl), SVDLIBC: http://tedlab.mit.edu/~dr/SVDLIBC/ SVDPACKC: http://www.netlib.org/svdpack/ =cut PDL-CCS-1.24.1/CCS/Compat.pm0000644000175000017500000007347614736165363014606 0ustar moocowbovines## File: PDL::CCS::Compat.pm ## Author: Bryan Jurish ## Description: backwards-compatibility hacks for PDL::CCS package PDL::CCS::Compat; use PDL; use PDL::VectorValued; use PDL::CCS::Config qw(ccs_indx); use PDL::CCS::Functions; use PDL::CCS::Utils; use PDL::CCS::Ufunc; use PDL::CCS::Ops; use strict; our $VERSION = '1.24.1'; ##-- update with perl-reversion from Perl::Version module our @ISA = ('PDL::Exporter'); our @ccs_binops = (qw(plus minus mult divide modulo power), qw(gt ge lt le eq ne spaceship), qw(and2 or2 xor shiftleft shiftright), ); our @EXPORT_OK = ( ## ##-- Encoding qw(ccs_encode_compat), qw(ccsencode ccsencode_nz ccsencodefull ccsencodefull_nz), qw(ccsencodea ccsencode_naz ccsencodefulla ccsencodefull_naz), qw(ccsencodeg ccsencode_g ccsencodefullg ccsencodefull_g), qw(ccsencodei ccsencode_i ccsencodefulli ccsencodefull_i), qw(ccsencodei2d ccsencode_i2d ccsencodefulli2d ccsencodefull_i2d), ## ##-- Decoding qw(_ccsdecodecols ccsdecodecols), qw(ccsdecode ccsdecodefull), qw(ccsdecode_g ccsdecodeg ccsdecodefull_g ccsdecodefullg), ## ##-- Indexing qw(ccsiNDtonzi ccsi2dtonzi ccsitonzi), qw(ccswhichND ccswhich2d ccswhichfull ccswhich), qw(ccstranspose ccstransposefull), ## ##-- Lookup qw(ccsget ccsget2d), ## ##-- Operations (map {("ccs${_}_cv","ccs${_}_rv")} (@ccs_binops,qw(add diff))), ## ##-- Ufuncs (map {("ccs${_}","ccs${_}t")} qw(sumover prodover)), ); our %EXPORT_TAGS = ( Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully) ); ##====================================================================== ## pod: headers =pod =head1 NAME PDL::CCS::Compat - Backwards-compatibility module for PDL::CCS =head1 SYNOPSIS use PDL; use PDL::CCS::Compat; ##-- source pdl $a = random($N=8,$M=7); ##--------------------------------------------------------------------- ## Non-missing value counts $nnz = $a->flat->nnz; ##-- "missing" == 0 $nnaz = $a->flat->nnza(1e-6); ##-- "missing" ~= 0 #$ngood = $a->ngood; ##-- "missing" == BAD (see PDL::Bad) ##--------------------------------------------------------------------- ## CCS Encoding ($ptr,$rowids,$vals) = ccsencode_nz ($a); # missing == 0 ($ptr,$rowids,$vals) = ccsencode_naz($a,$eps); # missing ~= 0 ($ptr,$rowids,$vals) = ccsencode_g ($a); # missing == BAD ($ptr,$rowids,$vals) = ccsencode_i ($i,$ivals,$N); # generic flat ($ptr,$rowids,$vals) = ccsencode_i2d($xi,$yi,$ivals); # generic 2d ##--------------------------------------------------------------------- ## CCS Decoding $cols = ccsdecodecols($ptr,$rowids,$nzvals, $xvals $a2 = ccsdecode ($ptr,$rowids,$vals); # missing == 0 $a2 = ccsdecode_g($ptr,$rowids,$vals); # missing == BAD ##--------------------------------------------------------------------- ## CCS Index Conversion $nzi = ccsitonzi ($ptr,$rowids, $ix, $missing); # ix => nzi $nzi = ccsi2dtonzi($ptr,$rowids, $xi,$yi, $missing); # 2d => nzi $ix = ccswhich ($ptr,$rowids,$vals); # CCS => ix ($xi,$yi) = ccswhichND($ptr,$rowids,$vals); # CCS => 2d $xyi = ccswhichND($ptr,$rowids,$vals); # ...as scalar ##--------------------------------------------------------------------- ## CCS Lookup $ixvals = ccsget ($ptr,$rowids,$vals, $ix,$missing); # ix => values $ixvals = ccsget2d($ptr,$rowids,$vals, $xi,$yi,$missing); # 2d => values ##--------------------------------------------------------------------- ## CCS Operations ($ptrT,$rowidsT,$valsT) = ccstranspose($ptr,$rowids,$vals); # CCS<->CRS ##--------------------------------------------------------------------- ## Vector Operations, by column $nzvals_out = ccsadd_cv ($ptr,$rowids,$nzvals, $colvec); $nzvals_out = ccsdiff_cv($ptr,$rowids,$nzvals, $colvec); $nzvals_out = ccsmult_cv($ptr,$rowids,$nzvals, $colvec); $nzvals_out = ccsdiv_cv ($ptr,$rowids,$nzvals, $colvec); ##--------------------------------------------------------------------- ## Vector Operations, by row $nzvals_out = ccsadd_rv ($ptr,$rowids,$nzvals, $rowvec); $nzvals_out = ccsdiff_rv($ptr,$rowids,$nzvals, $rowvec); $nzvals_out = ccsmult_rv($ptr,$rowids,$nzvals, $rowvec); $nzvals_out = ccsdiv_rv ($ptr,$rowids,$nzvals, $rowvec); ##--------------------------------------------------------------------- ## Scalar Operations $nzvals_out = $nzvals * 42; # ... or whatever ##--------------------------------------------------------------------- ## Accumulators $rowsumover = ccssumover ($ptr,$rowids,$nzvals); ##-- like $a->sumover() $colsumovert = ccssumovert($ptr,$rowids,$nzvals); ##-- like $a->xchg(0,1)->sumover =cut ##====================================================================== ## Encoding =pod =head1 Encoding =cut ##--------------------------------------------------------------- ## Encoding: generic =pod =head2 ccs_encode_compat =for sig Signature: (indx awhich(2,Nnz); avals(Nnz); indx $N; indx $M; indx [o]ptr(N); indx [o]rowids(Nnz); [o]nzvals(Nnz)) Generic wrapper for backwards-compatible ccsencode() variants. =cut *ccs_encode_compat = \&PDL::ccs_encode_compat; sub PDL::ccs_encode_compat { my ($aw,$avals,$N,$M,$ptr,$rowids,$nzvals) = @_; $N = $aw->slice("(0),")->max+1 if (!defined($N)); $M = $aw->slice("(1),")->max+1 if (!defined($M)); my ($ptr1,$awi) = ccs_encode_pointers($aw->slice("(0),"), $N); if (defined($ptr)) { $ptr .= $ptr1->slice("0:-2"); } else { $ptr = $ptr1->slice("0:-2"); $ptr->sever; } if (defined($rowids)) { $rowids .= $aw->slice("(1),")->index($awi); } else { $rowids = $aw->slice("(1),")->index($awi); $rowids->sever; } if (defined($nzvals)) { $nzvals .= $avals->index($awi); } else { $nzvals = $avals->index($awi); $nzvals->sever; } return ($ptr,$rowids,$nzvals); } ##--------------------------------------------------------------- ## Encoding: MISSING=zero =pod =head2 ccsencode =head2 ccsencode_nz =for sig Signature: (a(N,M); indx [o]ptr(N); indx [o]rowids(Nnz); [o]nzvals(Nnz)) Encodes matrix $a() in compressed column format, interpreting zeroes as "missing" values. Allocates output vectors if required. =cut *ccsencode = *ccsencodefull = *ccsencodefull_nz = *PDL::ccsencode = *PDL::ccsencode_nz = *PDL::ccsencodefull = *PDL::ccsencodefull_nz = \&ccsencode_nz; sub ccsencode_nz { #my ($a,$ptr,$rowids,$nzvals) = @_; my $a = shift; $a = $a->clump(1+$a->ndims-2); ##-- clump(-2) broken in PDL-2.0.14 my $aw = $a->whichND; return ccs_encode_compat($aw, $a->indexND($aw), $a->dims, @_); } ##--------------------------------------------------------------- ## Encoding: MISSING=ZERO (approx) =pod =head2 ccsencodea =head2 ccsencode_naz =for sig Signature: (a(N,M); eps(); indx [o]ptr(N); indx [o]rowids(Nnz); [o]nzvals(Nnz)) Encodes matrix $a() in CCS format interpreting approximate zeroes as "missing" values. This function is just like ccsencode_nz(), but uses the tolerance parameter $eps() to determine which elements are to be treated as zeroes. Allocates output vectors if required. =cut *ccsencodea = *ccsencodefulla = *ccsencodefull_naz = *PDL::ccsencodea = *PDL::ccsencode_naz = *PDL::ccsencodefulla = *PDL::ccsencodefull_naz = \&ccsencode_naz; sub ccsencode_naz { #my ($a,$eps,$ptr,$rowids,$nzvals) = @_; my $a = shift; my $eps = shift; $a = $a->clump(1+$a->ndims-2); ##-- clump(-2) is broken in PDL-2.014 my $aw = $a->approx(0,$eps)->inplace->not->whichND; ##-- FIXME: optimize return ccs_encode_compat($aw, $a->indexND($aw), $a->dims, @_); } ##--------------------------------------------------------------- ## Encoding: MISSING=BAD =pod =head2 ccsencodeg =head2 ccsencode_g =for sig Signature: (a(N,M); indx [o]ptr(N); indx [o]rowids(Nnz); [o]nzvals(Nnz)) Encodes matrix $a() in CCS format interpreting BAD values as "missing". Requires bad-value support built into PDL. Allocates output vectors if required. =cut *ccsencodeg = *ccsencodefullg = *ccsencodefull_g = *PDL::ccsencodeg = *PDL::ccsencode_g = *PDL::ccsencodefullg = *PDL::ccsencodefull_g = \&ccsencode_g; sub ccsencode_g { #my ($a,$ptr,$rowids,$nzvals) = @_; my $a = shift; $a = $a->clump(1+$a->ndims-2); ##-- clump(-2) is broken in PDL-v2.014 my $amask = zeroes(byte,$a->dims); $a->isgood($amask); my $aw = $amask->whichND; return ccs_encode_compat($aw, $a->indexND($aw), $a->dims, @_); } ##--------------------------------------------------------------- ## Encoding: from flat index =pod =head2 ccsencode_i =for sig Signature: (indx ix(Nnz); nzvals(Nnz); indx $N; int [o]ptr(N); indx [o]rowids(Nnz); [o]nzvals_enc(Nnz)) General-purpose CCS encoding method for flat indices. Encodes values $nzvals() from flat-index locations $ix() into a CCS matrix ($ptr(), $rowids(), $nzvals_enc()). Allocates output vectors if required. $N (~ $a-Edim(0)) must be specified. =cut *ccsencodei = *ccsencodefulli = *ccsencodefull_i = *PDL::ccsencodei = *PDL::ccsencode_i = *PDL::ccsencodefulli = *PDL::ccsencodefull_i = \&ccsencode_i; sub ccsencode_i { #my ($iflat,$avals,$N_optional,$ptr,$rowids,$nzvals) = @_; my ($iflat,$avals) = splice(@_,0,2); my $N = defined($_[0]) && (!ref($_[0]) || $_[0]->nelem==1) ? shift : $_[0]->nelem; my $aw = ($iflat % $N)->cat($iflat/$N)->xchg(0,1); return ccs_encode_compat($aw, $avals, $N, undef, @_); } ##--------------------------------------------------------------- ## Encoding: from 2d index =pod =head2 ccsencode_i2d =for sig Signature: ( indx xvals(Nnz) ; indx yvals(Nnz) ; nzvals(Nnz) ; indx $N ; ##-- optional indx [o]ptr(N) ; indx [o]rowids(Nnz) ; [o]nzvals_enc(Nnz); ) General-purpose encoding method. Encodes values $nzvals() from 2d-index locations ($xvals(), $yvals()) in an $N-by-(whatever) PDL into a CCS matrix $ptr(), $rowids(), $nzvals_enc(). Allocates output vectors if required. If $N is omitted, it defaults to the maximum column index given in $xvals(). =cut *ccsencodei2d = *ccsencodefulli2d = *ccsencodefull_i2d = *PDL::ccsencodei2d = *PDL::ccsencode_i2d = *PDL::ccsencodefulli2d = *PDL::ccsencodefull_i2d = \&ccsencode_i2d; sub ccsencode_i2d { #my ($whichx,$whichy,$avals,$N_optional,$ptr,$rowids,$nzvals) = @_; my ($whichx,$whichy,$avals) = splice(@_, 0, 3); my $aw = $whichx->cat($whichy)->xchg(0,1); my $N = defined($_[0]) && (!ref($_[0]) || $_[0]->nelem==1) ? shift : ($whichx->max+1); return ccs_encode_compat($aw, $avals, $N, undef, @_); } ##====================================================================== ## Decoding =pod =head1 Decoding =cut ##--------------------------------------------------------------- ## Decoding: column-wise =pod =head2 ccsdecodecols =for sig Signature: ( indx ptr (N) ; indx rowids (Nnz); nzvals (Nnz); indx xvals (I) ; # default=sequence($N) missing() ; # default=0 M () ; # default=rowids->max+1 [o]cols (I,M); # default=new ) Extract dense columns from a CCS-encoded matrix (no dataflow). Allocates output matrix if required. If $a(N,M) was the dense source matrix for the CCS-encoding, and if missing values are zeros, then the following two calls are equivalent (modulo data flow): $cols = $a->dice_axis(1,$col_ix); $cols = ccsdecodecols($ptr,$rowids,$nzvals, $col_ix,0); =cut *PDL::_ccsdecodecols = \&_ccsdecodecols; #Pars => 'indx ptr(N); indx rowids(Nnz); nzvals(Nnz); indx col_ix(I); missing(); [o]cols(I,M);', sub _ccsdecodecols { ccsdecodecols(@_[0,1,2], $_[3],$_[4], undef, $_[5]); } *PDL::ccsdecodecols = \&ccsdecodecols; sub ccsdecodecols { my ($ptr,$rowids,$nzvals, $coli,$missing,$M, $cols) = @_; $coli = sequence(ccs_indx,$ptr->dim(0)) if (!defined($coli)); $coli = pdl(ccs_indx,$coli) if (!ref($coli)); my $ptr1 = zeroes(ccs_indx,$ptr->nelem+1); $ptr1->slice("0:-2") .= $ptr; $ptr1->set(-1 => $nzvals->nelem); $M = $rowids->max+1 if (!defined($M)); my ($ptrix,$nzix) = ccs_decode_pointer($ptr1,$coli); my $which = $ptrix->cat($rowids->index($nzix))->xchg(0,1); if (!defined($cols)) { $cols = ccs_decode($which, $nzvals->index($nzix), $missing, [$coli->nelem,$M]); $cols->sever; ##-- compat } else { ccs_decode($which, $nzvals->index($nzix), $missing, [$coli->nelem,$M], $cols); } return $cols; } ##--------------------------------------------------------------- ## Decoding: MISSING=0 =pod =head2 ccsdecode =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals(Nnz); $M; [o]dense(N,M)) Decodes compressed column format vectors $ptr(), $rowids(), and $nzvals() into dense output matrix $a(). Allocates the output matrix if required. Note that if the original matrix (pre-encoding) contained trailing rows with no nonzero elements, such rows will not be allocated by this method (unless you specify either $M or $dense). In such cases, you might prefer to call ccsdecodecols() directly. =cut *PDL::ccsdecodefull = \&ccsdecodefull; ##-- (indx ptr(N); indx rowids(Nnz); nzvals(Nnz); [o]dense(N,M)) sub ccsdecodefull { ccsdecodecols(@_[0,1,2], undef,0,undef, @_[3..$#_]); } *PDL::ccsdecode = \&ccsdecode; sub ccsdecode { my ($ptr,$rowids,$nzvals, $M, $dense)=@_; if (!defined($dense)) { ##-- check for old calling convention (is $M a multi-dim PDL?) if (ref($M) && UNIVERSAL::isa($M, 'PDL') && $M->dim(0)==$ptr->dim(0)) { $dense = $M; } else { $M = $rowids->max+1 if (!defined($M)); $dense = zeroes($nzvals->type,$ptr->dim(0),$M); } } ccsdecodecols($ptr,$rowids,$nzvals, undef,0,$M, $dense); return $dense; } ##--------------------------------------------------------------- ## Decoding: MISSING=BAD =pod =head2 ccsdecode_g =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals(Nnz); $M; [o]dense(N,M)) Convenience method. Like ccsdecode() but sets "missing" values to BAD. =cut *ccsdecodefullg = *PDL::ccsdecodefullg = *PDL::ccsdecodefull_g = \&ccsdecodefull_g; sub ccsdecodefull_g { my $badval = pdl($_[2]->type,0)->setvaltobad(0); ccsdecodecols(@_[0,1,2], undef,$badval,undef,undef, @_[3..$#_]); } *ccsdecodeg = *PDL::ccsdecodeg = *PDL::ccsdecode_g = \&ccsdecode_g; sub ccsdecode_g { my ($ptr,$rowids,$nzvals, $M, $dense)=@_; if (!defined($dense)) { ##-- check for old calling convention (is $M a multi-dim PDL?) if (ref($M) && UNIVERSAL::isa($M, 'PDL') && $M->dim(0)==$ptr->dim(0)) { $dense = $M; } else { $M = $rowids->max+1 if (!defined($M)); $dense = zeroes($nzvals->type,$ptr->dim(0),$M); } } my $badval = pdl($nzvals->type,0)->setvaltobad(0); ccsdecodecols($ptr,$rowids,$nzvals, undef,$badval,$M, $dense); return $dense; } ##====================================================================== ## Index Conversion ##====================================================================== =pod =head1 Index Conversion =cut ##------------------------------------------------------ ## ccsiNDtonzi() : index conversion: N-dimensional =pod =for sig Signature: (indx ptr(N); indx rowids(Nnz); indx ind(2,I); indx missing(); indx [o]nzix(I)) =head2 ccsiNDtonzi Convert N-dimensional index values $ind() appropriate for a dense matrix (N,M) into indices $nzix() appropriate for the $rowids() and/or $nzvals() components of the CCS-encoded matrix ($ptr(),$rowids(),$nzvals()). Missing values are returned in $nzix() as $missing(). =cut *PDL::ccsiNDtonzi = \&ccsiNDtonzi; sub ccsiNDtonzi { my ($ptr,$rowids,$ind, $missing, $nzix) = @_; my ($ptri,$ptrnzi) = ccs_decode_pointer($ptr->append($rowids->nelem)); my $ccswnd = $ptri->cat($rowids->index($ptrnzi))->xchg(0,1)->vv_qsortvec; $nzix = $ind->vsearchvec($ccswnd); my $nzix_mask = ($ind==$ccswnd->dice_axis(1,$nzix))->andover; $nzix_mask->inplace->not; #(my $tmp = $nzix->where($nzix_mask)) .= $missing; ##-- fix "Can't modify non-lvalue subroutine call" in 5.15.x (perl bug #107366) $nzix->where($nzix_mask) .= $missing; return $nzix; } ##------------------------------------------------------ ## ccsi2dtonzi() : index conversion: 2d =pod =head2 ccsi2dtonzi =for sig Signaure: (indx ptr(N); indx rowids(Nnz); indx col_ix(I); indx row_ix(I); indx missing(); indx [o]nzix(I)) Convert 2d index values $col_ix() and $row_ix() appropriate for a dense matrix (N,M) into indices $nzix() appropriate for the $rowids() and/or $nzvals() components of the CCS-encoded matrix ($ptr(),$rowids(),$nzvals()). Missing values are returned in $nzix() as $missing(). =cut *PDL::ccsi2dtonzi = \&ccsi2dtonzi; sub ccsi2dtonzi { my ($ptr,$rowids,$xi,$yi, $missing, $nzix) = @_; return ccsiNDtonzi($ptr,$rowids, $xi->cat($yi)->xchg(0,1), $missing,$nzix); } ##------------------------------------------------------ ## ccsitonzi() : index conversion: flat =pod =for sig Signature: (indx ptr(N); indx rowids(Nnz); indx ix(I); indx missing(); indx [o]nzix(I)) =head2 ccsitonzi Convert flat index values $ix() appropriate for a dense matrix (N,M) into indices $nzix() appropriate for the $rowids() and/or $nzvals() components of the CCS-encoded matrix ($ptr(),$rowids(),$nzvals()). Missing values are returned in $nzix() as $missing(). =cut *PDL::ccsitonzi = \&ccsitonzi; sub ccsitonzi { my ($ptr,$rowids,$ix, $missing, $nzix) = @_; my $dummy = pdl(byte,0)->slice("*".($ptr->dim(0)).",*".($rowids->max+1)); my ($xi,$yi) = $dummy->one2nd($ix); return ccsiNDtonzi($ptr,$rowids, $xi->cat($yi)->xchg(0,1), $missing,$nzix); } ##------------------------------------------------------ ## ccswhichND: get indices (N-dimensional) =pod =head2 ccswhichND =head2 ccswhich2d =head2 ccswhichfull =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals(Nnz); indx [o]which_cols(Nnz); indx [o]which_rows(Nnz)', In scalar context, returns concatenation of $which_cols() and $which_rows(), similar to the builtin whichND(). Note however that ccswhichND() may return its index PDLs sorted in a different order than the builtin whichND() method for dense matrices. Use the qsort() or qsorti() methods if you need sorted index PDLs. =cut *ccswhich2d = *PDL::which2d = *PDL::ccswhichND = *ccswhichfull = *PDL::ccswhichfull = \&ccswhichND; sub ccswhichND { my ($ptr,$rowids,$nzvals, $which_cols,$which_rows) = @_; my ($ptrnzi); ($which_cols,$ptrnzi) = ccs_decode_pointer($ptr->append($rowids->nelem), sequence(ccs_indx, $ptr->nelem), $which_cols ); $which_rows = zeroes(ccs_indx, $rowids->nelem) if (!defined($which_rows)); $which_rows .= $rowids->index($ptrnzi); return wantarray ? ($which_cols,$which_rows) : $which_cols->cat($which_rows)->xchg(0,1); } ##------------------------------------------------------ ## ccswhich(): get indices (flat) =head2 ccswhich =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals(Nnz); indx [o]which(Nnz); indx [t]wcols(Nnz)', Convenience method. Calls ccswhichfull(), and scales the output PDLs to correspond to a flat enumeration. The output PDL $which() is B guaranteed to be sorted in any meaningful order. Use the qsort() method if you need sorted output. =cut *PDL::ccswhich = \&ccswhich; sub ccswhich { my ($ptr,$rowids,$nzvals, $which, $wcols) = @_; my $nnz = $rowids->dim(0); $which = zeroes(ccs_indx,$nnz) if (!defined($which)); $wcols = zeroes(ccs_indx,$nnz) if (!defined($wcols)); ccswhichfull($ptr,$rowids,$nzvals, $wcols,$which); $which *= $ptr->dim(0); $which += $wcols; return $which; } ##------------------------------------------------------ ## ccstranspose() : transposition (convenience) =pod =head2 ccstranspose =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals(Nnz); indx [o]ptrT(M); indx [o]rowidsT(Nnz); [o]nzvalsT(Nnz)', Transpose a compressed matrix. =cut *ccstransposefull = *PDL::ccstransposefull = *PDL::ccstranspose = \&ccstranspose; sub ccstranspose { my ($ptr,$rowids,$nzvals, $ptrT,$rowidsT,$nzvalsT)=@_; my $N = $ptr->dim(0); my $M = defined($ptrT) ? $ptrT->dim(0) : $rowids->max+1; my $wnd = ccswhichND($ptr,$rowids,$nzvals)->slice("1:0,"); return ccs_encode_compat($wnd,$nzvals,$M,$N, $ptrT,$rowidsT,$nzvalsT); } ##====================================================================== ## Lookup ##====================================================================== =pod =head1 Lookup =cut ##------------------------------------------------------ ## ccsget2d() : lookup: 2d =pod =head2 ccsget2d =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals(Nnz); indx xvals(I); indx yvals(I); missing(); [o]ixvals(I)) Lookup values in a CCS-encoded PDL by 2d source index (no dataflow). Pretty much like ccsi2dtonzi(), but returns values instead of indices. If you know that your index PDLs $xvals() and $yvals() do not refer to any missing values in the CCS-encoded matrix, then the following two calls are equivalent (modulo dataflow): $ixvals = ccsget2d ($ptr,$rowids,$nzvals, $xvals,$yvals,0); $ixvals = index($nzvals, ccsi2dtonzi($ptr,$rowids, $xvals,$yvals,0)); The difference is that only the second incantation will cause subsequent changes to $ixvals to be propagated back into $nzvals. =cut *PDL::ccsget2d = \&ccsget2d; sub ccsget2d { my ($ptr,$rowids,$nzvals, $xi,$yi, $missing, $ixnzvals) = @_; my $nzi = ccsi2dtonzi($ptr,$rowids, $xi,$yi, -1); my $nzi_isgood = ($nzi != -1); $ixnzvals = zeroes($nzvals->type, $xi->nelem) if (!defined($ixnzvals)); if (!all($nzi_isgood)) { my $tmp; ($tmp=$ixnzvals->where( $nzi_isgood)) .= $nzvals->index($nzi->where($nzi_isgood)); ($tmp=$ixnzvals->where(!$nzi_isgood)) .= $missing; $ixnzvals->badflag(1) if (PDL->topdl($missing)->badflag); } return $ixnzvals; } ##------------------------------------------------------ ## ccsget() : lookup: flat =pod =head2 ccsget =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals(Nnz); indx ix(I); missing(); [o]ixvals(I)) Lookup values in a CCS-encoded PDL by flat source index (no dataflow). Pretty much like ccsitonzi(), but returns values instead of indices. If you know that your index PDL $ix() does not refer to any missing values in the CCS-encoded matrix, then the following two calls are equivalent (modulo dataflow): $ixvals = ccsget ($ptr,$rowids,$nzvals, $ix,0); $ixvals = index($nzvals, ccsitonzi($ptr,$rowids, $ix,0)) The difference is that only the second incantation will cause subsequent changes to $ixvals to be propagated back into $nzvals. =cut *PDL::ccsget = \&ccsget; sub ccsget { my ($ptr,$rowids,$nzvals, $ix, $missing, $ixnzvals) = @_; my $nzi = ccsitonzi($ptr,$rowids, $ix,-1); my $nzi_isgood = ($nzi != -1); $ixnzvals = zeroes($nzvals->type, $ix->nelem) if (!defined($ixnzvals)); if (!all($nzi_isgood)) { my $tmp; ($tmp=$ixnzvals->where( $nzi_isgood)) .= $nzvals->index($nzi->where($nzi_isgood)); ($tmp=$ixnzvals->where(!$nzi_isgood)) .= $missing; $ixnzvals->badflag(1) if (PDL->topdl($missing)->badflag); } return $ixnzvals; } ##====================================================================== ## Vector Operations ##====================================================================== =pod =head1 Vector Operations =cut ##====================================================================== ## Vector Operations: Columns ##====================================================================== =pod =head2 ccs${OP}_cv =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals_in(Nnz); colvec(M); [o]nzvals_out(Nnz)) Column-vector operation ${OP} on CCS-encoded PDL. Should do something like the following (without decoding the CCS matrix): ($colvec ${OP} ccsdecode(\$ptr,\$rowids,\$nzvals))->ccsencode; Missing values in the CCS-encoded PDL are not affected by this operation. ${OP} is one of the following: plus ##-- addition (alias: 'add') minus ##-- subtraction (alias: 'diff') mult ##-- multiplication (NOT matrix-multiplication) divide ##-- division (alias: 'div') modulo ##-- modulo power ##-- potentiation gt ##-- greater-than ge ##-- greater-than-or-equal lt ##-- less-than le ##-- less-than-or-equal eq ##-- equality ne ##-- inequality spaceship ##-- 3-way comparison and2 ##-- binary AND or2 ##-- binary OR xor ##-- binary XOR shiftleft ##-- left-shift shiftright ##-- right-shift =cut sub ccs_binop_compat_cv { my $ccsop = shift; return sub { $ccsop->(@_[1,2,3,4]) }; } foreach my $op (@ccs_binops) { no strict 'refs'; *{"ccs${op}_cv"} = *{"PDL::ccs${op}_cv"} = ccs_binop_compat_cv(\&{"PDL::ccs_${op}_vector_mia"}); } *ccsadd_cv = *PDL::ccsadd_cv = \&ccsplus_cv; *ccsdiff_cv = *PDL::ccsdiff_cv = \&ccsminus_cv; *ccsdiv_cv = *PDL::ccsdiv_cv = \&ccsdivide_cv; ##====================================================================== ## Vector Operations: Rows ##====================================================================== =pod =head2 ccs${OP}_rv =for sig Signature: (indx ptr(N); indx rowids(Nnz); nzvals_in(Nnz); rowvec(N); [o]nzvals_out(Nnz)) Row-vector operation ${OP} on CCS-encoded PDL. Should do something like the following (without decoding the CCS matrix): ($column->slice("*1,") ${OP} ccsdecode($ptr,$rowids,$nzvals))->ccsencode; Missing values in the CCS-encoded PDL are not effected by this operation. See ccs${OP}_cv() above for supported operations. =cut sub ccs_binop_compat_rv { my $ccsop = shift; return sub { my $ptr = shift; my ($ptri,$ptrnzi) = ccs_decode_pointer($ptr->append($_[1]->nelem)); $ccsop->($ptri, $_[1]->index($ptrnzi), @_[2,3]); }; } foreach my $op (@ccs_binops) { no strict 'refs'; *{"ccs${op}_rv"} = *{"PDL::ccs${op}_rv"} = ccs_binop_compat_rv(\&{"PDL::ccs_${op}_vector_mia"}); } *ccsadd_rv = *PDL::ccsadd_rv = \&ccsplus_rv; *ccsdiff_rv = *PDL::ccsdiff_rv = \&ccsminus_rv; *ccsdiv_rv = *PDL::ccsdiv_rv = \&ccsdivide_rv; ##------------------------------------------------------ ## Ufuncs (accumulators) ## \&ufuncsub = ccs_ufunc_compat(\&ccs_accum_sub) sub ccs_ufunc_compat { my $sub = shift; return sub { my ($ptr,$rowids,$nzvals, $M,$rowvals) = @_; my ($ixout,$valsout) = $sub->($rowids->slice("*1,"),$nzvals, 0,0); $M = $rowids->max+1 if (!defined($M)); $rowvals = zeroes($nzvals->type,$M) if (!defined($rowvals)); $rowvals->index($ixout->flat) .= $valsout; return $rowvals; }; } ## \&ufuncsub = ccs_ufunc_compat_t(\&ccs_accum_sub) sub ccs_ufunc_compat_t { my $sub = shift; return sub { my ($ptr,$rowids,$nzvals, $colvals) = @_; my ($colids,$nzix) = ccs_decode_pointer($ptr->append($nzvals->nelem)); ccs_ufunc_compat(undef,$colids,$nzvals->index($nzix), $ptr->dim(0),$colvals); }; } *ccssumover = *PDL::ccssumover = ccs_ufunc_compat (\&ccs_accum_sum); *ccssumovert = *PDL::ccssumovert = ccs_ufunc_compat_t(\&ccs_accum_sum); *ccprodover = *PDL::ccsprodover = ccs_ufunc_compat (\&ccs_accum_prod); *ccsprodovert = *PDL::ccsprodovert = ccs_ufunc_compat_t(\&ccs_accum_prod); 1; ##-- make perl happy ##====================================================================== ## Footer Administrivia ##====================================================================== ##--------------------------------------------------------------------- =pod =head1 EXAMPLES =head2 Compressed Column Format Example $a = pdl([ [10, 0, 0, 0,-2, 0], [3, 9, 0, 0, 0, 3], [0, 7, 8, 7, 0, 0], [3, 0, 8, 7, 5, 0], [0, 8, 0, 9, 9, 13], [0, 4, 0, 0, 2, -1] ]); ($ptr,$rowids,$nzvals) = ccsencode($a); print join("\n", "ptr=$ptr", "rowids=$rowids", "nzvals=$nzvals"); ... prints something like: ptr=[0 3 7 9 12 16] rowids=[ 0 1 3 1 2 4 5 2 3 2 3 4 0 3 4 5 1 4 5] nzvals=[10 3 3 9 7 8 4 8 8 7 7 9 -2 5 9 2 3 13 -1] =head2 Sparse Matrix Example ##-- create a random sparse matrix $a = random(100,100); $a *= ($a>.9); ##-- encode it ($ptr,$rowids,$nzvals) = ccsencode($a); ##-- what did we save? sub pdlsize { return PDL::howbig($_[0]->type)*$_[0]->nelem; } print "Encoding saves us ", ($saved = pdlsize($a) - pdlsize($ptr) - pdlsize($rowids) - pdlsize($nzvals)), " bytes (", (100.0*$saved/pdlsize($a)), "%)\n"; ... prints something like: Encoding saves us 71416 bytes (89.27%) =head2 Decoding Example ##-- random matrix $a = random(100,100); ##-- make an expensive copy of $a by encoding & decoding ($ptr,$rowids,$nzvals) = ccsencode($a); $a2 = ccsdecode($ptr,$rowids,$nzvals); ##-- ...and make sure it's good print all($a==$a2) ? "Decoding is good!\n" : "Nasty icky bug!\n"; =cut ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS Perl by Larry Wall. PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. Original inspiration and algorithms from the SVDLIBC C library by Douglas Rohde; which is itself based on SVDPACKC by Michael Berry, Theresa Do, Gavin O'Brien, Vijay Krishna and Sowmini Varadhan. =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS Many. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head2 Copyright Policy Copyright (C) 2005-2024, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl), PDL::SVDLIBC(3perl), PDL::CCS::Nd(3perl), SVDLIBC: http://tedlab.mit.edu/~dr/SVDLIBC/ SVDPACKC: http://www.netlib.org/svdpack/ =cut PDL-CCS-1.24.1/CCS/Config.pm0000644000175000017500000000336414736165666014563 0ustar moocowbovines## Automatically generated, remove to re-configure! package PDL::CCS::Config; use strict; use PDL qw(); our @ISA = qw(Exporter); our (%ccsConfig); our @EXPORT = qw(ccs_indx); our @EXPORT_OK = ('%ccsConfig', 'ccs_indx'); our %EXPORT_TAGS = (config=>['%ccsConfig'], Func=>\@EXPORT, default=>\@EXPORT, all=>\@EXPORT_OK); %ccsConfig = ( 'INDX_CTYPE' => 'PDL_Indx', 'INDX_FUNC' => 'indx', 'INDX_FUNCDEF' => '*ccs_indx = \\&PDL::indx; ##-- typecasting for CCS indices (deprecated) ', 'INDX_SIG' => 'indx', 'INDX_TYPEDEF' => 'typedef PDL_Indx CCS_Indx; /**< typedef for CCS indices (deprecated) */ ', 'INT_TYPE_CHRS' => [ 'A', 'B', 'S', 'U', 'L', 'K', 'N', 'P', 'Q' ], 'INT_TYPE_KEYS' => [ 'PDL_SB', 'PDL_B', 'PDL_S', 'PDL_US', 'PDL_L', 'PDL_UL', 'PDL_IND', 'PDL_ULL', 'PDL_LL' ], 'INT_TYPE_MAX_IONAME' => 'longlong' ); *PDL::ccs_indx = *ccs_indx = \&PDL::indx; ##-- typecasting for CCS indices (deprecated) 1; ##-- be happy PDL-CCS-1.24.1/ChangeLog0000644000175000017500000003572314736165630014155 0ustar moocowbovinesv1.24.1 Sat, 04 Jan 2025 09:02:21 +0100 mohawk2 - use `signed char` to accumulate logical values - #19 + same problem as https://github.com/PDLPorters/pdl/issues/502 + PR #20 - fixups - set dimsize in Pars - CI min 5.16 v1.24.0 Fri, 03 Jan 2025 08:59:42 +0100 + github issue #16: overhaul PP output dimension initialization (use RedoDimsCode) + add and use CCS_PDL_IS_NULL macro + double-check ccsutils type signatures (remove int+) + moderinize bad-handling + workaround for failing bandover,borover tests under PDL-2.096 + expand TABs to spaces in *.{pm,pd,t,PL,perl} files + fix indentation, opt-in to $multi_c from local submodule builds + add deprecation comment for ccs_indx() etc. to auto-generated Config.pm + require perl >= v5.10 for //= operator + fix typo for 'Func' export tag in Config.PL v1.23.29 Fri, 27 Dec 2024 17:59:08 +0100 + support BAD non-missing values in ccs_matmult2d_zdd - TODO: support BAD values (including missing) in ccs_matmult2d_sdd v1.23.28 Fri, 20 Dec 2024 20:12:18 +0100 + fix 'Runtime error: Tried to convert(null)' when multiplying all-missing CCS::Nd - reported as https://github.com/moocow-the-bovine/PDL-CCS/issues/14#issuecomment-2556862635 v1.23.27 Fri, 20 Dec 2024 11:10:00 +0100 mohawk2 + PR #15 assign "wanted" data of correct type in _ind and qsorti tests v1.23.26 Fri, 20 Dec 2024 10:55:18 +0100 + allow ccs_accum_sumover() to accept empty nzValsIn + add tests for https://github.com/moocow-the-bovine/PDL-CCS/issues/14 + set out_type=>indx for ccs_accum_nbad() - https://github.com/moocow-the-bovine/PDL-CCS/issues/6 v1.23.25 Thu, 14 Nov 2024 16:29:14 +0100 + fix embarrassing typo in ChangeLog v1.23.24 Thu, 14 Nov 2024 16:06:52 +0100 + PR #13 if want $PDL::VERSION, load PDL + PR #12 ccs_pointerlen removal - keep pure-perl PDL::CCS::Functions::ccs_pointerlen for paranoia reasons v1.23.23 Wed, 15 May 2024 21:51:55 +0200 mohawk2 + PR #8: no strict "refs" instead of string-eval + PR #9: switch from $PP() to $P() v1.23.22 Fri, 14 Apr 2023 14:11:53 +0200 mohawk2 + PR #7 from mowhawk2/tweaks: error-handling tweaks & bugfixes for PDL v2.082 - stop passing in outputs in ccs_binop_vector_mia - DRY in CCS::Functions - stop passing in outputs in recode - done_testing means no need count-padding in CCS/t/06_matops.t - DRY in CCS/t/06_matops.t - use params not globals in CCS/t/06_matops.t - _ufuncsub to give stack-trace if $vals1 is empty - zap old files - MANIFEST.SKIP expansion - zap patches - zap nullbarf file - zap CVS remnants - if empty nzvalsIn, stack-trace instead of SEGV - empty nzvalsIn, stack-trace instead of SEGV v1.23.21 Sat Apr 8 12:01:01 2023 +0200 moocow + adjust test expectations for CCS/Utils/t/02_encode.t + port mohawk2 test tweaks from https://github.com/moocow-the-bovine/PDL-HMM/pull/2/ v1.23.20 Tue, 19 Apr 2022 11:03:00 +0200 moocow + fixed variable-clobbering warning in 02_encode.t + type-mismatch fixes for ccs ufunc counters https://github.com/moocow-the-bovine/PDL-CCS/issues/6 - ccs ufunc counters (nbad, ngood, nnz) set out_type=>'indx' rather than out_type=>'int+' - ccs ufunc counters always clear nzvalsOut bad-flag in CopyBadStatusCode - ccs ufunc tests ensure $missing->type==$nzvalsIn->type v1.23.19 Thu, 14 Apr 2022 17:05:42 +0200 mohawk2 + update default config for recent PDL + fix for ccs_accum_hash() code generator in ccsufunc.pd + cleaner tests (use strict+warnings, zap redundant use_ok-only tests) v1.23.18 Fri, 18 Feb 2022 17:10:21 +0100 moocow + fixes for PDL v2.073, contributed by mohawk2 + shared github actions, contributed by zmughal v1.23.17 Tue, 18 Jan 2022 21:26:32 +0100 moocow + merged changes for PDL 2.066+ from mohawk2 - opt in to PDL 2.058 multi-C, dep on PDL v2.019 - simplify for 2.014+ types, compat with PDL 2.066+ + updated copyright notices in PODs v1.23.16 Thu, 29 Apr 2021 08:06:04 +0200 moocow + fixed $PDL::VERSION checks in Config.PL to reflect reality - integer-type downcasting behavior actually changed in PDL-2.037 with commit #f892aeb4ae on PDL/Basic/Ufunc/ufunc.pd - should fix new cpantesters failures, e.g. http://www.cpantesters.org/cpan/report/1fc08e78-a7e3-11eb-aa01-337c1f24ea8f + added missing "resources" level to META_MERGE section in Makefile.PL v1.23.15 Tue, 27 Apr 2021 13:13:20 +0200 moocow + added new PDL-2.039 integer-type listing code to Config.PL + fixed downcasting in b*over methods be PDL-compatible (problem was 'max_int_type' option to ccs_accum_def()) + re-enabled b*over tests skipped in v1.23.14 + added Makefile.PL META_MERGE section pointing to new public github repo moocow-the-bovine/PDL-CCS - github repo is just a fork of read-only ZDL git mirror of upstream SVN repository v1.23.14 Mon, 26 Apr 2021 14:58:50 +0200 moocow + skip some b(and|or)over type-check tests to avoid test failures for PDL >= v2.039 - CCS implementations are returning 'indx' type here, dense PDL versions are giving 'longlong' for input type=double v1.23.13 Thu, 19 Nov 2020 06:54:54 +0100 moocow + fix RT bug #133772, reported by Sebastiaan Couwenberg (spelling error in POD) v1.23.12 Tue, 28 Aug 2018 09:20:08 +0200 moocow + RT bug #126924, part III - added exception to CCS::Nd::borover() test in CCS/t/03_ufuncs.t - analogous to v1.23.11 fix for CCS/Ufunc/t/01_ufunc.t v1.23.11 Mon, 27 Aug 2018 14:35:47 +0200 moocow + workaround for RT bug #126294, reported by G. Herrmann - skip ufunc "borover:missing=BAD" test in CCS/Ufunc/t/01_ufunc.t if PDL::borover() is broken - upstream patch submitted to PDL maintainers as https://sourceforge.net/p/pdl/bugs/446/ v1.23.10 Fri, 24 Aug 2018 10:14:40 +0200 moocow + fixed typo in failed test label-reporting labstr() in t/common.plt, added 'use strict' + may help to diagnose RT bug #126294 (CCS/Ufunc/t/01_ufunc.t test 'borover:missing=BAD' fails on armv6l-linux ~ rpi) v1.23.9 Fri, 22 Jun 2018 13:55:35 +0200 moocow + ufunc.pd: avoid "|=" and "&=" operators (attempt to get build working on ARM64, reported by L. Baillet) - see http://www.cpantesters.org/cpan/report/eaad8962-7102-11e8-905e-5ddc267117a8 - see https://buildd.debian.org/status/package.php?p=libpdl-ccs-perl + more verbose diagnostics for failed pdlok() tests in t/common.plt v1.23.8 Fri, 15 Jun 2018 13:45:06 +0200 moocow + various fixes for debian packaging (RT bug #125587), patches provided by L. Baillet and G. Herrmann v1.23.7 Wed, 06 Jun 2018 09:18:55 +0200 moocow + CCS/IO 'clean' target: remove test temporaries t/ccs3.* t/dense3.* v1.23.6 Tue, 05 Jun 2018 16:39:46 +0200 moocow + fixed "do 'Config.PL'" call in Makefile.PL v1.23.5 Tue, 05 Jun 2018 15:05:00 +0200 moocow + fixed typos reported by L. Baillet (RT bug #125493) v1.23.4 Tue, 06 Jun 2017 10:17:44 +0200 moocow + fixed bogus bareword pdl() call in CCS/Nd.pm (RT bug #121952) + added 'use lib "."' to Makefile.PL (RT bug #121661) v1.23.3 Mon, 06 Jun 2016 14:45:29 +0200 moocow + fixed ccs_wfits() typecast-to-long hack for indx types - feature request including patch posted to https://sourceforge.net/p/pdl/bugs/421/ v1.23.2 Mon, 06 Jun 2016 11:20:12 +0200 moocow + win32/NaN fixes for tests (RT bug #115078) v1.23.1 Tue, 12 Jan 2016 13:24:00 +0100 moocow + fixed index overflow bug picking maximum output dimension in perl-side ccs_xindex2d() + added optional pass-in $anorm() for ccs_vcos_zdd() + added pointer-optimized sparse-crs matrix vs. sparse-coo vector cosine method ccs_vcos_pzd() v1.23.0 Tue, 15 Dec 2015 13:25:35 +0100 moocow + fixed "uninitialized value" warnings for PDL->can($type) in PDL::CCS::IO::* + added support for ndims>2 to PDL::CCS::IO::MatrixMarket + added sparse/dense vector-cosine ccs_vcos_zdd() in PDL::CCS::MatrixOps, with wrapper PDL::CCS::Nd::vcos_zdd() - dense/dense variant in PDL::VectorValued::Utils::vv_vcos() for PDL::VectorValued v1.0.5 + fixed BAD handling in CCS::Compat::ccsget(), CCS::Compat::ccsget2d() + fixed I/O type handling in integer ufuncs (borover) + fixed wrongly succeeding bogus tests with unary ok() - tests now use Test::More and re-factored common test subroutines + fixed C-level abs() function in CCS::Utils::nnza(); now dispatches to one of {abs,labs,llabs,fabsf,fabs} using PDL::PP types(...) macro + fixed CCS ufunc type-promotion logic to be compatible with PDL v2.015 + pared down CCS/t/06_matops.t to test only missing==0 : matrix ops don't work correctly with missing!=0 + pdlmaker.plm doesn't distribute generated PM files any more (PDL now does this for us) v1.22.6 Wed, 25 Nov 2015 16:27:24 +0100 moocow + added CCS::IO::FITS, CCS::IO::MatrixMarket, CCS::IO::LDAC, CCS::IO::PETSc + moved common I/O utilities to CCS::IO::Common + added CCS::IO tests v1.22.5 Mon, 23 Nov 2015 12:34:25 +0100 moocow + no real joy with Makefile.PL workaround (UNKNOWN results are still pretty wonky) + updating PDL::VectorValued to use shared $VERSION via perl-reversion script from module Perl::Version + PDL::CCS can now depend directly on PDL::VectorValued v1.22.4 Tue, 17 Nov 2015 09:54:23 +0100 mocoow + Makefile.PL workaround for PDL::VectorValued(::Version) strangeness on cpantesters - see http://sourceforge.net/p/pdl/mailman/message/34623263/ ("headaches with indirect PDL-related dependencies on cpantesters", 2015-11-16 13:16:44) v1.22.3 Thu, 05 Nov 2015 10:43:54 +0100 moocow + workaround for PDL::clump(-N) bug in PDL-v2.014: compute non-negative clump() arguments in CCS/Compat.pm - see RT bug #108472; PDL bug https://sourceforge.net/p/pdl/bugs/406/ + workaround for changed PDL::reshape() behavior in CCS/t/05_binops.t, CCS/t/06_matops.t : getting ugly realloc errors without it - see RT bug #107829 v1.22.2 Tue, 18 Aug 2015 13:04:09 +0200 moocow + added clearptr($pdimi) method v1.22.1 Wed, 08 Apr 2015 16:09:43 +0200 moocow + fixed ccs_xindex2d() utility and added CCS::Nd::xsubset2d() wrapper v1.22.0 Wed, 08 Apr 2015 13:49:14 +0200 + added ccs_xindex2d() utility function: fast Cartesian product indexing of sparse 2d matrices v1.21.0 Mon, 16 Mar 2015 13:22:34 +0100 moocow + added PDL::IO::FastRaw wrappers (incl mapfraw) for PDL::CCS::Nd objects + PDL::CCS::Nd->fromWhich() now accepts ARRAY-refs for 'pdims' and 'vdims' options v1.20.2 Wed, 05 Nov 2014 13:24:55 +0100 moocow + more empty-piddle fixes for PDL-v2.4.11 (kaskade / debian wheezy) v1.20.1 Wed, 05 Nov 2014 10:41:19 +0100 moocow + improved handling of empty pdls in PDL::CCS::Nd v1.19.1 Thu, 26 Sep 2013 08:57:11 +0200 moocow + use ExtUtils::MakeMaker::prompt() for configuration questions; fixes RT #88972 v1.19.0 Wed, 25 Sep 2013 12:13:27 +0200 moocow + added (optional) support for 64-bit indices via PDL_Indx (requires PDL >= v2.007) v1.18.0 Wed, 07 Nov 2012 13:57:26 +0100 + added CCS::Functions::ccs_qsort(), CCS::Nd::qsort(), CCS::Nd::qsorti() + new qsort code requires PDL::VectorValued >= v0.06 (for enumvec()) + added :lvalue attribute to selected CCS::Nd and CCS::Functions subs v1.16 Mon, 02 Jan 2012 13:38:48 +0100 moocow + cpan-friendly distribution with pdlmaker.plm v1.15 2011-12-20 moocow * [r5936] band-aided barf()ing PDL::CCS::Functions::ccs_decode() due to mismatched dimensions in empty index and value piddles v1.14 2011-03-31 moocow * [r5596] CCS/Makefile.PL, CCS/Nd.pm, CCS/Version.pm, CCS/testme.perl, ChangeLog, Makefile.PL, testme.perl: + v1.14: updated for PDL::VectorValued 0.04 (qsortveci -> vv_qsortveci) v1.13 2010-02-26 moocow * [r4085] CCS/MatrixOps/ccsmatops.pd, CCS/Nd.pm, CCS/Version.pm, testme.perl: + updated MatrixOps::ccs_matmult2d_sdd : 2d matrix mult with arbitrary finite missing values * [r4084] MANIFEST: + updated MANIFEST (added CCS/MatrixOps/ subdir) v1.12 2009-11-04 moocow * [r3653] CCS/Nd.pm: + v1.12: fixed empty-dimension bug in CCS::Nd::dice_axis() [not indexND as in last log message] * [r3652] CCS/Nd.pm, CCS/Utils/ccsutils.pd, CCS/Version.pm: + v1.12: fixed empty-dimension bug in CCS::Nd::indexND() v1.11 2009-10-31 moocow * [r3621] CCS/MatrixOps/ccsmatops.pd, CCS/Nd.pm, CCS/t/06_matops.t, testme.perl: + added matmult2d_zdd() variant: should really work * [r3618] CCS.pm, CCS/Attic, CCS/Makefile.PL, CCS/MatrixOps, CCS/MatrixOps/Makefile.PL, CCS/MatrixOps/ccsmatops.pd, CCS/MatrixOps/t, CCS/MatrixOps/t/00_basic.t, CCS/MatrixOps/t/common.plt, CCS/Nd.pm, CCS/Version.pm, CCS/t/06_matops.t, testme.perl: + v1.11: added CCS::Nd::matmult2d_sdd for correct matrix multiplication with dense 2nd operand and output v1.10 2009-10-22 moocow * [r3567] CCS/Nd.pm, CCS/Version.pm: + v1.10: added isbad(), isgood() v1.09 2009-10-19 moocow * [r3540] CCS/Ufunc/ccsufunc.pd: * [r3539] CCS/Ufunc/ccsufunc.pd, CCS/Version.pm: * [r3538] CCS/Ufunc/ccsufunc.pd: v1.08 2009-07-16 moocow * [r3395] CCS/Nd.pm, CCS/Version.pm, ChangeLog, testme.perl: + added CCS::Nd methods interpolate(), interpol() v1.07 2008-07-26 moocow * [r2534] CCS/Nd.pm: + improved BAD handling in _ccsnd_binary_op_mia() * [r2533] CCS/Nd.pm, CCS/Version.pm: + improved BAD handling in _ccsnd_binary_op_mia() v1.06 2008-06-26 moocow * [r2490] CCS/Version.pm: + v1.06: added CCS::Nd::_missing() * [r2489] CCS/Nd.pm: + added '_missing()' method v1.05 Fri, 02 May 2008 13:00:22 +0200 + added CCS::Nd::ismissing(), CCS::Nd::ispresent() mask methods + added CCS::Nd::maximum_ind(), CCS::Nd::minimum_ind() v1.04 Mon, 28 Apr 2008 23:48:57 +0200 + added PDL::CCS::Ufunc::ccs_accum_average() + added PDL::CCS::Nd wrappers: average_nz, avg_nz, average, avg + documented PDL::CCS::Nd method _nzvals(), added alias _whichVals() + added CCS::Nd::badflag() v1.03 Wed, 20 Feb 2008 10:30:39 +0100 + fixed some bugs in PDL::CCS::Nd::to_physically_indexed() - bad use of vdims for pdims (output pdl should be physically ordered) - missing value wasn't getting appended to output pdl v1.02 Thu, 14 Feb 2008 12:50:11 +0100 + fixed some bugs in PDL::CCS::Nd::string(), ::appendWhich() for objects with empty index pdls + fixed virtual-dimension indexing bug in PDL::CCS::Nd::indexNDi causing indexing to fail for e.g. transposed sparse matrices v1.01 Tue, 24 Apr 2007 01:24:05 +0200 (moocow) + added PDL::CCS::Nd perl class for sparse Nd piddle-like structures + separated out submodules Utils, Ufunc, Ops + added PDL::CCS::Compat for backwards-compatibility 2007-03-27 moocow * [r1933] Attic/CCS.pd, CCS.pd: + minor documentation fixes 2007-02-27 moocow * [r1847] Attic/CCS.pd, CCS.pd, t/02_encode.t, t/03_ops.t, t/Attic/02_encode.t, t/Attic/03_ops.t, t/common.plt, testme.perl: + added partial decoding, encoding from indices, ufuncs 2007-02-26 moocow * [r1845] Attic/CCS.pd, CCS.pd, t/03_ops.t, t/Attic/03_ops.t, testme.perl: + added whichND, which, transpose, and basic vector ops * [r1842] Attic/CCS.pd, CCS.pd: + added bad-processing stuff to PDL::CCS 2007-02-26 moocow * [r1845] Attic/CCS.pd, CCS.pd, t/03_ops.t, t/Attic/03_ops.t, testme.perl: + added whichND, which, transpose, and basic vector ops * [r1842] Attic/CCS.pd, CCS.pd: + added bad-processing stuff to PDL::CCS 2005-08-02 moocow * [r1215] Attic/CCS.pd, CCS.pd, ChangeLog: re-import (gaspode) v0.01 Sat, 11 Jun 2005 10:32:05 +0200 (moocow) + initial version, 2d pdls only PDL-CCS-1.24.1/Makefile.PL0000644000175000017500000000324114735713775014353 0ustar moocowbovinesuse ExtUtils::MakeMaker; require 5.10.0; ##-- for the `//=` operator require "./pdlmaker.plm"; pdlmaker_init(); ##-- prerequisites (for PREREQ_PM) my %prereq = ( 'PDL' => '2.081', 'PDL::VectorValued' => '1.0.4', 'File::Basename' => 0, ); ##-- read in user variables do "./Config.PL"; die "$0: reading './Config.PL' failed: $@" if ($@); ##-- put 'realclean_files' in a variable: avoid MakeMaker puking with: ## ERROR from evaluation of .../ccsutils/Makefile.PL: ## Modification of a read-only value attempted at /usr/share/perl/5.8/Carp/Heavy.pm line 45. my $realclean_files = join(' ', qw(*~ *.tmp), (-e 'README.rpod' ? qw(README.txt README.html) : qw()), (-e 'Config.PL' ? qw(CCS/Config.pm) : qw()), ); WriteMakefile( NAME =>'PDL::CCS', AUTHOR => 'Bryan Jurish', ABSTRACT =>'Sparse N-dimensional PDLs with compressed column storage', ## VERSION_FROM => 'CCS.pm', LICENSE => 'perl', ## #PM => { (map {$_=>"\$(INST_LIBDIR)/CCS/$_"} <*.pm>), }, DIR =>[ 'CCS', ], realclean=>{ FILES=>$realclean_files, }, PREREQ_PM => {%prereq}, TEST_REQUIRES => { 'Test::More' => '0.88', }, CONFIGURE_REQUIRES => { %prereq, 'ExtUtils::MakeMaker'=>0, 'Data::Dumper' => 0, }, ## META_MERGE => { "meta-spec" => { version => 2 }, resources => { repository => { url => 'git://github.com/moocow-the-bovine/PDL-CCS.git', type => 'git', web => 'https://github.com/moocow-the-bovine/PDL-CCS', }, }, }, ); ##-- avoid applying 'processPL' rules to 'Config.PL' sub MY::processPL { return ''; } PDL-CCS-1.24.1/MANIFEST0000644000175000017500000000221514736165776013535 0ustar moocowbovinesChangeLog MANIFEST MANIFEST.SKIP Makefile.PL Config.PL pdlmaker.plm README.txt README.rpod CCS.pm CCS/Makefile.PL CCS/Functions.pm CCS/Compat.pm CCS/Config.pm CCS/IO/Makefile.PL CCS/IO/Common.pm CCS/IO/FastRaw.pm CCS/IO/FITS.pm CCS/IO/LDAC.pm CCS/IO/MatrixMarket.pm CCS/IO/PETSc.pm CCS/Nd.pm CCS/Version.pm CCS/Ops/Makefile.PL CCS/Ops/ccsops.pd # CCS/Ops/Ops.pm CCS/Ops/Ops.pm CCS/Ufunc/Makefile.PL CCS/Ufunc/ccsufunc.pd # CCS/Ufunc/Ufunc.pm CCS/Ufunc/Ufunc.pm CCS/Utils/Makefile.PL CCS/Utils/ccsutils.pd # CCS/Utils/Utils.pm CCS/Utils/ccsutils.h CCS/Utils/Utils.pm CCS/MatrixOps/Makefile.PL CCS/MatrixOps/ccsmatops.pd # CCS/MatrixOps/MatrixOps.pm CCS/MatrixOps/MatrixOps.pm t/common.plt t/02_encode.t t/03_ops.t CCS/t/01_encode.t CCS/t/02_indexing.t CCS/t/03_ufuncs.t CCS/t/04_unops.t CCS/t/05_binops.t CCS/t/06_matops.t CCS/t/common.plt CCS/IO/t/01_io.t CCS/Utils/t/01_nnz.t CCS/Utils/t/02_encode.t CCS/Utils/t/03_decode.t CCS/Utils/t/common.plt CCS/Ufunc/t/01_ufunc.t CCS/Ufunc/t/common.plt META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) PDL-CCS-1.24.1/META.yml0000644000175000017500000000142114736165776013653 0ustar moocowbovines--- abstract: 'Sparse N-dimensional PDLs with compressed column storage' author: - 'Bryan Jurish' build_requires: ExtUtils::MakeMaker: '0' Test::More: '0.88' configure_requires: Data::Dumper: '0' ExtUtils::MakeMaker: '0' File::Basename: '0' PDL: '2.081' PDL::VectorValued: v1.0.4 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PDL-CCS no_index: directory: - t - inc requires: File::Basename: '0' PDL: '2.081' PDL::VectorValued: v1.0.4 resources: repository: git://github.com/moocow-the-bovine/PDL-CCS.git version: v1.24.1 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' PDL-CCS-1.24.1/Config.PL0000644000175000017500000000615414735713775014051 0ustar moocowbovines## File: PDL-CCS/Config.PL ## Description: user variables for PDL::CCS package ##-- load cached values? if (0 && -e "./CCS/Config.pm") { require "./CCS/Config.pm"; if ($@) { warn("$0: could not load cache data from './CCS/Config.pm': $@"); } %cconfig = %PDL::CCS::Config::ccsConfig; } ##-- ## $val = cprompt($key, $message) ## $val = cprompt($key, $message, $default) ## + sets $cconfig{$key} sub cprompt { my ($key, $msg, $default)=@_; return $cconfig{$key} if (defined($cconfig{$key})); $default = '' if (!defined($default)); my $answer = ExtUtils::MakeMaker::prompt(" $msg [$default] ? "); chomp($answer); return $cconfig{$key} = ($answer eq '' ? $default : $answer); } require PDL; $cconfig{INDX_CTYPE} = "PDL_Indx"; $cconfig{INDX_SIG} = "indx"; $cconfig{INDX_FUNC} = "indx"; $cconfig{INDX_TYPEDEF} = "typedef $cconfig{INDX_CTYPE} CCS_Indx; /**< typedef for CCS indices (deprecated) */\n"; $cconfig{INDX_FUNCDEF} = "*ccs_indx = \\&PDL::$cconfig{INDX_FUNC}; ##-- typecasting for CCS indices (deprecated)\n"; ##-- figure out what integer types we have available require PDL::Types; if (version->parse($PDL::VERSION) >= version->parse("2.037")) { ##-- integer types for b*over &c, PDL >= v2.037: elegant (and more correct) local $, = ' '; $cconfig{INT_TYPE_KEYS} = [map {$_->sym} grep {$_->integer} PDL::Types::types()]; $cconfig{INT_TYPE_CHRS} = [map {$_->ppsym} grep {$_->integer} PDL::Types::types()]; $cconfig{INT_TYPE_MAX_IONAME} = (grep {$_->integer} PDL::Types::types())[-1]->ioname; } else { ##-- integer types for b*over &c, PDL < v2.037: functional (and mostly equivalent) $cconfig{INT_TYPE_KEYS} = [map {$_->{sym}} sort {$a->{numval} <=> $b->{numval}} grep {$_->{ppsym} =~ /^(?:[BSULQN]|LL|US)$/} values %PDL::Types::typehash ]; $cconfig{INT_TYPE_CHRS} = [map {$_->{ppsym}} @PDL::Types::typehash{ @{$cconfig{INT_TYPE_KEYS}} }]; ##-- PDL < v2.037 downcasts to 'indx' if available (but probably should use 'longlong' if it could) ## + behavior changed (for the better) apparently due to PDL commit #f892aeb4ae on Basic/Ufunc/ufunc.pd #$cconfig{INT_TYPE_MAX_IONAME} = $PDL::Types::typehash{$cconfig{INT_TYPE_KEYS}[-1]}{ioname}; ##-- -> longlong $cconfig{INT_TYPE_MAX_IONAME} = 'ccs_indx'; } ##-- save cache file open(CONFIGPM,">./CCS/Config.pm") or die("$0: failed to open ./CCS/Config.pm for writing: $!"); print CONFIGPM <<'EOF'; ## Automatically generated, remove to re-configure! package PDL::CCS::Config; use strict; use PDL qw(); our @ISA = qw(Exporter); our (%ccsConfig); our @EXPORT = qw(ccs_indx); our @EXPORT_OK = ('%ccsConfig', 'ccs_indx'); our %EXPORT_TAGS = (config=>['%ccsConfig'], Func=>\@EXPORT, default=>\@EXPORT, all=>\@EXPORT_OK); EOF ##-- config hash use Data::Dumper; $Data::Dumper::Sortkeys=1; # reproducible order of hash keys print CONFIGPM Data::Dumper->Dump([\%cconfig],['*ccsConfig']), "\n"; ##-- type conversion sub print CONFIGPM << "EOF"; \*PDL::ccs_indx = $cconfig{INDX_FUNCDEF} 1; ##-- be happy EOF close CONFIGPM; 1; ##-- return nicely PDL-CCS-1.24.1/README.rpod0000644000175000017500000000243414734512720014211 0ustar moocowbovines=pod README for PDL::CCS =head1 ABSTRACT PDL::CCS - Sparse N-dimensional PDLs with Harwell-Boeing compressed column storage =head1 REQUIREMENTS =over 4 =item * PDL E= v2.4.2 Tested version(s) 2.4.2, 2.4.3, 2.4.7_001, 2.4.9_015, 2.4.10, 2.019, 2.039 =item * PDL::VectorValued E= v0.07001 =back =head1 DESCRIPTION PDL::CCS is a set of perl modules for representation and manipulation of large sparse n-dimensional numeric arrays using PDL. It includes a perl class implementing a subset of the PDL API for memory-efficient storage and operations on large sparse arrays, as well as utilities for extracting Harwell-Boeing compressed column- and/or row-storage "pointers" from/to indexND() vector lists. =head1 BUILDING Build this module as you would any perl module, by doing something akin to the following: gzip -dc PDL-CCS-XYZ.tar.gz | tar -xof - cd PDL-CCS-XYZ/ perl Makefile.PL make make test # optional make install See L(1) for details. =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head1 COPYRIGHT Copyright (c) 2005-2024 by Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =cut PDL-CCS-1.24.1/pdlmaker.plm0000644000175000017500000001255614735713775014723 0ustar moocowbovines## -*- Mode: CPerl -*- ## ## File: pdlmaker.plm ## Author: Bryan Jurish ## Description: hacks for CPAN-friendly PDL module distribution ## ## Usage: ## + optionally set the variable $MY::README (boolean); default is ## $MY::README = grep {-e $_} (,,) ## + read this file in top-level Makefile.PL: ## require "pdlmaker.plm"; ## + call pdlmaker_init([$pdfile, $pmbase, $module]) as for pdlpp_stdargs() ## - will actually call pdlpp_stdargs() and return that hash if called in list context ## + call WriteMakefile() as usual ## + omit the pdlpp_postamble() call from MY::postamble() ## (you still need to 'use PDL::Core::Dev' though) ## ## Effects: ## + clobbers sub ExtUtils::MakeMaker::WriteMakefile() ## - unlinks all @pdpm files before calling "real" WriteMakefile() ## + clobbers/appends MY::depend (appends) ## x- adds @pdpm dependencies to dist,distcheck,create_distdir ## - also adds README.txt dependencies if README.txt or README.rpod is present ## + clobbers/appends MY::special_targets (appends) ## - adds (pm|pod|rpod) -> (txt|html) rules ## + clobbers/appends MY::postamble (appends) ## - adds pdlpp_postamble($package) if $package is specified package MY; use ExtUtils::MakeMaker qw(); use ExtUtils::Manifest qw(); use Cwd qw(cwd abs_path); use File::Basename qw(dirname basename); use PDL::Core::Dev; use strict; ##---------------------------------------------------------------------- sub pdlmaker_init { my $package = shift; my @pdpm = $package ? "$package->[1].pm" : qw(); my $cwd = cwd(); my $label = "pdlmaker_init [DIR=$cwd]"; #print STDERR "$label\n"; ##---------------------------- ## read manifest @pdpm (for user info message) my @manipm = qw(); if (-r 'MANIFEST') { my $mani = ExtUtils::Manifest::maniread(); my ($pd,$pm); foreach $pd (grep {/\.pd$/i} keys %$mani) { if ($mani->{$pd}) { ($pm=$mani->{$pd}) =~ s/^[\#\s]*(?:pm=)?//; if ($pm) { push(@manipm,$pm); next; } } ($pm=$pd)=~s/\.pd$/\.pm/i; push(@manipm,$pm); } print STDERR "Info: ignore any warnings about missing $_\n" foreach (@manipm); } elsif (0 && $package) { print STDERR "Info: ignore any warnings about missing $package->[1].pm\n"; ; } ##---------------------------- ## $MY::README if (!defined($MY::README)) { $MY::README = grep {-e $_} map {glob("README.$_")} qw(txt pod rpod); } ##---------------------------- ## unlink @pdpm files here foreach (@pdpm) { #print STDERR "$label: UNLINK $_\n"; unlink($_) if (-e $_); } ##---------------------------- ## @missed = ExtUtils::Manifest::manicheck() ## + ignore @pdpm files in manicheck my %manipm = (map {($_=>undef)} @manipm,@pdpm); my $_manicheck0 = \&ExtUtils::Manifest::manicheck; my $_manicheck1 = sub { grep {!exists($manipm{$_})} $_manicheck0->(@_); }; *ExtUtils::Manifest::manicheck = $_manicheck1; ##---------------------------- ## depend() ## + add @pdpm, README.txt my $depend0 = MY->can('depend') || sub {''}; my $depend = sub { my $inherited = $depend0->(@_) . shift->SUPER::depend(@_); my $deps = join(' ', ($MY::README ? 'README.txt' : qw()), #sort keys %manipm ); return $inherited if (!$deps); return $inherited .<(txt|html) my $special_targets0 = MY->can('special_targets') || sub {''}; my $special_targets = sub { my $inherited = $special_targets0->(@_) . shift->SUPER::special_targets(@_); $inherited .= <parse($PDL::VERSION) >= version->parse('2.058')); ##---------------------------- ## postamble() ## + add pdlpp postamble if available my $postamble0 = MY->can('postamble') || sub {''}; my $postamble = sub { my $inherited = $postamble0->(@_) . shift->SUPER::postamble(); if (defined($package) && UNIVERSAL::can('PDL::Core::Dev','pdlpp_postamble')) { $inherited .= PDL::Core::Dev::pdlpp_postamble($package); } $inherited; }; *MY::postamble = $postamble; ##--------------------------- ## returning list context? --> call pdlpp_stdargs() if ($package && wantarray && UNIVERSAL::can('main','pdlpp_stdargs')) { ## + TODO: dodge 'redefined' warnings here for Basic/Core/Types.pm.PL symbols on 1st nested submodule (currently PDL::CCS::Utils) ## > Subroutine typesrtkeys redefined at Basic/Core/Types.pm.PL line 484. return ::pdlpp_stdargs($package,@_); } } ##---------------------------------------------------------------------- package main; *pdlmaker_init = \&MY::pdlmaker_init; 1; ##-- be happy