(Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).
| primitive.pd (PDL-2.081) | : | primitive.pd (PDL-2.082) |
|---|
| | |
| skipping to change at line 464 | | skipping to change at line 464 |
|---|
| | |
| pp_def('norm', | | pp_def('norm', |
| HandleBad => 1, | | HandleBad => 1, |
| Pars => 'vec(n); [o] norm(n)', | | Pars => 'vec(n); [o] norm(n)', |
| GenericTypes => [ppdefs_all], | | GenericTypes => [ppdefs_all], |
| Doc => 'Normalises a vector to unit Euclidean length', | | Doc => 'Normalises a vector to unit Euclidean length', |
| Code => | | Code => |
| 'long double sum=0; | | 'long double sum=0; |
| int flag = 0; | | int flag = 0; |
| loop(n) %{ | | loop(n) %{ |
|
| PDL_IF_BAD(if ( $ISGOOD(vec()) ) {,) | | PDL_IF_BAD(if ( $ISGOOD(vec()) ),) { |
| sum += | | sum += |
| PDL_IF_GENTYPE_REAL( | | PDL_IF_GENTYPE_REAL( |
| $vec()*$vec(), | | $vec()*$vec(), |
| creall($vec())*creall($vec()) + cimagl($vec())*cimagl($vec()) | | creall($vec())*creall($vec()) + cimagl($vec())*cimagl($vec()) |
| ); | | ); |
|
| PDL_IF_BAD(flag = 1; },) | | PDL_IF_BAD(flag = 1;,) } |
| %} | | %} |
|
| PDL_IF_BAD(if ( flag ) {,) | | PDL_IF_BAD(if ( flag ),) { |
| if (sum > 0) { | | if (sum > 0) { |
| sum = sqrt(sum); | | sum = sqrt(sum); |
| loop(n) %{ | | loop(n) %{ |
| PDL_IF_BAD(if ( $ISBAD(vec()) ) { $SETBAD(norm()); } | | PDL_IF_BAD(if ( $ISBAD(vec()) ) { $SETBAD(norm()); } |
|
| else {,) | | else ,) { |
| $norm() = $vec()/sum; | | $norm() = $vec()/sum; |
|
| PDL_IF_BAD(},) | | } |
| %} | | %} |
| } else { | | } else { |
| loop(n) %{ | | loop(n) %{ |
| if ( $ISBAD(vec()) ) { $SETBAD(norm()); } | | if ( $ISBAD(vec()) ) { $SETBAD(norm()); } |
| else { $norm() = $vec(); } | | else { $norm() = $vec(); } |
| %} | | %} |
| } | | } |
|
| PDL_IF_BAD(} else { | | } PDL_IF_BAD(else { |
| loop(n) %{ | | loop(n) %{ |
| $SETBAD(norm()); | | $SETBAD(norm()); |
| %} | | %} |
| },) | | },) |
| ', | | ', |
| ); | | ); |
| | |
| # this one was motivated by the need to compute | | # this one was motivated by the need to compute |
| # the circular mean efficiently | | # the circular mean efficiently |
| # without it could not be done efficiently or without | | # without it could not be done efficiently or without |
| | |
| skipping to change at line 738 | | skipping to change at line 738 |
|---|
| print $x->uniq; | | print $x->uniq; |
| [0 3 6 9] | | [0 3 6 9] |
| | |
| =cut | | =cut |
| | |
| *uniq = \&PDL::uniq; | | *uniq = \&PDL::uniq; |
| # return unique elements of array | | # return unique elements of array |
| # find as jumps in the sorted array | | # find as jumps in the sorted array |
| # flattens in the process | | # flattens in the process |
| sub PDL::uniq { | | sub PDL::uniq { |
|
| use PDL::Core 'barf'; | | |
| my ($arr) = @_; | | my ($arr) = @_; |
| return $arr if($arr->nelem == 0); # The null list is unique (CED) | | return $arr if($arr->nelem == 0); # The null list is unique (CED) |
|
| my $srt = $arr->clump(-1)->where($arr==$arr)->qsort; # no NaNs or BADs for | | return $arr->flat if($arr->nelem == 1); # singleton list is unique |
| qsort | | my $aflat = $arr->flat; |
| my $nans = $arr->clump(-1)->where($arr!=$arr); | | my $srt = $aflat->where($aflat==$aflat)->qsort; # no NaNs or BADs for qsort |
| my $uniq = ($srt->nelem > 0) ? $srt->where($srt != $srt->rotate(-1)) : $srt; | | my $nans = $aflat->where($aflat!=$aflat); |
| | my $uniq = ($srt->nelem > 1) ? $srt->where($srt != $srt->rotate(-1)) : $srt; |
| # make sure we return something if there is only one value | | # make sure we return something if there is only one value |
|
| my $answ = $nans; # NaN values always uniq | | ( |
| if ( $uniq->nelem > 0 ) { | | $uniq->nelem > 0 ? $uniq : |
| $answ = $uniq->append($answ); | | $srt->nelem == 0 ? $srt : |
| } else { | | PDL::pdl( ref($srt), [$srt->index(0)] ) |
| $answ = ( ($srt->nelem == 0) ? $srt : PDL::pdl( ref($srt), [$srt->index(0 | | )->append($nans); |
| )] ) )->append($answ); | | |
| } | | |
| return $answ; | | |
| } | | } |
| EOPM | | EOPM |
| | |
| pp_add_exported ('', 'uniqind'); | | pp_add_exported ('', 'uniqind'); |
| pp_addpm (<< 'EOPM'); | | pp_addpm (<< 'EOPM'); |
| =head2 uniqind | | =head2 uniqind |
| | |
| =for ref | | =for ref |
| | |
| Return the indices of all unique elements of an ndarray | | Return the indices of all unique elements of an ndarray |
| | |
| skipping to change at line 3969 | | skipping to change at line 3968 |
|---|
| my $inds=which($s1 == $s2); | | my $inds=which($s1 == $s2); |
| | |
| if ($inds->nelem() > 0) { | | if ($inds->nelem() > 0) { |
| return $union->index($inds); | | return $union->index($inds); |
| } else { | | } else { |
| return $inds; | | return $inds; |
| } | | } |
| | |
| } elsif ($op eq 'AND') { | | } elsif ($op eq 'AND') { |
| # The intersection of the arrays. | | # The intersection of the arrays. |
|
| | | return $x if $x->isempty; |
| | return $y if $y->isempty; |
| # Make ordered list of set union. | | # Make ordered list of set union. |
| my $union = append($x, $y)->qsort; | | my $union = append($x, $y)->qsort; |
|
| | | return $union->where($union == rotate($union, -1))->uniq; |
| return $union->where($union == rotate($union, -1)); | | |
| } else { | | } else { |
| print "The operation $op is not known!"; | | print "The operation $op is not known!"; |
| return -1; | | return -1; |
| } | | } |
| | |
| } | | } |
| EOD | | EOD |
| | |
| pp_add_exported("", 'intersect'); | | pp_add_exported("", 'intersect'); |
| pp_addpm(<<'EOD'); | | pp_addpm(<<'EOD'); |
| | | |
| End of changes. 11 change blocks. |
|---|
| 22 lines changed or deleted | | 19 lines changed or added |
|---|
"Fossies" - the Fresh Open Source Software Archive 