"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Basic/Primitive/primitive.pd" between
PDL-2.076.tar.gz and PDL-2.077.tar.gz

About: PDL (Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).

primitive.pd  (PDL-2.076):primitive.pd  (PDL-2.077)
skipping to change at line 687 skipping to change at line 687
=cut =cut
EOD EOD
Pars => 'a(m); kern(p); [o]b(m);', Pars => 'a(m); kern(p); [o]b(m);',
GenericTypes => [ppdefs_all], GenericTypes => [ppdefs_all],
OtherPars => 'int reflect;', OtherPars => 'int reflect;',
HandleBad => 0, HandleBad => 0,
PMCode => ' PMCode => '
sub PDL::conv1d { sub PDL::conv1d {
my $opt = pop @_ if ref($_[$#_]) eq \'HASH\'; my $opt = pop @_ if ref($_[-1]) eq \'HASH\';
die \'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )\' die \'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )\'
if $#_<1 || $#_>2; if @_<2 || @_>3;
my($x,$kern) = @_; my($x,$kern) = @_;
my $c = $#_ == 2 ? $_[2] : PDL->null; my $c = @_ == 3 ? $_[2] : PDL->null;
PDL::_conv1d_int($x,$kern,$c, PDL::_conv1d_int($x,$kern,$c,
!(defined $opt && exists $$opt{Boundary}) ? 0 : !(defined $opt && exists $$opt{Boundary}) ? 0 :
lc $$opt{Boundary} eq "reflect"); lc $$opt{Boundary} eq "reflect");
return $c; return $c;
} }
', ',
Code => ' Code => '
int i,i1,i2,poff,pflip; int i,i1,i2,poff,pflip;
double tmp; double tmp;
skipping to change at line 935 skipping to change at line 935
my $pdl2d = $pdl->clump(1..$pdl->ndims-1); my $pdl2d = $pdl->clump(1..$pdl->ndims-1);
my $ngood = $pdl2d->ngoodover; my $ngood = $pdl2d->ngoodover;
$pdl2d = $pdl2d->mv(0,-1)->dice($ngood->which)->mv(-1,0); # remov e all-BAD vectors $pdl2d = $pdl2d->mv(0,-1)->dice($ngood->which)->mv(-1,0); # remov e all-BAD vectors
my $numnan = ($pdl2d!=$pdl2d)->sumover; # wo rks since no all-BADs to confuse my $numnan = ($pdl2d!=$pdl2d)->sumover; # wo rks since no all-BADs to confuse
my $presrt = $pdl2d->mv(0,-1)->dice($numnan->not->which)->mv(0,-1); # re move vectors with any NaN values my $presrt = $pdl2d->mv(0,-1)->dice($numnan->not->which)->mv(0,-1); # re move vectors with any NaN values
my $nanvec = $pdl2d->mv(0,-1)->dice($numnan->which)->mv(0,-1); # th e vectors with any NaN values my $nanvec = $pdl2d->mv(0,-1)->dice($numnan->which)->mv(0,-1); # th e vectors with any NaN values
# use dice instead of slice since qsortvec might be packing
# the badvals to the front of the array instead of the end like
# the docs say. If that is the case and it gets fixed, it won't
# bust uniqvec. DAL 14-March 2006
my $srt = $presrt->qsortvec->mv(0,-1); # BA Ds are sorted by qsortvec my $srt = $presrt->qsortvec->mv(0,-1); # BA Ds are sorted by qsortvec
my $srtdice = $srt; my $srtdice = $srt;
my $somebad = null; my $somebad = null;
if ($srt->badflag) { if ($srt->badflag) {
$srtdice = $srt->dice($srt->mv(0,-1)->nbadover->not->which); $srtdice = $srt->dice($srt->mv(0,-1)->nbadover->not->which);
$somebad = $srt->dice($srt->mv(0,-1)->nbadover->which); $somebad = $srt->dice($srt->mv(0,-1)->nbadover->which);
} }
my $uniq = $srtdice->nelem > 0 my $uniq = $srtdice->nelem > 0
? ($srtdice != $srtdice->rotate(-1))->mv(0,-1)->orover->which ? ($srtdice != $srtdice->rotate(-1))->mv(0,-1)->orover->which
skipping to change at line 990 skipping to change at line 985
$SETBAD(c()); $SETBAD(c());
} else { '.$code.' }', } else { '.$code.' }',
Doc => 'clip (threshold) C<$a> by C<$b> (C<$b> is '. Doc => 'clip (threshold) C<$a> by C<$b> (C<$b> is '.
($name eq 'hclip' ? 'upper' : 'lower').' bound)', ($name eq 'hclip' ? 'upper' : 'lower').' bound)',
PMCode=><<"EOD", PMCode=><<"EOD",
sub PDL::$name { sub PDL::$name {
my (\$x,\$y) = \@_; my (\$x,\$y) = \@_;
my \$c; my \$c;
if (\$x->is_inplace) { if (\$x->is_inplace) {
\$x->set_inplace(0); \$c = \$x; \$x->set_inplace(0); \$c = \$x;
} elsif (\$#_ > 1) {\$c=\$_[2]} else {\$c=PDL->nullcreate(\$x)} } elsif (\@_ > 2) {\$c=\$_[2]} else {\$c=PDL->nullcreate(\$x)}
PDL::_${name}_int(\$x,\$y,\$c); PDL::_${name}_int(\$x,\$y,\$c);
return \$c; return \$c;
} }
EOD EOD
); # pp_def $name ); # pp_def $name
} # for: my $opt } # for: my $opt
pp_add_exported('', 'clip'); pp_add_exported('', 'clip');
pp_addpm(<<'EOD'); pp_addpm(<<'EOD');
skipping to change at line 1051 skipping to change at line 1046
if($x->is_inplace) { if($x->is_inplace) {
$x->set_inplace(0); $x->set_inplace(0);
return $x; return $x;
} else { } else {
return $x->copy; return $x->copy;
} }
} }
if($x->is_inplace) { if($x->is_inplace) {
$x->set_inplace(0); $d = $x $x->set_inplace(0); $d = $x
} elsif ($#_ > 2) { } elsif (@_ > 3) {
$d=$_[3] $d=$_[3]
} else { } else {
$d = PDL->nullcreate($x); $d = PDL->nullcreate($x);
} }
if(defined($l) && defined($h)) { if(defined($l) && defined($h)) {
PDL::_clip_int($x,$l,$h,$d); PDL::_clip_int($x,$l,$h,$d);
} elsif( defined($l) ) { } elsif( defined($l) ) {
PDL::_lclip_int($x,$l,$d); PDL::_lclip_int($x,$l,$d);
} elsif( defined($h) ) { } elsif( defined($h) ) {
PDL::_hclip_int($x,$h,$d); PDL::_hclip_int($x,$h,$d);
skipping to change at line 1218 skipping to change at line 1213
$SETBAD(rms()); $PDLSTATESETBAD(rms); $SETBAD(rms()); $PDLSTATESETBAD(rms);
$SETBAD(adev()); $PDLSTATESETBAD(adev); $SETBAD(adev()); $PDLSTATESETBAD(adev);
$SETBAD(min()); $PDLSTATESETBAD(min); $SETBAD(min()); $PDLSTATESETBAD(min);
$SETBAD(max()); $PDLSTATESETBAD(max); $SETBAD(max()); $PDLSTATESETBAD(max);
$SETBAD(prms()); $PDLSTATESETBAD(prms); $SETBAD(prms()); $PDLSTATESETBAD(prms);
}', }',
CopyBadStatusCode => '', CopyBadStatusCode => '',
PMCode => ' PMCode => '
sub PDL::statsover { sub PDL::statsover {
barf(\'Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($ data,[$weights])\') if $#_>1; barf(\'Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($ data,[$weights])\') if @_>2;
my ($data, $weights) = @_; my ($data, $weights) = @_;
$weights = $data->ones() if !defined($weights); $weights = $data->ones() if !defined($weights);
my $median = $data->medover(); my $median = $data->medover();
my $mean = PDL->nullcreate($data); my $mean = PDL->nullcreate($data);
my $rms = PDL->nullcreate($data); my $rms = PDL->nullcreate($data);
my $min = PDL->nullcreate($data); my $min = PDL->nullcreate($data);
my $max = PDL->nullcreate($data); my $max = PDL->nullcreate($data);
my $adev = PDL->nullcreate($data); my $adev = PDL->nullcreate($data);
my $prms = PDL->nullcreate($data); my $prms = PDL->nullcreate($data);
skipping to change at line 1334 skipping to change at line 1329
=for bad =for bad
Bad values are handled; if all input values are bad, then all of the output Bad values are handled; if all input values are bad, then all of the output
values are flagged bad. values are flagged bad.
=cut =cut
*stats = \&PDL::stats; *stats = \&PDL::stats;
sub PDL::stats { sub PDL::stats {
barf('Usage: ($mean,[$rms]) = stats($data,[$weights])') if $#_>1; barf('Usage: ($mean,[$rms]) = stats($data,[$weights])') if @_>2;
my ($data,$weights) = @_; my ($data,$weights) = @_;
# Ensure that $weights is properly broadcasted over; this could be # Ensure that $weights is properly broadcasted over; this could be
# done rather more efficiently... # done rather more efficiently...
if(defined $weights) { if(defined $weights) {
$weights = pdl($weights) unless UNIVERSAL::isa($weights,'PDL'); $weights = pdl($weights) unless UNIVERSAL::isa($weights,'PDL');
if( ($weights->ndims != $data->ndims) or if( ($weights->ndims != $data->ndims) or
(pdl($weights->dims) != pdl($data->dims))->or (pdl($weights->dims) != pdl($data->dims))->or
) { ) {
$weights = $weights + zeroes($data) $weights = $weights + zeroes($data)
skipping to change at line 2627 skipping to change at line 2622
The difference occurs in the handling of out-of-bounds values; here The difference occurs in the handling of out-of-bounds values; here
an error message is printed. an error message is printed.
=cut =cut
# kept in for backwards compatability # kept in for backwards compatability
sub interpol ($$$;$) { sub interpol ($$$;$) {
my $xi = shift; my $xi = shift;
my $x = shift; my $x = shift;
my $y = shift; my $y = shift;
my $yi = @_ == 1 ? $_[0] : PDL->null;
my $yi;
if ( $#_ == 0 ) { $yi = $_[0]; }
else { $yi = PDL->null; }
interpolate( $xi, $x, $y, $yi, my $err = PDL->null ); interpolate( $xi, $x, $y, $yi, my $err = PDL->null );
print "some values had to be extrapolated\n" print "some values had to be extrapolated\n"
if any $err; if any $err;
return $yi if @_ == 0;
return $yi if $#_ == -1;
} # sub: interpol() } # sub: interpol()
*PDL::interpol = \&interpol; *PDL::interpol = \&interpol;
EOD EOD
pp_add_exported('','interpND'); pp_add_exported('','interpND');
pp_addpm(<<'EOD'); pp_addpm(<<'EOD');
=head2 interpND =head2 interpND
=for ref =for ref
skipping to change at line 2928 skipping to change at line 2917
6 6
pdl> print one2nd($x, maximum_ind($c)) pdl> print one2nd($x, maximum_ind($c))
0 1 1 0 1 1
pdl> p $x->at(0,1,1) pdl> p $x->at(0,1,1)
3 3
=cut =cut
*one2nd = \&PDL::one2nd; *one2nd = \&PDL::one2nd;
sub PDL::one2nd { sub PDL::one2nd {
barf "Usage: one2nd \$array \$indices\n" if $#_ != 1; barf "Usage: one2nd \$array \$indices\n" if @_ != 2;
my ($x, $ind)=@_; my ($x, $ind)=@_;
my @dimension=$x->dims; my @dimension=$x->dims;
$ind = indx($ind); $ind = indx($ind);
my(@index); my(@index);
my $count=0; my $count=0;
foreach (@dimension) { foreach (@dimension) {
$index[$count++]=$ind % $_; $index[$count++]=$ind % $_;
$ind /= $_; $ind /= $_;
} }
return @index; return @index;
skipping to change at line 2969 skipping to change at line 2958
with output from C<which>, remember to flatten it before calling index: with output from C<which>, remember to flatten it before calling index:
$data = random 5, 5; $data = random 5, 5;
$idx = which $data > 0.5; # $idx is now 1D $idx = which $data > 0.5; # $idx is now 1D
$bigsum = $data->flat->index($idx)->sum; # flatten before indexing $bigsum = $data->flat->index($idx)->sum; # flatten before indexing
Compare also L</where> for similar functionality. Compare also L</where> for similar functionality.
SEE ALSO: SEE ALSO:
L</which_both> returns separately the indices of both L</which_both> returns separately the indices of both nonzero and zero
zero and nonzero values in the mask. values in the mask.
L</where_both> returns separately slices of both nonzero and zero
values in the mask.
L</where> returns associated values from a data PDL, rather than L</where> returns associated values from a data PDL, rather than
indices into the mask PDL. indices into the mask PDL.
L</whichND> returns N-D indices into a multidimensional PDL. L</whichND> returns N-D indices into a multidimensional PDL.
=for example =for example
pdl> $x = sequence(10); p $x pdl> $x = sequence(10); p $x
[0 1 2 3 4 5 6 7 8 9] [0 1 2 3 4 5 6 7 8 9]
skipping to change at line 2992 skipping to change at line 2984
[7 8 9] [7 8 9]
=cut =cut
EOD EOD
my $doc_which_both = <<'EOD'; my $doc_which_both = <<'EOD';
=for ref =for ref
Returns indices of zero and nonzero values in a mask PDL Returns indices of nonzero and zero values in a mask PDL
=for usage =for usage
($i, $c_i) = which_both($mask); ($i, $c_i) = which_both($mask);
This works just as L</which>, but the complement of C<$i> will be in This works just as L</which>, but the complement of C<$i> will be in
C<$c_i>. C<$c_i>.
=for example =for example
pdl> $x = sequence(10); p $x pdl> p $x = sequence(10)
[0 1 2 3 4 5 6 7 8 9] [0 1 2 3 4 5 6 7 8 9]
pdl> ($small, $big) = which_both ($x >= 5); p "$small\n $big" pdl> ($big, $small) = which_both($x >= 5); p "$big\n$small"
[5 6 7 8 9] [5 6 7 8 9]
[0 1 2 3 4] [0 1 2 3 4]
=cut =cut
EOD EOD
for ( for (
{Name=>'which', {Name=>'which',
Pars => 'mask(n); indx [o] inds(m);', Pars => 'mask(n); indx [o] inds(m);',
Variables => 'int dm=0;', Variables => 'int dm=0;',
Elseclause => "", Elseclause => "",
Autosize => '$SIZE(m) = sum;', Autosize => '$SIZE(m) = sum;',
Doc => $doc_which, Doc => $doc_which,
PMCode=><<'EOD', PMCode=><<'EOD',
sub which { my ($this,$out) = @_; sub which { my ($this,$out) = @_;
$this = $this->flat; $this = $this->flat;
$out = $this->nullcreate unless defined $out; $out //= $this->nullcreate;
PDL::_which_int($this,$out); PDL::_which_int($this,$out);
return $out; return $out;
} }
*PDL::which = \&which; *PDL::which = \&which;
EOD EOD
}, },
{Name => 'which_both', {Name => 'which_both',
Pars => 'mask(n); indx [o] inds(m); indx [o]notinds(q)', Pars => 'mask(n); indx [o] inds(m); indx [o]notinds(q)',
Variables => 'int dm=0; int dm2=0;', Variables => 'int dm=0; int dm2=0;',
Elseclause => "else { \n \$notinds(q => dm2)=n; \n d m2++;\n }", Elseclause => "else { \n \$notinds(q => dm2)=n; \n d m2++;\n }",
Autosize => '$SIZE(m) = sum;'."\n".' $SIZE(q) = dpdl->dims[0 ]-sum;', Autosize => '$SIZE(m) = sum;'."\n".' $SIZE(q) = dpdl->dims[0 ]-sum;',
Doc => $doc_which_both, Doc => $doc_which_both,
PMCode=><<'EOD', PMCode=><<'EOD',
sub which_both { my ($this,$outi,$outni) = @_; sub which_both { my ($this,$outi,$outni) = @_;
$this = $this->flat; $this = $this->flat;
$outi = $this->nullcreate unless defined $outi; $outi //= $this->nullcreate;
$outni = $this->nullcreate unless defined $outni; $outni //= $this->nullcreate;
PDL::_which_both_int($this,$outi,$outni); PDL::_which_both_int($this,$outi,$outni);
return wantarray ? ($outi,$outni) : $outi; return wantarray ? ($outi,$outni) : $outi;
} }
*PDL::which_both = \&which_both; *PDL::which_both = \&which_both;
EOD EOD
} }
) )
{ {
my $p1 = $_->{Variables} .' my $p1 = $_->{Variables} .'
loop(n) %{ loop(n) %{
skipping to change at line 3144 skipping to change at line 3136
Note: C<$i> is always 1-D, even if C<$x> is E<gt>1-D. Note: C<$i> is always 1-D, even if C<$x> is E<gt>1-D.
WARNING: The first argument WARNING: The first argument
(the values) and the second argument (the mask) currently have to have (the values) and the second argument (the mask) currently have to have
the exact same dimensions (or horrible things happen). You *cannot* the exact same dimensions (or horrible things happen). You *cannot*
broadcast over a smaller mask, for example. broadcast over a smaller mask, for example.
=cut =cut
sub PDL::where { sub PDL::where {
barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if @_ == 1;
if(@_ == 2) {
if($#_ == 1) {
my($data,$mask) = @_; my($data,$mask) = @_;
$data = $_[0]->clump(-1) if $_[0]->getndims>1; $data = $_[0]->clump(-1) if $_[0]->getndims>1;
$mask = $_[1]->clump(-1) if $_[0]->getndims>1; $mask = $_[1]->clump(-1) if $_[0]->getndims>1;
return $data->index($mask->which()); return $data->index($mask->which());
} else { } else {
if($_[-1]->getndims > 1) { if($_[-1]->getndims > 1) {
my $mask = $_[-1]->clump(-1)->which; my $mask = $_[-1]->clump(-1)->which;
return map {$_->clump(-1)->index($mask)} @_[0..$#_-1]; return map {$_->clump(-1)->index($mask)} @_[0..$#_-1];
} else { } else {
my $mask = $_[-1]->which; my $mask = $_[-1]->which;
return map {$_->index($mask)} @_[0..$#_-1]; return map {$_->index($mask)} @_[0..$#_-1];
} }
} }
} }
*where = \&PDL::where; *where = \&PDL::where;
EOD EOD
pp_add_exported("", 'where_both');
pp_addpm(<<'EOD');
=head2 where_both
=for ref
Returns slices (non-zero in mask, zero) of an ndarray according to a mask
=for usage
($match_vals, $non_match_vals) = where_both($pdl, $mask);
This works like L</which_both>, but (flattened) data-flowing slices
rather than index-sets are returned.
=for example
pdl> p $x = sequence(10) + 2
[2 3 4 5 6 7 8 9 10 11]
pdl> ($big, $small) = where_both($x, $x > 5); p "$big\n$small"
[6 7 8 9 10 11]
[2 3 4 5]
pdl> p $big += 2, $small -= 1
[8 9 10 11 12 13] [1 2 3 4]
pdl> p $x
[1 2 3 4 8 9 10 11 12 13]
=cut
sub PDL::where_both {
barf "Usage: where_both(\$pdl, \$mask)\n" if @_ != 2;
my ($arr, $mask) = @_; # $mask has 0==false, 1==true
my $arr_flat = $arr->clump(-1);
map $arr_flat->index1d($_), PDL::which_both($mask);
}
*where_both = \&PDL::where_both;
EOD
pp_add_exported("", 'whereND'); pp_add_exported("", 'whereND');
pp_addpm(<<'EOD'); pp_addpm(<<'EOD');
=head2 whereND =head2 whereND
=for ref =for ref
C<where> with support for ND masks and broadcasting C<where> with support for ND masks and broadcasting
C<whereND> accepts one or more data ndarrays and a C<whereND> accepts one or more data ndarrays and a
mask ndarray. It returns a list of output ndarrays, mask ndarray. It returns a list of output ndarrays,
skipping to change at line 3222 skipping to change at line 3251
# Used in lvalue context: # Used in lvalue context:
$data->whereND($mask4) .= 0; $data->whereND($mask4) .= 0;
SEE ALSO: SEE ALSO:
L</whichND> returns N-D indices into a multidimensional PDL, from a mask. L</whichND> returns N-D indices into a multidimensional PDL, from a mask.
=cut =cut
sub PDL::whereND :lvalue { sub PDL::whereND :lvalue {
barf "Usage: whereND( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; barf "Usage: whereND( \$pdl1, ..., \$pdlN, \$mask )\n" if @_ == 1;
my $mask = pop @_; # $mask has 0==false, 1==true my $mask = pop @_; # $mask has 0==false, 1==true
my @to_return; my @to_return;
my $n = PDL::sum($mask); my $n = PDL::sum($mask);
foreach my $arr (@_) { foreach my $arr (@_) {
my $sub_i = $mask * ones($arr); my $sub_i = $mask * ones($arr);
my $where_sub_i = PDL::where($arr, $sub_i); my $where_sub_i = PDL::where($arr, $sub_i);
# count the number of dims in $mask and $arr # count the number of dims in $mask and $arr
# $mask = a b c d e f..... # $mask = a b c d e f.....
my @idims = dims($arr); my @idims = dims($arr);
# ...and pop off the number of dims in $mask # ...and pop off the number of dims in $mask
foreach ( dims($mask) ) { shift(@idims) }; foreach ( dims($mask) ) { shift(@idims) };
my $ndim = 0; my $ndim = 0;
foreach my $id ($n, @idims[0..($#idims-1)]) { foreach my $id ($n, @idims[0..($#idims-1)]) {
$where_sub_i = $where_sub_i->splitdim($ndim++,$id) if $n>0; $where_sub_i = $where_sub_i->splitdim($ndim++,$id) if $n>0;
} }
push @to_return, $where_sub_i; push @to_return, $where_sub_i;
} }
return (@to_return == 1) ? $to_return[0] : @to_return; return (@to_return == 1) ? $to_return[0] : @to_return;
} }
*whereND = \&PDL::whereND; *whereND = \&PDL::whereND;
EOD EOD
pp_add_exported("", 'whichND'); pp_add_exported("", 'whichND');
pp_addpm(<<'EOD'); pp_addpm(<<'EOD');
=head2 whichND =head2 whichND
 End of changes. 28 change blocks. 
42 lines changed or deleted 62 lines changed or added

Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)