PDL-2.100/0000755000175000017500000000000014771136047012073 5ustar osboxesosboxesPDL-2.100/META.json0000644000175000017500000000447114771136046013521 0ustar osboxesosboxes{ "abstract" : "Perl Data Language", "author" : [ "PerlDL Developers " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.72, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "PDL", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0", "ExtUtils::ParseXS" : "3.21", "File::Path" : "0", "Pod::Select" : "0" } }, "configure" : { "requires" : { "Devel::CheckLib" : "1.01", "ExtUtils::MakeMaker" : "7.12", "File::Path" : "0", "File::Which" : "0" } }, "runtime" : { "recommends" : { "Astro::FITS::Header" : "2.1", "Inline" : "0.83", "Inline::C" : "0.62", "Term::ReadKey" : "2.34" }, "requires" : { "Data::Dumper" : "2.121", "File::Map" : "0.57", "File::Which" : "0", "Filter::Simple" : "0.88", "Filter::Util::Call" : "0", "List::Util" : "1.33", "Math::Complex" : "0", "Pod::Select" : "0", "Scalar::Util" : "0", "Storable" : "1.03", "Text::Balanced" : "2.05", "perl" : "5.016" }, "suggests" : { "Sys::SigAction" : "0" } }, "test" : { "requires" : { "CPAN::Meta" : "2.120900", "Test::Deep" : "0", "Test::Exception" : "0", "Test::Warn" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/PDLPorters/pdl/issues" }, "homepage" : "http://pdl.perl.org/", "repository" : { "type" : "git", "url" : "git://github.com/PDLPorters/pdl.git", "web" : "https://github.com/PDLPorters/pdl" }, "x_IRC" : "irc://irc.perl.org/#pdl" }, "version" : "2.100", "x_serialization_backend" : "JSON::PP version 4.04" } PDL-2.100/script/0000755000175000017500000000000014771136046013376 5ustar osboxesosboxesPDL-2.100/script/pdl.c0000644000175000017500000000353314727756302014331 0ustar osboxesosboxes/****************************** * pdl.c - perldl spawner * Works around a problem with many unices that you can't use an interpreter * to run an interpreter -- so "#!/usr/bin/perldl" won't work. * This is a compiled piece of code that launches perldl "directly", * so that the poor kernel's mind isn't blown. * * If you feed in a single non-switch argument it gets prepended with a * "-" to let perldl know that it's an input file. That way you can be lazy * and say "#!/usr/bin/pdl" at the top of your script. * * CED 21-Jul-2004 */ #include #include #include #include #include int main(int argc, char **argv) { char perldl[BUFSIZ]; int pipes[2]; int pid,i; int status; if(pipe(pipes)) {perror("pdl (perldl spawn wrapper)"); exit(1);} pid = fork(); if(pid==0) { dup2(pipes[1],1); dup2(pipes[1],2); exit(system("which perldl")); } pid = wait(&status); if(! WIFEXITED(status) ) { fprintf(stderr,"Hmmm... couldn't seem to find perldl anywhere. Quitting.\n"); goto exit; } if( read(pipes[0],perldl,BUFSIZ) <= 0 ) { fprintf(stderr, "Read error - quitting.\n"); goto exit; } /* Remove trailing newline */ for(i=0;i\s*); # RE for shell prompts $PERLDL::PAGER = (exists $ENV{PAGER} ? $ENV{PAGER} : 'more'); # Default output paging program $PERLDL::PAGE = 0; $PERLDL::PAGING = 0; @PERLDL::AUTO = (); $PERLDL::PREPROCESS = undef; # old interface -- disabled @PERLDL::PREPROCESS = (); # new preprocessor pipeline $HOME = $ENV{HOME}; # Useful in shell if ($^O =~ /win32/i and $HOME eq ""){ $HOME = $ENV{USERPROFILE}; $HOME =~ s/\\/\//g; } $,=" "; # Default $Modules = $Modules = ""; # pacify -w sub mypdlconfig { require Config; # pick up perl version info eval 'require PDL' if not defined $PDL::VERSION; eval "use Data::Dumper"; my $hasdumper = $@ eq "" ? 1 : 0; my $txt = "\nSummary of my PDL configuration\n\n"; $txt .= "VERSION: PDL v$PDL::VERSION (supports bad values)\n\n"; $txt .= Config::myconfig(); # append perl config info } sub preproc_registered ($) { my ($sub) = @_; die "preprocessors must be code references" unless ref $sub eq 'CODE'; return grep ($_ == $sub, @PERLDL::PREPROCESS) > 0; } sub preproc_add ($) { my ($sub) = @_; die "preprocessors must be code references" unless ref $sub eq 'CODE'; push @PERLDL::PREPROCESS, $sub; return $sub; } sub preproc_del ($) { my ($sub) = @_; die "preprocessors must be code references" unless ref $sub eq 'CODE'; die "preprocessor can't be deleted: not installed" unless preproc_registered $sub; @PERLDL::PREPROCESS = grep ($_ != $sub, @PERLDL::PREPROCESS); return $sub; } # Parse ARGV my $read_from_file; while(defined($_ = shift @ARGV)) { if($_ eq "-tk") { print "Using Tk"; eval "use Tk;"; if ($@ eq "") { print " v$Tk::VERSION\n" if defined $Tk::VERSION; # make -w happy } else { print ", sorry can't load module Tk\n"; } next; } elsif($_ eq "-glut") { print "Using OpenGL for GLUT support"; eval <<'EOF'; use OpenGL qw/ :glfunctions :glconstants /; use OpenGL::GLUT qw/ :all /; EOF if (!$@) { print ", OpenGL v$OpenGL::VERSION" if defined $OpenGL::VERSION; print ", OpenGL::GLUT v$OpenGL::GLUT::VERSION" if defined $OpenGL::GLUT::VERSION; } else { print ", sorry can't load module OpenGL"; } print "\n"; OpenGL::GLUT::glutInit() unless OpenGL::GLUT::done_glutInit(); next; } elsif(/^-f(.*)/) { my $file = $1; if(0 == length $1) { $file = shift @ARGV; } print "Doing '$file'\n"; do $file; if($@) { die "Initialization error: $@"; } next; } elsif(/^-w$/){ $^W = 1; next; } elsif (/^-(M|m)([\w:]+)(\=\w+)?$/x) { my ($way,$m,@im) = ($1,$2,$3?substr($3,1):()); eval "require $m"; warn, next if $@; if ($way eq 'M') { $m->import(@im); } else { $m->unimport(@im); } } elsif (/^-I (\S*) $/x) { my $dir = $1; $dir = $ARGV[++$arg] if !$dir; if ($dir =~ m{^ \/ }x) { unshift(@INC, $dir); } else { require FindBin; die "Error: can't find myself" if ! $FindBin::Bin; unshift(@INC, "$FindBin::Bin/$dir"); } } elsif (/^-V\s*$/) { print mypdlconfig(); exit 0; } elsif( /^-\s*$/) { $read_from_file = 1; last; } else { print << 'EOP'; Usage: perldl [options] -glut try to load OpenGL module (Enables readline event-loop processing). -tk try to load Tk module (Enables readline event-loop processing). -f execute file before starting perldl -w run with warning messages turned-on -m unload module -M load module -I Add to include path. -V print PDL version info (e.g. for a bug report) - Following arguments are files for input. EOP die("Unknown argument $_"); } } my $readlines = 0; if(!$read_from_file and -t STDIN) { eval "use Term::ReadLine"; if ( $readlines = !$@ ) { $PERLDL::TERM = Term::ReadLine->new('perlDL', \*STDIN, \*STDOUT); readhist(); $PERLDL::TERM->GetHistory if $PERLDL::TERM->can('GetHistory'); # if don't do this before loading OpenGL, it can load libedit via LLVM which has C symbol clashes with GNU readline } } my @enabled = (); push @enabled, "ReadLines" if $readlines; eval 'use PDL::NiceSlice'; unless ($@) { my $report = 0; sub report { my $ret = $report; $report = $_[0] if $#_ > -1; return $ret; } my $preproc = sub { my ($txt) = @_; my $new = PDL::NiceSlice::perldlpp('PDL::NiceSlice',$txt); print STDERR "processed $new\n" if report && $new ne $txt; return $new; }; sub trans { preproc_add $preproc unless preproc_registered $preproc; preproc_del $preproc if $#_ > -1 && !$_[0] && preproc_registered $preproc; } sub notrans { trans 0 } trans; # switch on by default push @enabled, "NiceSlice"; } use Text::Balanced; push @enabled, "MultiLines"; my $interrupt_handle = eval 'use Sys::SigAction qw(set_sig_handler); 1'; my $interrupt_msg = "Ctrl-C detected"; if ($interrupt_handle) { push @enabled, "Interrupt"; } else { $SIG{'INT'} = sub { die "$interrupt_msg\n" }; # Ctrl-C handler } sub mksighandle { $interrupt_handle ? set_sig_handler(INT => sub { die "$interrupt_msg\n"; }) : undef; } print join(', ',@enabled)," enabled\n" if @enabled > 0; if ( $readlines ){ if (defined &OpenGL::GLUT::done_glutInit ) { # Attempt to use with FreeGLUT if ($PERLDL::TERM->can('event_loop')) { print "Using FreeGLUT event loop\n"; # Presumably, if you're using this loop, you're also selecting on other # fileno's. It is up to you to add that in to the wait callback (first # one passed to event_loop) and deal with those file handles. $PERLDL::TERM->event_loop( sub { # This callback is called every time T::RL wants to # read something from its input. The parameter is # the return from the other callback. my $fileno = shift; my $rvec = ''; vec($rvec, $fileno, 1) = 1; while(1) { select my $rout = $rvec, undef, undef, 0; last if vec($rout, $fileno, 1); OpenGL::GLUT::glutMainLoopEvent(); } }, sub { # This callback is called as the T::RL is starting up # readline the first time. The parameter is the file # handle that we need to monitor. The return value # is used as input to the previous callback. # We return the fileno that we will use later. # cygwin/TRL::Gnu seems to use some other object here # that doesn't respond to a fileno method call (rt#81344) fileno($_[0]); } ) unless $Term::ReadLine::toloop; } else { warn("Sorry, cannot use FreeGLUT with this version of ReadLine\n"); } } if(defined &Tk::DoOneEvent and not ref $Term::ReadLine::toloop) { # Attempt to use with Tk if(${$PERLDL::TERM->Features}{tkRunning}) { print "Using Tk event loop\n"; $PERLDL::TERM->tkRunning(1); } else { warn("Sorry, cannot use Tk with this version of ReadLine\n"); } } } sub readhist { if ( ( -e "$HOME/.perldl_hist" ) && ( open HIST, "<$HOME/.perldl_hist" ) ) { my @allhist = ; close HIST; map s/\n//g , @allhist ; foreach (@allhist) { $PERLDL::TERM->addhistory($_); } } } sub savehist { return if !$readlines; # Save History in $ENV{'HOME'}/.perldl_hist # GetHistory doesn't work on all versions... return if !$PERLDL::TERM->can('GetHistory'); my @a= grep $_ && /\S/, $PERLDL::TERM->GetHistory; pop @a if $a[-1] =~ /^(q$|x$|\s*exit\b|\s*quit\b)/; # chop off the exit command return if !@a; # nothing to do (and don't overwrite) @a = map {s/^\s*(.*?)\s*$/$1/;$_} @a; # strip whitespace my %seen; @a = reverse grep !$seen{$_}++, reverse @a; # dedup @a= @a[(@a-$PERLDL::HISTFILESIZE)..($#a)] if @a > $PERLDL::HISTFILESIZE; if( open HIST, ">$HOME/.perldl_hist" ) { print HIST join("\n",@a); close HIST; } else { print " Unable to open \"$HOME/.perldl_hist\"\n"; } } sub l { if ($readlines) { my $n = $#_ > -1 ? shift : 20; my @h = $PERLDL::TERM->GetHistory(); my $min = $#h < $n-1 ? 0 : $#h-$n+1; map {print "$_: $h[$_]\n"} ($min..$#h); } } sub with_time (&) { require Time::HiRes; my @t = Time::HiRes::gettimeofday(); &{$_[0]}(); printf "%g ms\n", Time::HiRes::tv_interval(\@t) * 1000; } sub gv { my ($input, $file) = @_; my ($g, %opts, $format); if (UNIVERSAL::isa($input, 'PDL')) { $g = PDL::Core::pdumpgraphvizify(PDL::Core::pdumpgraph(PDL::Core::pdumphash($input))); } elsif (UNIVERSAL::isa($input, 'Graph')) { $g = $input; } else { die "gv: unknown input '$input': only know ndarray or Graph\n"; } if (defined $file) { $format = (split /\./, $file)[-1]; %opts = (output_file => $file); } else { $format = 'png'; } require GraphViz2; my $gv = GraphViz2->from_graph($g); $gv->run(format => $format, %opts); my $output = $gv->dot_output; if (!defined $file) { require PDL::IO::Pic; require File::Temp; require File::Spec; my ($fh, $filename) = File::Temp::tempfile('XXXX', DIR => File::Spec->tmpdir, SUFFIX => '.png', UNLINK => 1); print $fh $output; close $fh; my $img = PDL->rpic($filename); require PDL::Graphics::Simple; PDL::Graphics::Simple->import('erase'); # else is surprising if no work PDL::Graphics::Simple::imag($img->mv(0,-1)); } $output; # return just in case } sub x { require Data::Dumper; local $Data::Dumper::Indent = 1; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Terse = 1; print Data::Dumper::Dumper(@_); } sub do_print { $PERLDL::DO_PRINT = $_[0]; } sub page { $PERLDL::PAGE = (defined $_[0] ? $_[0] : 1); } sub nopage { page(0); } sub startpage { if ($PERLDL::PAGE) { open(SAVEOUT, '>&STDOUT'); open(STDOUT, "| $PERLDL::PAGER"); $PERLDL::PAGING = 1; } } sub endpage { if ($PERLDL::PAGING) { close(STDOUT); open(STDOUT, '>&SAVEOUT'); $PERLDL::PAGING = 0; } } sub startup_def { return "PDL/default.pdl" if $^O =~ /win32/i; return "PDL/default.perldlrc"; } # Global and local startup my $startup_file = -e "$HOME/.perldlrc" ? "$HOME/.perldlrc" : startup_def(); print "Reading $startup_file...\n"; eval 'require "'.$startup_file.'"'; my $PDL_OK = ($@ eq ""); if ($PDL_OK) { require PDL if not defined $PDL::VERSION; print "Type 'demo' for online demos\n"; print "Loaded PDL v$PDL::VERSION (supports bad values)\n"; }else{ warn "WARNING: Error loading PDL: '$@' - trying blib. \n"; eval "use blib"; delete $INC{$startup_file}; # so require will try again! eval 'require "'.$startup_file.'"'; $PDL_OK = ($@ eq ""); if ($PDL_OK) { require PDL if not defined $PDL::VERSION; print "Loaded PDL v$PDL::VERSION\n"; }else{ warn "WARNING: PDL startup not found only plain perl available\n"; $PERLDL::PROMPT = 'perl> '; # so there is visual indication of no PDL eval << 'EOD'; # Fallback eval routine - proper one defined in PDL::Core sub eval_and_report { my $__code = shift; # Can be code ref or string my $__string; $__string = (ref $__code eq "CODE") ? '&$__code()' : $__code; my $retval = eval $__string; # Use boring eval() which misses some errors print $retval if $PERLDL::DO_PRINT && !ref($__code) && $__code !~ /;\n?\z/; $@; } EOD } } print "\nNote: AutoLoader not enabled ('use PDL::AutoLoader' recommended)\n\n" unless defined($PDL::AutoLoader::Rescan); if (-e 'local.perldlrc') { print "Reading local.perldlrc ...\n"; require 'local.perldlrc' ; } # Short hand for some stuff sub p { local $^W=0; # suppress possible undefined var message print(@_); ''; # in case do_print is on } use PDL::Demos; sub demo { if (!$_[0]) { require List::Util; my @kw = sort grep $_ ne 'pdl', PDL::Demos->keywords; my $maxlen = List::Util::max(map length, @kw); print "Use:\n"; printf " demo %-${maxlen}s # %s\n", @$_[0,1] for map [PDL::Demos->info($_)], 'pdl', @kw; return; } no strict; PDL::Demos->init($_[0]); $_->[0]->($_->[1]) for PDL::Demos->demo($_[0]); PDL::Demos->done($_[0]); } my $preproc_warned = 0; sub preproc_oldwarn { warn << 'EOW'; Deprecated usage: $PERLDL::PREPROCESS was set. Usage of this variable is now strongly deprecated. To enable preprocessing with recent versions of perldl you should use the 'preproc_add' function. For details check the perldl manpage. EOW $preproc_warned = 1; # warn only once } # # count_tags: Return a string containing (in order) the open brackets # and strings in the string that is passed in. Used for multi-line parsing. # # Works by analysing the error message returned by Text::Balanced -- this # is sort of fragile against changes in Text::Balanced, but what the heck. # --CED 18-Mar-2003 # sub count_tags { my $s = shift; $s =~ s/\\.//g; # Ignore all escaped characters return undef unless($s =~ m/[^\s]/); # [Ignore quotelike operators: they cause more trouble than they're worth!] our($prefix,$delim,%closers); unless(defined $prefix) { $delim = '{[(`\'")]}'; %closers = ('{'=>'}','['=>']','('=>')'); } # Run Text::Balanced on the string with a '{' in front of it, to # make sure that all quoted strings are "embedded" in the outermost "{". # The whitespace works around a short-string bug in extract_bracketed. my $x; my @result; $s =~ s/^\s*\#.*$//mg; # Eliminate comment lines before extract. eval { @result = Text::Balanced::extract_bracketed("{".$s, $delim, $prefix); $x = $@; }; print "x = $x\nreturn = '",join("','",@result),"'\n" if($PERLDL::debug); if($x =~ m/^Did not find/) { # No quotes -- this should never happen and is a syntax error. print STDERR "[Error in parsing: this should never happen!]\n" if($PERLDL::debug); return undef; } elsif($x =~ m/^Unmatched emb\w+ quote \((.)\), de\w+ at offset (\d+)/) { # Embedded quote: try to close it and reparse. $x = $1; return count_tags($s.$1) . $x; } elsif($x =~ m/^Mismatched closing bracket/) { # This is an error condition - return false and let perl parse it return undef; } elsif($x =~ m/^Unmatched opening bracket\(s\)\: \{\.\.(.\.\.)+/) { $x = $1; $x=~ s/\.\.//g; return count_tags($s.$closers{$x}) . $x; } elsif($x =~ m/^Unmatched opening bracket\(s\)\: \{\.\.\,/) { # Should have exactly one unmatched opening bracket. return undef; } elsif(!$x) { return undef; } print STDERR "Unknown error message '$x' from parser...\n" if($PERLDL::debug); return undef; } # # process_input -- this is the central grab-some-input-and-execute it loop. # sub process_input { my $lines; # The {} around the do let us get out with 'last' in the EOF case. multiline: { my $cont; $lines = ""; do { local $, = ""; my $prompt = $cont ? "..$cont".(" "x(5-length($cont)))."> " : ((ref $PERLDL::PROMPT) ? &$PERLDL::PROMPT : $PERLDL::PROMPT); { my $sig_action = mksighandle(); if ($readlines) { $_ = $PERLDL::TERM->readline($prompt); }else{ print $prompt if(-t ARGV); # Don't print prompt in pipes $_ = <>; } } if(!defined $_) { if($cont) { if( $PERLDL::NO_EOF > 1 && -t STDIN ) { print STDERR "\nEOF ignored. (Close delimiters to end block. \$PERLDL::NO_EOF = $PERLDL::NO_EOF)\n"; } else { last multiline; } } else { if($PERLDL::NO_EOF && -t STDIN ) { print STDERR "EOF ignored. ('q' or 'exit' to quit. \$PERLDL::NO_EOF = $PERLDL::NO_EOF)\n"; } else { print STDERR "EOF detected, exiting shell.\n"; savehist(); exit 0; } } } $lines .= "\n" if($cont); # Make multi-line strings work right. $lines .= $_; print "lines = $lines\n" if($PERLDL::debug); } while( $PERLDL::MULTI && ($cont = count_tags($lines)) ); } # Execute the list of auto-code for my $c (@PERLDL::AUTO) { my $mess = eval_and_report($c); warn $mess if $mess; } # Filter out PDL shell prefixes from cut-n-pasted lines if ( $lines =~ s/$PERLDL::PREFIX_RE// and $readlines ) { my @hist = $PERLDL::TERM->GetHistory(); foreach my $entry (@hist) { $entry =~ s/$PERLDL::PREFIX_RE//; } $PERLDL::TERM->SetHistory(@hist); } if(!defined $lines || lc $lines eq 'q' || lc $lines eq 'x' || lc $lines eq 'quit') {savehist(); exit;}; next if $lines =~/^\s*$/; # Blank line - do nothing $lines =~ s/^\s*\?\?\s*/apropos /; # Make '??' = 'apropos' $lines =~ s/^\s*\?\s*/help /; # Make lone '?' = 'help' if ( $lines =~ /^\s*(help|usage|apropos|sig|badinfo|demo)\s+/) { # Allow help foo (no quotes) my @t = split(/\s+/,$lines); my $x; foreach $x(@t) { $x=~s/^["']+//; $x=~s/['"]+$//; }; $t[1] = "'".$t[1]."'" if ($#t == 1 && !($t[1] =~ /^\$/)); $lines = join(' ',@t); } if (substr($lines,0,1) eq substr($PERLDL::ESCAPE,0,1) and substr($lines,0,2) ne '#!') { # Allow escapes, avoid shebang my @lines = split /\n/, $lines; system(substr(shift @lines,1)); # Shell escape $lines = join("\n",@lines); next; } else { # Send code to pre-processor filters if defined for my $filter (@PERLDL::PREPROCESS) { $lines = $filter->($lines); } # honor the deprecated interface for now if (defined $PERLDL::PREPROCESS && ref($PERLDL::PREPROCESS) eq 'CODE') { preproc_oldwarn() unless $preproc_warned; $lines = &$PERLDL::PREPROCESS($_); } startpage; my $mess = eval_and_report($lines); warn $mess if $mess; endpage; } print "\n"; } ###################################################################### ###################################################################### ##### ##### Main loop is here! (Commands not inside any sub!) # check for old usage of PERLDL::PREPROCESS if (defined $PERLDL::PREPROCESS) { preproc_oldwarn() unless $preproc_warned; } $|=1; while(1) { eval {process_input()}; if ($@) { if ($@ =~ /$interrupt_msg/) { print "$interrupt_msg\n"; next; } else { print "Unknown error: $@\n exiting...\n"; last; } } } ##### ##### ###################################################################### ###################################################################### # Work routine to eval code and post-process messages # Currently used by 'perldl' shell sub eval_and_report { my $__code = shift; # Can be code ref or string $@ = ""; # clear $@ since we might not execute the eval below ## Compile the code ref to execute. The code gets put inside {} braces ## so that there is a trivial loop (the simple block) for 'last' and 'next' ## to escape from. (Otherwise perl 5.6.1 and 5.8 do a little fandango ## on stack if you type "last" at the shell). --CED 18-Mar-2003 my $__coderef = (ref $__code eq "CODE") ? $__code : eval << "EOD" sub { { $__code; } } EOD ; %@ = (); # Workaround to prevent spurious loss of $@ in early (pre-5.14 anyway) versions of perl if( (!$@) and (ref $__coderef eq 'CODE')) { eval { my $sig_action = mksighandle(); my $retval = &$__coderef(); die $@ if $@; print $retval if $PERLDL::DO_PRINT && !ref($__code) && $__code !~ /;\n?\z/; }; } if ($@) { my $mess = $@; # Remove surplus parts $mess =~ s/^\s*\(in cleanup\)\s+//; # 'cleanup ...' from Usage:... $mess =~ s/\n\s*\(in cleanup\).*$//; # 'cleanup...'s at end $mess =~ s/\s+at \(eval \d+\) line \d+\.?$//; # at eval ?? line ??. return $mess; # Report error } return ""; } __END__ =head1 NAME perldl - Simple shell for PDL =head1 SYNOPSIS Use PDL interactively: bash$ perldl pdl> $x = sequence(10) # or any other perl or PDL command bash$ pdl pdl> print "Hello, world!\n"; pdl> with_time { print +($A->matmult($B))->info, "\n" } for 1..5; pdl> gv $A, 'output.png' # uses GraphViz2 to show connected transforms etc pdl> 1+1 # no output pdl> do_print 1 # or put this in your .perldlrc - as of 2.099 pdl> 1+1; # no output, like MATLAB pdl> 1+1 2 Run a script: bash$ cat > pdlscript #!/usr/bin/pdl print "Hello, world!\n"; ... =head1 DESCRIPTION The program B is a simple shell (written in perl) for interactive use of PDL. It consists of a command-line interface that supports immediate interpretation of perl commands and expressions. Perl expressions, including PDL constructs, can be entered directly at the keyboard and are compiled and executed immediately. The syntax is not exactly identical to Perl, in that under most circumstances ending a line causes immediate execution of the command entered so far (no trailing ';' is required). The synonym B is a compiled executable that is useful as a script interpreter using UNIX shebang (C<#!>) syntax. This is useful for generating and re-executing command-journal files from B. The B shell runs an initial startup file (C<~/.perldlrc>) that can be used to pre-load perl modules or configure the global perl environment. It features a path mechanism for autoloading perl subroutines. There is a command-history mechanism, and several other useful features such as command preprocessing, shortcuts for commonly used commands such as "print", and the ability to execute arbitrary code whenever a prompt is printed. Depending on your configuration settings, B can be set to honor or ignore the ^D (end-of-file) character when sent from a terminal, or to attempt to do the Right Thing when a block construct spanning multiple lines is encountered. B and B support several command-line options, which are discussed near the end of this document. =head2 Reference manual & online help The PDL reference manual and online help are available from within B, using the B and B commands (which may also be abbreviated B and B.) The B command alone prints a summary of help syntax, and B<< help >> will print POD documentation from the module you mention (POD is the Perl format for embedding documentation in your perl code; see L for details). If you include POD documentation in your autoload subroutines (see B below), then both B and B will find it and be able to format and display it on demand. =head2 History mechanism If you have the perl modules ReadLines and ReadKeys installed, then B supports a history and line-editing mechanism using editing keys similar to C. The last 500 commands are always stored in the file F<.perldl_hist> in your home directory between sessions. Set C<$PERLDL::HISTFILESIZE> to change the number of lines saved. The command C shows you the last C commands you typed where C defaults to 20. e.g.: bash$ perldl ReadLines enabled pdl> $x = rfits "foo.fits" BITPIX = -32 size = 88504 pixels Reading 354016 bytes BSCALE = && BZERO = pdl> imag log($x+400) Displaying 299 x 296 image from 4.6939525604248 to 9.67116928100586 ... =head2 Command execution If you enter a simple command at the B command line, it is immediately executed in a Perl C. The environment is almost identical to that within a perl script, with some important exceptions: =over 3 =item * $_ is not preserved across lines $_ is used to hold the command line for initial processing, so at the beginning of processing of each command line, $_ contains the command itself. Use variables other than $_ to store values across lines. =item * Scope is not preserved across lines Each command line is executed in a separate C block within perl, so scoping commands such as C and C may not perform exactly as expected -- in particular, if you declare a variable with C, it is local to the particular command line on which you typed the C command, which means that it will evaporate before the next prompt is printed. (You can use C variables in a multi-line block or to isolate values within a single command line, of course). =item * Execution is immediate Under most circumstances, as soon as you end a line of input the line is parsed and executed. This breaks Perl's normal dependence on semicolons as command delimiters. For example, the two-line expression print "Hello ", "world"; prints the phrase C in Perl, but (under most circumstances) C in B. =item * Multi-line execution In multiline mode (which is enabled by default, see B, below), B searches for searches for block-like constructs with curly braces, parentheses, quotes, and related delimiters. If you leave such a construct open, B accepts more lines of input until you close the construct or explicitly end the multi-line expression with ^D. Following the example above, the phrase { print "Hello ", "world"; } will print "Hello world" from either Perl or (in multi-line mode) B. B: The multi-line parsing uses Damian Conway's L module, which contains some flaws -- so it can be fooled by quote-like operators such as C, included POD documentation, multi-line CE> quotes, and some particularly bizarre-but-valid C matches and C substitutions. In such cases, use ^D to close out the multi-line construct and force compilation-and-execution. =back If you want to preserve this behavior in a script (for example to replay a command journal file; see below on how to create one), you can use B instead of B as the interpreter in the script's initial shebang line. =head2 Terminating C A C session can be terminated with any of the commands C, C or the shorthands C or C. If EOF handling is switched on (the default) you can also type ^D at the command prompt. If the command input is NOT a terminal (for example if you are running from a command journal file), then EOF will always terminate B. =head2 Terminating commands (Ctrl-C handling) Commands executed within C can be terminated prematurely using C (or whichever key sequence sends an INT signal to the process on your terminal). Provided your PDL code does not ignore Cs this should throw you back at the C command prompt: pdl> $result = start_lengthy_computation() Ctrl-C detected pdl> As of 2.077, this requires L to be installed (without that, and before 2.077, for Perl >5.8 it didn't actually interrupt things). =head2 Shortcuts and aliases =over =item * The shell aliases C

to be a convenient short form of C, e.g. pdl> p ones 5,3 [ [1 1 1 1 1] [1 1 1 1 1] [1 1 1 1 1] ] =item * C and C are short-hand for C. =item * C lists the history buffer pdl> l # list last 20 commands pdl> l 40 # list last 40 commands =item * C is an alias for L pdl> ? vars # show information about ndarrays in current namespace =item * C is an alias for L pdl> ?? PDL::Doc =item * L, L, L and L: all words after these commands are used verbatim and not evaluated by perl. So you can write, e.g., pdl> help help instead of pdl> help 'help' =item * C runs the following code-block, and tells you how long it took, in milliseconds. Requires L. pdl> with_time { print +($A->matmult($B))->info, "\n" } for 1..5; =item * C uses L etc to visualise the given ndarray, with all connected transformations, etc, into the given file. Requires L and L. pdl> gv $A, 'output.png' =back =head2 Command-line options B and B support several command-line options to adjust the behavior of the session. Most of them are equivalent to commands that can be entered at the B> prompt. They are: =over 4 =item -glut Load OpenGL when starting the shell (the perl OpenGL module, which is available from CPAN must be installed). This enables readline event loop processing. Don't use with -tk. =item -tk Load Tk when starting the shell (the perl Tk module, which is available from CPAN must be installed). This enables readline event loop processing. Don't use with -glut. =item -f file Loads the file before processing any user input. Any errors during the execution of the file are fatal. =item -w Runs with warning messages (i.e. the normal perl C<-w> warnings) turned-on. =item -M module Loads the module before processing any user input. Compare corresponding C switch. =item -m module Unloads the module before processing any user input. =item -I directory Adds directory to the include path. (i.e. the @INC array) Compare corresponding C switch. =item -V Prints a summary of PDL config. This information should be included with any PDL bug report. Compare corresponding C switch. =back =head2 The startup file F<~/.perldlrc> If the file F<~/.perldlrc> is found it is sourced at start-up to load default modules, set shell variables, etc. If it is NOT found the distribution file F is read instead. This loads various modules considered useful by default, and which ensure compatibility with v1.11. If you don't like this and want a more streamlined set of your own favourite modules simple create your own F<~/.perldlrc>. You may wish to start from the existing F as a template since it will not be sourced once you replace it with your own version. To set even more local defaults the file F (in the current directory) is sourced if found. This lets you load modules and define subroutines for the project in the current directory. The name is chosen specifically because it was found hidden files were NOT wanted in these circumstances. The startup file should normally include "use PDL::AutoLoader;", as many of the nicer interactive features won't work without it. =head2 Shell variables Shell variables: (I: if you don't like the defaults change them in F<~/.perldlrc>) =over =item * $PERLDL::ESCAPE - default value '#' Any line starting with this character is treated as a shell escape. The default value is chosen because it escapes the code from the standard perl interpreter. =item * $PERLDL::HISTFILESIZE - default value 500 This is the number of lines of perldl shell command history to keep. =item * $PERLDL::PAGER - default value C External program to filter the output of commands. Using C prints output one screenful at a time. On Unix, setting C and $PERLDL::PAGER to C will keep a record of the output generated by subsequent perldl commands (without paging). =item * $PERLDL::PROMPT - default value 'pdl> ' Enough said But can also be set to a subroutine reference, e.g. $PERLDL::PROMPT = sub {join(':',(gmtime)[2,1,0]).'> '} puts the current time into the prompt. =item * $PERLDL::MULTI - default value 1 If this is set to a true value, then perldl will parse multi-line perl blocks: your input will not be executed until you finish a line with no outstanding group operators (such as quotes, blocks, parenthesis, or brackets) still active. Continuation lines have a different prompt that shows you what delimiters are still active. Note that this is not (yet!) a complete perl parser. In particular, Text::Balanced appears to be able to ignore quoting operatores like C within a line, but not to be able to extend them across lines. Likewise, there is no support for the '<<' operator. Multiline conventional strings and {}, [], and () groupings are well supported. =item * $PERLDL::NO_EOF - default value 0 / 1 on MSWin32 Protects against accidental use of "^D" from the terminal. If this is set to a true value, then you can't accidentally exit perldl by typing "^D". If you set it to a value larger than 1 (and PERLDL::MULTI is set), then you can't use "^D" to exit multiline commands either. If you're piping commands in from a file or pipe, this variable has no effect. =item * $HOME The user's home directory =item * $PERLDL::TERM This is the Term::ReadLine object associated with the perldl shell. It can be used by routines called from perldl if your command is interactive. =item * $PDL::toolongtoprint The maximal size pdls to print (defaults to 10,000 elements). This is not just a C variable but it is something that is usually needed in an interactive debugging session. =back =head2 Executing scripts from the C prompt A useful idiom for developing perldl scripts or editing functions on-line is pdl> # emacs script & -- add perldl code to script and save the file pdl> do 'script' -- substitute your favourite window-based editor for 'emacs' (you may also need to change the '&' on non-Unix systems). Running "do 'script'" again updates any variables and function definitions from the current version of 'script'. =head2 Executing perldl scripts from the command line PDL scripts are just perl scripts that happen to use PDL (and possibly PDL::NiceSlice). But for the truly lazy, perldl can be invokes as a script interpreter. Because perldl is itself an interpreted perl script, most unices won't allow you to say "#!/usr/bin/perldl" at the top of your script. Instead, say "#!/usr/bin/pdl" and your script will be executed exactly as if you typed it, line-by-line, into the perldl shell. =head2 Command preprocessing NOTE: This feature is used by default by L. See below for more about slicing at the C prompt In some cases, it is convenient to process commands before they are sent to perl for execution. For example, this is the case where the shell is being presented to people unfamiliar with perl but who wish to take advantage of commands added locally (eg by automatically quoting arguments to certain commands). *I*: The preprocessing interface has changed from earlier versions! The old way using C<$PERLDL::PREPROCESS> will still work but is strongly deprecated and might go away in the future. You can enable preprocessing by registering a filter with the C function. C takes one argument which is the filter to be installed. A filter is a Perl code reference (usually set in a local configuration file) that will be called, with the current command string as argument, just prior to the string being executed by the shell. The modified string should be returned. Note that you can make C completely unusable if you fail to return the modified string; quitting is then your only option. Filters can be removed from the preprocessing pipeline by calling C with the filter to be removed as argument. To find out if a filter is currently installed in the preprocessing pipeline use C: pdl> preproc_add $myfilter unless preproc_registered $myfilter; Previous versions of C used the variable C<$PERLDL::PREPROCESS>. This will still work but should be avoided. Please change your scripts to use the C etc functions. The following code would check for a call to function 'mysub' and bracket arguments with qw. $filter = preproc_add sub { my $str = shift; $str =~ s/^\s+//; # Strip leading space if ($str =~ /^mysub/) { my ($command, $arguments) = split(/\s+/,$str, 2); $str = "$command qw( $arguments )" if (defined $arguments && $arguments !~ /^qw/); }; # Return the input string, modified as required return $str; }; This would convert: pdl> mysub arg1 arg2 to pdl> mysub qw( arg1 arg2 ) which Perl will understand as a list. Obviously, a little more effort is required to check for cases where the caller has supplied a normal list (and so does not require automatic quoting) or variable interpolation is required. You can remove this preprocessor using the C function which takes one argument (the filter to be removed, it must be the same coderef that was returned from a previous C call): pdl> preproc_del $filter; An example of actual usage can be found in the C script. Look at the function C to see how the niceslicing preprocessor is enabled/disabled. =head2 C and L L introduces a more convenient slicing syntax for ndarrays. In the current version of C niceslicing is enabled by default (if the required CPAN modules are installed on your machine). At startup C will let you know if niceslicing is enabled. The startup message will contain info to this end, something like this: perlDL shell v1.XX PDL comes with ABSOLUTELY NO WARRANTY. For details, see the file 'COPYING' in the PDL distribution. This is free software and you are welcome to redistribute it under certain conditions, see the same file for details. ReadLines, NiceSlice enabled Reading /home/csoelle/.perldlrc... Type 'demo' for online demos Loaded PDL v2.XX When you get such a message that indicates C is enabled you can use the enhanced slicing syntax: pdl> $x = sequence 10; pdl> p $x(3:8:2) For details consult L. L installs a filter in the preprocessing pipeline (see above) to enable the enhanced slicing syntax. You can use a few commands in the C shell to switch this preprocessing on or off and also explicitly check the substitutions that the NiceSlice filter makes. You can switch the L filter on and off by typing pdl> trans # switch niceslicing on and pdl> notrans # switch niceslicing off respectively. The filter is on by default. To see how your commands are translated switch reporting on: pdl> report 1; pdl> p $x(3:8:2) processed p $x->slice([3,8,2]) [3 5 7] Similarly, switch reporting off as needed pdl> report 0; pdl> p $x(3:8:2) [3 5 7] Reporting is off by default. =head2 Automatically execute your own hooks The variable @PERLDL::AUTO is a simple list of perl code strings and/or code reference. It is used to define code to be executed automatically every time the user enters a new line. A simple example would be to print the time of each command: pdl> push @PERLDL::AUTO,'print scalar(gmtime),"\n"' pdl> print zeroes(3,3) Sun May 3 04:49:05 1998 [ [0 0 0] [0 0 0] [0 0 0] ] pdl> print "Boo" Sun May 3 04:49:18 1998 Boo pdl> Or to make sure any changes in the file 'local.perldlrc' are always picked up :- pdl> push @PERLDL::AUTO,"do 'local.perldlrc'" This code can of course be put *in* 'local.perldlrc', but be careful :-) [Hint: add C to above to ensure it only gets done once!] Another example application is as a hook for Autoloaders (e.g. PDL::AutoLoader) to add code too which allows them to automatically re-scan their files for changes. This is extremely convenient at the interactive command line. Since this hook is only in the shell it imposes no inefficiency on PDL scripts. Finally note this is a very powerful facility - which means it should be used with caution! =cut PDL-2.100/script/pdldoc0000755000175000017500000000402014727756302014571 0ustar osboxesosboxes#!perl use strict; $|++; use PDL::AutoLoader; use PDL::Doc::Perldl; use File::Basename; our $VERSION = '0.3'; my %options = ( a => \&apropos, b => \&badinfo, h => \&help, s => \&sig, u => \&usage ); my $name = basename( $0 ); my $usage = <<"EOH"; Usage: $name [-a] [-b] [-h] [-s] [-u] This program provides command-line access to the PDL documentation. If no flag is specified, -h is assumed. -a (apropos) searches the documentation for the string -b (badinfo) does the function support bad values? -h (help) prints the help for the function/module/document -s (sig) prints the signature of the function -u (usage) gives usage information on the function EOH my $oflag = $#ARGV > -1 ? substr($ARGV[0],0,1) eq "-" : 0; die $usage unless ($#ARGV == 0 and not $oflag) or ($#ARGV == 1 and $oflag); my $option = "h"; if ( $oflag ) { $option = substr($ARGV[0],1,1); die $usage unless exists $options{$option}; shift @ARGV; } &{$options{$option}}( $ARGV[0] ); exit; __END__ =head1 NAME pdldoc - shell interface to PDL documentation =head1 SYNOPSIS B =cut B [B<-a>] [B<-b>] [B<-h>] [B<-s>] [B<-u>] =head1 DESCRIPTION The aim of B is to provide the same functionality as the C, C, C, C, and C commands available in the L shell. It searches for L functions also. Think of it as the PDL equivalent of C. =head1 OPTIONS =over 5 =item B<-h> help print documentation about a PDL function or module or show a PDL manual. This is the default option. =item B<-a> apropos Regex search PDL documentation database. =item B<-b> badinfo Information on the support for bad values provided by the function. =item B<-s> sig prints signature of PDL function. =item B<-u> usage Prints usage information for a PDL function. =back =head1 VERSION This is pdldoc version 0.3. =head1 AUTHOR Doug Burke . Chris Marshall . PDL-2.100/script/pptemplate0000755000175000017500000001152414727756302015506 0ustar osboxesosboxes#!perl -w use strict; use warnings; use File::Basename; use File::Path qw(make_path); sub names { my ($module) = @_; my $pdname = 'lib/'.($module =~ s#::#/#gr) . '.pd'; my $dir = $module =~ s#::#-#gr; return ($module, $pdname, $dir); } sub pdtmpl { my ($module) = @_; <'Top'}, <<'EOPM'); use strict; use warnings; =head1 NAME $module - new PDL module to clutter up CPAN =head1 SYNOPSIS use $module; # FILL THIS IN =head1 DESCRIPTION This will change the world. =cut EOPM # pp_add_exported(''); # add the list of functions # to the list of exported functions # pp_addxs(''); # add plain XS code to the XS section # pp_add_isa(qw//); # inheritance business: add arglist to modules \@ISA pp_def('myinc', Pars => 'a(); [o]b()', Code => '\$b() = \$a() + 1;', ); pp_done(); # you will need this to finish pp processing EOF } sub pdMakefile { my ($module, $pdname) = @_; return < '$module', AUTHOR => 'A.U.Thor ', VERSION_FROM => '$pdname', MIN_PERL_VERSION => '5.016', LICENSE=> 'perl', PREREQ_PM => { 'PDL::Basic' => '2.096', # deep mode }, CONFIGURE_REQUIRES => { 'PDL::Basic' => '2.096', }, BUILD_REQUIRES => { 'PDL::Basic' => '2.096', }, TEST_REQUIRES => { 'Test::More' => '0.88', # done_testing 'Test::PDL' => '0.21', }, ); { my \@pd_srcs; package MY; # so that "SUPER" works right sub init_PM { my (\$self) = \@_; \$self->SUPER::init_PM; \@pd_srcs = ::pdlpp_eumm_update_deep(\$self); } sub postamble { ::pdlpp_postamble(\@pd_srcs) } } EOM } sub usage { require File::Basename; die "usage: @{[File::Basename::basename $0]} modulename\n"; } usage if !@ARGV; my ($module, $pdname, $dir) = names $ARGV[0]; die "$dir already exists; move out of the way if you want to proceed" if -d $dir; mkdir $dir or die "$dir: $!"; chdir $dir or die "$dir: $!"; my $pd_dir = dirname $pdname; make_path $pd_dir; die "$pd_dir not created" if !-d $pd_dir; open my $pdfl, ">", $pdname or die "$pdname: $!"; print $pdfl pdtmpl($module); close $pdfl; open my $mkfl, ">", 'Makefile.PL' or die "Makefile.PL: $!"; print $mkfl pdMakefile($module, $pdname); close $mkfl; mkdir 't' or die "t: $!"; open my $tfl, '>', 't/basic.t' or die "t/basic.t: $!"; print $tfl <myinc, pdl(4,6); done_testing; EOF close $tfl; =head1 NAME pptemplate - script to generate Makefile.PL and PP file skeleton =head1 SYNOPSIS # generate Makefile.PL and mymodule.pd in PDL-MyModule pptemplate PDL::MyModule; =head1 DESCRIPTION The B script is the easiest way to start a new module for PDL that contains PP code (see also L). The usage is simply pptemplate modulename; As a result pptemplate will generate a perl Makefile for the new module (F) that contains the minimal structure to generate a module from PP code and also a skeleton file for your new module. The file will be called F if you called C as pptemplate PDL::CleverAlgs::Mymod; I suppose you can work out the naming rule C<;)>. If not resort to experimentation or the source code. C will stop if the directory to be created already exists, to avoid accidents. Move it out of the way if you really want to scrap it. As of 2.096, the "internal mode" of this script has been removed, and it creates the files using the new "deep mode". This is because the earlier practice of incorporating vast numbers of modules into the main PDL distribution has been rethought due to the problems it causes. Use this script to make it easy to create new CPAN-distributed PDL modules. =head1 BUGS Feedback and bug reports are welcome. =head1 COPYRIGHT Copyright (c) 2001, Christian Soeller. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as PDL itself (see L). =cut PDL-2.100/MANIFEST.SKIP0000644000175000017500000000224314727756302013775 0ustar osboxesosboxes\.DS_Store %$ -stamp$ .*/TAGS$ .*Version_check$ .*\#$ .*\.0$ .*\.orig$ .*\.rej$ \.swp$ .exe$ /\.\#.* /pm_to_blib$ /tmp.* MANIFEST\.bak$ MANIFEST\.old META\.json META\.yml Makefile$ Makefile\.aperl Makefile\.old \.(tmp|new|diff|ori)$ \.BAK$ \.bck$ \.bs \.bundle$ \.inlinewith \.inlinepdlpp \.pptest \.lck$ \.m$ \.o$ \.out$ \.patch$ \.so$ \.tar\.gz$ \b_eumm/ ^examples/Benchmark/\.git ^examples/Benchmark/Bench.c ^examples/Benchmark/blib/ ^lib/PDL/Bad(\.(pm|xs|c)$|-pp-) ^lib/PDL/Compression(\.(pm|xs|c)$|-pp-) ^lib/PDL/FFT(\.(pm|xs|c)$|-pp-) ^lib/PDL/IO/Misc(\.(pm|xs|c)$|-pp-) ^lib/PDL/IO/Pnm(\.(pm|xs|c)$|-pp-) ^lib/PDL/Image2D(\.(pm|xs|c)$|-pp-) ^lib/PDL/ImageND(\.(pm|xs|c)$|-pp-) ^lib/PDL/ImageRGB(\.(pm|xs|c)$|-pp-) ^lib/PDL/Math(\.(pm|xs|c)$|-pp-) ^lib/PDL/MatrixOps(\.(pm|xs|c)$|-pp-) ^lib/PDL/Ops(\.(pm|xs|c)$|-pp-) ^lib/PDL/Primitive(\.(pm|xs|c)$|-pp-) ^lib/PDL/Slices(\.(pm|xs|c)$|-pp-) ^lib/PDL/Transform(\.(pm|xs|c)$|-pp-) ^lib/PDL/Ufunc(\.(pm|xs|c)$|-pp-) ^lib/PDL/Core\.c$ ^lib/PDL/Core/pdl\.h$ ^script/pdl$ \b[\._]Inline ^\.\#.* ^\.exists ^\.git \.gitignore$ ^blib/ ^pm_to_blib$ ~$ ^xt/ ^\.github/ ^\.cirrus\.yml cover_db/ ^nytprof(/|\.out) \.gc(ov|no|da)$ pp-\w*\.c$ PDL-2.100/t/0000755000175000017500000000000014771136046012335 5ustar osboxesosboxesPDL-2.100/t/clump.t0000644000175000017500000000353614736571600013651 0ustar osboxesosboxesuse strict; use warnings; # Test ->clump(). This is not yet good enough: we need # nasty test cases use Test::More; use PDL::LiteF; use Test::PDL; # PDL::Core::set_debugging(1); kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. sub abstol { {atol=>0.01, test_name=>$_[0]} } # tolerance for tests if(0) { # TODO dead code my $a0 = zeroes(3,3); note $a0; my $b0 = 10 * $a0; note $b0; } { # TODO no test here my $pa0 = zeroes(3,3); #my $pa = $pa0->PDL::Core::new_or_inplace($a0); my $pa = $pa0->copy; my $pb = $pa->transpose; note $pa; # PDL::Primitive::axisvalues($pb); # note $pa; } { # TODO no test here my $pa0 = xvals(zeroes(3,3)); my $pa1 = yvals(zeroes(3,3)); my $pa2 = 10*$pa1; my $pa3 = $pa0 + $pa1; for my $p ( $pa0, $pa1, $pa2, $pa3 ) { note $p; } } { my $pa = xvals(zeroes(3,3)) + 10*yvals(zeroes(3,3)); note $pa; my $pb = $pa->clump(-1); # $pb->make_physical(); # $pa->jdump(); # $pb->jdump(); note $pb; is_pdl $pb, pdl([0,1,2,10,11,12,20,21,22]), abstol 'clump(-1) entire ndarray'; my $pc = $pa->slice('0:2:2,:'); my $pd = $pc->clump(-1); my $pe = $pd->slice("2:4"); my $pf = ""; # Warning eater $pf= $pe->copy(); kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. # ok(2,$@ =~ /^clump: Increments do not match/); # Clump supports this now. is_pdl $pd,pdl([0,2,10,12,20,22]), abstol 'clump(-1) slice with skip and whole dim'; is_pdl $pe,pdl([10,12,20]), abstol 'clump(-1) slice'; # SF bug #406 clump(-N) failure ##-- test data my $a1 = sequence(2,13); my $b1 = sequence(3,2,13); ##-- bash to max 2 dimensions my $a2 = $a1->clump(-2); ##-- no-op my $b2 = $b1->clump(-2); ##-- merge 1st 2 dims ok($a1->ndims == 2, "no-op clump(-2)"); ok($b2->ndims == 2, "general clump(-2)"); } done_testing; PDL-2.100/t/thread.t0000644000175000017500000000733714727756302014007 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; { # 2. If we don't want flow, we mustn't have it. my $pa = pdl 2,3,4; my $pb = $pa + $pa; is "$pb", '[4 6 8]'; $pa->set(0,50); is "$pb", '[4 6 8]'; } { # 3. Test what happens when we assign to $pb. (no coredumps allowed) my $pa = pdl 2,3,4; $pa->flowing; my $pb = $pa + $pa; is "$pb", '[4 6 8]'; $pb->set(0,50); $pb->sever; # As of 2.064 you must break the dataflow manually is "$pb", '[50 6 8]'; is "$pa", '[2 3 4]'; $pa->set(0,33); is "$pa", '[33 3 4]'; is "$pb", '[50 6 8]'; } { # 4. Now a basic slice test. my $pa = pdl [2,3,4],[5,6,7]; is("$pa", "\n[\n [2 3 4]\n [5 6 7]\n]\n"); my $pb = $pa->slice('1:2,:'); is("$pb", "\n[\n [3 4]\n [6 7]\n]\n"); $pa->set(1,1,9); is("$pa", "\n[\n [2 3 4]\n [5 9 7]\n]\n"); is("$pb", "\n[\n [3 4]\n [9 7]\n]\n"); my $pc = $pa->slice('0:1,:'); is("$pc", "\n[\n [2 3]\n [5 9]\n]\n"); $pb->set(0,0,8); is("$pa", "\n[\n [2 8 4]\n [5 9 7]\n]\n"); is("$pb", "\n[\n [8 4]\n [9 7]\n]\n"); is("$pc", "\n[\n [2 8]\n [5 9]\n]\n"); } # 5. Now, to the hairy stuff of generations and progenitors. # 7. What about axisvals: { my $pa = zeroes 5,3; is("$pa", "\n[\n [0 0 0 0 0]\n [0 0 0 0 0]\n [0 0 0 0 0]\n]\n"); my $pb = PDL::Core::new_or_inplace($pa); my $pc = $pb->transpose; axisvalues($pc->inplace); is("$pc", "\n[\n [0 1 2]\n [0 1 2]\n [0 1 2]\n [0 1 2]\n [0 1 2]\n]\n"); is("$pb", "\n[\n [0 0 0 0 0]\n [1 1 1 1 1]\n [2 2 2 2 2]\n]\n"); is("$pa", "\n[\n [0 0 0 0 0]\n [0 0 0 0 0]\n [0 0 0 0 0]\n]\n"); $pa = zeroes 5,5; $pb = $pa->slice("1:3,1:3"); $pc = $pb->slice("(1),(1)"); is($pc->at(), 0); $pa .= 1; is($pc->at(), 1); $pa .= 2; is($pc->at(), 2); } { my $pa = pdl [2,3,4],[5,6,7]; $pa->flowing; my $a2 = pdl 1; my $pb = $pa + $a2; is("$pb", "\n[\n [3 4 5]\n [6 7 8]\n]\n", 'pb flowing'); my $pc = $pb * 2; # This should stay the same flowed structure. is("$pc", "\n[\n [ 6 8 10]\n [12 14 16]\n]\n", 'multiplied'); } { # Then, the more difficult ways: explicit broadcasting. # Dims: 3,3,2 my $pa = pdl [[0,1,2],[3,4,5],[6,7,8]],[[10,11,12],[13,14,15],[16,17,18]]; my $pb = zeroes(3,3); my $pc = $pb->broadcast(0,1); is $pc->info, 'PDL: Double D [] T1 [3,3]', 'info right for explicit broadcasting 1 dim'; is $pb->broadcast(0)->info, 'PDL: Double D [3] T1 [3]', 'info right for explicit broadcasting 2 dims'; is zeroes(4,7,2,8)->broadcast(2)->info, 'PDL: Double D [4,7,8] T1 [2]', 'info right for higher-dim explicit broadcasting 1 dims'; is zeroes(4,7,2,8)->broadcast(2,1)->info, 'PDL: Double D [4,8] T1 [2,7]', 'info right for higher-dim explicit broadcasting 2 dims'; is zeroes(4,7,2,8,5,6)->broadcast(2,4)->info, 'PDL: Double D [4,7,8,6] T1 [2,5]', 'info right for higher-dim explicit broadcasting 2 dims'; is zeroes(4,7,2,8,5,6)->broadcast1(2)->broadcast2(3)->info, 'PDL: Double D [4,7,8,6] T1 [2] T2 [5]', 'info right for higher-dim explicit broadcasting 2 sets of dims'; $pb->make_physical(); $pc->make_physical(); maximum($pa->broadcast(0,1),$pc); cmp_ok($pb->at(0,0), '==', 10, 'at(0,0)'); cmp_ok($pb->at(1,1), '==', 14, 'at(1,1)'); minimum($pa->broadcast(0,1),$pb->broadcast(0,1)); cmp_ok($pb->at(0,0), '==', 0, 'at(0,0)'); cmp_ok($pb->at(1,1), '==', 4, 'at(1,1)'); } { # Now, test 'unbroadcast'. my $pa = zeroes(4,5,6); my $pb = $pa->broadcast(1); my $pc = $pb->unbroadcast(2); is(join(',',$pc->dims), "4,6,5", 'unbroadcast dims'); # $pb->jdump; $pc->jdump; } { #### Now, test whether the Perl-accessible broadcast works: my $pa = pdl [[0,1,2],[3,4,5],[6,7,8]],[[10,11,12],[13,14,15],[16,17,18]]; my $pb = pdl [2,3,4]; PDL::broadcastover_n(sub {print "ROUND: @_\n"},$pa,$pb); # As well as with virtuals... PDL::broadcastover_n(sub {print "ROUND: @_\n"},$pa->slice("-1:0,-1:0"),$pb); } done_testing; PDL-2.100/t/primitive-interpolate.t0000644000175000017500000001255614733413371017064 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use Test::PDL; subtest interpol => sub { subtest real => sub { my $yvalues = pdl( 0 .. 5 ) - 20; my $xvalues = -pdl( 0 .. 5 ) * .5; my $x = pdl(-2); is_pdl $x->interpol( $xvalues, $yvalues ), pdl(-16); }; subtest complex => sub { my $yvalues = ( pdl( 0 .. 5 ) - 20 ) * ( 1 + i() ); my $xvalues = -pdl( 0 .. 5 ) * .5; my $x = pdl(-2); is_pdl $x->interpol( $xvalues, $yvalues ), pdl('-16-16i'); throws_ok { $x->interpol( $xvalues * i(), $yvalues ) } qr/must be real/, "x must be real"; }; }; subtest interpolate => sub { my $yvalues = pdl(0 .. 5) - 20; my $xvalues = -pdl(0 .. 5) * .5; my $x = pdl(-2); is_pdl +($x->interpolate($xvalues, $yvalues))[0], pdl(-16); eval {cdouble(-2)->interpolate($xvalues, $yvalues)}; like $@, qr/must be real/; eval {$x->interpolate($xvalues->cdouble, $yvalues)}; like $@, qr/must be real/; }; subtest interpND => sub { my $x = xvals( 10, 10 ) + yvals( 10, 10 ) * 10; my $index = cat( 3 + xvals( 5, 5 ) * 0.25, 7 + yvals( 5, 5 ) * 0.25 ) ->reorder( 2, 0, 1 ); my $z = pdl '73 73.25 73.5 73.75 74; 75.5 75.75 76 76.25 76.5; 78 78.25 78.5 78.75 79; 80.5 80.75 81 81.25 81.5; 83 83.25 83.5 83.75 84'; my $y; lives_ok { $y = $x->interpND($index) } 'interpND'; is_pdl $y, $z; is_pdl $x->long->interpND($index), $z->long, {atol=>6}; is_pdl $x->long->interpND($index, {method=>'l'}), $z->long; is_pdl $x->long->interpND($index, {method=>'c'}), $z->long; }; subtest PCHIP => sub { my $x = sequence(10); my $y = pdl('43.3 44.3 47.3 52.3 59.3 68.3 79.3 92.3 107.3 124.3; -23 -22 -15 4 41 102 193 320 489 706'); my $xi = sequence(float,5) + 2.3; my ($g) = pchip_chsp([0,0], [0,0], $x, $y); is_pdl $g, pdl('0 2 4 6 8 10 12 14 16 18; 0 3 12 27 48 75 108 147 192 243'), 'pchip_chsp'; ($g) = pchip_chic([0,0], [0,0], 0, $x, $y); is_pdl $g, pdl('0 1.5 3.75 5.8333333 7.875 9.9 11.916667 13.928571 15.9375 18; 0 1.75 10.230769 25.107143 46.061224 73.039474 106.02752 145.02027 190.01554 241'), 'pchip_chic'; ($g) = pchip_chim($x, $y); is_pdl $g, pdl('0 1.5 3.75 5.8333333 7.875 9.9 11.916667 13.928571 15.9375 18; 0 1.75 10.230769 25.107143 46.061224 73.039474 106.02752 145.02027 190.01554 241'), 'pchip_chim'; my ($yi) = pchip_chfe($x, $y, $g, $xi); is_pdl $yi, my $yi_exp = pdl('48.56375 54.173375 61.777925 71.38055 82.98225; -10.973827 12.780893 56.345513 125.71307 226.88177'), 'pchip_chfe'; ($yi) = pchip_chfd($x, $y, $g, $xi); is_pdl $yi, $yi_exp, 'pchip_chfd'; my ($integral) = pchip_chia($x, $y, $g, 3, 4); is_pdl $integral, pdl(55.6298611111111,20.7538265306122), 'pchip_chia'; ($integral) = pchip_chid($x, $y, $g, 3, 4); is_pdl $integral, pdl(55.6298611111111,20.7538265306122), 'pchip_chid'; my ($t, $bcoef) = pchip_chbs($x, $y, $g, 0); is_pdl $t, pdl('0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 9 9; 0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 9 9'), 'pchip_chbs t'; is_pdl $bcoef, pdl('43.3 43.3 43.8 44.8 46.05 48.55 50.355556 54.244444 56.675 61.925 65 71.6 75.327778 83.272222 87.657143 96.942857 101.9875 112.6125 118.3 124.3; -23 -23 -22.583333 -21.416667 -18.410256 -11.589744 -4.3690476 12.369048 25.646259 56.353741 77.653509 126.34649 157.65749 228.34251 271.65991 368.34009 425.66149 552.33851 625.66667 706'), 'pchip_chbs bcoef'; my $x_slice = $x->slice('*1,0:-2'); # because calling with last value is out of range my ($val) = pchip_bvalu($t, $bcoef, 0, $x_slice); is_pdl $val->t, pdl('43.3 44.3 47.3 52.3 59.3 68.3 79.3 92.3 107.3; -23 -22 -15 4 41 102 193 320 489'), 'pchip_bvalu'; $x = float( 3 .. 10 ); my $f = $x*$x*$x + 425.42352; my $answer = 3*$x*$x; my ( $d, $err ) = pchip_chim( $x, float($f) ); is_pdl $err, indx 0; # don't check the first and last elements, as expect the # error to be largest there # value of 5% comes from tests on linux and solaris machines is_pdl +(map $_->slice('1:-2'), $d, $answer), {rtol=>0.05}; my $d2 = $f->zeroes; pchip_chic( pdl([0, 0]), pdl([0, 0]), 1, $x, $f, $d2, my $err2=null ); is_pdl $err2, indx 0; is_pdl $d2, $d->double, {atol=>2e-2}; pchip_chsp( pdl([0, 0]), pdl([0, 0]), $x, $f, my $d3=null, my $err3=null ); is_pdl $err3, indx 0; is_pdl $d3, $d->double, {atol=>2}; my $xe = float( pdl( 4 .. 8 ) + 0.5 ); my ( $fe, $de ); ( $fe, $de, $err ) = pchip_chfd( $x, $f, $d, $xe ); is_pdl $err, indx(0); $answer = $xe*$xe*$xe + 425.42352; is_pdl $fe, $answer, {rtol=>1e-5}; $answer = 3.0*$xe*$xe; is_pdl $de, $answer, {rtol=>2e-2}; ( $fe, $err ) = pchip_chfe( $x, $f, $d, $xe ); is_pdl $fe, $xe*$xe*$xe + 425.42352, {rtol=>1e-3}; is_pdl $err, indx 0; $x = float( 1, 2, 3, 5, 6, 7 ); $f = float( 1, 2, 3, 4, 3, 4 ); ( $d, $err ) = pchip_chim($x, $f); is_pdl $err, indx 2; $x = double( sequence(11) - 0.3 ); $f = $x * $x; ( $d, $err ) = pchip_chim($x, $f); my $ans = pdl( 9.0**3, (8.0**3-1.0**3) ) / 3.0; ( my $int, $err ) = pchip_chia($x, $f, $d, pdl(0.0,1.0), pdl(9.0,8.0)); is_pdl $err, indx 0,0; is_pdl $int, $ans, {atol=>4e-2}; my $hi = pdl( $x->at(9), $x->at(7) ); my $lo = pdl( $x->at(0), $x->at(1) ); $ans = ($hi**3 - $lo**3) / 3; ( $int, $err ) = pchip_chid( $x, $f, $d, pdl(0,1), pdl(9,7) ); is_pdl $err, indx 0,0; is_pdl $int, $ans, {atol=>6e-2}; }; done_testing; PDL-2.100/t/pic_16bit.t0000644000175000017500000000230214744321614014274 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use File::Temp qw(tempdir); use File::Spec; use PDL::LiteF; use PDL::NiceSlice; use PDL::IO::Pic; my $can_png = PDL->wpiccan('PNG'); my $can_jpg = PDL->wpiccan('JPEG'); $PDL::IO::Pic::debug=20; my $tmpdir = tempdir( CLEANUP => 1 ); sub roundtrip { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($in, $file, $label, $dimonly, @extra) = @_; $file = File::Spec->catfile($tmpdir, $file); $in->wpic($file); my $got = rpic($file, @extra); return is_deeply [$got->dims], [$in->dims] if $dimonly; is_pdl $got, $in, {require_equal_types=>0, test_name=>"$label image save+restore"}; } # test save/restore of 8-bit image roundtrip(my $x = sequence(16,16), 'byte_a.pnm', 'pnm byte'); roundtrip($x, 'byte_a.png', 'png byte', 0, $^O =~ /MSWin32/i ? {FORMAT => 'PNG'} : ()) if $can_png; # test save/restore of 16-bit image roundtrip(my $a16 = sequence(256, 255)->ushort * 231, 'tushort_a16.pnm', 'pnm ushort', ); roundtrip($a16, 'tushort_a16.png', 'png ushort', 0, $^O =~ /MSWin32/i ? {FORMAT => 'PNG'} : ()) if $can_png; roundtrip(sequence(byte,3,32,24), 'byte_a.jpg', 'jpeg byte', 1, {FORMAT => 'JPEG'}) if $can_jpg; done_testing; PDL-2.100/t/lvalue.t0000644000175000017500000000143514770344745014023 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use PDL::Dbg; my @lv_subs = map [$_], qw( dice flat indexND indexNDb broadcast nslice_if_pdl px range reorder reshape sever slice indexNDb mslice ); push @lv_subs, map [$_, zeroes(indx,2,0)], qw(indexND); push @lv_subs, map [$_, 1], qw(clump dummy index unbroadcast); push @lv_subs, map [$_, pdl 1], qw(where whereND); push @lv_subs, map [$_, 0, 1], qw(diagonal); push @lv_subs, map [$_, 0, 0], qw(dice_axis index2d mv xchg); push @lv_subs, map [$_, pdl([0]), undef, undef], qw(rangeb); my $pa = sequence 3,3; for (@lv_subs) { my ($name, @args) = @$_; no warnings 'uninitialized'; lives_ok { $pa->$name(@args) .= 0 } "lvalue @$_ ran OK"; } is($pa->max, 0, "lvalue slice modified values"); done_testing; PDL-2.100/t/imagend.t0000644000175000017500000001033114727756302014130 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use PDL::LiteF; use PDL::ImageND; use PDL::NiceSlice; my $eps = 1e-15; { my $ans = pdl( [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27], [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27], [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27] ); is_pdl convolve(xvals(10,3), pdl([1,2],[2,1])), $ans; } my $pa = zeroes(6,6); $pa(4,:) .= 1; $pa(5,:) .= 1; $pa(1,2) .= 1; $pa(0,4) .= 1; $pa(2,0) .= 1; my $pb = pdl( [-1,0],[0,1] ); { my $ans_e = pdl( [ 0, 0, 1, -1, 0, 0], [-1, 0, 0, -1, 0, 0], [ 0, 1, 0, -1, 0, 0], [ 0, 0, 0, -1, 0, 0], [ 1, 0, 0, -1, 0, 0], [ 0, 0, 0, -1, 0, 0] ); is_pdl convolveND($pa,$pb,{m=>'d',b=>'e'}),$ans_e; is_pdl convolveND($pa,$pb,{m=>'f',b=>'e'}),$ans_e; } { my $ans_p = pdl( [ 0, 0, 1, -1, 0, 1], [-1, 0, 0, -1, 0, 1], [ 0, 1, 0, -1, 0, 1], [ 0, 0, 0, -1, 0, 0], [ 1, 0, 0, -1, 0, 1], [ 0, -1, 0, -1, 0, 1] ); is_pdl convolveND($pa,$pb,{m=>'d',b=>'p'}), $ans_p; is_pdl convolveND($pa,$pb,{m=>'f',b=>'p'}), $ans_p; } { my $ans_t = pdl( [ 0, 0, 1, -1, 0, 1], [-1, 0, 0, -1, 0, 1], [ 0, 1, 0, -1, 0, 1], [ 0, 0, 0, -1, 0, 1], [ 1, 0, 0, -1, 0, 1], [ 0, 0, 0, 0, 1, 1] ); is_pdl convolveND($pa,$pb,{m=>'d',b=>'t'}), $ans_t; is_pdl convolveND($pa,$pb,{m=>'f',b=>'t'}), $ans_t; } { my $ans = pdl([14,22,30],[62,70,78],[110,118,126]); is_pdl rebin(sequence(6,6),3,3,{Norm=>1}), $ans; } is_pdl circ_mean_p(sequence(8,8)), pdl('[36 36 36 36 23.14285 14.4]'); is_pdl circ_mean(sequence(2,2)), pdl('[[1 1][1 3]]'); { # cut down from demo 3d my $size = 5; my $x = xvals($size+1,$size+1) / $size; my $y = yvals($size+1,$size+1) / $size; my $z = 0.5 + 0.5 * (sin($x*6.3) * sin($y*6.3)) ** 3; my $cvals = pdl q[0.203 0.276]; my $points = cat($x,$y,$z)->mv(-1,0); my (undef, $cnt) = contour_segments($cvals, $z, $points); is_pdl $cnt, indx(15,15), {atol=>2, test_name=>'contour_segments'}; $z = pdl q[ 0 0 0 0 0; 0 0 1 0 0; 0 1 0 1 0; 0 1 1 1 0; 0 0 0 0 0 ]; (my $got, $cnt) = contour_segments(0.5, $z, my $coords = $z->ndcoords); $got = $got->slice(',0:'.$cnt->max)->uniqvec; my $exp = float q[ [0.5 2] [0.5 3] [ 1 1.5] [ 1 3.5] [1.5 1] [1.5 2] [ 2 0.5] [ 2 1.5] [ 2 2.5] [ 2 3.5] [2.5 1] [2.5 2] [ 3 1.5] [ 3 3.5] [3.5 2] [3.5 3] ]; is_pdl $got, $exp, {atol=>0.1, test_name=>'contour_segments'}; my ($pi, $p) = contour_polylines(0.5, $z, $coords); my $pi_max = $pi->max; $p = $p->slice(','.($pi_max < 0 ? '1:0:1' : "0:$pi_max"))->uniqvec; is_pdl $p, $exp, {atol=>0.1, test_name=>'contour_polylines'}; } for ( [6, q[0 1; 2 3; 4 5], '[1 3 5]', '[4 5 2 3 0 1]', 1], [6, q[0 1; 1 2; 2 3; 3 1; 3 2; 4 5], '[1 6 8 -1 -1 -1]', '[4 5 0 1 2 3 2 3 1 -1 -1 -1]', 1], [9, q[0 1; 1 2; 2 3; 3 1; 3 2; 4 5; 6 7; 7 8; 8 6], '[1 6 8 12 -1 -1 -1 -1 -1]', '[4 5 0 1 2 3 2 3 1 6 7 8 6 -1 -1 -1 -1 -1]', 1], [6, q[0 1; 1 2; 2 3; 3 1; 3 2; 4 5], '[4 6 8 -1 -1 -1]', '[0 1 2 3 1 2 3 4 5 -1 -1 -1]', 0], [6, q[0 1; 2 1; 2 3; 3 1; 3 2; 4 5], '[4 6 8 -1 -1 -1]', '[0 1 2 3 1 2 3 4 5 -1 -1 -1]', 0], ) { my ($d, $e, $pindsexp, $pexp, $directed) = @$_; my ($pinds, $p) = path_join(pdl($e), $d, $directed); is "$p", $pexp; is "$pinds", $pindsexp; } { my ($pi, $p) = map pdl($_), '[4 6 8 -1 -1 -1]', '[0 1 2 3 1 2 3 4 5 -1 -1 -1]'; is_deeply [map "$_", path_segs($pi, $p)], ['[0 1 2 3 1]', '[2 3]', '[4 5]']; } { my ($x, $y, $z) = map float($_), 5..7; my $c3 = combcoords($x,$y,$z); is_pdl $c3, float(5,6,7); $x++; is_pdl $c3, float(6,6,7); } { my $coords = float([0,-1,0], [-1,-1,-2], [3,5,2], [2,1,-3], [1,3,1], [1,1,2]); my $from = indx([0,1,2,3,4,4,4,5,5,5]); my $to = indx([1,2,3,1,0,2,3,0,1,2]); is_pdl repulse($coords,3,5000,-100,-5,-0.1,0.01), float('[-19.9785 -83.469 27.7307; -75.2499 -57.671 -78.2403; 57.7644 92.1679 42.674; 47.2407 6.71818 -93.5201; -15.8246 75.1071 8.60458; 6.04795 -32.8531 92.7511]'), {atol=>1e-2}; is_pdl attract($coords,$from,$to,1,30,1), float('[172.197 779.117 199.115; 2054.32 2486.76 1963.34; -2004.3 -3652.66 -2542.66; -300.804 1010.14 1942.27; 211.198 -700.071 -680.188; -132.611 76.7175 -881.878]'), {atol=>1e-2}; } done_testing; PDL-2.100/t/ppt-03_name_munging.t0000644000175000017500000000141414744321614016266 0ustar osboxesosboxes# Boilerplate use strict; use warnings; package My::Foo; use PDL::LiteF; use PDL::Parallel::threads qw(retrieve_pdls); use Test::More; use Test::Exception; use Test::PDL; sequence(20)->sqrt->share_as('test'); my $short_name = retrieve_pdls('test'); my $long_name; lives_ok { $long_name = retrieve_pdls('My::Foo/test') } 'Retrieving fully ' . 'resolved name does not croak (that is, they exist)'; is_pdl $short_name, $long_name, 'Regular names get auto-munged with the ' . 'current package name'; sequence(20)->share_as('??foo'); lives_ok { retrieve_pdls('??foo') } 'Basic retrieval with funny name works'; throws_ok { retrieve_pdls('My::Foo/??foo') } qr/retrieve_pdls could not find data associated with/ , 'Names with weird characters are not auto-munged'; done_testing; PDL-2.100/t/primitive-vector.t0000644000175000017500000004411414740772324016037 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::PDL; subtest 'cmpvec' => sub { is_pdl pdl( 1, 2, 3 )->cmpvec( pdl( 3, 2, 1 ) ), sbyte( -1 ), 'less'; is_pdl pdl( 3, 2, 1 )->cmpvec( pdl( 1, 2, 3 ) ), sbyte( 1 ), 'more'; is_pdl pdl( 3, 2, 1 )->cmpvec( pdl( 3, 2, 1 ) ), sbyte( 0 ), 'same'; is_deeply pdl('[1 BAD]')->cmpvec( pdl( 3, 2 ) )->unpdl, [-1], 'bad before'; is_deeply pdl('[BAD 1]')->cmpvec( pdl( 3, 2 ) )->unpdl, ['BAD'], 'bad'; my $vdim = 4; my $v1 = zeroes($vdim); my $v2 = pdl($v1); $v2->set( -1, 1 ); ok $v1->cmpvec($v2) < 0, "1d:<"; ok $v2->cmpvec($v1) > 0, "1d:>"; is $v1->cmpvec($v1)->sclr, 0, "1d:=="; }; subtest 'eqvec' => sub { is_pdl pdl( 3, 2, 1 )->eqvec( pdl( 1, 2, 3 ) ), sbyte( 0 ), 'diff'; is_pdl pdl( 3, 2, 1 )->eqvec( pdl( 3, 2, 1 ) ), sbyte( 1 ), 'same'; is_deeply pdl('[2 1 BAD]')->eqvec( pdl( 1, 3, 2 ) )->unpdl, ['BAD'], 'bad before'; is_deeply pdl('[2 BAD 1]')->eqvec( pdl( 2, 3, 2 ) )->unpdl, ['BAD'], 'bad'; }; subtest 'uniqvec' => sub { is_deeply pdl( [ [ 0, 1 ], [ 2, 2 ], [ 0, 1 ] ] )->uniqvec->unpdl, [ [ 0, 1 ], [ 2, 2 ] ], '2x3'; is_deeply pdl( [ [ 0, 1 ] ] )->uniqvec->unpdl, [ [ 0, 1 ] ], '1x2'; is_deeply pdl( [ [ 0, 1, 2 ], [ 0, 1, 2 ], [ 0, 1, 2 ], ] )->uniqvec->unpdl, [ [ 0, 1, 2 ] ], '3x3'; }; subtest 'qsortvec' => sub { my $p2d = pdl( [ [ 1, 2 ], [ 3, 4 ], [ 1, 3 ], [ 1, 2 ], [ 3, 3 ] ] ); is_pdl $p2d->qsortvec, my $p2de = pdl( [ [ 1, 2 ], [ 1, 2 ], [ 1, 3 ], [ 3, 3 ], [ 3, 4 ] ] ), "qsortvec"; is_pdl $p2d->dice_axis( 1, $p2d->qsortveci ), $p2de, "qsortveci"; }; subtest 'vsearchvec' => sub { my $which = pdl( long, [ [ 0, 0 ], [ 0, 0 ], [ 0, 1 ], [ 0, 1 ], [ 1, 0 ], [ 1, 0 ], [ 1, 1 ], [ 1, 1 ] ] ); my $find = $which->slice(",0:-1:2"); is_pdl $find->vsearchvec($which), indx([ 0, 2, 4, 6 ]), "match"; is_pdl pdl( [ -1, -1 ] )->vsearchvec($which), indx(0), "<<"; is_pdl pdl( [ 2, 2 ] )->vsearchvec($which), indx($which->dim(1)-1), ">>"; }; subtest 'unionvec' => sub { my $vtype = long; my $universe = pdl( $vtype, [ [ 0, 0 ], [ 0, 1 ], [ 1, 0 ], [ 1, 1 ] ] ); my $v1 = $universe->dice_axis( 1, pdl( [ 0, 1, 2 ] ) ); my $v2 = $universe->dice_axis( 1, pdl( [ 1, 2, 3 ] ) ); my ( $c, $nc ) = $v1->unionvec($v2); is_pdl $c, pdl($vtype, [ [0,0], [0,1], [1,0], [1,1], [0,0], [0,0] ]), "list:c"; is $nc, $universe->dim(1), "list:nc"; my $cc = $v1->unionvec($v2); is_pdl $cc, $universe, "scalar"; }; subtest 'intersectvec' => sub { my $vtype = long; my $universe = pdl( $vtype, [ [ 0, 0 ], [ 0, 1 ], [ 1, 0 ], [ 1, 1 ] ] ); my $v1 = $universe->dice_axis( 1, pdl( [ 0, 1, 2 ] ) ); my $v2 = $universe->dice_axis( 1, pdl( [ 1, 2, 3 ] ) ); my ( $c, $nc ) = $v1->intersectvec($v2); is_pdl $c, pdl( $vtype, [ [ 0, 1 ], [ 1, 0 ], [ 0, 0 ] ] ), "list:c"; is $nc->sclr, 2, "list:nc"; my $cc = $v1->intersectvec($v2); is_pdl $cc, $universe->slice(",1:2"), "scalar"; }; subtest 'setdiffvec' => sub { my $vtype = long; my $universe = pdl( $vtype, [ [ 0, 0 ], [ 0, 1 ], [ 1, 0 ], [ 1, 1 ] ] ); my $v1 = $universe->dice_axis( 1, pdl( [ 0, 1, 2 ] ) ); my $v2 = $universe->dice_axis( 1, pdl( [ 1, 2, 3 ] ) ); my ( $c, $nc ) = $v1->setdiffvec($v2); is_pdl $c, pdl( $vtype, [ [ 0, 0 ], [ 0, 0 ], [ 0, 0 ] ] ), "list:c"; is $nc, 1, "list:nc"; my $cc = $v1->setdiffvec($v2); is_pdl $cc, pdl( $vtype, [ [ 0, 0 ] ] ), "scalar"; }; subtest '*_sorted' => sub { my $all = sequence(20); my $amask = ( $all % 2 ) == 0; my $bmask = ( $all % 3 ) == 0; my $alpha = $all->where($amask); my $beta = $all->where($bmask); is_pdl scalar($alpha->union_sorted($beta)), $all->where( $amask | $bmask ), "union_sorted"; is_pdl scalar($alpha->intersect_sorted($beta)), $all->where( $amask & $bmask ), "intersect_sorted"; is_pdl scalar($alpha->setdiff_sorted($beta)), $all->where( $amask & $bmask->not ), "setdiff_sorted"; }; ##-------------------------------------------------------------- ## dim-checks and implicit broadcast dimensions ## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 subtest 'broadcast_dimensions' => sub { ##-- unionvec my $empty = zeroes( 3, 0 ); my $uw = pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ] ] ); my $wx = pdl( [ [ 1, 2, 3 ], [ 4, 5, 6 ] ] ); my $xy = pdl( [ [ 4, 5, 6 ], [ 7, 8, 9 ] ] ); # unionvec: basic is_pdl scalar( $uw->unionvec($wx) ), pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ], [ 4, 5, 6 ] ] ), "unionvec - broadcast dims - uw+wx"; is_pdl scalar( $uw->unionvec($xy) ), pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ], [ 4, 5, 6 ], [ 7, 8, 9 ] ] ), "unionvec - broadcast dims - uw+xy"; is_pdl scalar( $empty->unionvec($wx) ), $wx, "unionvec - broadcast dims - 0+wx"; is_pdl scalar( $wx->unionvec($empty) ), $wx, "unionvec - broadcast dims - wx+0"; is_pdl scalar( $empty->unionvec($empty) ), $empty, "unionvec - broadcast dims - 0+0"; # unionvec: broadcasting my $k = 2; my $kempty = $empty->slice(",,*$k"); my $kuw = $uw->slice(",,*$k"); my $kwx = $wx->slice(",,*$k"); my $kxy = $xy->slice(",,*$k"); is_pdl scalar( $kuw->unionvec($wx) ), pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ], [ 4, 5, 6 ] ] )->slice(",,*$k"), "unionvec - broadcast dims - uw(*k)+wx"; is_pdl scalar( $kuw->unionvec($xy) ), pdl( [ [-3,-2,-1], [1,2,3], [4,5,6], [7,8,9] ] )->slice(",,*$k"), "unionvec - broadcast dims - uw(*k)+xy"; is_pdl scalar( $kempty->unionvec($wx) ), $kwx, "unionvec - broadcast dims - 0(*k)+wx"; is_pdl scalar( $kwx->unionvec($empty) ), $kwx, "unionvec - broadcast dims - wx(*k)+0"; is_pdl scalar( $kempty->unionvec($empty) ), $kempty, "unionvec - broadcast dims - 0(*k)+0"; ##-- intersectvec my $needle0 = pdl( [ [ -3, -2, -1 ] ] ); my $needle1 = pdl( [ [ 1, 2, 3 ] ] ); my $needles = pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ] ] ); my $haystack = pdl( [ [ 1, 2, 3 ], [ 4, 5, 6 ], [ 7, 8, 9 ], [ 10, 11, 12 ] ] ); # intersectvec: basic is_pdl scalar( $needle0->intersectvec($haystack) ), $empty, "intersectvec - broadcast dims - needle0&haystack"; is_pdl scalar( $needle1->intersectvec($haystack) ), $needle1, "intersectvec - broadcast dims - needle1&haystack"; is_pdl scalar( $needles->intersectvec($haystack) ), $needle1, "intersectvec - broadcast dims - needles&haystack"; is_pdl scalar( $haystack->intersectvec($haystack) ), $haystack, "intersectvec - broadcast dims - haystack&haystack"; is_pdl scalar( $haystack->intersectvec($empty) ), $empty, "intersectvec - broadcast dims - haystack&empty"; is_pdl scalar( $empty->intersectvec($haystack) ), $empty, "intersectvec - broadcast dims - empty&haystack"; # intersectvec: broadcasting my $kneedle0 = $needle0->slice(",,*$k"); my $kneedle1 = $needle1->slice(",,*$k"); my $kneedles = pdl( [ [ [ -3, -2, -1 ] ], [ [ 1, 2, 3 ] ] ] ); my $khaystack = $haystack->slice(",,*$k"); is_pdl scalar( $kneedle0->intersectvec($haystack) ), $kempty, "intersectvec - broadcast dims - needle0(*k)&haystack"; is_pdl scalar( $kneedle1->intersectvec($haystack) ), $kneedle1, "intersectvec - broadcast dims - needle1(*k)&haystack"; is_pdl scalar( $kneedles->intersectvec($haystack) ), pdl( [ [ [ 0, 0, 0 ] ], [ [ 1, 2, 3 ] ] ] ), "intersectvec - broadcast dims - needles(*k)&haystack"; is_pdl scalar( $khaystack->intersectvec($haystack) ), $khaystack, "intersectvec - broadcast dims - haystack(*k)&haystack"; is_pdl scalar( $khaystack->intersectvec($empty) ), $kempty, "intersectvec - broadcast dims - haystack(*k)&empty"; is_pdl scalar( $kempty->intersectvec($haystack) ), $kempty, "intersectvec - broadcast dims - empty(*k)&haystack"; # setdiffvec: basic is_pdl scalar( $haystack->setdiffvec($needle0) ), $haystack, "setdiffvec - broadcast dims - haystack-needle0"; is_pdl scalar( $haystack->setdiffvec($needle1) ), $haystack->slice(",1:-1"), "setdiffvec - broadcast dims - haystack-needle1"; is_pdl scalar( $haystack->setdiffvec($needles) ), $haystack->slice(",1:-1"), "setdiffvec - broadcast dims - haystack-needles"; is_pdl scalar( $haystack->setdiffvec($haystack) ), $empty, "setdiffvec - broadcast dims - haystack-haystack"; is_pdl scalar( $haystack->setdiffvec($empty) ), $haystack, "setdiffvec - broadcast dims - haystack-empty"; is_pdl scalar( $empty->setdiffvec($haystack) ), $empty, "setdiffvec - broadcast dims - empty-haystack"; # setdiffvec: broadcasting is_pdl scalar( $khaystack->setdiffvec($needle0) ), $khaystack, "setdiffvec - broadcast dims - haystack(*k)-needle0"; is_pdl scalar( $khaystack->setdiffvec($needle1) ), $khaystack->slice(",1:-1,"), "setdiffvec - broadcast dims - haystack(*k)-needle1"; is_pdl scalar( $khaystack->setdiffvec($needles) ), $khaystack->slice(",1:-1,"), "setdiffvec - broadcast dims - haystack(*k)-needles"; is_pdl scalar( $khaystack->setdiffvec($haystack) ), $kempty, "setdiffvec - broadcast dims - haystack(*k)-haystack"; is_pdl scalar( $khaystack->setdiffvec($empty) ), $khaystack, "setdiffvec - broadcast dims - haystack(*k)-empty"; is_pdl scalar( $kempty->setdiffvec($haystack) ), $kempty, "setdiffvec - broadcast dims - empty(*k)-haystack"; }; ## see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 subtest intersect_implicit_dims => sub { # intersectvec: from ETJ/mohawk2 a la https://stackoverflow.com/a/71446817/3857002 my $toto = pdl( [ 1, 2, 3 ], [ 4, 5, 6 ] ); my $titi = pdl( 1, 2, 3 ); my $notin = pdl( 7, 8, 9 ); is_pdl scalar intersectvec( $titi, $toto ), pdl([ [ 1, 2, 3 ] ]), 'intersectvec - implicit dims - titi&toto'; is_pdl scalar intersectvec( $notin, $toto ), zeroes( 3, 0 ), 'intersectvec - implicit dims - notin&toto'; is_pdl scalar intersectvec( $titi->dummy(1), $toto ), pdl([ [ 1, 2, 3 ] ]), 'intersectvec - implicit dims - titi(*1)&toto'; is_pdl scalar intersectvec( $notin->dummy(1), $toto ), zeroes( 3, 0 ), 'intersectvec - implicit dims - notin(*1)&toto'; my $needle0_in = pdl( [ 1, 2, 3 ] ); # 3 my $needle0_notin = pdl( [ 9, 9, 9 ] ); # 3 my $needle_in = $needle0_in->dummy(1); # 3x1: [[1 2 3]] my $needle_notin = $needle0_notin->dummy(1); # 3x1: [[-3 -2 -1]] my $needles = pdl( [ [ 1, 2, 3 ], [ 9, 9, 9 ] ] ) ; # 3x2: $needle0_in->cat($needle0_notin) my $haystack = pdl( [ [ 1, 2, 3 ], [ 4, 5, 6 ] ] ); # 3x2 sub intersect_ok { my ( $label, $a, $b, $c_want, $nc_want, $c_sclr_want ) = @_; my ( $c, $nc ) = intersectvec( $a, $b ); my $c_sclr = intersectvec( $a, $b ); is_pdl $c, pdl($c_want), "$label - result"; is_pdl $nc, pdl(indx,$nc_want),"$label - counts"; is_pdl $c_sclr, pdl($c_sclr_want), "$label - scalar"; } intersect_ok( 'intersectvec - implicit dims - needle0_in&haystack', $needle0_in, $haystack, [ [ 1, 2, 3 ] ], 1, [ [ 1, 2, 3 ] ] ); intersect_ok( 'intersectvec - implicit dims - needle_in&haystack', $needle_in, $haystack, [ [ 1, 2, 3 ] ], 1, [ [ 1, 2, 3 ] ] ); intersect_ok( 'intersectvec - implicit dims - needle0_notin&haystack', $needle0_notin, $haystack, [ [ 0, 0, 0 ] ], 0, zeroes( 3, 0 ) ); intersect_ok( 'intersectvec - implicit dims - needle_notin&haystack', $needle_notin, $haystack, [ [ 0, 0, 0 ] ], 0, zeroes( 3, 0 ) ); intersect_ok( 'intersectvec - implicit dims - needles&haystack', $needles, $haystack, [ [ 1, 2, 3 ], [ 0, 0, 0 ] ], 1, [ [ 1, 2, 3 ] ] ); # now we want to know whether each needle is "in" one by one, not really # a normal intersect, so we insert a dummy in haystack in order to broadcast # the "nc" needs to come back as a 4x2 my $needles8 = pdl( [ [ [ 1, 2, 3 ], [ 4, 5, 6 ], [ 8, 8, 8 ], [ 8, 8, 8 ] ], [ [ 4, 5, 6 ], [ 9, 9, 9 ], [ 1, 2, 3 ], [ 9, 9, 9 ] ] ] ); # 3x4x2 # need to manipulate above into suitable inputs for intersect to get right output # + dummy dim here also ensures singleton query-vector-sets are (trivially) sorted my $needles8x = $needles8->slice(",*1,,"); # 3x*x4x2 # dummy of size 1 inserted in dim 1 # haystack: no changes needed; don't need same number of dims, broadcast engine will add dummy/1s at top my $haystack8 = $haystack; my $c_want8 = [ [ [ [ 1, 2, 3 ] ], [ [ 4, 5, 6 ] ], [ [ 0, 0, 0 ] ], [ [ 0, 0, 0 ] ] ], [ [ [ 4, 5, 6 ] ], [ [ 0, 0, 0 ] ], [ [ 1, 2, 3 ] ], [ [ 0, 0, 0 ] ] ], ]; my $nc_want8 = [ [ 1, 1, 0, 0 ], [ 1, 0, 1, 0 ] ]; intersect_ok( 'intersectvec - implicit dims - needles8x&haystack8', $needles8x, $haystack8, $c_want8, $nc_want8, $c_want8 ); }; ## dim-checks and implicit broadcast dimensions ## + analogous to https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 subtest v_broadcast_dimensions => sub { # data: basic my $empty = zeroes(0); my $v1_2 = pdl( [ 1, 2 ] ); my $v3_4 = pdl( [ 3, 4 ] ); my $v1_4 = $v1_2->cat($v3_4)->flat; # data: broadcasting my $k = 2; my $kempty = $empty->slice(",*$k"); my $kv1_2 = $v1_2->slice(",*$k"); my $kv3_4 = $v3_4->slice(",*$k"); my $kv1_4 = $v1_4->slice(",*$k"); #-- union_sorted is_pdl scalar( $v1_2->union_sorted($v3_4) ), $v1_4, "union_sorted - broadcast dims - 12+34"; is_pdl scalar( $v3_4->union_sorted($v1_4) ), $v1_4, "union_sorted - broadcast dims - 34+1234"; is_pdl scalar( $empty->union_sorted($v1_4) ), $v1_4, "union_sorted - broadcast dims - 0+1234"; is_pdl scalar( $v1_4->union_sorted($empty) ), $v1_4, "union_sorted - broadcast dims - 1234+0"; is_pdl scalar( $empty->union_sorted($empty) ), $empty, "union_sorted - broadcast dims - 0+0"; # is_pdl scalar( $kv1_2->union_sorted($v3_4) ), $kv1_4, "union_sorted - broadcast dims - 12(*k)+34"; is_pdl scalar( $kv3_4->union_sorted($v1_4) ), $kv1_4, "union_sorted - broadcast dims - 34(*k)+1234"; is_pdl scalar( $kempty->union_sorted($v1_4) ), $kv1_4, "union_sorted - broadcast dims - 0(*k)+1234"; is_pdl scalar( $kv1_4->union_sorted($empty) ), $kv1_4, "union_sorted - broadcast dims - 1234(*k)+0"; is_pdl scalar( $kempty->union_sorted($empty) ), $kempty, "union_sorted - broadcast dims - 0(*k)+0"; #-- intersect_sorted is_pdl scalar( $v1_2->intersect_sorted($v3_4) ), $empty, "intersect_sorted - broadcast dims - 12&34"; is_pdl scalar( $v3_4->intersect_sorted($v1_4) ), $v3_4, "intersect_sorted - broadcast dims - 34&1234"; is_pdl scalar( $empty->intersect_sorted($v1_4) ), $empty, "intersect_sorted - broadcast dims - 0&1234"; is_pdl scalar( $v1_4->intersect_sorted($empty) ), $empty, "intersect_sorted - broadcast dims - 1234&0"; is_pdl scalar( $empty->intersect_sorted($empty) ), $empty, "intersect_sorted - broadcast dims - 0&0"; # is_pdl scalar( $kv1_2->intersect_sorted($v3_4) ), $kempty, "intersect_sorted - broadcast dims - 12(*k)&34"; is_pdl scalar( $kv3_4->intersect_sorted($v1_4) ), $kv3_4, "intersect_sorted - broadcast dims - 34(*k)&1234"; is_pdl scalar( $kempty->intersect_sorted($v1_4) ), $kempty, "intersect_sorted - broadcast dims - 0(*k)&1234"; is_pdl scalar( $kv1_4->intersect_sorted($empty) ), $kempty, "intersect_sorted - broadcast dims - 1234(*k)&0"; is_pdl scalar( $kempty->intersect_sorted($empty) ), $kempty, "intersect_sorted - broadcast dims - 0(*k)&0"; #-- setdiff_sorted is_pdl scalar( $v1_2->setdiff_sorted($v3_4) ), $v1_2, "setdiff_sorted - broadcast dims - 12-34"; is_pdl scalar( $v3_4->setdiff_sorted($v1_4) ), $empty, "setdiff_sorted - broadcast dims - 34-1234"; is_pdl scalar( $v1_4->setdiff_sorted($empty) ), $v1_4, "setdiff_sorted - broadcast dims - 1234-0"; is_pdl scalar( $empty->setdiff_sorted($v1_4) ), $empty, "setdiff_sorted - broadcast dims - 0-1234"; is_pdl scalar( $empty->setdiff_sorted($empty) ), $empty, "setdiff_sorted - broadcast dims - 0-0"; # is_pdl scalar( $kv1_2->setdiff_sorted($v3_4) ), $kv1_2, "setdiff_sorted - broadcast dims - 12(*k)-34"; is_pdl scalar( $kv3_4->setdiff_sorted($v1_4) ), $kempty, "setdiff_sorted - broadcast dims - 34(*k)-1234"; is_pdl scalar( $kv1_4->setdiff_sorted($empty) ), $kv1_4, "setdiff_sorted - broadcast dims - 1234(*k)-0"; is_pdl scalar( $kempty->setdiff_sorted($v1_4) ), $kempty, "setdiff_sorted - broadcast dims - 0(*k)-1234"; is_pdl scalar( $kempty->setdiff_sorted($empty) ), $kempty, "setdiff_sorted - broadcast dims - 0(*k)-0"; }; subtest v_vcos => sub { my $a = pdl([[1,2,3,4],[1,2,2,1],[-1,-2,-3,-4]]); my $b = pdl([1,2,3,4]); my $c_want = pdl([1,0.8660254,-1]); ##-- 1..2: vcos: basic is_pdl $a->vcos($b), $c_want, {atol=>1e-4, test_name=>"vcos:flat"}; is_pdl $a->vcos($b->slice(",*3")), $c_want->slice(",*3"), {atol=>1e-4, test_name=>"vcos:broadcasted"}; ##-- 3: vcos: nullvec: a my $a0 = $a->pdl; my $nan = $^O =~ /MSWin32/i ? ((99**99)**99) - ((99**99)**99) : 'nan'; (my $tmp=$a0->slice(",1")) .= 0; is_pdl $a0->vcos($b), pdl([1,$nan,-1]), {atol=>1e-4, test_name=>"vcos:nullvec:a:nan"}; ##-- 4: vcos: nullvec: b my $b0 = $b->zeroes; ok all($a->vcos($b0)->isfinite->not), "vcos:nullvec:b:all-nan"; ##-- 5-6: bad values my $abad = $a->pdl->setbadif($a->abs==2); my $abad_cwant = pdl([0.93094,0.64549,-0.93094]); is_pdl $abad->vcos($b), $abad_cwant, {atol=>1e-4, test_name=>"vcos:bad:a"}; my $bbad = $b->pdl->setbadif($b->xvals==2); my $bbad_cwant = pdl([0.8366,0.6211,-0.8366]); is_pdl $a->vcos($bbad), $bbad_cwant, {atol=>1e-4, test_name=>"vcos:bad:b"}; }; done_testing; PDL-2.100/t/ppt-01_ref_counting.t0000644000175000017500000000223114727756302016307 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Parallel::threads qw(retrieve_pdls free_pdls); my $data = sequence(20); is($data->datasv_refcount, 1, "Data's initial refcount for normal ndarray is 1"); my $copy = $data; is($data->datasv_refcount, 1, "Shallow copy does not increase data's refcount"); $data->share_as('foo'); is($data->datasv_refcount, 2, "Sharing data increases data's refcount"); my $shallow = retrieve_pdls('foo'); is($data->datasv_refcount, 3, "Retrieving data increases data's refcount"); undef($shallow); is($data->datasv_refcount, 2, "Undef'ing retrieved copy decreases data's refcount"); undef($copy); is($data->datasv_refcount, 2, "Undef'ing one of two original copies does not decrease data's refcount"); undef($data); # At this point, there should be only one reference, but we can't actually # know because we don't have a reference to an ndarray to check! Get a new # shared copy: $shallow = retrieve_pdls('foo'); is($shallow->datasv_refcount, 2, "Getting rid of original does not destroy the data"); free_pdls('foo'); is($shallow->datasv_refcount, 1, "Freeing memory only decrements refcount by one"); done_testing; PDL-2.100/t/tp-eq_pdl.t0000644000175000017500000002623414727756302014422 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL; use Test::PDL qw( eq_pdl ); my @warns; $SIG{__WARN__} = sub {push @warns, @_}; sub run_eq_pdl { my $scalar = eq_pdl(@_); my @list = eq_pdl(@_); cmp_ok(scalar @list, '==', 3, 'eq_pdl() returns a list with two elements in list context'); cmp_ok $scalar, '==', $list[0], '... and first element matches the return value in scalar context'; return @list; } my $values_not_match = qr/values do not match/; my ( $got, $expected, $ok, $diag ); ( $ok, $diag ) = run_eq_pdl(); ok !$ok, 'rejects missing arguments'; is $diag, 'received value is not an ndarray'; $got = pdl( 9,-10 ); ( $ok, $diag ) = run_eq_pdl( $got ); ok !$ok, 'rejects missing arguments'; is $diag, 'expected value is not an ndarray'; $expected = 3; $got = 4; ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'rejects non-ndarray arguments'; is $diag, 'received value is not an ndarray'; $expected = 3; $got = long( 3,4 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'rejects non-ndarray arguments'; is $diag, 'expected value is not an ndarray'; $expected = short( 1,2 ); $got = -2; ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'rejects non-ndarray arguments'; is $diag, 'received value is not an ndarray'; $expected = long( 3,4 ); $got = pdl( 3,4 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected, { require_equal_types => 0 } ); ok $ok, 'all else being equal, compares equal on differing types when \'require_equal_types\' is false'; is $diag, ''; $expected = long( 3,4 ); $got = pdl( 3,4 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected, { require_equal_types => 1 } ); ok !$ok, 'catches type mismatch, but only when \'require_equal_types\' is true'; is $diag, 'types do not match (\'require_equal_types\' is true)'; $expected = long( 3 ); $got = long( 3,4 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'catches dimensions mismatches (number of dimensions)'; is $diag, 'dimensions do not match in number'; $expected = zeroes( double, 3,4 ); $got = zeroes( double, 3,4,1 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'does not treat degenerate dimensions specially'; is $diag, 'dimensions do not match in number'; $expected = long( [ [3,4],[1,2] ] ); $got = long( [ [3,4,5], [1,2,3] ] ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'catches dimensions mismatches (extent of dimensions)'; is $diag, 'dimensions do not match in extent'; $expected = long( 4,5,6,-1,8,9 )->inplace->setvaltobad( -1 ); $got = long( 4,5,6,7,-1,9 )->inplace->setvaltobad( -1 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'catches bad value pattern mismatch'; like $diag, $values_not_match; $expected = long( 4,5,6,7,8,9 ); $got = long( 4,5,6,7,-8,9 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'catches value mismatches for integer data'; like $diag, $values_not_match; $expected = pdl( 4,5,6,7,8,9 ); $got = pdl( 4,5,6,7,-8,9 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'catches value mismatches for floating-point data'; like $diag, $values_not_match; $expected = pdl( 4,5,6,7,8,9 ); $got = pdl( 4,5,6,7,8.001,9 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'approximate comparison for floating-point data fails correctly at documented default tolerance of 1e-6'; like $diag, $values_not_match; $expected = pdl( 4,5,6,7,8,9 ); $got = pdl( 4,5,6,7,8.0000001,9 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok $ok, 'approximate comparison for floating-point data succeeds correctly at documented default tolerance of 1e-6'; is $diag, ''; $expected = pdl( 4,5,6,7,8,9 ); $got = pdl( 4,5,6,7,8.001,9 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-2 } ); ok $ok, 'approximate comparison for floating-point data succeeds correctly at user-specified tolerance of 1e-2'; is $diag, ''; $expected = pdl( 0,1,2,3,4 ); $got = sequence 5; ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok $ok, 'succeeds when it should succeed'; is $diag, ''; $expected = null; $got = null; ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok $ok, 'null == null'; is $diag, ''; $got = zeroes(0,3); $expected = zeroes(0,2); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'differently-shaped empties are different'; is $diag, 'dimensions do not match in extent'; $got = zeroes(0); $expected = null; ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok $ok, 'null == empty'; is $diag, ''; $expected = null; $got = pdl( 1,2,3 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'pdl( ... ) != null'; is $diag, 'dimensions do not match in extent'; $expected = pdl( 1,2,3 ); $got = null; ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok !$ok, 'null != pdl( ... )'; is $diag, 'dimensions do not match in extent'; ################################################################################ note 'mixed-type comparisons'; $expected = double( 0,1,2.001,3,4 ); $got = long( 0,1,2,3,4 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-2, require_equal_types => 0 } ); ok $ok, 'succeeds correctly for long/double'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-6, require_equal_types => 0 } ); ok !$ok, 'fails correctly for long/double'; like $diag, $values_not_match; $expected = short( 0,1,2,3,4 ); $got = float( 0,1,2.001,3,4 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-2, require_equal_types => 0 } ); ok $ok, 'succeeds correctly for float/short'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-6, require_equal_types => 0 } ); ok !$ok, 'fails correctly for float/short'; like $diag, $values_not_match; $expected = float( 0,-1,2.001,3,49999.998 ); $got = double( 0,-0.9999,1.999,3,49999.999 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-2, require_equal_types => 0 } ); ok $ok, 'succeeds correctly for double/float'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-6, require_equal_types => 0 } ); ok !$ok, 'fails correctly for double/float'; like $diag, $values_not_match; ################################################################################ note 'tests with values of significantly different magnitudes, no zeroes'; $expected = double( 1e+3, 1, 1e-3 ); $got = double( 1.001e+3, 1.001, 1.001e-3 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 0.999, rtol => 0 } ); ok !$ok, 'still fails with an absolute tolerance of 0.999'; like $diag, $values_not_match; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1, rtol => 0 } ); ok $ok, 'passes with an absolute tolerance of 1'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-4, rtol => 0 } ); ok !$ok, 'fails for case with different magnitudes and pure absolute tolerance of 1e-4'; like $diag, $values_not_match; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-2, rtol => 0 } ); ok !$ok, 'still fails with an absolute tolerance of 1e-2'; like $diag, $values_not_match; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 10, rtol => 0 } ); ok $ok, 'needs an absolute tolerance of 10 to pass'; is $diag, ''; # notice the other values that are way off ... ( $ok, $diag ) = run_eq_pdl( double( 1.001e+3, 9, 9 ), $expected, { atol => 10, rtol => 0 } ); ok $ok, '... and this leads to large errors in the smaller components'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 0, rtol => 1e-4 } ); ok !$ok, 'should not pass with a pure relative tolerance of 1e-4'; like $diag, $values_not_match; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 0, rtol => 1e-2 } ); ok $ok, 'but passes with a pure relative tolerance of 1e-2'; is $diag, ''; ################################################################################ note 'tests with values of significantly different magnitudes, with zeroes'; $expected = double( 1e+3, 1, 1e-9, 0 ); $got = double( 1.00001e+3, .99999, 1.00001e-9, 1e-5 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 0, rtol => 1e-6 } ); ok !$ok, 'fails at pure relative tolerance of 1e-6'; like $diag, $values_not_match; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 0, rtol => 1e-4 } ); ok !$ok, 'but also fails at pure relative tolerance of 1e-4'; like $diag, $values_not_match; ( $ok, $diag ) = run_eq_pdl( $got, $expected, { atol => 1e-4, rtol => 1e-4 } ); ok $ok, 'needs both absolute and relative tolerances to pass'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( double( 1e+3, 1, 0.001, 0 ), $expected, { atol => 1e-4, rtol => 1e-4 } ); ok !$ok, 'combination of relative and absolute tolerances avoids large relative errors in small components'; # (provided atol is not too high) like $diag, $values_not_match; ################################################################################ note 'test perfect equality'; ( $ok, $diag ) = run_eq_pdl( pdl(1), pdl(1), { atol => 1e-10 } ); ok $ok, 'perfectly equal ndarrays should always pass'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( pdl(0), pdl(0), { atol => 1e-10 } ); ok $ok, 'perfectly equal ndarrays should always pass'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( pdl(0), pdl(0), { rtol => 1e-10 } ); ok $ok, 'perfectly equal ndarrays should always pass'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( pdl(-1e20), pdl(-1e20), { atol => 1e-10 } ); ok $ok, 'perfectly equal ndarrays should always pass'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( pdl(-1e-20), pdl(-1e-20), { atol => 1e-10 } ); ok $ok, 'perfectly equal ndarrays should always pass'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( double( 0,0,0 ), double( 0,0,0 ), { atol => 1e-10 } ); ok $ok, 'perfectly equal ndarrays should always pass'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( double( 0,0,0 ), double( 0,0,0 ), { rtol => 1e-10 } ); ok $ok, 'perfectly equal ndarrays should always pass'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( double( 0,0,0 ), double( 0,0,0 ), { atol => 1e-10, rtol => 1e-10 } ); ok $ok, 'perfectly equal ndarrays should always pass'; is $diag, ''; ################################################################################ note 'test tolerance "sharpness"'; ( $ok, $diag ) = run_eq_pdl( double(1.99), double(1), { atol => 0, rtol => 1 } ); ok $ok, 'passes correctly within tolerance'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( double(1.99), double(1), { atol => 1, rtol => 0 } ); ok $ok, 'passes correctly within tolerance'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( double(1.99), double(1), { atol => 1, rtol => 1 } ); ok $ok, 'passes correctly within tolerance'; is $diag, ''; ( $ok, $diag ) = run_eq_pdl( double(2.01), double(1), { atol => 0, rtol => 1 } ); ok !$ok, 'fails correctly just outside of tolerance'; like $diag, $values_not_match; ( $ok, $diag ) = run_eq_pdl( double(2.01), double(1), { atol => 1, rtol => 0 } ); ok !$ok, 'fails correctly just outside of tolerance'; like $diag, $values_not_match; ( $ok, $diag ) = run_eq_pdl( double(2.01), double(1), { atol => 1, rtol => 1 } ); ok !$ok, 'combined tolerances should not yield a larger comparison margin'; like $diag, $values_not_match; ################################################################################ note 'miscellaneous'; $expected = long( 4,5,6,7,8,9 ); $expected->badflag( 1 ); $got = long( 4,5,6,7,8,9 ); $got->badflag( 0 ); ( $ok, $diag ) = run_eq_pdl( $got, $expected ); ok $ok, "isn't fooled by differing badflags"; is $diag, ''; is "@warns", "", "no warnings"; done_testing; PDL-2.100/t/m51.fits.fz0000644000175000017500000043120014727756302014250 0ustar osboxesosboxesSIMPLE = T / file does conform to FITS standard BITPIX = 16 / number of bits per data pixel NAXIS = 0 / number of data axes EXTEND = T / FITS dataset may contain extensions COMMENT FITS (Flexible Image Transport System) format is defined in 'AstronomyCOMMENT and Astrophysics', volume 376, page 359; bibcode: 2001A&A...376..359H CHECKSUM= '4hD84ZA54fA54ZA5' / HDU checksum updated 2021-12-26T23:11:03 DATASUM = ' 0' / data unit checksum updated 2021-12-26T23:11:03 END XTENSION= 'BINTABLE' / binary table extension BITPIX = 8 / 8-bit bytes NAXIS = 2 / 2-dimensional binary table NAXIS1 = 8 / width of table in bytes NAXIS2 = 384 / number of rows in table PCOUNT = 131630 / size of special data area GCOUNT = 1 / one data group (required keyword) TFIELDS = 1 / number of fields in each row TTYPE1 = 'COMPRESSED_DATA' / label for field 1 TFORM1 = '1PB(373)' / data format of field: variable length array ZIMAGE = T / extension contains compressed image ZTILE1 = 384 / size of tiles to be compressed ZTILE2 = 1 / size of tiles to be compressed ZCMPTYPE= 'RICE_1 ' / compression algorithm ZNAME1 = 'BLOCKSIZE' / compression block size ZVAL1 = 32 / pixels per block ZNAME2 = 'BYTEPIX ' / bytes per pixel (1, 2, 4, or 8) ZVAL2 = 4 / bytes per pixel (1, 2, 4, or 8) EXTNAME = 'COMPRESSED_IMAGE' ZSIMPLE = T / Created with PDL (http://pdl.perl.org) ZBITPIX = 32 ZNAXIS = 2 ZNAXIS1 = 384 ZNAXIS2 = 384 BUNIT = 'Massaged Data Value' CDELT1 = 0.01 CDELT2 = 0.01 CRPIX1 = 182.5 CRPIX2 = 192 CRVAL1 = 0 CRVAL2 = 0 CTYPE1 = 'X' CTYPE2 = 'Y' CUNIT1 = 'Arcmin' CUNIT2 = 'Arcmin' OBJECT = 'm51 log-scaled' ORIGIN = 'Hubble Heritage project' RA = '13:29:24.00' / RIGHT ASCENSION TELESCOP= 'Hubble WF/PIC2' DEC = '47:15:34.00' / DECLINATION HISTORY 9-Dec-2003: Reduced from Hubble Heritage image CROTA2 = 360 CHECKSUM= 'DPkiEPjfDPjfDPjf' / HDU checksum updated 2021-12-26T23:11:03 DATASUM = '1750720547' / data unit checksum updated 2021-12-26T23:11:03 END %.C-q302C38 v@ 8 : &E`DGD0FtGKDLBPB"IdFFY 9S!O"O$4S%d&S(:U)^*c,@b-`/\0eZ1a3X4|_5d73b8g9d;`b<e>&e?o@jB_gC_E0iFoGdIg^J^L)iMaNbPQ_QUSbTgaUcW*\XWY][@]\W]X_Q]``bZcf[dRf[gmQhajZkzRlYn&PoTp]r#Vs`t\v6[w\xbzIg{c}k~uekE]f gs[^5X[ZFS^KQMHR1SUO+NzXQ OqRRWdSYLgIRMNRYXFZRSJQ[KIRPL6^YU9]^^I_§cdihf5gɛjglmf@bЦbbjh`4lהdcdfe-`ޒahShi#bbjP_aaz`f;^a_`ZmgfdSha_ab@l[^i\Y#f |` \ B_ cm`mj:]dceig1kpZs[[!(Z"i#_%Ff&b( \)mr*d,;e-d/u0hd1d3Ab4X6a7_c8g:#f;h<l>Xf?cA*cB]CeEMeFhHbIdJTLEWMaN`PQiQbScT|`U_W?eX]Z][`[\[^f_s^`Vb7]c^dSfHWg\h[jNikfmgnxfoXqE^rUsVuPYvRweyQ^z\|]}pe~^2[VNAWXO>QQY/QTT-U]_3UTc;UYULX^cW]ZYq`S*R}YX(aZV;RWN:K^Z1aYSEVZ`H_UZ\`Ķ\RrQT^iJH?YFИKG)ApAձAM3>ـEھ<G?Aކ3862Ch9>C"@eJ;>*?h=<+ 1K)|3/'#. Q%q%'$*I H $I"!V+u{" 3ûI-xFW$Ńp4ZV8kݡM9VE !`pL CB jv%DŽ{)m|G˼  .2%FI8.twHLR2UL)yL8z4̾w[b 0 =-{-sͩDM| uB$I $ÞOd MY\g H& "7@331UT@UG"8 HfiBqL+.Sp5vP;)D4 [6 JmB" n`El*xvNƚY^33'ÂeI^g4|fH/)6 @qI':ƃ=&-EAA@#x̊ddT}`m4^'@W; YzOF*`UP*(@PP$DGDDF+ѤqOF8Hl&b"DDA 33 ,!9B ok1b]0颅 Clzҁ5e($ت9wpDXBxyġ@,F3A#Y>(=30iTR=Fk/Rpi"jr`jci#Z ŇbG gIxbgRX\%N D"!ݱ;זkE{ HIV@ eUU5R{/yI2Q6[汁[+E^VȡDQ"f[駮u1 [5e,Bhٚ7-YK'Fucc3{?nٽpWM)ZqVI!Ff!0" g-q#fb͏^QC`RxW+rwi$ %w=kg/G-k)FwAGD X$u3Vy1@lup pVy2 1b ^↬F693XTCX< fŒ /m1*Rӫt QYqmI,cd̟ҐPۛ㖧 Yn9DE[,VT<B(Ϣ Z7psH>ީٹQ]ve. , sO]#w 2 sŒEAcFA* [v|@l4x^N`@ ^ \DzRx$=ʁPl؍ø8h#CTǘb,Z^D6+ 0`R*VϔJƠ6X\=3y$@YT-l2_l3(ś B!ͬł9$4j R/"SSZJ-qSu?%)&T#"EG9AW՟j3ָI*٩l=nfXPO=l#|#UY rypMh9dI$f`1pU""R>~ 6yR&":^1-E͚ / T@fbL.Lv><{0 Gc{Hθ~g2&πQ76n H, dHAqFs@j+_慲!Bll<4 UC8L66_KAY{)(&[ᰠ1Xp su]c4.z ziQ >Ųr*`-kZ{}b˼RWˣn[ `KDpXS>7!mdo%' >bV'(T@om3nV*0S/,7CG@ޕ@oTVj|.ƨV`noE΍F[i2Wk2jѦ/ıP@ݪ1 TDYX$jQ C^DlDDD@Ay;C=)G\ J7GfO P c j?uaj`Ad[,&yZsyҜuz,b& RKU&7,]I/$8mV)bbOYḇa+8nT<`NJ 9C/̖grep m֬J OIx#)"~cԴ*e9c 5*&wֺNRWW*1 ːNB>IVY##OHkb"""""48l %|`!8 ^/$Pa$רd zO],7JUO=h"qARttpR9BKkD]|8+Rwg [bYX&V$3IĴWʟ^ɸHcKhVHM\^Fh щW5t)HG|\;4 5UJ8-CIDnτ&{d%_E.GƝ"-ġ A@޻A,θ+H/J:Gj)*"7c@@XXx93PH`0dTwe=ck#ag(rё rl,6Q嶩CkoiY5!-$\$L$-eԏw{-en06Y}ĶVd_( ~}i_v̛T-S-jzU娪6'⊷_¯),@@.2plpkWx%uD!i&p w*ZX7$s/t fJ;^Fu( kfCւP0Q!=JVTa 9Hqkbqjwt@8b}(͢H&:,fj^gƹ 1|A@t:2: kY/Owp(I$0wV#VHzaID@ r^EI,wvK}\Xb I% s$AHX0a9 A`زbhj3"F]Æp/Nrm޻uC)2YzrVwzG]a +4{LJ()ԑLFTAe{2_2nHn|I&514GmLL w"jK ^ȦIƷTDu:`a&ƃ.8(Pc^5a d3*2'ai|3q`@&ҟ~2q\v#`Ϋ8-{(F9UZD#L/*2^u5=xsfFDz`ӌ=HQhKKl0~o4qu0r* aj"$A+F{76,0`e)Ao24D aLXZ,4ʻ `!}k,%qD@"1* >93RƇ p0(VH}Elhop1 uq4tJ`ʓC6К ȇu;L4C<-5gTS*M&͉[ ?I$~=YNYj-ֿb&h*r-KgDj8>`ZHM>^2'@|>:i>D9.">wXdئBؘ )GAq zy:kmH% 7R8 ) u@L@UG$Qiybj -S"y <9$Oг}ZA| ,b#7_K |AZ[eIFc\FYj&v9 (? Ll@"JT+>z^b\f􊉎O K r[SL%S +'5,?P4#cwYnEGSkUʒ~]"y=!D\D'2`C(£j,,$c˻op{?uGBZ4Je^xw|=ɒˠ,OWo@x7F \Nqf%$*Uc"sJd &josD&HtyU:xA.Y+mLhY,G7\VPO橞G@t@޼4L2z4I.يiͽdW ,1`xJ!q `= (*YajS]% A!j$R2QzGmY dkf/`JYqV>XСia upá~R&C7aD]ۼ.I47d-]UoQ0I 5;0fD,]͙-VK- 87%3Sm$޼!@K #XJ5 \Jnpa$"0Q9Glu}$G{, 4T]uBQ mj"*4X\ xlLio4DБ!`-̛7֓)6Igf]_ؓ,U*ĈXl LQ>J)+eKAK'/ bo¤% x"'X[9%h04=͙GiZbLMZMIVWh֩yT h@cp$%[ѠXĔfcG̨LE Q7E*c- Jq녹sqIB5 %ʢ|g) ϣE.VV%\8nDAw!9]/ZgRt 4Z[G|f&HȢ@W4w"t1]_i϶pIP t\։Q=dr*lIk2(7E =a4۪IrM(LRo[;. FPY"_R{IsW8R&FA pnCe c`av+n6ӁK >t& ыsF@tJ'` M7~S46@SWJԴ~IL/(s V|Ǐ3UWxA~VKx,[˅8(D BE#kHљU`{iu*A=i.y=.*4DODN6>O'x D&`gz8jj-%"b2B`URVY؊&Kh1Y1Hs 01jFM6u(3IXiߢbҹai ;E2q 8q# $Ȫ#^58T9|rE55Em%CFGŶ/vv, 'WXHq.HחL(/㕯:FAALl[=q_WEb^ʉ!FZtD]ꓣZ<& jĉaAr$̇Ժ XJ|h4q}" bG6%@< s-]ՂκSt|>JDLg2g ԧ`u9 ho[uYJN^TLDG~6ye]L4q䊌`Ir6S]: }=գl6R"%pQpV G 7֪[L+Ad ^  e9Ckep~r,GvYƹ]hV$Q+7fץeru4#qSanU5CdeqRmׯښ액Q,up'CV\.\1~Uxsh WL5B\J2d6rZ@48l(4Z9pk/k:ًL&OZRNS;H}dW;* !uvAİXAQ; xUHxBoG/{YvD"oqGNTHLZ|4)k )w ?94v?JiD Âw?@;yǥcU1 GO%W`QkǮEY(i 29#Yt ږބߚf1l9#hCk9rEE! 鑘 :*~gng j 9& a tvl'0P֣;q.e 964 d)`<ڦ`dY-cALmHf2H'*OH M=% q M(BY{TH,Gv)rZF {b4|EҀwN]1uy18FO P_^G \CnL )R+tw,GǦ{xő1Bd'On>gM~lBד{cDfH -hםX%u!,I%\%(c)]Ku߬MJ264N+` :vUN(܅Fak[OgDǵngYFgj^֏ٱ B Y뼲`]Z+:[<\ Hŷ^V[D. :JF99J{9 GqQk& kIя~ж=X-|ƴpql|̦1_3eU;pn:F' gC-^I&pb9J M O~4O զ)Q]Z>%v/tqR-##mKQUW_b2& [0^cr >^nV=+sktĘ( .MTy<[*㠫! fb5k|/mX,I@ktU{T+7ePS yE6O< E,n^"AT0KDTaG0* E?X)4v )q* R/qMʑ{v@E>?Kuxꥥ`P5M Sg rC٪)"__;ku\v3i3I($q]F% @F;ʬ b6n,{X;Úy/݋yB x:ې*g{k_Cn&ݡ°M#WӪ/y&[I#dLr[vOJ "Mh?o-@0{]0M49woI&lݩ$O]i "wee0X< ljh(L "y *TU0`Z+(m*k-/WeRr!:XۛyX"PDOx8Pv|{ƒJV @ ) Sג=Ӊ$0;$b1ZM!@Qh&4v5~,#skiXƔCքÍͱ`[L's3;]oJ~Xm'0&V&NB_eGJй S0H[{<p>VL\"ŊYt3 f 2=`v$7*6q˸< 4FYjhEH @a1 < {)9UZB{*4%(0x +kn݇+e=iFfGn/W`ps& ,k^DZzªʢd8E˥`LFɄ X}eLf}Ki]67ݵn[uBuaRUe!f#l,R]fnosK#Id!U)76tmKNw.k$~"gISOpwA#PMDВͩt)eٝ.0lk[u#bP@Xu#87< _PB QQ]riړ@1{2V)lL7נ"ҏk+(lIQ x U+%O,0pVvwrdܳ9hR;zOb6b5;ⵌU,..\\mdPZUݝK3u C~ aaQaw ^%G:*la $8/GEݍtg+"L Uq%; w&.p,([t]kMdV5YTlL ki+074)U[] < mMoÓ4y, j}TԴnQfCTYьWٺ+EfK0O*Jr+zCJEi.6#rQk>pXR+__ΪSBVN;gp1-as3(nZ)L cvm]VOTXG'u0zK^]yܣF}Yx1(WN^ş|[B@PGe c!$" %4t v\& h TD%ijjߦ dUf_+ V' L( R1o5ύapf |*e04X#@[Bk~ZYgHxĈl,wJ{X=尢](" .k¡e6qa ze< s79%^t~&̑}.-`g~y 6-jp E# RE(C=뺜Wd>[).^ЫBrPċ.ČIr!j,wss3-Z BN? Qr=FnZlyD |2fh&%GZH1'R!ZY4Pty^Eqʫkmvo,8ȈX+N/^֒n7U48L /@RKG| %MMeemhD@%m*\لHxSx0*XАBEgK6}3 z&'v{aןdqFqz8SS"@؆j͹p=lASq@7u  I.lqlTq'AD[.= XvށhV»?%m]{ƶX^5IFm R{`b}ޤư]̍t$6ԄmUD8_>6NlZ#W7TWϬ.B9Y," Ȧp1= Y jdͽ܋u){5rʒ /*9aE'-kFz8#qUI~.gP/f&W`Q*O»!m1G&RqMZB^ SA*g*DDou Bpt'yka{d6Kcgr34_bqsp&$e0ɦlk\b7p_4&pSԝsPȴU8<V\0lK_ 'EMIbS+ x.GF%)@dڦ}LV~t=2Gf+Ee/U՗aR naVA3K"6-T 1*C(" BTȉ1\>5U#ъYZwjOQ"U{^@Nɡ¸ pDa'+Li;;Dcq`h5=xfl%gbK7TصNPd\Nɏ4a5 =༷+'de7߬W3淑a[&=%#b%<Q EKUs g$4jv=B@QZ م[eSqsN }x3K~֢QԂá;K?xP>b酡4=rUSr$p☸0(RC~=G(TͻPSJ<~Ӻ$WS M.RJ nlp6B!;[}Ki񈗥#!%` ɘ3e Jp:82;Hڬ@Vb򺖱h!l\Z~Q eث~,]-ba$xEH= h$bF*7n&\>5PN z4-FZ6fl .->q:0vg Q8H;mh}9.P,Ơ$^qh;,a+`'NQو҆I#B=ƣNP9u-/Br6gAk>M-0/7:H^@e+̍iF͹Α J)#hXi sbnjJ*GT(is0FKE%ei, u*K`(Я9kTZ>HE@ͺz B5SqUF$KPaMDR;(^KeVd#2ա LmmnKfF2?0FJ a't^GF'M+UI qs^JGSeVF\ țИLkXT* JBU}a㕟a4,쀃C{(``Yq{7gȘ WB۟!azgFDw}5M!l-e5֎-2fSFUL$i{Y8CAVDWz }s8fbT斓)'(F qɂ _Y۔en̓w|xeoQ(9[yCuMxז0"ϗ{ .J ڈȷ$`Xr MzE.SVdu'IO=1P<4(p/~:'ժ|4PPE1Jц{ɐ?e +jB-@$!@]Dh9;/}h7ޤmֱv6KF!bF`j\ג+b|BycWINXe.UʓޙC_ HFWi:%:g By1Z? Y}4.TsT?^Iò* #a 96ǖv"īVU7#H>꘡+Vo3 BNV+QZD{ *UwOY@[+h%j&6$,*847[.( 40HE;~FRV]/p$LK(;`M C}_\y(-[ 5>M_(1,!d-H۝ʨFkkfp~aNo%TlR㒣>˦$ H^[[`BR/8:m~TF!a`Ni[\soIJA3`IvZ5f=pH1\Oe"i7 HGRO=fkqT0oj^ZH{S!v%2BWRwh:nN9U8w5\#8I(in$ .!\x<Ȍ{X6!y¦2So 4ɦS2E}F R9-2C->|#SD܉B3)=gVzPIzz:z+02ʁ Ǭj3JD46!fTsoK *RY,9P&,s1E^uTknjIqm'( YCYA2>!G0YC K/+brH>#&ҙEՏޑ{K&FkRr v f K+ _m M eY R-V;L'`r294#wbtw,=3`Z*,Ócsu͚4A^*F$/y63 4 *dvՑd ^})NU;/#:&02δl@+@20hcw(i^{0xfi0ʙZCxe{:r;kS L[_\gng,K\G&a(tP&/`1t[㎿!2͍bN~ mYiA8* ĦQ#>.c]9&|FpWo)V(7Ȭ_HUc|\ IE KXrs.~%JJ < 71< a~:occ0a('!+RGZ2#H“F^bf5_d r`'JbjOwa4K}3 f.<5jK)eT.S}JIj'vTi[51j^ qȊ#.$FSQ g~7~RNSԺz@@} e2otY#')o~='߃.'h.TjB# ξ4 !\9,j*%1a' *'`AK!%bc,C,B$6 $e$Ʀ4`~DͱΜMLT$d69Wx`O[a(Lv }[0fb f|Ejˬ/-wEf݀d%w0K VA=%{ _ZTm|v tǁ>kBU(kS{ Q5+Qd3bNcLqS#w"P31ʟX.S>$zSa^!2" #ANlVN 3^b ޥ'b{H:`DFOʾ"9mb#. 3,"H4\ k23V#.Ǎ,O+1(Pe>0 gYΡnPX%͗_?.kʉ8{& s>iZ_HPK+I.!ۧDR#Y-x>ƿ!o*h&5pf2J\fM4`Zq F"AT'#Do,G:WPp*IШ[ ˜bPU]`~@-5#EZgPK!Uq0r^#Zr씿RYBGy|B1A΀𱮨 !K#"+<Ýb4&Jj|Y6Q*vRB<0doi6ʓ)l)!.ie8$ܜ1PvNkTDNUF/IqO ;^Pt:l-KB\Qdٔ6TI`cmE\KXi D23wN{Ȃ#B&ܲmGpfʦoo; er(;-$44N BkwęɄƓ~M3ђ]"ŅNܩ ,ZtUDpM=?\{X=BzH,ׇ_׽!c[RA & Y D"H&L'f K@̮|dVD]_:cw|0iwfǯX32ݸga#9cPՏo6 \y2l!jnP\P/JEm1|U*2&_"MW0RrC4ML4bIkaӼMgȁ} )`gSw21qb0-k]ܣLR6! ypfYpAHz:O!A~+׵St@]vo/^`mx snQ6g"BI:,d&DSW50aIN+ғKbo/_*~F|)*K |:NCn9mvj|ڝN9yOsL.&I!R)%-AYeH\7T| km4c3jƳ,َ@ҏIovŶtQ&ypf4kwp/}`"Ęպ!ȫ+ߢJ1dOe_kTqx|rRàF5!~`PDX`L۔j706ts4 ;8 $|L\N!c ~0H\H5K&?MSjqvւmA^g:xOu28N/k (1ilE2';ӐY\ڬ!l}`?T˖&"!#L֯ Bk.dTx@De_׉P%`V&GQ:)&u" k_̢h,:9V%@AXn+;cMi=HRY, JjE0!VBuGg\3Ղy[Ka{%kr:ώ1WVVWy#NP)R ,s}MW#Lԟ,:O?~He_ ߯,L9荳n{D|TK5L4faz`^IK؍ZwMUkIn&ssph+) ėz"2٠n&viNHQ܂󣂕 dpG,D30MGÄ.7fvh,USp AU]Ҍ\9D w%'0]V]yK7@OU70RgQ&ذ%ތO(Ҭ-E;JBh(vKFL^ V%>|ޯ :N5m)" [n h`ƃol6O%R"=jvۋrX@˝5!l"' R'eqYDʧEX,n^g `7/H+╣dc-IfB0C,Eaqdg㤄-9j٥3[ Tk 5]l!ZD%8Lo644A\qZD{G◈Uqic*lO62Mۖ<%eזDAHR`߯4=h*+;HX.Fs1| %V{@b»|P3oPP"eHhGa=cK0[F#V1)I('4FfjcKN1۪5$Fip 2?^NLTmXCT&12KI*^TGz=Uk'6W&%1rI5O.B=blqLNG@ >l0,*HP\9+Ju `ey 47YVk_Hwxʪ5Aکgɦ 3oA1km$ı:X8dX@)$`@ln2쌫Wf[4 kk8vL8$f%ƄxQ2FX'5Q@56Sa(kwܻ( Y-"!PDݸ~  rl1k:ve]7HBһD0usA7 l䜠@ 7S)9upAu 弓Ml 9n+ ˜USlib6%h1Nx,( n]egpaG)!'VIN"҉ygGfZ X̕; ; Wߍ|_2S64j!P\_<ً #hMB; Ӥ.0m,v,Cl pOق4fJ2K I`&ɽK¾鵾GŽ]VB"GIO?x!= x{uE e¤H SDkrw,7ɅMkiVX\B&th,9 Cå8<B㒤xŅȰ3T!jCQQD͜fE 2Ws!JRA^J ''N}.7f]XNv&Q28,#\EPݳ(FSZ[;h%rFJ8,y4B jz^ !/ٱ"%ܦ&MEcDꈽT+0`49:_~g7 ;:_6| 8 l($fdž}/ f)F2sN֧~>v4< mdԯ.,ȊS:w aƬ–:+>e, 6`2>/w,@@g3U3v!:JWp}kxk =45o͕C/YaECiumbZ T\exe"\ݝ Lx@[Iy.LOl*WHUC/czץε-ckSPo^]f3S4ӥ kY㨅|AET ;(O>gkľ*Iu,1;%e؅RAW XU28\&iKWTY2z[tc ׽G fIˢ-tv5/G_M[qQ„`/-G ܛU*̈" Ua +Ŕk$T9Gt4 ׯ$fa^S…&tˎT}k$ٮЗC%qvy?q[@\n@pj*˦"v8RZ~pI@DqJ#ptф?(f׏ XKik"lVO$ Wk&Sq4džԗ_fL+ l@'4m cLhjrYUKYXT B<3`rM?YYџ%0 󡐰 R*@>\; 5(L7Jeڛ.J¹@@}<y:<{5*N}a/4ƹRc])]G>ciL_6|o:G&J' TBE)?P&\o?χ8͇8*,TvŶgO0xA^uGn8\(˰-laܻ$߬/TB,)frm!'10}s0 %u*\/WoN4fb%R+P`rnDCQ\ZmE/dFQau8"y6?jX(45Q !O3S|j/сlddc x Ի<*ؑrqݰ4/˛ rKVRNO\B TJG`C`h;7%.{ !~NtHjAYjjci0x4e6KfA.2h `*Pذ7 Q&,~/*Q.tJ/va:PEL/b:hp%o>e T&I|W_mmr85SybjGi52O9ql| wIvm򶾣0ChVvar:ZgJC=lۚU4'+^*^_5_صx,(ӢAh@n[qd.J;؅~?`eKUזe%AH꣱,"Mخ߭| PTE8%{XS3$qj_E2jz056pLhO2/e04HA*R:ӽ, 517LF/myӥć,Bk+pTȣ(0%ͩHf$;eDf"wRK「 x11Ĭ!i}4VK+A|Ų̦\H/Ւbr[#7+r7ǻXSC?ռcbQoO뾴Ljsa"@,IQySb[( -.ĸJ;z@܂3!|MPVID1EuVֵSc|m32E2dl#JAG7X NIVjR_]HP:PbC5% DwdžhHLFDӐz ڻ0 }-A:?? Ŝ 81&d.vdo^ 406+ *,`ֺP729jbZk\,\:b mFR ؒ2}_/v.L{򳜅<;> :I6_PP:!=e$rg?^F2(7kfZLLY$FOhlˮw_m+.҅QD[6؃*e8hmDag H=P $I-TJYݗJ%JHX"%]:TH2m X5\nL=%j %( R~yu ,Kjά$ RUI2`*G{\mhP"X(מEPe1&b !@Ms߻|Jm7E2JأHm5- cMX? q_:4pߢǥ" ͱ޿}{lV8:1pr<Sb)fʱqR+xUb|}cdo˱Q} LaxkΐƨcN}h?%SwEƩzůLg6)WYk fo1SB"/F*t2XgǐCJѤ^FNuY3c$RT^$e^2ԄlXZH h8$jcƢUMܛ:RlȎvX˾(wT^Jm˜Jy'v%;+3n"5+6*-Hcˁо΁o^뙽|4b KQ0{dq]RJ&TOE)7ŁIyFSG[4Ddu憎̫K,W+~L\dʉ×B "y^OI1؋m&c]:w.%]sKNy*!TDDb}W갲 uµ._HxB(Vmb-ʼeA5s 2-jЋ`<;@0)|yTe3_aR tMWJV#N`%ć _e5?s8|—|!qQW(-z/fyґU26ޙvdLet&fH5TlBur  $ 4PD@"@OCP;Mym 'cnVcl굨$Yst@X Q0NSv` xDbIXO"7D.5a.+F1dw i,l=G'"I>D%hU{".-V3My`o`RK|YIKk1QN+oTk0ܐJy(FX|h zQM4 ȇ%i3,RtIyDԧAFG>a*4 鬝{̨L?56Fy$/ڐVz\c<=$-Yӌ8QkquW3~UTb. ijS(H?Ę}yq4{rR3W7y =a7`n#V:-/ho;d@Z=fE,j-pˁYT?Pu )9>wwj;#w픆#Jþ(QA,z_Dɠ۫,!~(<;{qˢDLeAǒ`+ֱ[kܓ*w41v,q,M9<&/Zr4H} +DGMɡGIcie(3UBax7TV FFP wpö7pm+_}U۹q@v+Dz,T-$9&hegh^ @weҼd529ۀ6<0 zƘ! U0QʹɝvăV ޻"%k5o&r_chS~"w &lz@ZX_ #;iKVh5pV8YE\E27p}y1AF&&MkKxƗ ,Zk +ma JK( @w3V_gSVj^on5tߍspGͬH5g7Υ<<GB9WXʕ_ܱ<D7TZ쯮0@# CÚ9Թ oxBw*Zˆ ZE5rYDjg<"EH6q,$k 8#!Kʱr* zp[”e+ ]kmlzkذ7*T%0G"ud'fà!4鶇cP''4?)eB7 eRyX<d, U# Nv/x0KxzMJkѪK( Y̴<xȘ$ sDOGb9ջCS\0|%:Ti Q2<]ҌE"MTnB`Y4e\hk#QKm֬ɴ49lbQUH 5`~hHHޖB8Wcg/!=X}Rj 4$N"4 wH"X98]"|5>6b8rZ)'ɚn8}R)Y1]i+Cd SqлBDHݵX )wjħSAN:Љ`jŒ$jB\haVgM.4'mDĉiGg,v[MHNeRUMoJPB4ЧEX4  5Iz&)J݆M 9jVN8w]OFt/C.Fc-LXLZaαh՚4$ Btbs |/0BPJ?/fD"M9c6wQe"bm*ke*-RLP0Xpĝ``H0V%3wT`Y(r(%kli$%L pV\Si!'B S _"{eݩ-h!EyQ|Iʱ3)FSeZW Dye ވj,B($(. XZ sN:j~R$]1-S@Kp5 m_n d]VG@ /rχ #R\3;8 7|I#fH'+&NIt9Y(=oeT ZnJzV"@G 5*3coe4崳#"WT͒_܉jHaChG[ }nM!䕣UeJs5`R$;.̻pNKlNjyjF̷.,2t=Bߛ.R¨Nĩ6 Z?"[gzS5-`hu$z6@O_ȫ_4DOPdzd.( J0lӽBHX,E+O: ̶!'ܧbȏ]F ?/}d``\&V*EZ[X24ƄE$< X ہ`ӣT ͇u`jNF9k.=\SgKDqu .Gky4~. NxR( jLKj`M޳f6K떻lJ6Y%B@nFJR`c"}PB@"w1uXy@_,G=ɰZItC*L`:'m?0uř## Gя/)HKfH M714:9.ZNݫ_^d |,FRW@^ &ja)|fW%! 5J2^|x|I,Y}lRHOe)I aTCӇWܢΊ4!aQ@ho}v$6YW$FU8u]xg=Lblމ+/DՑ!` x E¾$RucBik4_dӹj<=RO'cqrT`W.*`HϠC39DxLjIe$fhj[&^iRIH|JEP'L$Rمrˏ$26)IH9|C"#T#lqVN4^5x%xo0n b:CY U.'ݬ*}."Q_5=,+IK3aT)oWk;za ׏M t%(GI4`mKP|_H1z2)_4My}KtL>5]~22eAa ac{@2kF҃ojz!%FLMKVbLIn8JS=^sddNNI_n##N#ǰ3dĵb{=$Vmk@X^ ],<&NMTQ\#b 1'Q4}"rrh2ݒ%jZNm2-ʂ)ꑵux0/ fJY;b *Jb:q2OR DL=7G %㻍_d`z<_%EwgY_MK;Tl,=B4+$dI]I;E]l׾)V~<94Te*[N($@޽1sN0㐔`,:|6DӖ\RR,Еw/  ʃ-cjKf܀4P3WZJhIC  ;?/iY?7kz(ʶAq$?ӇD@-: 6;%@hi4zع$XFjL;Kh2cM>(y!eϩ!)5 9goB_7ᦟVM%`3.jn"iQRӂ2'2VzogK|sYa^|#ƻe`HfN᳜m,L0]PY}U57jE-[@c[J#7c8 $KbFҷ:>cI@t1qS*jqJW Z, !nYQ02ʞ,(AJ0, L(8JK90oBA\ jfW> $@D ɺR6w pJ (m&Ć*!2pX%8FhY{N@%tSv.ü(j-)30(p[lr=.H7IζB"7D`\1fAaq 'ġ}vJTvcI$\JfX՜[^De*7S 8/%qF%2w&L dr#A٭hBagD Eܮ <d#vzi;+a9-=,~x ZīLeP CaՓ(ieTfY&-9! r.hrl.ok 'Y.ڝ1H[-͟2$U0??(,J |YSt yPV.v Up{k0aUvOF4jκjAF {c<߃ #FgpتbꌌmhiN'TaAt suX)4p ַo|Ɗ+kaQ~* eW /T4IQ.ghA)Al%  ԝGY,0+ݪ:6ahC#l$ eG /X[>U>N!a`|GY&39ZV (w(-v_S^SWbm4ab,Trq?R. :0$2 8ůrRNCRo^ʑz,̛pB$ƮYfm~tB3ofڑ'5rŊJF]r}&M * .߱ɴ!2^Cq>@ߌWi"v%p `'"~ Rb9վkmE> gf7u*4G4/׈!/HVѰ5w9(k,yq^wm.0$vC*#?-Y}rE{ '7 kAFh=>a9d,MG 76%?ѳe8أ_S*lq؂_/%jogNgGD'yVKuC3 `qGy%>Km6˨!EKFqJ1~cZL\F9.dOՅKJ5gvSV1X,3QZk8#B SWT2&h|"W!g!944W{HfVhM^J$ƔgodeeA:5Rm̎Yh6d@\Jf*2]}q!ʙ ?3'a;Q @-AzS[*NYɫ;Q!d"ԅQ2*lr[&* p&‡NQ-#k+0! Na/4 Mدk,T"FhZD=4Fv`R3E s;R5/K1/By& @TapUĬCPD"-Ț"[|0AhUzR`G_zb.? &],4Q/v*&:_\]_fNQO6[G6}#<<>71XSq&J/qej[U#18쌺WaJܨ'ҴﬠH`C9kdEoø&vY5*3U^6Gftb%I0xcC|i4 ym9Ni,IZ2,Y2wb9P(6JU\%ET ttjjF - UM$BoH ,oBIՄB(M+CmTrR i@`tyb|lKS`V8)nbˡ|^{hϨ H*i+Ʋe!ī|{:놷Y0Ҁd #2ω.{pBv.Vl(4{= +S+%nB4k|Y_cdi% Qp,.q-qe~9))EFfJg{R 0?[?D }ӎl˴0*:fUαRKoLfAQ>Ö^/^L;6Dg}uT6\,04UNy@ܡirt:.]+H5~lU jxФȅΑĴ*z|i'`@ĵK<_Gyb]be$GMZ(RX`0|+0M^rd+>IWC`PWՃ§%Fׇ,`j6S, Z\+c9J ~(-}ģ@Z,(ިz<8 `Pl/ Ÿ?l:۰fDdP(pms9V&Q + H9LAVrv(xV6)LBn{aE%nBX5 -N=a%#mporRh0v5R1hLӑK'G m ZZb&%.YY)ҋn8 g#%ȈAN4Iؔ S\^%!э@P+R|C^sBzklU ctո`=ƾ^\O4)8!ji)1vQÿ=(+ | %MeUZ,BÆ8dXuCD߳o`4_6ĭTphlccBL$:ϳ‰ QྂP8Q\LbK-;ig3p\3[~Ld&7Rv;$9Uju#69"8è6-evsdV$ N*\}K,DN&N #vr! -&Yk[yN'׊{jn&7Sޒ4>nDE*ՆB1SC|I@64 l;YzŅM,^=TĔLN3Hk6/x0뉲_&&}HsCo `.G&=^|N&+ jE{QATjY\xu.$Iz{nHqjf&6 WZR)&^uXz"ʻ;zdz=;3ƛqnNhS+e;Dn?_Ii:}"e,cT {<0Kf.1'"jQrc9J!cS}Pf2N,o }"f㏸H%ܺ]-D]ӧDЀ4,$}+#E|Ek$Ū̔$'Q.LJ_i1Ev`ht ]2!RM#0#6S(~InӷOx(wa<DL4hE eeCh½6,r;}S7RDi!ljSK\q}hM.R _<Þ+:QYHq gԂ 6w"!,).,'SRQZx98{<Y 01pC*IL8J.s[ "%G1Es6 ;4'ʵe7yYWSgͷWҊ+-m` 0S{\ lњ"d8R MZnjMSWШ+h" !׉-/_vjKsdEѰ9&(6Ą$: ["o*Ks 8?8wpdd[WsQXu*+@&,"J T` LB׆ +*'#oNۀ@^% zy5"؇]eݐM1(at ->wk/4e*1 h^ԚUƙ|}U?;l7\r^]ڨiYb _h 3n v B:\ٔ윈$"K Is;̙$%Xɲ$|NE-(F[2-~ǂ@Dr4uAG-cVkBr"d,`es`mZ *Q"Qafq:3#$L{)Q#4 6Hf ZN1i S5“ ?!FA¨P" ƶ@&B5zqj B%d # sW?@mmИm~% )[5f*K.*|_j6r8uc\Џ֐ LO̢ $tX(^0j07x;4B*Р?YztO\yɻJ ea:[=7@,z 4̄ޣ魶hוo4Pjɩh БO  ;V) }tuߩ+  [Pλu R24aCbֿ:]/ȹ7ߑ7UoyDĊ|vASXTԞ`U6Iő'Xo:6_h xV5\6z XI%8)n gynZ<\-P-N j Lflh ĎShjUgO;Er 4ڣvrbZa; +5VK`S{HSL22x*/%MX悀϶ (YQ(pn\~b%&[ g;+%!)zPmf* T:DH&TmsBv 2,! X.qڇ{gNN?Z1D;y5xBgB9S|)Lj&Q&"3 0X\T~ub@֕0֬;D'Tf~UT4AKGv"nBbHHK&UvmQ)@WU_z"ov_x-DYjCp@ #eIaai, WZ(ZDT 3U/Ĉ@* V)_Y2q:@_ZJee,8l\IErDeUhHUܢmN5#16kRL$E.J aft4,+%LD۩atDҭ[^ : Vu<[&Zrt eY^0 gHD@Ld͜IEh쵅!7cABn;S`wah&Mj$d]˜It³51(mX@P`H[،de0]E^_YZ8.`PB+T\"++{KaM"ax : f" :͈ E0",)Rc'(D g~D!X7ZBEJ㹡 G62VO, 3vYֹ̞tXnT,IV*Q,<:Dqݵߐ8K}[3!T\1Uq2mH>1- Ω6Wy/3rnW _93nvQYjQ$^ T#BL| _3&p d8A(k څX9ξZj1tb#d/ lU_-Kx,]~~kmޓ2<1@lS֔.|8욭&ˢ tDU$חĒoT 晜eXQ5RC mڃq4pŷ]*ġ%g&c d,"qQX.nȻTX#* lȆ{s)mJžx`WRh&6og7wB2~(L( =+$vPfKt8j٘XQ<$;be#K:s 2xX'RJ u1عx2;"|m5Q-H%·/A Ok1XQt&GZ`Ć @xjZr\VklS)PF3Ïe8( أxLD҂5BT.!V< +U_l3KԔeOR\NPs[bٜ 1"n,""aɻ \o|I# l٤^HC2A1V~zuaM>Urx(! .m Uxu"d/R@ tazL+]RDA-|< EvWf.}"֌MА?( wuC|ՇI}ѱ_a*]$𰃢 R3R%P)߷i24j=ص_|Vy{|`$\\Ew{ʺFZ E]N/_+sO[d\"( _P1+2*guNR4[̐O2+XжeE2@?A(q,*eKcL&la$Q4m܆ڭ}9"=.2MDzum.&8LHGÅ{:.0H1H")6dŒ2A,(+zĎNN-S@CFۑqsh=݀W)ͣ[_lZZ^`pW : =R$R'.3x_YӭT%/A W8r,9xa(~ Y&QnHc {~9KogK hak8$lTw5$&*rZ q& td3ٰ*LPT-h, &jу&XFXx9Y'"7{Fˍj7Styc14H_)> $TX6{ŷuG2I6Kz̋E1?H;1%ps[f2jڴ]Z>b)Ycf]qv$_ZdXb3 1F^ ra snޚt1t̡reFB2 鑐5LB~#<Ň.5(O}@Kx(AA#6TrAf [GhXL(>]`, vn3VEI[!aR骚+R~ʧZL3"I4z^!%PYcOۄ ѿ -ք_pވ>x,:y uV4FcU44`e73+.bS3E2! |Y-}Y,F dD N]1="6KR~,"_+h AԵ@HBb;|X^oюdk'fƴ湡)SML65'H?7 > |:rz ho,7A6pnu^jPa]酩4Ls"7  :h;T$R۞MrCV(հ D8rѮd:z{7ʠݱj8;Y Lr"JW`:COhf&i/U'ƞGBȨ^ϔD&uͲL(^5`>FvRBK7L /^ZRp|p.Ogx*1Z7|l/|o ͿOIJ+qaOHɮ|Ğ%_"+dkqQ7CcZ\\u5 bU "8%~*]Ui,=[YX<,!],d9dQwM27c ?,UPn+Lҕ8) QdBL-$8#el"80^9Tl6"!(5Ŭx1 !LR W~'3 PƜ!o˚4$^G.S``zrZqr~Ȣ79s4?&j YK7a)T)&]k,LPkf%U֒I Ne1BE~ . Sˉ)v?e|6_7A~m.儖5+], l*,,?^[uOi%TQw"h,T, {%qV@lq?%0$0DAb/#]X,ɍL-İ*ɶ%O ВW(ၲr{&ZKK"lxS>rRgOx\Y29|#$Šڪ))Ƣ3yI K4[$E:vNKEJ+HA9WPP֔H28HA5<}4@ϵ'q҅sbHAuZ]bb`@l2}PEQ`BeĨ٨sᲾ)k>B(TNi6mh, (N ZݭQ-ن,ϖ Pן(y *dvKiTܹM;[uRAzJrMCDdͶ<v (A$_/ =;9{mx'_Cq b֤~Z_ ♎14ίJOo@_|) I)H,X& R 讃K`ǫ+`e'{wITre-Wx.&)k i/C{{ myA-VpXe#YNn@,Ux& ڨ n+b>e-^b2jhˍq՜)x>XrgiD(.2T}̀/˽lkͬ+$)o>Rg2Qa),HNRАlR h fFZPNEoG0E vjqӪޘ@_]X[qR.QR^v0Vuv[$«zD.(*Hۖ[&[ZŦo6gͅP̘ƚbK$C]&$twUv,ت0E]spya_(E(j HeR[sY)$(05tVAʐitiW=u@ljieHdhyAF`Z0ߖĈ׶\+d{D4<8؀ÈO Sr6 ?B 0MJ~4L1U_{$^!Pc,)@#4//!o}Ϋz >=f|بN(oE4I\ _+ϫKz΄f4S-ua%5`ň8 &]v􁒋]!]&i-) bM@>c%hk, -tkg9aSNک>[> ,ދ&Rh>riT+k{,EAa(H朽84jr+ l+?(h FmmTXפ1r;=ka!Tex{,t 'X5JMpp=D#'4_= 8<̫;+bz6/YN& ({M^SB˷e5%I&W+smS`~6[ !-ćԍqJZ%˵e6>_Q@`{~PIEw/ 61 &1[Q(G@x,v˟JΙՍsn `Uuɔ@a>%%`Chq&H6+B ?Chbx&q#0JW~DKh&B3nI{REj椕}kFsH*0*ҶsAYQ \fK59+^{M+Q Ȝ&|)z/_-6qZ47ܣ+z+?19]-7ܐ:"Z"fn6\L1d1&1U"lMe|n )5X@M)0NcAQpWC OpDD Qxka,  .7ZF.¹\T .m,@Dh؁׻e JT-g+5SRN"=@p-Lϵ܂FZF-/$J'qZL5&"'z*+[:8U^Z6 ,z&8Ec3Aqk2 Q޻>rQ,apk1]oGa{tH 9yb8`m65]|e>8ɾLe(Z ODvtſRLɳfdJ\v:TA>;_[2!w%w1  #`!;mdbBq41J҉ QL:*@5i*DTK9ႵߵnH6 o"YLDjDK }03hZ3@VwAEhbw̲&)˅[65DŽ$61̳ JݤHXqpf&_ Z-huQ`R)|6x ($" L X0,&&L^8ufDO4Lm84D@h0]-z#0J]Dy3FM̬G5ᷤυ]*4I +Qx `gɓ8Z[]\WBU^` Y3 W: *ɜK&fL\ܾSOTC9sK&U>#5z OW'p(lɈ/F9qY>ğ{ 'fLw\3Mmߵrֈf'HԌIs~ д"{8<j)W6!A)SL X8.Snr]V3rb!'4 2Esyu{pRGKEKH ]sXL -K[[ ֶ%FW$T ҌCp!rFq7dYdz&`CK ϵIZYkhS"'^_/Ar$G"7Z"D%!BXtXRҗ8LEtpkđJQI]0X >t\%ݸ/8Se#jQ֩ƚ KM䠙__)lԄL--B0~CuYVh>y};x \bzh<&m[x,wjd]Н8Ă'4;IfA4);f4W+ɟp5Fe ^^T?a&29pe>rNG@ɐ:n6h(ao3)Ⱥ[1^0n jbvmA("A9mjfE.rt>AqG86#C`ZE-_3 YA-w-躚["Z0C1SvUjtv=F'.;S&km/v&^P穘TP#Ƞ})+ِ-XYt`H"R9(l3+ |VUK,lU*(4*SmZ5߰ Jc6"فJ%iPLVf(ފI@I_XQ#0'\͒\F.܃/V$L2\!ېz(=נw/Ojmȫ><Ǭ NM{~֤3NkW9{Y0NdOeNr@( fhQږy,ɀY+C3"xMc/i+H@> kIj$39 (ϒ㗢 zBE\sJXnבh*^VS0jkKb&*Z{^I>dE3"mPaL4,a^꒻Mf" 0:&룠١y ӿ:JᎢV0B9pnl1O8ks}Tآ(g`{Rpſ m1ECրٟUsk b-X_3Y J,<ʊB>̚-=)UZ+x"q󾀭WK?xH9=ڊ[-,JXXprRyc) hZYPsA)DztzCI*Dp Q vIY^@rHS6)MP iߺ(:VNF$LΩ\hl?jt Vl~=f jfpB2\☪lA' e\_i;t>F-a9ϗ'(pdkkԚ]m '= .7!MSղ owZ@D?cP/"2\ē c_x$d 2(*C)س MpcVM⦹miܡa&8 P`x4drG2D~t׆Hc&%Ŧ% ƴ`14ʏ`>c7g !ԣ %;Vj=d#a ǿfhsp(АMysNhR xGb" DÖb8"ehւa JI"~1C{Dqv["5"`ld ͒c.zOKN SJJ<; YkxɂJ6'J3#f26/߼ދOVo#F>KqV6p. D_rJU#9~gf.PR5ؒiw_ky`&VaUF N4I5jr}#}h&[0.w^aZ }9J,Mj!]$q]N*kmMCj zйPK SdP!*22}~ZQe WBQ9)!T&m*״|t A_HGF)B:t I0Ou!AQH5FДkc«)MF<1%/I032GD ㄖcR?|A2vCTO`ym,Sݘ|zEs,ߓ4uPO2cx@{Ui.m(0G,bl"*Adr!6\Pc뗙ؘW|jy"—Cjwq6TsxBU0>0D @xߒH/VLM2h۲YChtyNQq|sYڂ1 LaaW H慨aZ)6'ƝH\5 e2D_>SDo!4=3Dnrs ?Te_Кɢ`8/";RÀz4A+) =g5GWUP|~ls RK&"$@kncgةOnJHͿ#H^&2% ݱO &0,,4yZ»" s> `uz<؎J0{zQ"{!Q}&+h!X ʷ](ENuL6͍HبLA& <dhV,@?Е`c5͘*xi<_|^ϕU ?I .^*"a=Ld!yJzV43z(w'H`I3e\::Z,iJ"U<6X+Y(3~J-|fv1L[& e?ekZʊciXU``d`E9dX a6N )Ji>?M\6wfW6|:L&b'4{\|qZFQZt 9E-1˜7uS0p,\^7Pf 1̄ɫk&ErEZVfKϲAe(DٔO08ց~%di .$; \)(JK'DpLH4UɻiWlbK!!S '`tS`2漐|wӱ+9Rq'E0~@`ܘ̸Nfr?{Op(jU2ʽ-3|X#">n4E mᄫuk࣋ )rfgŒܥb&V B4R[c=±聸d^%P -fD 4IYI -G6e mjbJD V5acXd F2{K2gY-+C &Jhjpu^F͍A+l]\Q#3/`TE'(ΌC._O19P{q)9v8gvD ( G(_Dd~I+ c˾wp-1.'X݄e3ܦa0 bBu<fdd iܧFE(qvL@!g4 w AYI!%G—x\VcQ,MUX cF}B Vy0L*x҈ڟ&ƻE Jk HOa,s(VebB^_ :0W"Z0' ȴ_UWSGTnfPfFq,`$$RĥC{eV2∟JE02(k)ÉxU}P&qH/TnM)uYHv+,@&aq[OE/a):P,ČQq 8O{5?d0 GW$y|=鍪 ,۬xM# A@~_-mB:zf!Ht'/ v/ !*AVsH$ZS*KRHlT=P|I%gU5)6ME1BNXivhz8|GOg!Iy\4P29+xE}eFkիy3Jrapkg^㶬O1!% "va:(7*0w"p. >)"Føɪ. Ma9~h ^9+B;{{HFh}NVsɦLde"+DD'rЮh },aO2h@eBۋC+:N#^k`;X(!/vQܡ=ג&!kp1MvXg8=BVKgv%e꫖ ]؉EjSjRJL6|A(um\>ҏkg+ފL@< 7Qsl@&̓k`t1Bit;rjqKnWGC Eefтnt̏ p( 1hI@0ι;N NSzp3 ;tKSx*^3%6BO!HLxULQ3B[;Xi^ݏauIKP%0ySX[q֌1ȭ{ZkO1&Ĥ 0DktDTh!r{mщ\'nj2>jscZ°XIn u8Ʃ,oA[OQh4!DKC& [+lH:ڈw(\4}xzcQDAUw\}V<KqMA )ef6WhO2?K$f7cyǥ.[ө_!W{=, n=\(A[4{Fiae5sUTDP/.6JJ*i+@,&xLYԊQW<4 zXe \b^t˾{_{h٫g!˂%jzs0M1OGDv A? i;b2I iMga+\wSv܋7Up yZ,U*PBtZrC*5<=~_F<P6+2 *Lr *VwVs˺OtP1y]ˡ;L<-T(6T0 Ao(HltjW~2iyxNG-H l,Z50ˑ:4n4]Ej\v*E+O@$܄C--T^$U0#pu2ʱrsUOI"E(ȞbTm:ujS%#KiۀA FjX0a|7MXDc cC67㐟r@'W]оmTX~ Lθfx; qV/U3R>UU9ZZ mhkD‰b&z넱' @ ,VxFv"aRuyrH\9RLĝ3]xۭ LyYj as]zQ@R(BHe^:q$k H LJdشFsFRS2K^ōNfSzeul )Ro``)7_£Gm#"-Ĭ$$CLƦ#n%5e$ԍ$oUIVt)$bkll7v"7I BhD ]%s`(6߻b,i&7[MRpa1, pTo rHWe88e{;GB"\)G|fii lq!9%1D=q!u鬋A~<ա̡M Wc}kU˗\ܐ#Un|)'96.#FnaE(/t%onkuqh+V "p27RBEk!׃)1)GjId$0@ 3\ W{@% z1f]MڍjJ|*B)ZXE0_v0ʳ%,vRw>S_m8w#ɱWx ^kIٶ:[^", 4sJfIz :* %.Lr4,8'E n %gFU)Gr l0#ix}⽗j*8TPx džj]pje/[oźwV>F?,J LPXL̼$RN^~[%V @9oa!ĐTP/!%VzrUա ۇl6OJ I&܎EwNf4|9Hof^N[f*xDƘ9ɪ gU @WW W@D50}wZD.`7j<*W)g7E& )مuo1"g #^;AdDF|Mh߫I4D\ @ԚVB|;kx1e;NX[RT9icrpo҃C#fC 2nrӣz fꬆ6[Te^E0O_+^{LΌnD-bM6itpLj\6@=٪Mp(4/z錯 !ZXK-(:` 5|(]^ 2-Kv+j|#IvlEQH;@SZY W 9-Gه~}QsҙIJqjG^(KK\F>`T#L"jڏ'XѰX~q1V8QЙx癈`EhIۯh`Bz,93 Pq-PT!Y~ 4`orQ=tB4*)Z"HOcU@leP\8@̒)W=nSfJqJ,RI..T2܊e[4 p`Kbp6~dPRDpO߅sDaE>yker9L8?YIP!y!uXrpcDq/Re%zlɦ*JKP DPRJLGPyQhtSoR qXs Xdn`zS] X!+`l P3De0rKB+Pmy=0db3i]e,^(ُ삳12"\Li>"gnRTV& (˴nɞw $3Q@NF-Lgp7li$4i rq 7++`}v˨^Rb`@۞?]$$`jEڥ@p;k.(kvQ;B:YUgh뙻&"AAJd; 43P(r3cPՉ3,!3ˏ7<~,!H"199T$̔v"zh!YӞXGإhRH < ohwfb=?^ reI Yz\^tD,Ie}bKXՓ/ % s;* ,!q\an5`"4 y?4Ldl XPĕEEWf 3Ea˷%).8'Bqn1}^]TF=~T \_T]R0< Ajz+(})1Ì;427nGq I}PMZTԍ5q]c"4}:W1@l$l&_,N,;l;Oza ۷fᇨenA$Stj>`J"O!0#rs"áM2f+,f&؂`$ZHWlE+\1jD̉7GECEMBV] 5& 뱩9Qx!4 ?|WJ{kdPЕ"q9&"`{uZM?o/MNIĥaX#!-dH&ڥ //. ^p (t>mJ#Zʴy-oNbiSH™)@ uyS h=4ΎK^Մ6K)țͶYY𩬰|~i~jאxE&!j 15JϚdbPYo(QRra0m#8wikT9*TO:|:ftȈZ@VGcÅ8bߒW$K#C`DŽp %) _UvWA'ɲNLOP4%`>셊f[(826}TrAٌ$zXY +o`1:LT%/? .ih >uZA&Vn|_ F.I5< @j;29p ?_QD@3Y&fNu&L&ط"N%efb<#Z\B1 ht]tc5fF_LVBЌ]2*Nm 7WUyYм|9A dԙCtLAfFZjv(3%5>iG$iOI>̙&NnX4"(z*6"IlFB݅A=l0jBKp .fs{4;G*\H05.Ԍ9sAvOW˜F([IVcE62\h>Z$bzE\4~*#SA*-b`!/F\oBX`j;qI%Tny-CZ[!QJnm:]㜗G 8n^ǪSh m%P.bpX æU.!kYz"?fe'O$XU:m~Q;J)(-$bI-esNEGl< r[v G5Swgl*dS>Xh!cU/;%#HQPMR ŧȷ%HB{GUv(Q)$Xv *_(Ji/Y+'#̭;(k&atVBRSBԆ?Ł,e<[n;Ч$lI u ETvMCY\5)=zhc)TlK"QD/0TY, -'&,+襞Q$MF}j-daTkWUx*yA&J4 a^ӗS@GBq荂BB A3i%pf!07V-:beA+<'M.@ ;,8ԑ=+{C5r{jSb>uv(6}M;u"&, (xѻ-2|zZ! 1ي-'x4ya\dpAc_뱲I17gv'`By[g1֐8JA2Z'NgZmY ",Q>붖V&T6 5e0+ȝ ާpEt'.裃> ,MͱBIH>g~^\˸@..#YH L%`34-BF@:/b"5ZIp2'iM nNTŽgƑHHPcl]tw&bd5Hh"~O~y9`.ċј&Klup+AE9uг+䬨8.> Pƒs<"8)+kwoW E '=:d@ 3:k  t̠B6;sɗ^tSD`LE42YGogGȻRÞ|:s] EQLlq^=TT&5Ąg(R11f#0`gbސi. e(L|14.!9a!KW+2)qg&kNw۴^iKRיe!BFg }ar*d-UP9ilHnjZP}.|V=ϐ讦 ;jj Ų C0N"oʖf%P%WF%49)5U<7(dss{ciJXRPHv  y~uG|栔 tJo| P03`Z1X> p%g$ }t̟D=RTT0R `L,'I]RF S(/KI=d9Bfo&.X/ 떓 ]ʂ[Pg%<ZٖRRr%.0ƩjBӄKC}AL㕆iI EТGԽT'G0w!*b9&EvAIَQJJJ|׬hdQ3|@}VeB"LUy2wE^ xAoS#uo̅5#whGԄ,B0Ԭ|J ٦c_yAD=Z*CC𦢓3de ^Tt, 2Sb!"3-=  _#}Dzc0fll*Q'7y6_ ( 0_OC\OA7CG>KД34ca߿3LX@o*ĶjWc1_cDp:j 1J # ejD@ &E8&w{4ؽ!ٓ-!1oED_׭<+g[q+}2u2 N hi* KoJXZg9H=RJ()'+iw6BdyUj15 Y,OI-dG{ǜ 7{ U]<)F!M"ίPijž&B5iwv߄)#9"}țتE> ٛ;LI|دFgz԰FCKadxqfM5SI#R4, %Zt z@ORM7m!-c1,`ɆN1%hTB XV)8!&5rٻ |q&!d:%IO|C.j7rяn:RiG,"7 lLqX1sZVal˹Rf|h7"bU٪&fm7P1g%[ ]&滕Ƃh< 3/un9,%cUطJWm N(<MB`Hݏ nr3!D|}81!>Xw%3?jR~TZ]7EcƏ f:kZR "Xx*جH>3B`W2ի;ۡaX(wSYM{=gjvNJirrЫtv|2h,gɘoFv[[ާ/V%Bv "%2R7F4?ҰF֋mG+eXҵQd DZ z}7(uGM$JHWzdɒ%E!^VJ[acVZ&i1F4Ͳ0DB+F́T}G+#HJhu"+% Dn)jW#Z| eB<ɠFzc馫~1: FN)&VAw^ {!/<$S+Tedׅ~a e%*RcC+jP[û.LCu?T:5д3Xf2V# 0GҀ,JI+'bށ4>^h%&p4tZ%% ԍ;>&!"sՔ!E"B[)l6 eh b35YpRt[lqjRx͎XxvԑĩKn! ).D3Dd2`x%!yLQB%UE(TE$a dލϨc*1'@JZAU50so@#C8zNO9`=9֍jFD猫M_l&Qr+^L %e̋l:j/ի/Qw`D!(I`caC`D;Eڂe#`'#4>p9R&"+]c! Y$l]F⑱$m`Ѭ":@ ÝQ:${iSzB,-Y \i"hۦ_EaC*AmBqӕ6S`0X=| Og}U*:&'* żJg35,%xKp\#ɯ;l M %X xe05}vHX@G0nbQYI2c^'G+\i2JQzC>^vŗ&;Ǔ>6hUDyښD`O.X"":ACeK[Xi ތ/!2\HXpǓ$&"[ qJ XQN=91-qm'?ThJEc#PhFuO$R‹(:,ܦ"gxI-wh r+w*Jf_ZZǾLocG7E,xsnADFUҁx NR R./"^no/"v9F(P u+JpYdEi*r̊=KVitAAwAuUDLUAR,Mow < 7.lMv.q#ύ+2"-amSP>e,a"xbf}P>AG P&+;%((F>8Y19ܐfqk bS 6Bi:_ҍ,唘# ILmj8JJ FcR8bm`Ywqa wa7N YPkg"qjeO A:@G-I1i3GX\jpm53wfo))AAUV7.fزE{%9gIpCOHL-SFn×xƪ޹lM<7%@4 ҇ YA3"ĕ'V#eٜfmNq¼a"aBohHu_A*>c 8|9CV?qi;ۘ'EJE>"R\@+4݄A$PuJLJ7K`o@fK{^)BAd)h DJilI.)G1.4 NNFb"ݼ3>1¢^=K9|iOY}Or5iJfhJ~M}3tam@-kH)_BsÆY)@k Ӻ&Rp4Ɖ ŠDtH5A' k+\64LAϡA9Taڔ!"(`k&Xb'':vH3~|::Iq!ƌ 󪏂*c9 m&*r? Ye~<{@ daIӉJMٍE#՟dmb |-t xqnapC=$7B$7@ئé, AMhqŃ9&< a$zM|{STfL_&ZּF,uBa+iײHEDۺbPb;Q󺬕*KfgvͮMܥGQ&c'`l+Idb3&*D]Qo*!5?!xě6MY,عē84 !KB[VM-=S>RhK-w ,bZf_ GcG3R]/ ŬEQ HWMW5&T^F ˌ F?5/_ S 8~k&9ʒ`тӕpR!TG!dmPA>*|zƋK{ I(یho͊VH2[ C䖄i""3R|kynQLM0KA킂$ 8 . 4r8_h\Dv͂_Dk*X Ňճ$ hcrJo:N 1'DD$14I؎lEߓ{ԄJ6 Asuq ]ƛ!B^l33Q۞W|+F s" $E|8; B7a|v| '4+mֽB2M ːؖ#кק :tiRz*5;_\j/HD..1QP`3a*6Ulq$m4 }Y5 %!5`BBJՙԕ(I/l*PF_UiN4y]늇x?pv$, WiL љA/qQz&0T $#46- {26`TnLzxWU6 ʜ[opPZHÛЦo>Id  4.jJi4!pZeh84QBKfBt"%vp*\Ri=SgrVbB0E߿BΎ]n@?2tB(ھKY%-۩M ZyB4aQn;$)}Y6 ^zMrDž+*%E ZQ_/& w4*`BAhn04+h+=@m },1r^B*R2LF1߁ D0)YĹ]4# ˶"oIw%w&(9'#q*Cr ;%). ѭZ33i&wMGyqYY#.+_On4ļTAw2nf$-)|/IHg1Q ˕df\YdF>S9ꔓwLb _QgsAkHJי6񅴑:LO[ rpk>U@?d"nj>PB^.2SܯuP 9)a2/E: |d2gӆ$ O l-rkn%~E}'.H H@ "<}(q^eRٕѶ(RE֪Tg!Q:@Rfr1D , G@) 7-%5l:K2h/S Qx$$-.ᨄWeKr4 0164#x{& "xDN`_H|x pF ƥƀJWƁGPf  bBeɄ^u [,GL,W<DŽ\{X .G{(M,'Ud dFf'?;5g^)$bh[,OZ ~$* nc> }''ޥ\/5&!9}S |ےu6#A1Ce_1G$ZmG{MX`CNρ/)q V=h ⒑ٴlU.,d#^ֵ5zh8ѻ6L(Q=47]C!,κy{fIY`TIGC)ieI 8 !y-g~ +Ixnʚo5-,Ġ;w:xap3j6jVM1d ,۶.Jox+6l-eU*sCduʖ 7aDHaw̦.՞q|Fbu*IX{xLZP LcV@,-Q 5g/]g+0W)sHKf(%I< "@T.cMR曓FP 0 <:6^*bN2MRp4牗_KB2ooOH Oni"K%Rh* N9 O?oXYyщ\Zhn>\5:+O E(S8>DEF<Ԯh@A@DAэn ʨZ>:̳ 9p}톘ͅUJ{fK\`Q"Nu)ĤN3#cS2# ڍtJs[ Χ2t&ChPfvN^׽ |_LH6X̽p[bpAb|̀' tgȅAv5b, u*cB&h@+GWk\)eDMYZ ]K2ȒY_4Q_nЮ! ~ !q8\'\iwIetT؁rb((ܐ+(;c dd]yq{)Y8ylL\jwQ仛ugoں-Y>p΢E5 \cU~QU0pP;Y},5V(~sDѣe79e3VngQ"ֳ-C1#~Sy-7=OkL[1KY])f`z就.B99$4WvK_M%WTpDf 큮 kȷqUZk:s,4Wuؾ@6͐•K\7ʇV"Ƒ3M4E 4S00TADSh r ܙz2' [Fs)C{4+w 1My@-R~a|TM{ N%J4+j7m+E en vA.VmSCEW12|!t`% Q&O?YEWppp/AJ/NST|J e)(FblB`5S%1Qkl[uq m_L4?D^WiXg`U_K "(u+#]nI6Ե\VC?$꒴tSW_$3C[r:R\Mz@ȟ dyXz4R9* ']3#vL 7>FK7{od}Wpx(h.s6Y^vHq-&DZ u*MA!00ë[*!ūY('L ӊK.=,˦iTЈT|wTo/!"~ٳ|~ F5zHH2&y94y da?qlTЈRAn+J߲p~EH[!0B]- nɐn[ ܌Zuj/n]rI]jfpW훙L_tG3">bfxPX&?[f$E5'P$L}Ҝt4 (J\k,Z%R@R˿[%B"4t 1$W'"=`,R- t jV2eXh$ڗAS32^({b.!̸{Q 2Gncb7@  & [BI:1/q'3Irbf:lq9JmIr&t@4 1-%ǧ 67I(\Tc7TN-D'jh0-nr +̫W*_ni#60նl粗GH4f@D wZM sJ >8O Dzh3 ==D6l(5Dԝ5VQ@]5mї @Ͳ{!2WP3~iLݘeZ6W,A-Q[__1WӒҊ EElypvR4~SK^(amFMr`%xCfÜa84e225&QM|}VišBzT&c$:HZ/>Bt[q,,Q$|B_k,c?k!?EDfĿܽ\*)y&=k0SUU6!VZooۭjA7G5ai aф"L8F4|`ʳhHYY4tun)}g0ekCP_r#L$'.J1KEָ3 0\+v0D>o b  @P:h^Q&Rd!gI%E){l@VV") 4$,WE[RVm ku&H%qI# x2pڵ9(Nv$nͳY;$hpX'ab jH`CR4hY[ 2%Tpi.$d$`4 M2=0K@ayD6b+a:{qd/PVÛKv"*R<%m-d{y ƣ椩y2<^"X,0PcP5Ca1TZ%N ek#$zӘ^ Y:zBD BM,;h)LBZDƊ uǶ|ٮ6c[X0DNX=Ho웋%}:h ==̀4}7k3 oq VTmS\@_-zw\0xZZ B"2$,°ʼn!h/FK;DxLS^lG3)nHMbĥIMHPA"LPPE]{c@3Cu/WpWawl@)MI;^Ih<&3k) )Ia6>0PTx@KX=w*H2kìW˄yB!EeuB泘j{5ߟ G.v$3R Z6YJ1o]5]K5I TZj@`dZ܉4g#a;)[ɕ#*SD]Xʧ'`U!P_$( * 5PhBZls.hDLke> %ιWv-y?'#%@|Kp`T$lL(6)S;>>H7O+3#uʚbpx#s6*AݕE],%N=܊|V%@!ˎ = ^Vxy5o3v4*6q’!)A<*[S*4`޶(."=P޿aګ\l8w}=@v]$TrR"rHwll(*Z( n݄ Zen,9 ,)'#LLH{3%e1O-1/*<c4\[+OKmP"AkPi*2@B'Lzޜ%<e' ݔ#~M Vlq5Cdu! $n>S`qaS#hn>8B5tĉ$uTlet#FjT(VJV^E".>g ]+@b'2|ˎ"-bRwY TM|؅/ߐ X|4V;ޤ.پMR'-,)HV8*-}*bF5^ ՇfDcad4E+;:-i6j}˸#},FI|ŸmpFE)彡y5 ='i]˛BRBd qA "Og,\TyMb >OTN1mQADƚ(n8BoxZUAHٱ3V#7:PD5vd]%Q,/r%kF[|PfP7i[d vѡkTv^7M$@1ٍ,Xb[{hJ[#)ųMe ]yq7MHL2)P) +mU-sH4\ȌBȸDBXU(B87TsheP-qXurh .ױY':#C I@ JcgO;/1!G{lRI3Zb^4ވB~uNkHHI 'Lt#2j,0" >&:Y0! KB~7jWDž@4 I4 Zg(HSلP.Jke*LI&-reX~>D\<EJ~wLz>繳7F[GF >aF혡Z4Nd +:l 7$+U` {5IM7R뀁Q,Y![>@O<);䦄Mf(q~SbtR%Hs g-?QSE- [Dm{EstUQ5A"66Y͕ rRxIa=]ysME"y|Tp0 ]tÂ@/ A2sg*_4R$j%Kyo|fh>K\_ PFD[3ϢUKh`<}@n B0LYq\O9B!-5% m8L-y=ema=3~%* \' 4M+Ii9TH/g)ɗ_$ȵU+>=3<M8FFX-XkؕI E{j2GbwV;HRuٝ{d }"?fgb,؀XItDAqġoD8k G̚;s MT efeǼ}V'R.. 4 |9`QbE"_#2tS2)>7ǸMH$;8~wlhsk^y}*uV:@g2eㄙvi7ES^4_@ᑮ¨iM'>cok1 }3CT t"@a(lyGfKDɞ!#XJ] N0Nԇ0wV#<' &q;>/dW#DDwJ jE38`l4_1 )%T$!D7k>I] (؅,4$ W!49 F6/V %r2hl\!CqcOgq;S%@\؆9ğ_͚mV ɕvI @\|wa#c"]A MݢO}TWD tp"= :C[E8dAl6w0E5>cX4 bU)#.%|:ZPl6)lYb34X*}5etuެRPf4)p1#-Ӣ;Q 㧹R?dlFp3PbRi(m/B ݖ爨HS,CAF "D% Čd T Pc'+1iOs)<'5U q@w/|hlko۸[P?M YU Eb=gRD 3idA|1|K,##>BB&K k5Z{)<lSݪ0`ȫ ͖H6I,I]xN I4&O㡒5g5]|dIÍ/ҟmk` KîmjgGjPԥ  k *G6yTz(F~XwinKh#;ikL f4-k Rߑ {pVfηd Q |6NvC/*oq0fik@P`E,۝pd%[噗-> +F$S3Zf/ʙl!7fz4{b N<ڭzD !oJtf=j F@ 3$YN1a|R@ ?&,C*_,="_Ȯb(  jxuiPѓ$xH]0be D 2iʫM& |"T Qxj G-ř[SNAȯ|GY"uD=שQĸ5}7sL?>gh#@S IԼjWqG^B?9rg$CKۼ)jM}Ǔ)[I=_ЕCA^Ky'g pe&m>Lz2#[n0A*wMT|`b@JE\wȋ"dZ}\K0 Yhf\q ɜAX2,4= M_>(.UblC&s4.!r6vX0lI*g.a@xSj*2~鲏  I|O(!MA^K>-Tm9A UϵU21a,&"lxIUi6TS HYJ! KKVLIl iXK {vZbj~BMzm/9(S3%2٥jh җBRRQ3(>e4^XMsQju@7 ~ ]* Aضh^YY#|H' Ԧp N@Eb\68BsL(&xr#|YX4$S%؋˭i:CMN%(c$f}2=u!t~, ⸊q1=LIu#ǨbvWM\\C(˦ʸܡDjEΔv Kz Dp#ct>AhNtZJ^f#r!\#j%-N/N 6Me|e1O%VP`P'Yn ګ$2QpԔ|m}U w]9pTFIXLR0ӆ)c3l}UOA0#ݵIJTX,6]'sU] |wꤖ*-4UEA`@% EGD$5x$(o0AUu҅$l@ q"T gNDz'UTf2^ x`AI #{/#C.@+{Z:Prx|ю#W`g YM mY*( )EdBJ2&ۇd7 ߄. w|oʏ| Y(e.,\3[+3Y|"km$@Ϧ| *Z[v lY@XH@V!!T B:l*RqĒYw9y8e"ˊdPٍ4I}!ppJJ\E$ ѦAW`[~`Cũ:J!f*}Vh7A-@fw 8̥ w˔)wcKN/8/ZJ6,`DDgeL $. ]+f4a4^CTI6K V $XA7 QwF0,DQ"@w`7> v7ݾxTl  ١ZLwS wNy{~n6`*ؘ-$h谆 (JL#NDT,Xe|/3VbC`?*4S ׌DQ/Vו]sU`tҏMxyChrˇ>!dw)𘍂< ֬_(,Ix$Է@ oZ,=nqӻkqMX4ItKF=lc2&.b 9g$T$,V@̬04_:/"vT6#'S9 Lf'42'A!*RŞA[(~,ǦS .v*83ƶ؈GIy16X9Р /=(&Ƹ#ULP 5/eTK"=]A"i;6XF*eG\%6,TA*jMF3@eFC/ryR) X#~&rmϭb8_Urf4դ/D۶1+ t `PՐ#Ib`-(C UjF  ;Ѱ.?uQ'T/ dM-𞥀&wATES{fN7*`4 &E(Cu<.EO*ȹA $it* ldMf7+1'ai6$ rDWDJ)@ [pv!uVg˵DCPjxJ$eI.!S$@6oqݪL*)hW>6\+nq&!kp{_1I8-?|/} M݀4*'fD038tV+ ?b$1(sHxQXX.r% BUbu}^b}bR)E$@L0@B ̓44"#MԒ-ͥTYgZQ'z:9bR/LT :ۀ[!.cWE0s}_ #7dEs@$DC7 5 sc4 i=CSR@P^&s&(4Ǟ@1BRј,ei܈TK7;MPzrSkslJa%W83H偵X ;0X |g-/Ki`̄”-ƥOMIO`+>ܵJs-͏Z4dϊ!+'<4R^ h-f ](q:s"R$2dB046mI(N1ŇN4n 5}Tld/Ȑ{sHDCY#tVɷ;ߤ$}p $NF ݘ9Л%i* !*EcQQ"yDxnjhWEG&d2A9ksbJ"ThފAGpZRbXQ`YEZ5Z%a1\#*auclFXE* &>1%nDEu`VeH+}Xi".RŬ_)f "d0F* Lcepx@bAu NXu7~27}dg:À4 YK-l D(HJE5bz5V~,|־\~+H T 8IGCW:?+UiGӹTHǵ.#w7X8]ZSՄpBIXA%^\툈YR$j"lъ5 E0+H?#7 J*7.v;l S * ?RDuPR 0Asi?w\c]/0~q=FJ~h| EΨ q˳8ƃX b;DER$tT'#͝T$vRXBA"ȱ .u_;_ 9hUQW:XTMR5|tqH0+.]ņ-bȍR*)qGxb Y0"4J ~3Dg]rE~4XY*!Um6|H`۠VBxNp)NĕAǒ$I)fN% FG. X VTpjP*ξ&'.DEO`e4b t],]T^gx"29*3H>Zf3d'4"rlZChjW$7!h;#䭉aP,D`WODJh/.(4pn*7cybČ x 3Jc)0cvxHV/%Trqx =zvæRLhpX;R4 xzgu2 Դx$t b\@h0;n##"-7vgB.yh?0| q=EiE8dxzުr w҃Jd"abB$')hp&A~׷E`(0"NV&g?K:-q$6oWݢސRDD"' 2ɥxhث H*XN1慻b>Q8G剋Y}v'Y\$dD;5"O) VX^޲2INS@K) raalժ,pE c)!}mU0$ 4vTޓ+L[Eʲ+l;`1Jft*KD wSs"b" IONؒ 'ՠi +)H@DJ c}sr<,3P^!#~]Q@^ؓ &}s,8A-5- d&reDE, ( Jq..J-7<@dG,kZXc陟eɻ9)u D:Z{Mp0  JV@HLAD,~I:N,IAh@j ~ P*l+ox3W;ΊMTl8*/ƴקv`d;O;Wpӈ{8Ez%|@ >i髕0{Y3mfRV?(noV3ćK ̒͘ ҫWCz~sp#YWl^l 4FH1ތy~Ddy.3*zVɰSDŬNU?XzorJR)Ӳd }2>+PZneX;C< ZdqIObHWVJ{[;-P ^{mWFB.G8fh?Cy*J`hZbjchҼ,\|%L+j2 xIynEoʌP߲i8vnr%WV91IlxQm` U;kD|mXzGKY=  9$[߉ʳwDGJeMSY> ҵI*mv*17ˆ<(|I^6 $< dߎ\8frHhmBT\V9iSFvvh(%gN *[f)Azgzq%M1/39iɨ(ȝga`VŘ@𕩋ÒP n6h$kZ&]84`po4l\b&a ABZS{&X--~TbhˬG@RCx(!: @  hWqRG>Z3ܴ`* L׬u]V( Dq $P0+}Vط`EMTT]Se(4/4 v\C"4%ިL1'd'@h}¹@!ֱTXɠ&9XF? eb"MۀEݿU4yWA˫#}m i=G|uLHU5 J T%YY*w Z ƾ4aBM%4=B bU6NÎ,5r^&/o˾ȩZF 9R@| SIXEW(P7W0ǿ<,6Y5M*U;1_#66G]|PeK \絪tQ5dJ4 UHbޙk6QV'4|0|yo9B2JwP CВl(_P:L1Yy# @-_du_yB&Hܖ0 p( ѓ4(ȇ]`˅]K^Z8.T^WY!0@xZGb&@m W22 *^i{)UR B5k Dwãl%$A±rR|)G٭ L-7 <ǻp7i /)gтxLpJL>a6."&FQV4Wx?X4=U4aPK4n:ŏsC`liBg.HKSI99rFFM-xeOaph0Ely{duaQ4rQC g7U(p݀DCr}%iRPR  RL S&KJiG3/7p- C:[qB|u5kak(3DfzHYGU#֬Dmdtro2 4̄_ټbɠbCﶦqlE`0LYI;3Ws_H&e>W^U+/ZE{5>eS[F=鰚ݲawEԌJlvT$M6ES~(1w ڃ2,qH bL2Eq*vV4 N9J8xc 2#!`,Du ɍ+ͩQ(Z4ـ1-[]%tIVLX{7adC&m*in)S>AUr1FHT&L0HsI@D:l"1P ,i~1ܰ& m+a(.cLRU4؄J\e.H3MH`` V*Ѫ2AJTD|oYZPĈFJйM/gϛ\J_iq\0NT X$B;8"yfUrYRa8ŀ" );K[ѭ}>ipVKc Du"`-i`0tj[J.cDZ5 q3dM1c)@]*/l4C&Qp~թUx) ߼`X2 x9)f vR? G490-e fUL&MX)hQ4f-?{LITehJypI}fO+j ~~63m)P7Qq0} FVVsikJ0ԔC e 4W)q"uT Q"cʱ$qǂJ,B+kDPtˌNd\MH^FdQ6b>7:+1_NqВ'k)˻ {i9IXadLsUNά{jאe66M2].˹P0B9lub5e'X~rtIaj%6]с1@m&-X{$ikռ𙩩5I&4l YnHLy@s̡ ΤwlP/G3ޘwLH:bhBz .ɩ73W.uÃ|ns@fz4 &'C zf͕0Ub)=^tG\B3Tla+dˋTؒ,W+>!DhVmv!| %,i# %%/4 j$ܮyad:eR@gwNXɨ3.=VJ腲/2">:Pnb_1JJ 4-@`o%FtF8 Ժ1|!dc=v7-btʰL^X 8F sthf!O: a'>ŀ3^!4ljR 0-⨹w Áq 8YJ!&aޫJ+dln\b3b2SZ2ףX:T,P8ݒ[4gFsK]˝P$Y0P';\Bx1*T,?UQa}i8pQĮ$%KEDiwN'e/@a&xzOQ}Gݦ|f sfzWU_dxԟ[2c&}9R:M4׭vƗ6ۻb\]:6PXmjB|S >(lZ7VML$HtҘ韤TɃ5zhX"d)%V,M 36a%'4pv6eĚowV&`RM&W~1!s/T˲.:We7%Š,24c3EL%0M RO9]x(8MRQۏGE'z0hyse~=b,LwKealvwgL@)O{AEX [YO9J~rH0{TU, 8XgARg20)k/8)>C(ɪCE}_V }a)˿o-R̰A[LL]Tq@{f2K&؀D]p5u)îh}I٫aTUs>xpXJ3pt]@.yv)TY2^AZ#HԎ4T@/k`@] G4\"EpV$,R @zcTYEq@c^HkКU_OJrBF!Jrj8,JB[oTuv{97w ,BE[,2-2!}zǦvM1&\ɔiY5'7T JݤEIȭ'u^[HXFjE(#c*UICk7fw2F9R :[wicv%u( ŭ 'Ul!T(Br?cǍR8I&ܙܴEG1׷0Euj*=!b&8r7'a`✈qꯈHlHT,U4(Pd BeXfRw^]Q6\k=ZLُF %l)$ue8-3oHa7fӜ]CsIImQ,5J UGYd4F4Xʝ ݈y%'/}JJUk A K .D Ҡ8(*#W bb#Zm:\X HG)?T|B0M*q#Kux ߙMu\ \L=i^Kn *-EKm#dS,]%PPD%fIY$j:0="zD.,,X͚UA=XL]xQ[5%vZD4qh z(ھlXXek=EӡEퟄl%Lňܛ[&ER$e 7\&L`DWG.dZxU°b(#jEn 3[:Ap\ Uuԕ>TG^0 @);OSYRy;JS, 4bI%`Ҕmq?n'qQDʇ쩫38 o?ʒBQ_ #"ٿtHZN4 VKڭuOQ9aT{F18fx}%jňdjBa.0>˩ 舎#t$AA,{7Ȇ|WC5!fHe-7B+b}1(U@[@䤗,L&ёW/V2Sհ4)$Ǯ1dMYiDxyC2_% CaKG=J6 Z'k->?u፺~pKAPN E7eL|.bY+RM{q`$!"^!rg@tbȱ@șH"rs^ܠcQo*$}r6,(zԋ]_ c"%۬M4͗:C+` 3Vw7}f^q7TF2ZmH;3eX5ZT 0 I11Wٸ4m<K,EUA ǍgcnΉs" 6b On-:[E`1 ЏV7tU'rL\ͳ`􁋳wȿ"ןL I2žMkx}bP'RQUAr¼H҅ : !]07r8'ÆfpHWM"pDlAzԻ`A-lF)bo@3n&u>PM^-d01\<Ǝ≊>HlEzS dj6@U\(Hb`$x Űm,FLń,y! J`8 ajcX8/J-4ddܵaZe;2S>N EuUl-o!ȸ^ C?e%Q{M'܆tm"kݸB $1LDGVd,-e@dore/.dfT6/27@#0ETQ՘\lMn=p0\vXZJ^4#B㲄ރ`M# LZ[Ӥx d㗓F})R N7)=G54LZDx7#H5&a*m83o~bƭTҐ,U(2|(iֵAX[B<`,!ZDL6f': seKue f>f"Lp=]2 ywS+(;$w\JqC:!_yT;0r`#ȭ.~5Fu$f_e9ҟyPȋjAQp<4/04/:ܪ7vVO[ \  yep~I\=4W"b}㔄jE$S88/X@IYoeTʝ +}RވLxo&JV8k.0 ^ +PE+ZA}sw*,Arг!]Ėy L@#r3;HUF>JKBNٍJut^KѬ,8 -ĸ .XNwYwIG&l;D ԙpdʑh|%v號,؟2! >54 +r3NB!1xia) XpuȜۯOs4ޱj4"QS+HmXEƆ~F:3Čn&CUKJo%&ݤ B0dD}$!4j@Kc ZJh?R*):,,[xUdR1Xt[ [(Ls>~Eye_$Z5je;$([D -*LP;'lA]#U< `b6u37q`Fg ,iApre1PeD$tCGuUXI"(C`[b4HM0C|tָ _ ?Ե*$H C>ZF0_Ɨ؅ |!xkG-XEA^Ie\"폚Ds{ )4ɻM|_%6 q 5a^1={DED,6_pHmgJ Ȱ4@*MThS1F su8kB&B w) *RmzB4_bSWsm)]W e٣q4 ?5 [HQ)"M*2闱Vmiҿ3?NaDQgtKV[@jȦyIfV|&ˬXH_&?3F] |pRh0$" Uuf+ X_Θi4:IPc^UQ@1noϯgzBԦwD;Ed!o[;2"!Q^[`. :{hGrD2$@NZ =R*񬋛M0n[V[:0%|k,H%CgQ)rHS׊/wP@=;zHk=H8u[!2 D}P4bJ $^y#E,P@&0d4%OZ]\tfEb-6$} [M]!{] *pa`.L؟Cx Ξ&|9 O%Q͓o|e81BDj>X WҪ+4dctuoHJ%ylf! }\”xL=O&d `nrz<Š:Ӷ<P|ZdNb?.Ӱ9-&CVNVQ  ̑1@3HˀnI4oz5) +3L$zbn P@YN%`liClLHb) / ǤJdy,)irH/^hl 2 ZֲwR$>VL3|Yq|]5l,߆ xSY1G[ Z*"WRVފ{gב,%U^v*IN'` 4]DsϢn$'˗lCltˀ0L]CaoIT< #&3ܕ!t.{u3~̱Ɇ'6/ςtYts7JDX*aI)qtص˫FB:df8ڡ-1Ir,Ӫ^LM`(:rHZ(I%bp-QT|lj $h=͓"u)Z-KH٧c  P lYt% i:2.MKTؒQ9S2uEJTVlI#֪ZS Ɂ;/#1Vzz*4'XB >5d9L 6#pv,Bq3>ߢ/uZ<(y }l=(@q֧ C1@;W${-.)8 ;ȣyڑtǑ|d3(vM~0r7o}w;1#IMC֣{UD?676d T@p `0AULrŽ*'05n4eyA]ꨮeVɠ-Ӣԥ\#u#In)%ig) LĄ-P=g 5bŚ0 rբgkB pWf7`Tl$?(b8n2^yVI0t/\p7` ^%P>bBtn"6rtjEfه20O.qUbP/DJ@4}5C A#Kӹs!OGF<J_["iJ2E Q@0:^$e[}Y) 0xv_NħpЛ'8>)$vO gēpLJUb8+ I˶+c3jJ΂{ kP)dpe: _WD6HR~>oC#]Di:7CH(îÀ`g e}וBn0BGw1\ K,&؀݂8t@mdhњI1< ĘB HWdr). р4 kXOUXQ\ BLe39c)Fa5I*Djƀx/o1Lݗ{#^졑uM$ _,lϷG&HϪD5q$Q]-Q:'cJ8Z@ʥ 7;a蚭wbWvgj)qɆ>PY4!rge2#Fd06h&%~Qq o_{G3WH#,7qEI42՜Uj kpmi 4?yb@ ~XRjDЛeIKYI7 9tVHb !~bⓂub*$XdM1 ؚL'ȋͲÑUF.-E?g-r^lwTbu"aHJliORlRP ՃKdk0JO`|d1LAN]jֻͧ઴ګf/qh.Bn څD9ݥ~YR8x#ɊMYt~ I9XJ &^Jn輅ζ3H4@w1m(mn慥'lfx(EJm(cӊk#J`F 0ShL AAJNQ(h\ժZ%E+[ßNc!PU*_eSky )Te^$S׾igu Siau)9Y<9&`ICdO$ Zֲ[BW lEbAqW]Zle%> ǁ`3K \v8'#+^J)ů3ڪ-WW!8C LΞ$$zG2Ѽ0PyڰOT)_9}4#g4*J蕾x_P57r׽] M<ʱdwN "!e(% "o~AjE["bZ&Z`qPN7# c7pIXEFqbmmHr|H!x*,2j _5mJEtB gwp|<8tEVY%+E aU*`1'FUהX?^1dK&V _ե%x~Z*PPv&24AU_qۥ+b#6dol!P4I4ɥg^& *D>UR4çPIX}:{W*Q@1yB/@F&q ]P *TBRt^jAClA#<}YE#&k6?zu \zh'H4CEiVp5$zȊN(7@ 68( Y1X3?9`0x.)%zhҍ7|ܿe<;mh+ow'JG 4Qtu0G¯/*A]5+H+# [Jb\T5TROI<o Dj_h$Ft.  dJ.FJvm]EctEIZL*L{5H|%힆 =c' P1gsX]׉]]92nLۣKl^^&*Z4ch?C Q_4"t"^%M9,1fٽEΛrIxLAHl7ۙ/}}>L)8w R1-Rϊ,_R)If- MpvF6#[A@5" lK@" mRX:Gi$6T *2e =6g:nnի &iG,7bu5Hm@&r\$ mZ v{r*_!P/{C+nV]yw#T8k*-x S\ay2<W .҄'H $xdJ X|02w)|\4,# Pqg 6tX.`OkC܁CJZ3NSg {GPmJpH1,z֭cq1xAᤩPkpd$TTyCuEcB20zf'MdM)=y* 𴼡(2(mݟzbJvhZ>\a ^ˈ~5oqQ*[<433tz(h1C ^+嶉2XJ88'q-B^1GFAD wk(.E$QbGoq~$M_*@4__Խ!*^+F%].V5*J4&^ma@f[Yc-[%fehH FԸ&d]"E ÔI,rZAqp=t:MQw6:^&jk7 ԕaR0@J앆\f84!YQIqs4$F,5w IA;QР(_ k $>06LvW S\O=/A1xe^xplhXȠ K.p#)K`| e悢,Jq4յ_YDKf}c "]7<F䟴|8xZ%"<,4$y(yԧ+(ƻ!,:DU^-^i '7OK}"/k3Kn WSduͿp 'm2 >r{Ԑ.ѪɄ(#@IK!&uoPR`R7)!]U3d-`a$0Єh⧎+'ڳO<4+DK% KU+9)mɊ6:e\$Gϐap ͐03G^WMQDb,H䢌q7vgtوB1㠐-Y`&Q hii+3aZKb<9C9s%2/Zk t]>œ,ŏA b6^%> `s- `ѻNY#8Vtl Vģm8-v)5ꐖtũbA1[i'isrnd46v@̡t'?l̥IN'{Uy` .̀kV]V8,"+ Zд[``j>w$حaBZhIώD]U$ 0LWjőt$-1͔(h8J)rߤ/+kJ#cf/XV~x&\mlM[H>yf0*[d"{cHtY&SoF)͊+k?I"M/jVFV(85!LRvĵa???eVyLX%` ʰzv3[;Ur42&$R?ҡ/l !3Gп1L3aPL(^}$c;OZА(;taDWD;V8*Ou҆8XZ 0-4}A3RW 3}ba,ҁX}TUǎm\T`6~Y^wHM(~&aZoh^Pya_ .3^2 ɄD7`$Dzp4<+-s23$?e(h m[ pf!6ш%@n3* bwtFζcȻ5nNWʉ%+O&U$c+O$&91٨$aQ|Axrgᤂ infsK/WX9lnȢW9]1^En @[{bU,ŁbnҤtUF"f]ɅQ v\xQ#!ݱB :߫C|:Ԅr wSlM@(ОDL /^D:5ئ =gSoڑ.Yc_ebTu'{,/5R.IpZ=C1kS 3&jLs 0җ/ڮ6rޞ:oʬv,--?ۄkHm86n; 3)9Ņ*,(lBp\0DvɎ!EMAnRgIyr'#mB|V]>14QUf}gA"v"Ll9I{ I />0Wa-~rqA3Y{4D[rt%"=UO DHŪ* $|B78]Hد.g//j^\@$Ox*5kӪrjD>ĭ9)Hq8KvB`F-)랮]竌|iiyG w`^nSOvs"qf38=o,6,49af7BK$ńHD[avlimSEu ;Tt/z**<*7u!b)IO=`v`p* P@]z^$7ٹɉ4lPVd\-BU$2) eIhlwI|z ewT)*v@( w8[᠍TEEGfR*'nj,+ &@EƃOfn#5NJ AlWj60mJu@tЃ0i:U^m`l f:-H#@k.$FbTGa*8R  CwmQּs'Q^ (M&e*ь`,i]w4!Zt@jEx]Rf|LޯT^$`M] ] Q]0p/2g S]%ˋD@/>e7I~AWRT!t$YO#lZ{Jꅝ^'@joQ|˷ml#|2tGAy0׳zP|B#'!EQއU%S Fl{rjr.$Dz7 buPiZBU)(17k6!8^ޟљP`PkJ@(Hesa5,+T`xՈ;Q ,J%>-B zEA0|hל5j?U=7ͺM% Z*ED5 u2j}Mf*ڵ!{3O0GU[zM2H:ԕG:Wa? Ǎ}_lR@7Ps(wR(z^G~=!T~,3*(Yj FO.ZsLQD-M}nVx=C򔇟ew,ʹ@0˧ R6$\0:m@OZ C&QJRjвBr  S. r.H'W.(2]ਭp͹6[5Vt$0׻̬寢"wxoPd#xRyǫXJ/+O[̗pZxM}~|b*!npA4P8݅ĎDǂl#'&<dvYfc҃RFKSI5f,?E<[{s"P6˷2~ / U_"fH * Brk5G]'BͱF< D)~N4'm%WT 2&zp K2(r zXlt+SU)@E{]qY^df&JI$}us3UH+/vTI<ҒQw,!]#TdBZjPUFp?%z+N1|hBe^u0޶1| H9iX_T&Y^յjfbUqh шULqpzmeg@, 0M׏PrȣV+%ŝ, ;/ 0yL@{]$xlk̲[F6B0ˆJY^Mk4*|Ը(`[~ B DVvBíJhH>/+hWV*>ُ(F$txrᡂI)Z6/ {)]xXYH ڹRq҄Hri)m   MA-T(f]aȿFLJd⎿"Zpv?K$C&A0dlbݦ1 `|nl2ZpUN-Xk+2OavG[=^@r.s6}U,+j{^`e_V 1[.Sj(̅^μ*:o tj[Z\UhON/'ZY.,fe-tADx,t^ʆdF.9s5t]Z{;6IhRװ Ë j:JffnCR#wDžo~s).zvQ :%t+ _EDuZ ,FbF/^@w0H!AHO) A m`vƋlln4J%Tw&8ym)t|Ό$j ^$(,kôhhIXBܚ`!4Egw6-+ĵX:yxr\-Õa=,8h`<pv|3Rn `Jl*]_Oq8Qxv>2@&F,|z]}06ɞ3VMFX>nYƊbksND6my;$o0Xhu Te*D5e3P&3qS!S+U aik߯jB\y:%ᜌdǂU1 bW^Qu#ƅo}nJ[iaE:X| *$'U.(byqڶ uMcFFV4U,\6356||6+҄ϚNU+lUz2Ku)XytO2Fb@,+ mm}+]'dmf Rva*ÁDOd] ;'wU` z =|9* G>4,R .vV +4 L0wI2EEƃ:B)T ROJ*-sHsx/̕Κ! TXC?63r.<\X<-  #gC{3b$& ξRJ@~?c6786*]v q!Z" vP5+43ŽZ\!Iܮ`J8Gɸwt59m.@I$HIق@$hg-qIGQ$Xeaݻ ȈDpV`7'DC<+{ +v8pQ4FFxZ  $Ps;4*X/wȥW:[G%Z[AϩHA3ǬW $ă ,Ցx>uqo̎y~oɳ+`Br zy~- Op'-E*D\+M㩵e^k@\EgTKxE0dP$BS++,%YszJo,K, Qv,Bĩ8roXJđa"J IR : V5I![Y݁O&Yg C ()tz<#׃n/(UU?ѳ4Th!H!%lX8u~]U $@Ƭ0Х!O<(@$DDvK< )qt i'wth^`fDD1 `0dlq+Y#W b  *J'ٝ6wU>DpmqQQ]%vvjmR~71EZh1qɘkHc(j0$=山6.1l]AʞhJFsð!梗ر3<€.o8?Û z嶜?g%"tQF?S|JQغi.A8%HVSK&(lDmyI $GNG0&H0G4HCY|DȂJ* , a .!\lA QpEk[/+,ab>xPĠt6?xqCIE3 # q'Q}$C5{y"otA'8m""74p`Ң";I_8NI#0DFWq1IS P+QT in%X8Kqb L&O29}hE`km [+ۋv9 bUИ3:A[T}c$+$r/Hy9L)GIUI(9\? E :æU6(\z)FFuJqWJPnjrֺ(dc 6y) 3Ř2\HDz3##eLLypzhiq.%e1W@$A dc =;p ^!*""8#V舆F4X "NZI8i* X(i:Tww." !1kZ8-rև50yy^N&˦Y7˳,<CXՎy Py`YW}QeC*oR@ ѺX+c: 7 ?i Nª@贂EɜT-$iqr =I7$g;T'!GbDefɈa?#T?T{G)x%G*lʔfзb(p5b\$b7`t%+^aEX3I3SHp1I0p/ZI*b \Dܾ!΢ 5uNK(( 6i@f@*By+CDO]m;RIr&4k@ʁGʼn`ЕZ4ZvLq4hX@u&TݿOgDT(p Octvװ^ &Č3AQL$9Csz6&o3V;=!GsLgһ!0%!F1+gQa0LsN X<`(Մ $I$Dc:0\Dq<8* Y,#."owv! U@}*mZlүCi8Y`%tO"AX<_ IAk!<T@+Ej1LuK+ a%4+ǥ=_"&ZyZ9؋Wm$_kN>˙bЋ* cu.B.g$^dVqUmjW9Epa!pUݼJ|j[$iZҶч9VU8I@;`HU$Er@tޥXCGQœ{ -S1fg̎A̚mR V N%тHp* #@Ū$CnN"7z#$Vvaȁ r: ╢| 1#A+XDJyLgYWp+ %ZX +C`Vj&_Vgh CV}^m?lrdO3߾:G^툼mW1(6ArV=%4! o "-E22*NjlE֥hglroMBFQk7ɯTvD%fI`I `" L647TuIYOT  L0Ѭ*I|$)ûB7NF<,02Pwi<8+W/ .,+^yx@l*Kr`C-Z8(hK CIXE2p@/s eqbJe]%9 #D]TjZ!J]U7"PbO/ ;E Lz̨0 !fc[vȩXI })|ftz7HȪZ*u3a#} LJHH@7'VHk`$EXgT!z,(!c)3T|~ؐ F\zraRM3$ ~Z+%+OQD F,ynHIU %\zGD1PU5`[{u_Z@0 W M^L _}Lׄ+Kp$c<'DDI,I$1^mH+IDŤY;=: c bܬ(kVֳ P4P Yg 6j2d=LU˨=SQMygC!ౡqpFWY D@m%#۱3%GGjJu-@GƒuQ]$H PxMOfdxWF)#Am,;.:5_fy`2?x5v%ѾEs63#V)mDIˎV h R_+8 qq$1%|% >7W1cx1@$C%S) (Ձ$[]8B3eDAk i0)\@ 2Fi_- ^H;YUI&^dNN@HZ[F H0Ĉi)2NyA ;6`Ti6GVAJZe^ӵ*sǑ}٨ u$-}Y)z30aX@ iSXp⬑p*@t <:J%VN('2w6UV&붠j$@ָ\3I4 B`0DHzsE@0D! )(v@ gj" ZݭkLXM|F` _]+HE‚#B|K:I)9%/x #'Â*ygYZcZZ:SY!lQ␹>Ĭ IV1-#f!)|0 /=b%g)}WLTA\ f`$M5yDXw fS7>BxXZ s [ $q.-2@[|HZFV'TW$i ݉4n8k (D+ ,*H44^>3N YwrڶDAa rl_$Սd(h(2\W;-uN3W>sPiȓ}QT3Ld_ )|LHe&T8vJ _rvn">g*pRwwe}e:2mfUc f2:\0דg#Sj-/"T+17eJ1#t-=-?9yi͋daV?zkc $a#Jr-4*[s$' Px'z7W 5k# Тܽ}'j@c X$tGC8k;VvֵkZ4hrMX|P(-Z^urw>HD`›}8 hJWV*2L5%r^9A;¬ w:GP}%RiWB39Ο$|B€+uXCF\w!̫{kІc<h=OS"yC6fd9XA Mׄ嘑%uKi:!|Q\4NXN AcGqZO7$XQ;GX67-x\h<”X"LIՔy QK)gQͯXBiz mA"ltv(ZBzl)/OXّ5npXyDSYR0NȜv1Y\U)v2΍9C| <3=?crP 's9#D@I iH ufql+-ԲM"ݪ"4zX֔ҥj}4}f)clНpv ) [eL.zB+I-!%XgELCx@HV{X@tVLguUb2P ~"Ե2z*h6)3ʔbN+FzykB kq$@fy];R J$xvY:T/caxZX][DBNĵhAj:;$IbPz"!| )1JS];9&J9r}@KA1Ƅ7xe1)riro<^0I62rh\o;.ɾ2jei,|˔% R8į,|Qj1P<4j"=Sbd#!4K A)Ĥ`,e L GrY"65q[8h*"{XA@%C?$x #`T5'MN jmdr+g*+8x kpx]OT=T$*H'GKN&_b0 Xv1Fk::8 d,r 6+DR($XSZ[PJI -x!P7;8AVu%}P\Drd A -:AEMӢ03cp!.,(&$Tػi 2U30"*yݼ*<8,]$yڂ?|%2 7wW zBSPV^_~MwOLX JaMg;m4 "0(bb3"LN-K48 :Ģ@W_c.Fv,s %ZJc-I+"$]E%`$a#a{p28G [ $WA~$0(4Qc@H՜ 9b  (DDD90J4ԤZnX*P+-h&4ypڼWt'E%~zBAe`Kdې/$ˆ% n7(VT`BD7-98NnAb0K플9_4Բʟ 2g\{{bz{i5Vfױ^IxPh`q"Jf/)ʹ1n w($}2)M~AUA9bB1-uZ-˱ /3DzvYF>ݪM~b7|D . l@ 'WJS$C9k^죻ZG@Xj=Pqr|{kLXVjWv (x]@9@TDC""Q $o\CN(o`fZ`p 'Z%2ґS4H%H2KL<(Pm&Lð7͔^7n]\LX+ 'xwq[ln[5l# V]\ۻ78Z  $A+ `C| LX@ Tm5Hyȗ3ZZl RVCoƼevz,|2"9~3O'^莎9gB0 ZQ#VJ{g$A+$F1 _҅h]坃teBZ'Ze2 F}0ÈI$\D2" sMok~I@Pw3IYRg+u9 l@[-p 0x,2**Dв_lR -UHɠPlϫX2)ۉCpw$XY^2\ݬPEUOb[fQ]"LZFy8" +H ; Z΂tB:,kf8Q!Sê#^/6Mcna"V6j?f-nƌ3[Z눆DDlau/p$mq;i䈖wC8k $@Yw "X%az"%dQLQ:l+^p,& Jm^+Y/SCUBQw$KB'[tT`¶Eڰu,80b[#LCcu @@<jҳ-ճdIc 2-hW|5RhYbH$l/t@<t$n+ ߈D1)s<@*%%p0 0 9gy H߁@ LJZ^2hFțN}ҼDGn15uU\K 6HˆҴ >"#A+0rt@R,Yq]!n8]3XpHAVt[w9E f$"ӑA+\#@V a" f"Y0_wwD Ւ3Hy$Y& p2PDL-2.100/t/io-stl.t0000644000175000017500000000300514727756302013733 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use PDL::LiteF; use PDL::IO::STL; use File::Spec::Functions; use File::Temp qw/ tempfile /; my $cubev = pdl( PDL::float, [[0,0,0], [0,1,0], [1,1,0]], [[0,0,0], [1,1,0], [1,0,0]], [[0,0,0], [0,0,1], [0,1,1]], [[0,0,0], [0,1,1], [0,1,0]], [[0,0,0], [1,0,0], [1,0,1]], [[0,0,0], [1,0,1], [0,0,1]], [[0,0,1], [1,0,1], [1,1,1]], [[0,0,1], [1,1,1], [0,1,1]], [[1,0,0], [1,1,0], [1,1,1]], [[1,0,0], [1,1,1], [1,0,1]], [[0,1,0], [0,1,1], [1,1,1]], [[0,1,0], [1,1,1], [1,1,0]], ); my ($vertices, $faceidx) = rstl(catfile qw(t io-stl-cube.stl)); is_pdl $vertices->dice_axis(1, $faceidx->flat)->splitdim(1,3), $cubev; eval {wstl()}; like $@, qr/Usage:/, 'wstl error right'; { my $fh = tempfile(CLEANUP => 1); wstl $fh, $vertices, $faceidx; my ($v2, $f2) = rstl($fh); is_pdl $v2->dice_axis(1, $f2->flat)->splitdim(1,3), $cubev; } my $blender = float ' [0.0017237 0.102913 -0.00153113; 0.00195483 0.104636 -0.00253355; 0.00243758 0.104636 -0.00153113] [0.00138235 0.103254 -0.00253355; 0.000767261 0.103869 -0.00322725; 0.00108497 0.104636 -0.00322725] [0.00138235 0.103254 -0.00253355; 0.00108497 0.104636 -0.00322725; 0.00195483 0.104636 -0.00253355] '; ($vertices, $faceidx) = rstl(catfile qw(t io-stl-ascblender1.stl)); is_pdl $vertices->dice_axis(1, $faceidx->flat)->splitdim(1,3), $blender; ($vertices, $faceidx) = rstl(catfile qw(t io-stl-ascblender2.stl)); is_pdl $vertices->dice_axis(1, $faceidx->flat)->splitdim(1,3), $blender; done_testing; PDL-2.100/t/math.t0000644000175000017500000001370014763221604013450 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Math; use Test::PDL -atol => 0.01; use Config; is_pdl bessj0(0.5), pdl(0.9384), "bessj0"; is_pdl bessj0(0), ldouble(1), "bessj0"; is_pdl bessj1(0.1), pdl(0.0499), "bessj1"; is_pdl bessj1(0), ldouble(0) ,"bessj1"; is_pdl bessjn(0.8,3), pdl(0.010), "bessjn"; is_pdl bessyn(0.2,2), pdl(-32.15714) ,"bessyn"; { # test inplace my $pa = pdl(0.5,0.0); $pa->inplace->bessj0; is_pdl $pa, pdl(0.9384,1), "bessj0 inplace"; eval { $pa->inplace->bessj0(PDL->null) }; isnt $@, '', 'check providing explicit output arg to inplace throws exception'; } { my $pa = pdl(0.2); $pa->inplace->bessyn(2); is_pdl $pa, pdl(-32.15714), "bessyn inplace"; } is_pdl pow(2,3), sbyte(8), "pow"; is_pdl erf(0.), pdl(0.),"erf(0)"; is_pdl erf(30.), pdl(1.),"erf(30)"; is_pdl erf(0.5), pdl(1.-erfc(0.5)), "erf and erfc"; is_pdl erf(erfi(0.5)), pdl(0.5), "erfi (both ways)"; is_pdl erfi(erf(0.5)), pdl(0.5), "erfi (both ways)"; { # csqrt my $pi=4*atan2(1,1); my $eiO = exp(i()*(sequence(8)-3)*$pi/4); my $eiO2 = exp(i()*(sequence(8)-3)*$pi/8); is_pdl csqrt($eiO), $eiO2, "csqrt of complex"; is_pdl csqrt(-1), i(), "csqrt of real -1"; my $squares="-9 -4 -1 0 1 4 9"; my $roots="3i 2i i 0 1 2 3"; is_pdl long($squares)->csqrt, cdouble($roots), "csqrt of long"; is_pdl longlong($squares)->csqrt, cdouble($roots), "csqrt of longlong"; is_pdl float($squares)->csqrt, cfloat($roots), "csqrt of float"; is_pdl double($squares)->csqrt, cdouble($roots), "csqrt of double"; is_pdl ldouble($squares)->csqrt, cldouble($roots), "csqrt of ldouble"; is_pdl cfloat($squares)->csqrt, cfloat($roots), "csqrt of cfloat"; is_pdl cdouble($squares)->csqrt, cdouble($roots), "csqrt of cdouble"; is_pdl cldouble($squares)->csqrt, cldouble($roots), "csqrt of cldouble"; is_pdl pdl('-2i')->csqrt, pdl('1-i'); } is_pdl cacosh(-1), pdl('3.141592i'); is_pdl clog(-1), pdl('3.141592i'); is_pdl cacos(-2), pdl('3.141592-1.316957i'); is_pdl casin(-2), pdl('-1.570796+1.316957i'); { # csqrt_up my $pi=4*atan2(1,1); my $eiO = exp(i()*sequence(8)*$pi/4); my $eiO2 = exp(i()*sequence(8)*$pi/8); my $sqrt=csqrt_up($eiO); is_pdl($sqrt, $eiO2, "Square of csqrt_up of complex"); my $i=csqrt_up(-1); is_pdl($i, i(), "csqrt_up of real -1"); my $squares="-9 -4 -1 0 1 4 9"; my $roots="3i 2i i 0 1 2 3"; is_pdl long($squares)->csqrt_up, cdouble($roots), "csqrt_up of long"; is_pdl longlong($squares)->csqrt_up, cdouble($roots), "csqrt_up of longlong"; is_pdl float($squares)->csqrt_up, cfloat($roots), "csqrt_up of float"; is_pdl double($squares)->csqrt_up, cdouble($roots), "csqrt_up of double"; is_pdl ldouble($squares)->csqrt_up, cldouble($roots), "csqrt_up of ldouble"; is_pdl cfloat($squares)->csqrt_up, cfloat($roots), "csqrt_up of cfloat"; is_pdl cdouble($squares)->csqrt_up, cdouble($roots), "csqrt_up of cdouble"; is_pdl cldouble($squares)->csqrt_up, cldouble($roots), "csqrt_up of cldouble"; is_pdl pdl('-2i')->csqrt_up, pdl('-1+i'); } { my $pa = pdl(0.0,30.0); $pa->inplace->erf; is_pdl $pa, pdl(0.0,1.0), "erf inplace"; } { my $pa = pdl(0.5); $pa->inplace->erfc; is_pdl 1.0-$pa, erf(0.5), "erfc inplace"; } { my $pa = pdl( 0.01, 0.0 ); is_pdl erfi($pa), my $exp = pdl(0.00886,0.0), "erfi"; $pa->inplace->erfi; is_pdl $pa, $exp, "erfi inplace"; } eval {polyroots(1,0)}; like $@, qr/only works/, 'polyroots(1,0) throws exception not segfault'; my $coeffs = pdl(cdouble, 1,-55,1320,-18150,157773,-902055, 3416930,-8409500,12753576,-10628640,3628800); my $roots = 1+sequence(10); my $got; is_pdl qsort((polyroots $coeffs->re, $coeffs->im)[0]), $roots, 'polyroots'; polyroots $coeffs->re, $coeffs->im, $got=null; $got->inplace->qsort; is_pdl $got, $roots, 'polyroots with explicit output args'; is_pdl qsort(polyroots($coeffs)->re), $roots, 'polyroots native complex no output args'; polyroots $coeffs, $got=null; $got=$got->re->qsort; is_pdl $got, $roots, 'polyroots native complex explicit output args'; eval {polyroots(pdl("[1 0 0 0 -1]"),zeroes(5))}; is $@, '', 'polyroots no crash on 4 complex roots of 1'; is_pdl +(polyfromroots $roots, $roots->zeroes)[0], $coeffs->re, 'polyfromroots legacy no outargs'; polyfromroots $roots, $roots->zeroes, $got=null; is_pdl $got, $coeffs->re, 'polyfromroots legacy with explicit output args'; is_pdl polyfromroots(cdouble($roots)), $coeffs, 'polyfromroots natcom no outargs'; polyfromroots cdouble($roots), $got=null; is_pdl $got, $coeffs, 'polyfromroots natcom explicit outargs'; eval {pdl("[2 1 0 1]")->r2C->polyroots}; is $@, '', 'polyroots no crash on [2 1 0 1]'; my ($coeffs2, $x, $exp_val) = (cdouble(3,2,1), cdouble(5,7,9), cdouble(86,162,262)); is_pdl polyval($coeffs2, $x), $exp_val, 'polyval natcom no output'; polyval($coeffs2, $x, $got=null); is_pdl $got, $exp_val, 'polyval natcom explicit output'; is_pdl +(polyval($coeffs2->re, zeroes(3), $x->re, zeroes(3)))[0], $exp_val->re, 'polyval legacy no output'; polyval($coeffs2->re, zeroes(3), $x->re, zeroes(3), $got=null); is_pdl $got, $exp_val->re, 'polyval legacy explicit output'; { my $pa = sequence(41) - 20; $pa /= 4; #do test on quarter-integers, to make sure we're not crazy. my $ans_rint = pdl(-5,-5,-4,-4,-4,-4,-4,-3,-3,-3,-2,-2,-2,-2,-2, -1,-1,-1,0,0,0,0,0,1,1,1,2,2,2,2,2,3,3,3,4,4,4,4,4,5,5); is_pdl rint($pa), $ans_rint, "rint"; } is_pdl sinh(0.3), pdl(0.3045), "sinh"; is_pdl acosh(42.1), pdl(4.43305), "acosh"; is_pdl acos(0.3), pdl(1.2661), "acos"; is_pdl tanh(0.4), pdl(0.3799), "tanh"; is_pdl cosh(2.0), pdl(3.7621), "cosh"; is_pdl atan(0.6), pdl(0.54041), "atan"; { # inplace my $pa = pdl(0.3); $pa->inplace->sinh; is_pdl $pa, pdl(0.3045), "sinh inplace"; } if ($Config{cc} ne 'cl') { # lgamma not implemented for MS compilers my @x = lgamma(-0.1); is_pdl $x[0], pdl(2.36896133272879); is $x[1], -1; @x = lgamma(1.1); is_pdl $x[0], pdl(-0.0498724412598397); is $x[1], 1; my $p = sequence (1); $p->badvalue (0); $p->badflag (1); @x = lgamma($p->index(0)); is($x[0]->badflag(), 1); is($x[1]->badflag(), 1); } done_testing; PDL-2.100/t/transform.t0000644000175000017500000002052614732564205014541 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use PDL::Transform; use PDL::Transform::Cartography; # raster2fits helps limit mem consumption use Test::More; use Test::PDL; use Test::Exception; { ############################## ############################## # Test basic transformation my $t = t_linear(scale=>[2]); is_deeply [@$t{qw(idim odim)}],[1,1], "t_linear can make a 1-d transform"; my $pa = sequence(2,2)+1; is_pdl $pa->apply($t), pdl( [2, 2], [6, 4] ), "1-d apply on a collection of vectors ignors higher dim"; my $t2 = t_linear(scale=>[2,3]); is_deeply [@$t2{qw(idim odim)}],[2,2], "t_linear can make a 2-d transform"; is_pdl $pa->apply($t2), pdl( [2, 6], [6, 12] ), "2-d apply treats the higher dim"; is_pdl pdl(2,3)->invert($t2), pdl(1,1), "invert works"; my $t3 = t_rot([45,45,45]); is_pdl PDL::MatrixOps::identity(3)->apply($t3), pdl(<<'EOF'), 't_rot works'; 0.5 -0.14644661 0.85355339; 0.5 0.85355339 -0.14644661; -0.70710678 0.5 0.5 EOF my $t4 = t_linear(scale=>[2], idim=>2, odim=>2, iunit=>[('metres')x2], ounit=>[('radii')x2]); isnt $t4->{$_}, undef, "$_ in object" for qw(idim odim iunit ounit); my $t5 = t_linear(scale=>[0.5], idim=>2, odim=>2, iunit=>[('radii')x2], ounit=>[('half-radii')x2]) x $t4; is_deeply $t5->{iunit}, [('metres')x2], 'compose right iunit'; is_deeply $t5->{ounit}, [('half-radii')x2], 'compose right ounit'; } { ############################## # Simple testing of the map autoscaling my $pa = sequence(5,5); # Identity transformation should be an expensive no-op # (autoscaled correctly) is_pdl $pa->map(t_identity()), $pa; # Identity transformation on pixels should be a slightly less expensive # no-op (no autoscaling) is_pdl $pa->map(t_identity,{pix=>1}), $pa; # Scaling by 2 and then autoscaling should be an expensive no-op # (scaled, then autoscaled back down) is_pdl $pa->map(t_scale(2)), $pa; # Scaling by 2 in pixel coordinates should actually scale the image is_pdl $pa->map(t_scale(2),{pix=>1}), $pa*0.5; } ############################## # diab jerius' t_scale crash # (this is due to a problem with inplace flag handling in PDL <= 2.6; transform works around it) lives_ok { my $pa = pdl(49,49); my $t = t_linear({scale=>pdl([1,3]), offset=>pdl([12,8])}); my $pb = pdl( double, 2.2, 9.3); $pa->inplace->apply($t); my $q = 0; $pa += $q; }; ############################## # bad value handling... { my $pa = sequence(5,5); my $t1 = t_linear(pre=>[1.5,2]); my $t2 = t_linear(pre=>[1,2]); $pa->badflag(1); my $exp = pdl 'BAD BAD BAD BAD BAD; BAD BAD BAD BAD BAD; BAD BAD 0.5 1.5 2.5; BAD BAD 5.5 6.5 7.5; BAD BAD 10.5 11.5 12.5'; is_pdl $pa->map($t1,{pix=>1,method=>'l'}), $exp, "Bad values happen"; my $exp2 = pdl 'BAD BAD BAD BAD BAD; BAD BAD BAD BAD BAD; BAD 0 0.5 1.5 2.5; BAD 5 5.5 6.5 7.5; BAD 10 10.5 11.5 12.5'; is_pdl $pa->map($t1,{pix=>1,method=>'h'}), $exp2, "Bad values happen with 'h' method"; } { use PDL::IO::FITS; my $m51 = raster2fits(sequence(long, 10, 10), @PDL::Transform::Cartography::PLATE_CARREE); is_pdl $m51->map(t_identity,{method=>'s'}), $m51; #SHOULD be a no-op is_pdl my $m51map = $m51->map(t_identity, $m51->hdr,{method=>'s'}), $m51, 'map works with FITS hashref'; is_pdl pdl(0,0)->apply(t_fits($m51)), pdl(0,0)->apply(t_fits($m51map)); } ######################################## ######################################## ### ### Give map a workout... { ############################## # Basic testing of resampling methods my $pa = rvals(7,7) == 0; is_pdl $pa->match($pa,{method=>'s'}), $pa, "self-match with 's' method is a no-op"; is_pdl $pa->match($pa,{method=>'l'}), $pa, "self-match with 'l' method is an approximate no-op"; is_pdl $pa->match($pa,{method=>'h'}), $pa, "self-match with hanning method is an approximate no-op"; { my $b0 = zeroes($pa); $b0->slice([2,4],[2,4]) .= pdl([[0.0625,0.125,0.0625],[0.125,0.25,0.125],[0.0625,0.125,0.0625]]); is_pdl $pa->match($pa,{method=>'h',blur=>2}), $b0, "self-match with hanning method and blur of 2 blurs right"; } { my $pb = $pa->match($pa,{method=>'g'}); my $b0 = zeroes($pa)-9; my $bc = pdl([-9,-3.3658615,-2.7638017],[-3.3658615,-1.5608028,-0.95874296],[-2.7638017,-0.95874296,-0.35668313]); $b0->slice([1,3],[1,3]) .= $bc; $b0->slice([5,3],[1,3]) .= $bc; $b0->slice([1,5],[5,4]) .= $b0->slice([1,5],[1,2]); is_pdl $pb->clip(1e-9)->log10, $b0, "self-match with Gaussian method gives understood blur"; } { my $t = t_linear(pre=>[0.5,1]); { my $pb = $pa->map($t,{method=>'s',pix=>1}); is_pdl scalar $pb->whichND, indx([[3,4]]),'right boolean'; is_pdl $pb->slice(3,4), pdl([[1]]), 'offset with sample is a simple offset'; } { my $pb = $pa->map($t,{method=>'l',pix=>1}); is_pdl scalar $pb->whichND, indx([[3,4],[4,4]]),'right boolean'; is_pdl $pb->slice([3,4],4), pdl([[0.5,0.5]]), 'offset with linear interpolation does the right thing'; } { my $pb = $pa->map($t,{method=>'h',pix=>1}); is_pdl scalar $pb->whichND, indx([[3,4],[4,4]]), 'right boolean'; is_pdl $pb->slice([3,4],4), pdl([[0.5,0.5]]), 'offset with hanning interpolation does the right thing'; } } { ############################## #check that no resampling methods produce segfaults for transformations #was segfaulting on 'g' only use PDL::Transform::Cartography; my $m51 = raster2fits(sequence(long, 10, 10), @PDL::Transform::Cartography::PLATE_CARREE); my $tp = t_perspective(r0=>200,iu=>'arcmin',origin=>[-10,3]); foreach my $method(qw/s l c h g j H G/){ #f doesn't work so well on images this big lives_ok {$m51->map(!$tp,{nofits=>1,method=>$method})} "no map segfault m=>$method"; } } } { use PDL::Transform::Cartography; my $pa = raster2fits(sequence(byte, 10, 10), @PDL::Transform::Cartography::PLATE_CARREE); eval { $pa->match([100,100]) }; is $@, '', 't_fits invertible'; is earth_coast()->nbad, 0, 'earth_coast no BAD'; my $in = pdl '[178.5 63.1 NaN; NaN NaN 0; 178.5 63.1 1; 179 63.2 1; 179.6 63.3 1; -179.8 65 1; -179.5 65.1 0]'; my $exp = pdl '[178.5 63.1 0; 1000 1000 0; 178.5 63.1 1; 179 63.2 1; 179.6 63.3 0; -179.8 65 1; -179.5 65.1 0]'; my @cl_tests = ( [sub {clean_lines($in,{fn=>0})}, 'l'], [sub {clean_lines((map $in->slice($_), qw(0:1 (2))),{fn=>0})}, 'l p'], [sub {clean_lines((map $in->slice($_), qw(0:1 (2))), 0.1,{fn=>0})}, 'l p t'], [sub {clean_lines($in, 0.1,{fn=>0})}, 'lp t'] ); for (['', sub {}], ["broadcast ", sub { $_ = $_->dummy(2,2)->copy, $_->slice('0:1,,1')->where($_->slice('0:1,,1') < 500) += 2 for $in, $exp; }]) { my ($prefix, $mod) = @$_; $mod->(); is_pdl $_->[0]()->setnantobad->setbadtoval(1000), $exp, "${prefix}scalar $_->[1]" for @cl_tests; is_pdl +($_->[0]())[0]->setnantobad->setbadtoval(1000), $exp->slice('0:1'), "${prefix}listl $_->[1]" for @cl_tests; is_pdl +($_->[0]())[1]->setnantobad->setbadtoval(1000), $exp->slice('(2)'), "${prefix}listp $_->[1]" for @cl_tests; } $in = pdl '[178.5 63.1 1; 179 62 1; 178.8 63.1 1; 179 64.2 1; 179.2 63.7 1; 179.3 65 1; 179.4 63 1; 179.6 63.3 1; 179.8 65 1; 179.5 65.3 0]'; $exp = pdl '[179 64.2 1; 179.2 63.7 0; 179.4 63 1; 179.6 63.3 0]'; my $or = [[178.9,179.7], [62.8,64.5]]; is_pdl scalar $in->clean_lines(1.1,{or=>$or}), $exp, "scalar orange"; $in = pdl '[178.5 63.1 1; NaN NaN 0; 178.5 63.1 1; 179 63.2 0]'; $exp = pdl '[178.5 63.1 0; 178.5 63.1 1; 179 63.2 0]'; is_pdl scalar $in->clean_lines(1.1), $exp, "with filter_nan (default)"; } { ############################## # Test boundary conditions my $pa = sequence(5,5); { my $pb = $pa->match([10,10],{pix=>1,method=>'s'}); is_pdl $pb->slice([0,4],[0,4]), $pa; is_pdl $pb->slice([5,9]), zeroes(5,10); is_pdl $pb->slice('x',[5,9]), zeroes(10,5), "truncation boundary condition works"; } { my $pb = $pa->match([10,10],{pix=>1,method=>'h'}); is_pdl $pb->slice([0,4],[0,4]), $pa; is_pdl $pb->slice([5,9]), zeroes(5,10); is_pdl $pb->slice('x',[5,9]), zeroes(10,5), "truncation boundary condition works for jacobian methods"; } { my $pb = $pa->match([10,10],{pix=>1,method=>'s',bound=>'mp'}); is_pdl $pb->slice([0,4],[0,4]), $pa; is_pdl $pb->slice([9,5]), $pb->slice([0,4]); is_pdl $pb->slice('x',[5,9]), $pb->slice('x',[0,4]), "periodic and mirror boundary conditions work"; } { my $pb = $pa->match([10,10],{pix=>1,method=>'h',bound=>'mp'}); is_pdl $pb->slice([0,4],[0,4]), $pa; is_pdl $pb->slice([9,5]), $pb->slice([0,4]); is_pdl $pb->slice('x',[5,9]), $pb->slice('x',[0,4]), "periodic and mirror boundary conditions work for jacobian methods"; } } done_testing; PDL-2.100/t/pthread.t0000644000175000017500000001271314744204234014150 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Benchmark qw(timethese :hireswallclock); use Test::PDL -atol => 0.01; # set eps plan skip_all => 'No threads' if !PDL::Core::pthreads_enabled; set_autopthread_size(0); for ( [ 6, [6], 6, 0 ], [ 6, [5], 5, 0 ], [ 6, [4], 4, 0 ], [ 6, [7], 6, 0 ], [ 6, [7,12], 6, 1 ], [ 6, [5,12], 6, 1 ], [ 6, [12,7], 6, 0 ], [ 6, [12,5], 6, 0 ], [ 6, [7,5], 6, 0 ], [ 6, [4,5], 5, 1 ], [ 6, [5,4], 5, 0 ], [ 6, [4,5,12], 6, 2 ], [ 4, [9,6,2], 4, 1 ], [ 4, [6,9,2], 4, 0 ], ) { my ($thr_num, $size, $thr_want, $dim) = @$_; set_autopthread_targ($thr_num); (my $t = zeroes(@$size))++; is(get_autopthread_actual(), $thr_want, "right pthread no for (@$size)"); is(get_autopthread_dim(), $dim, "right pthread dim for (@$size)"); } set_autopthread_targ(0); my ($pa, $pb, $thr_want); my @T = ( [ sub { $_[0]->add_threading_magic(@_[1, 2]) }, sub { $_[0]->remove_threading_magic }, sub {}, {threaded => sub { $pa **= 1.3 }, unthreaded => sub { $pb **= 1.3 }}, 'explicit', ], [ sub { set_autopthread_targ($thr_want = $_[2]) }, sub { set_autopthread_targ(0); }, sub { is(get_autopthread_actual(), $thr_want, "right threadno auto") }, {threaded => sub { $pa **= 1.3 }}, 'auto', ], ); for (@T) { my ($thr_on, $thr_off, $thr_check, $bench_hash, $label) = @$_; { $pa = zeroes(200); $pb = zeroes(200); $thr_on->($pa, 0, 9); my $bench = timethese(20, $bench_hash); #diag explain $bench; $thr_check->(); is_pdl $pa,$pb, "pa and pb match $label"; } { $pa = sequence(3,10); $pb = ones(3); $thr_on->($pa, 1, 2); my $pc = inner $pa, $pb; $thr_off->($pa); my $cc = $pa->sumover; is_pdl $pc, $cc, "inner $label"; } { # Try multi-dim cases $pa = zeroes(200,2,2); $pb = zeroes(200,2,2); $thr_on->($pa, 0, 2); $pa+=1; $thr_off->($pb); $pb+=1; is_pdl $pa, $pb, "+= $label"; } ### Multi-dimensional incrementing case ### ## This is performed multiple times to be sure that indexing isn't ## messed up for the multiple pthreads foreach (1..20){ $pa = zeroes(3, 200,2,2); $thr_on->($pa, 1, 2); $pa += 1; ok( $pa->max < 1.1, "multi-run $label" ); # Should never be greater than 1 } { ### Pthread Indexing Test #### ### This checks for a problem seen in the dataflow back to the parent PDL (i.e. writeback xs code) ### seen when pthreading is present my $indexArg = pdl [[1]]; my $lutEx = pdl [[1,0],[0,1]]; # Do a pthreaded index operation $thr_on->($lutEx, 1, 2); my $in = $lutEx->index($indexArg); # Remove pthreading magic. This is a check to see if pthreading doesn't cause # errors in the lazy evaluation of the index operation that occurs in the following # inplace-assignment operation. $thr_off->($lutEx); # Do inplace assignment so that data is written back to the parent pdl: # The lazy evaluation of the index operation will occur here first $in .= 1; # Check for writeback to the parent PDL working (should have three ones in the array) my $lutExSum = $lutEx->sum; is_pdl $lutExSum, pdl(3), "writeback $label"; # Check for inplace assignment working. $in should be all ones my $inSum = $in->sum; is_pdl $inSum, pdl(2), "inplace $label"; } { ### Pthread Indexing Test #### ### Similar test to above, but the pthreading magic is changed (not just ### deleted) after the index operation my $indexArg = pdl [[1]]; my $lutEx = pdl [[1,0,0,1],[0,1,0,1]]; # Do a pthreaded index operation $thr_on->($lutEx, 1, 2); my $in = $lutEx->index($indexArg); $in->make_physical; # make sure the initial indexing operation has taken place # otherwise gets defered due to lazy evaluation. # Remove pthreading magic, and then add it back on another dim with # 4 threads. This is a check to see if pthreading doesn't cause # errors in the writeback-code of the index operation that occurs in the following # inplace-assignment operation. $thr_off->($lutEx); $thr_on->($lutEx, 0, 4); # Do inplace assignment so that data is written back to the parent pdl: # The lazy evaluation of the index operation will occur here first $in .= 1; # Check for writeback to the parent PDL working (should have three ones in the array) my $lutExSum = $lutEx->sum; is_pdl $lutExSum, pdl(5), "writeback with different magic $label"; # Check for inplace assignment working. $in should be all ones my $inSum = $in->sum; is_pdl $inSum, pdl(2), "inplace with different magic $label"; } } # These tests check for proper deferred handling of barf and warn messages when pthreading. ## Check Handling of barf messages when pthreading ### # These statements will cause pthread to happen in two pthreads set_autopthread_targ(2); set_autopthread_size(0); # Because of the duplicate 8's interpolates barf (in the PPcode) will get # called. This should not cause a segfault my $x = float( [1, 2, 3, 4, 5, 8, 9, 10], [1, 2, 3, 4, 5, 8, 8, 8] ); my $y = ($x * 3) * ($x - 2); # Setup to silence warning messages local $SIG{__WARN__} = sub { }; # Catch barf messages by running in eval: eval{ my ( $ans, $err ) = interpolate(8.5, $x, $y ); }; like( $@, qr/identical abscissas/ , "interpolate barf" ); # warning message segfaults when pthreaded if messages not deferred properly my $mask = zeroes(5,5); local $SIG{__WARN__} = sub { die $_[0] }; $mask->badvalue(1); eval{ PDL::gt($mask, 2, 0) }; like( $@, qr/badvalue is set to/, "safe barf" ); done_testing; PDL-2.100/t/tp-deep.t0000644000175000017500000001360214727756302014066 0ustar osboxesosboxesuse strict; use warnings; use Test::More 0.88; use Test::Deep qw( cmp_deeply code ); use Test::PDL qw( :deep eq_pdl ); use Test::Builder::Tester; use Test::Exception; use PDL; use PDL::Types; my @types = PDL::Types::types; isa_ok test_pdl( 1,2,3 ), 'Test::Deep::PDL'; for my $type ( @types ) { no strict 'refs'; my $sub = "test_$type"; isa_ok $sub->( 1,2,3 ), 'Test::Deep::PDL'; } { my $pdl1 = pdl( 1,2,3.13 ); my $got = { name => 'Histogram', data => $pdl1 }; my $pdl2 = pdl( 1,2,3.13 ); my $expected = { name => 'Histogram', data => $pdl2 }; throws_ok { ok $pdl1 == $pdl2 } qr/multielement ndarray in conditional expression /, '== dies with an error message'; throws_ok { is $pdl1, $pdl2 } qr/multielement ndarray in conditional expression /, 'is() dies with an error message'; } { my $pdl = pdl( 1,2,3.13 ); my $got = { name => 'Histogram', data => $pdl }; my $expected = { name => 'Histogram', data => $pdl }; throws_ok { ok $pdl == $pdl } qr/^multielement ndarray in conditional expression /, 'even shallow reference comparisons do not work with =='; } { my $pdl = pdl( 1,2,3.13 ); my $got = { name => 'Histogram', data => $pdl }; my $expected = { name => 'Histogram', data => $pdl }; test_out 'ok 1'; cmp_deeply $got, $expected; test_test 'cmp_deeply() without test_pdl() performs only shallow reference comparison'; } { my $pdl = pdl( 1,2,3.13 ); my $got = { name => 'Histogram', data => $pdl }; my $expected = { name => 'Histogram', data => $pdl->copy }; test_out 'not ok 1'; test_fail +4; test_diag 'Compared ${$data->{"data"}}'; test_err "/# got : '-?\\d+'/", "/# expect : '-?\\d+'/"; cmp_deeply $got, $expected; test_test 'but shallow reference comparison is not powerful enough'; } =pod The following test code may be a bit hard to follow. We're basically trying to ensure that my @vals = ( ... ); my $got = { data => long( @vals ) }; my $expected = { data => test_long( @vals ) }; cmp_deeply $got, $expected; passes for every conceivable type of ndarray (not only I), and for different sets of values @vals, some of which may contain bad values. We also test that { data => test_long( @vals ) } { data => test_pdl( long(@vals) ) } { data => code( sub { eq_pdl shift, long(@vals) } ) } yield the same results. =cut for my $vals ( [ 0 ], [ 2,3,0,1,99 ], [ 99,99,99 ] ) { for my $type ( @types ) { my @vals = @$vals; my $ctor = do { local *slot = $PDL::{ $type }; *slot{CODE} }; my $tester = do { local *slot = $Test::PDL::{ 'test_' . $type }; *slot{CODE} }; my $pdl = $ctor->( @vals )->inplace->setvaltobad( 99 ); note 'test with pdl = ', $pdl->info('%-8T'), ' ', $pdl; my $got = { data => $pdl }; my $expected1 = { data => $tester->( @vals ) }; $expected1->{data}->{expected}->inplace->setvaltobad( 99 ); test_out 'ok 1'; cmp_deeply $got, $expected1; test_test "$type succeeds when it should succeed, with ndarray supplied as values (@vals)"; my $expected2 = { data => test_pdl( $pdl ) }; test_out 'ok 1'; cmp_deeply $got, $expected2; test_test "... ($type) also when ndarray is supplied directly (@vals)"; my $expected3 = { data => code( sub { eq_pdl shift, $pdl } ) }; test_out 'ok 1'; cmp_deeply $got, $expected3; test_test "... ($type) and it's the same thing as using code() (@vals)"; } } { my $pdl1 = 2; my $pdl2 = pdl( 3,4,9.999 ); ok !eq_pdl( $pdl1, $pdl2 ), 'ndarrays are unequal to begin with'; my $got = { data => $pdl1 }; my $expected = { data => test_pdl( $pdl2 ) }; test_out 'not ok 1'; test_fail +5; test_diag 'Comparing $data->{"data"} as an ndarray:', 'received value is not an ndarray'; test_err "/# got : \\('2'\\)/", '/# expect : Double\s+D\s+\[3\].*/'; cmp_deeply $got, $expected; test_test 'fails with correct message and diagnostics when received value is not an ndarray'; test_out 'not ok 1'; test_fail +6; test_diag 'Ran coderef at $data->{"data"} on'; test_err '/#?\s*/'; test_diag "'2'", 'and it said', 'received value is not an ndarray'; cmp_deeply $got, { data => code( sub { eq_pdl shift, $pdl2 } ) }; test_test '... but the diagnostics are better than with code()'; } { my $pdl1 = pdl( 3,4,9.999 ); my $pdl2 = pdl( 3,4,10 ); ok !eq_pdl( $pdl1, $pdl2 ), 'ndarrays are unequal to begin with'; my $got = { data => $pdl1 }; my $expected = { data => test_pdl( $pdl2 ) }; test_out 'not ok 1'; test_fail +5; test_diag 'Comparing $data->{"data"} as an ndarray:', '1/3 values do not match'; test_err '/# got : Double\s+D\s+\[3\].*/', '/# expect : Double\s+D\s+\[3\].*/'; cmp_deeply $got, $expected; test_test 'fails with correct message and diagnostics on value mismatch'; test_out 'not ok 1'; test_fail +6; test_diag 'Ran coderef at $data->{"data"} on'; test_err '/#?\s*/', '/# PDL=SCALAR\(0x[0-9A-Fa-f]+\)/'; test_diag 'and it said', '1/3 values do not match'; cmp_deeply $got, { data => code( sub { eq_pdl shift, $pdl2 } ) }; test_test '... but the diagnostics are better than with code()'; } { my $pdl1 = short( 3,4,-6 ); my $pdl2 = long( 3,4,10 ); ok !eq_pdl( $pdl1, $pdl2 ), 'ndarrays are unequal to begin with'; my $got = { data => $pdl1 }; my $expected = { data => test_pdl( $pdl2 ) }; test_out 'not ok 1'; test_fail +5; test_diag 'Comparing $data->{"data"} as an ndarray:', 'types do not match (\'require_equal_types\' is true)'; test_err '/# got : Short\s+D\s+\[3\].*/', '/# expect : Long\s+D\s+\[3\].*/'; cmp_deeply $got, $expected; test_test 'fails with correct message and diagnostics on type mismatch'; test_out 'not ok 1'; test_fail +6; test_diag 'Ran coderef at $data->{"data"} on'; test_err '/#?\s*/', '/# PDL=SCALAR\(0x[0-9A-Fa-f]+\)/'; test_diag 'and it said', 'types do not match (\'require_equal_types\' is true)'; cmp_deeply $got, { data => code( sub { eq_pdl shift, $pdl2 } ) }; test_test '... but the diagnostics are better than with code()'; } done_testing; PDL-2.100/t/demos.t0000644000175000017500000000106514727756302013637 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::Demos; my @found = PDL::Demos->list; ok scalar @found, 'found demos'; my ($general) = grep /General$/, @found; isnt $general, undef, 'found the PDL demo' or diag 'found ', explain \@found; my @kw = PDL::Demos->keywords; ok scalar @kw, 'found keywords'; ok +(grep $_ eq 'pdl', @kw), 'found "pdl" in keywords' or diag explain \@kw; my @info = PDL::Demos->info('pdl'); is $info[0], 'pdl'; is scalar @info, 3, 'three elts in info'; my @demo = PDL::Demos->demo('pdl'); ok scalar @demo, 'demo commands'; done_testing; PDL-2.100/t/fits-noafh.t0000644000175000017500000000050614727756302014565 0ustar osboxesosboxesuse strict; use warnings; # Run fits.t with Astro::FITS::Header disabled use FindBin; open my $fh, "$FindBin::Bin/fits.t" or die "Cannot read $FindBin::Bin/fits.t: $!"; my $source = do { local $/; <$fh> }; close $fh; $INC{'Astro/FITS/Header.pm'} = 0; eval "#line 1 t/fits.t-run_by_fits-noafh.t\n$source"; die $@ if $@; PDL-2.100/t/storable_old_amd64.dat0000644000175000017500000000017314727756302016500 0ustar osboxesosboxespst0PDL  abcd DI@I@J@J@K@K@L@PDL-2.100/t/primitive-setops.t0000644000175000017500000000234414727756302016054 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::PDL; subtest 'setops' => sub { my $temp = sequence(10); my $x = which( ( $temp % 2 ) == 0 ); my $y = which( ( $temp % 3 ) == 0 ); is_pdl setops( $x, 'AND', $y ), my $exp = indx( [ 0, 6 ] ), "setops AND"; is_pdl intersect( $x, $y ), $exp, "intersect same as setops AND"; is_pdl setops( $x, 'OR', $y ), indx([0, 2, 3, 4, 6, 8, 9]), "setops OR"; is_pdl setops( $x, 'XOR', $y ), indx( [ 2, 3, 4, 8, 9 ] ), "setops XOR"; }; subtest 'intersect' => sub { my $intersect_test = intersect( pdl( 1, -5, 4, 0 ), pdl( 0, 3, -5, 2 ) ); is_pdl $intersect_test, pdl( -5, 0 ), 'Intersect test values'; }; subtest 'AND' => sub { # based on cases supplied by @jo-37 my @cases = ( [ pdl(1), empty(), empty() ], [ ones(1), empty(), empty() ], [ ones(4), empty(), empty() ], [ sequence(4), empty(), empty() ], [ pdl(1), ones(2), ones(1) ], [ ones(1), ones(2), ones(1) ], [ ones(4), ones(2), ones(1) ], [ sequence(4), ones(2), ones(1) ], ); is_pdl setops( $_->[0], 'AND', $_->[1] ), $_->[2], "$_->[0] AND $_->[1]" for @cases; }; done_testing; PDL-2.100/t/thread_def.t0000644000175000017500000000374614744204234014614 0ustar osboxesosboxesuse Test::More; use PDL::LiteF; use Test::Exception; use Test::PDL; use strict; use warnings; my $debug = 0; $PDL::debug = $debug; my $pa = sequence(3,4); my $pb = yvals(zeroes(4,3)) + sequence(4); my $pc = $pa->transpose->slice(':,-1:0'); # make sure compat alias works thread_define 'tline(a(n);b(n))', over { $_[0] .= $_[1]; }; # not very useful examples but simple and test the essentials broadcast_define 'tassgn(a(n,m);[o] b())', over { # sumover($_[0],$_[1]); $_[1] .= $_[0]->sum; }; broadcast_define 'ttext(a(n=3)), NOtherPars => 1', over { ${$_[1]} .= sprintf("%.3f %.3f %.3f,\n",$_[0]->list); #join(' ',$_[0]->list) . ",\n"; }; broadcast_define 'tprint(a(n);b(n)), NOtherPars => 1', over { ${$_[2]} .= "$_[1]"; }; PDL::Core::set_debugging(1) if $debug; tline($pc,$pb); is_pdl $pc, $pb; $pc = ones(5); # produce an error throws_ok { tline($pa,$pc); } qr/conflicting/; $pa = ones(2,3,4)*sequence(4)->slice('*,*,:'); tassgn($pa,($pb=null)); is_pdl $pb, 6*sequence(4); # test if setting named dim with '=' raises error # correctly at runtime $pa = sequence(4,4); throws_ok { ttext($pa, \my $text); } qr/conflicting/; # test if dim=1 -> broadcastdim note "testing tprint\n"; $pa = sequence(3); $pb = pdl [1]; my $text = ""; tprint($pa, $pb, \$text); is $text, '[1 1 1]'; # cut down from PDL::Apply which got broken by 2.057_01 thread_define '_apply_slice_ND(data(n);sl(2,m);[o]output(m)),NOtherPars=>2', over { my ($data, $sl, $output, $func, $args) = @_; _apply_slice_1D($sl, ones($data->type), my $output1D = null, $data, $func, $args); $output .= $output1D; }; thread_define '_apply_slice_1D(slices(n);dummy();[o]output()),NOtherPars=>3', over { my ($slices, $dummy, $output1D, $data, $func, $args) = @_; my $data_sliced = slice($data, $slices->unpdl); $output1D .= PDL::Core::topdl($data_sliced->$func(@$args)); }; my $x = sequence(5,3,2); my $slices = indx([0,2], [1,3], [2,4]); my $y = null; lives_ok { _apply_slice_ND($x, $slices, $y, 'sum', []) }; done_testing; PDL-2.100/t/pp_pod.t0000644000175000017500000002106314771135562014007 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::PP qw(Foo::Bar Foo::Bar foobar); # call pp_def and report args sub call_pp_def { my $obj = pp_def(@_); $obj; } # search and remove pattern in generated pod: sub find_usage { my ($obj, $str) = @_; my $res = $obj->{UsageDoc} =~ s/^\s+\Q$str\E;.*?(\n+|\z)//m; diag "Not found '$str' in: ", $obj->{UsageDoc} if !$res; $res; } # all checked? sub all_seen { my ($obj, $str) = @_; my $res = $obj->{UsageDoc} !~ /^.*?\b$str\b.*?;.*$/m; diag "Still: ", $obj->{UsageDoc} if !$res; $res; } pp_bless('Foo::Bar'); subtest a => sub { my $obj = call_pp_def(foo => Pars => 'a(n)', ); ok find_usage($obj, 'foo($a)'), 'function call'; ok find_usage($obj, '$a->foo'), 'method call'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest a_n => sub { my $obj = call_pp_def(foo => Pars => 'a(n)', NoExport => 1, ); ok find_usage($obj, '$a->foo'), 'method call'; ok find_usage($obj, 'Foo::Bar::foo($a)'), 'no-exp function call'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest a_b_noi => sub { my $obj = call_pp_def(foo => Pars => 'a(n); [o]b(n)', NoExport => 1, Overload => ['foo', 1], Inplace => ['a'], ); ok find_usage($obj, '$b = foo $a'), 'operator'; ok find_usage($obj, '$b = $a->foo'), 'method call'; ok find_usage($obj, '$a->foo($b)'), 'method, all args'; ok find_usage($obj, '$a->inplace->foo'), 'method, inplace'; ok find_usage($obj, '$b = Foo::Bar::foo($a)'), 'function call'; ok find_usage($obj, 'Foo::Bar::foo($a, $b)'), 'all args'; ok find_usage($obj, 'Foo::Bar::foo($a->inplace)'), 'function, inplace'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest a_b_oi => sub { my $obj = call_pp_def(foo => Pars => 'a(n); [o]b(n)', Overload => ['foo', 1], Inplace => ['a'], ); ok find_usage($obj, '$b = foo $a'), 'operator'; ok find_usage($obj, '$b = foo($a)'), 'function call'; ok find_usage($obj, 'foo($a, $b)'), 'all args'; ok find_usage($obj, '$b = $a->foo'), 'method call'; ok find_usage($obj, '$a->foo($b)'), 'method, all args'; ok find_usage($obj, 'foo($a->inplace)'), 'function, inplace'; ok find_usage($obj, '$a->inplace->foo'), 'method, inplace'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest a_b => sub { my $obj = call_pp_def(foo => Pars => 'a(n); [o]b(n)', ); ok find_usage($obj, '$b = foo($a)'), 'function call w/ arg'; ok find_usage($obj, 'foo($a, $b)'), 'all arguments given'; ok find_usage($obj, '$b = $a->foo'), 'method call'; ok find_usage($obj, '$a->foo($b)'), 'method call, arg'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest a_b_k => sub { my $obj = call_pp_def(foo => Pars => 'a(n); [o]b(n)', OtherPars => 'int k', ); ok find_usage($obj, '$b = foo($a, $k)'), 'function call w/ arg'; ok find_usage($obj, 'foo($a, $b, $k)'), 'all arguments given'; ok find_usage($obj, '$b = $a->foo($k)'), 'method call'; ok find_usage($obj, '$a->foo($b, $k)'), 'method call, arg'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_c_o => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n)', Overload => '?:', ); ok find_usage($obj, '$c = $a ?: $b'), 'biop'; ok find_usage($obj, '$c = foo($a, $b)'), 'function'; ok find_usage($obj, 'foo($a, $b, $c)'), 'function, all args'; ok find_usage($obj, '$c = $a->foo($b)'), 'method'; ok find_usage($obj, '$a->foo($b, $c)'), 'method, all args'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_c_oi => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n)', Overload => ['?:', 1], Inplace => ['a'], ); ok find_usage($obj, '$c = $a ?: $b'), 'biop'; ok find_usage($obj, '$c = foo($a, $b)'), 'function'; ok find_usage($obj, 'foo($a, $b, $c)'), 'function, all args'; ok find_usage($obj, '$c = $a->foo($b)'), 'method'; ok find_usage($obj, '$a->foo($b, $c)'), 'method, all args'; ok find_usage($obj, '$a ?:= $b'), 'mutator'; ok find_usage($obj, 'foo($a->inplace, $b)'), 'inplace function call'; ok find_usage($obj, '$a->inplace->foo($b)'), 'inplace method call'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_c_ni => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n)', Inplace => ['a'], NoExport => 1, ); ok find_usage($obj, '$c = Foo::Bar::foo($a, $b)'), 'function'; ok find_usage($obj, '$c = $a->foo($b)'), 'method'; ok find_usage($obj, '$a->foo($b, $c)'), 'method, all args'; ok find_usage($obj, '$a->inplace->foo($b)'), 'inplace method call'; ok find_usage($obj, 'Foo::Bar::foo($a, $b, $c)'), 'function, all args'; ok find_usage($obj, 'Foo::Bar::foo($a->inplace, $b)'), 'inplace function call'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_c_o => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n)', Overload => ['rho'], ); ok find_usage($obj, '$c = foo($a, $b)'), 'function'; ok find_usage($obj, 'foo($a, $b, $c)'), 'function, all args'; ok find_usage($obj, '$c = $a->foo($b)'), 'method'; ok find_usage($obj, '$a->foo($b, $c)'), 'method, all args'; ok find_usage($obj, '$c = rho $a, $b'), 'prefix biop'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_c_no => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n)', Overload => ['rho', 0, 0, 1], NoExport => 1, ); ok find_usage($obj, '$c = rho $a, $b'), 'prefix biop'; ok find_usage($obj, '$c = $a->foo($b)'), 'method'; ok find_usage($obj, '$a->foo($b, $c)'), 'method, all args'; ok find_usage($obj, '$c = Foo::Bar::foo($a, $b)'), 'function'; ok find_usage($obj, 'Foo::Bar::foo($a, $b, $c)'), 'function, all args'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest a_bc => sub { my $obj = call_pp_def(foo => Pars => 'a(n); [o]b(n); [o]c(n)', ); ok find_usage($obj, 'foo($a, $b, $c)'), 'multi output function call, all args'; ok find_usage($obj, '($b, $c) = foo($a)'), 'multi output function call'; ok find_usage($obj, '($b, $c) = $a->foo'), 'multi output method call'; ok find_usage($obj, '$a->foo($b, $c)'), 'method call, all args'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_k_c => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n)', OtherPars => 'int k', ArgOrder => [qw(a b k c)], ); ok find_usage($obj, 'foo($a, $b, $k, $c)'), 'OtherPars, ArgOrder, function call, all args'; ok find_usage($obj, '$c = $a->foo($b, $k)'), 'OtherPars, ArgOrder, method call'; ok find_usage($obj, '$a->foo($b, $k, $c)'), 'OtherPars, ArgOrder, method call, all args'; ok find_usage($obj, '$c = foo($a, $b, $k)'), 'OtherPars, ArgOrder, function call'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_c_k => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n)', OtherPars => 'int k', ); ok find_usage($obj, 'foo($a, $b, $c, $k)'), 'OtherPars, function call, all args'; ok find_usage($obj, '$c = $a->foo($b, $k)'), 'OtherPars, method call'; ok find_usage($obj, '$a->foo($b, $c, $k)'), 'OtherPars, method call, all args'; ok find_usage($obj, '$c = foo($a, $b, $k)'), 'OtherPars, function call'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_k_cd => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n); [o]d(n)', OtherPars => 'int k', ArgOrder => [qw(a b k c d)], ); ok find_usage($obj, 'foo($a, $b, $k, $c, $d)'), 'Multi-out, OtherPars, ArgOrder, function call, all args'; ok find_usage($obj, '($c, $d) = $a->foo($b, $k)'), 'Multi-out, OtherPars, ArgOrder, method call'; ok find_usage($obj, '$a->foo($b, $k, $c, $d)'), 'Multi-out, OtherPars, ArgOrder, method call, all args'; ok find_usage($obj, '($c, $d) = foo($a, $b, $k)'), 'Multi-out, OtherPars, ArgOrder, function call'; ok all_seen($obj, 'foo'), 'all seen'; }; subtest ab_cd_k => sub { my $obj = call_pp_def(foo => Pars => 'a(n); b(n); [o]c(n); [o]d(n)', OtherPars => 'int k', ); ok find_usage($obj, 'foo($a, $b, $c, $d, $k)'), 'Multi-out, OtherPars, function call, all args'; ok find_usage($obj, '($c, $d) = $a->foo($b, $k)'), 'Multi-out, OtherPars, method call'; ok find_usage($obj, '$a->foo($b, $c, $d, $k)'), 'Multi-out, OtherPars, method call, all args'; ok find_usage($obj, '($c, $d) = foo($a, $b, $k)'), 'Multi-out, OtherPars, function call'; ok all_seen($obj, 'foo'), 'all seen'; }; done_testing; PDL-2.100/t/primitive-stats.t0000644000175000017500000000317114727756302015674 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::PDL -atol => 1e-3; # provide independent copies of test data. sub IM { PDL->new( [ [ 1, 2, 3, 3, 5 ], [ 2, 3, 4, 5, 6 ], [ 13, 13, 13, 13, 13 ], [ 1, 3, 1, 3, 1 ], [ 10, 10, 2, 2, 2, ] ] ); } subtest 'default type' => sub { my @statsRes = IM->stats; is_pdl $statsRes[0], pdl( 5.36 ), "mean"; is_pdl $statsRes[1], pdl( 4.554 ), "prms"; is_pdl $statsRes[2], pdl( 3 ), "median"; is_pdl $statsRes[3], pdl( 1 ), "min"; is_pdl $statsRes[4], pdl( 13 ), "max"; is_pdl $statsRes[6], pdl( 4.462 ), "rms"; }; subtest 'short' => sub { my @statsRes = IM->short->stats; # Make sure that stats are promoted to floating-point is_pdl $statsRes[0], float( 5.36 ), "short mean"; is_pdl $statsRes[1], float( 4.554 ), "short prms"; is_pdl $statsRes[2], short( 3 ), "short median"; is_pdl $statsRes[3], long( 1 ), "short min"; is_pdl $statsRes[4], long( 13 ), "short max"; is_pdl $statsRes[6], float( 4.462 ), "short rms"; }; subtest 'weights' => sub { my $ones = ones( 5, 5 ); my @statsRes = IM->stats($ones); is_pdl $statsRes[0], pdl( 5.36 ), "trivial weights mean"; is_pdl $statsRes[1], pdl( 4.554 ), "trivial weights prms"; is_pdl $statsRes[2], pdl( 3 ), "trivial weights median"; is_pdl $statsRes[3], pdl( 1 ), "trivial weights min"; is_pdl $statsRes[4], pdl( 13 ), "trivial weights max"; is_pdl $statsRes[6], pdl( 4.462 ), "trivial weights rms"; }; done_testing; PDL-2.100/t/reduce.t0000644000175000017500000000067214744321614013773 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use PDL::LiteF; use PDL::Reduce; my $pa = sequence 5,5; is_pdl $pa->reduce('add',0), $pa->sumover; is_pdl $pa->reduce('add',1), $pa->mv(1,0)->sumover; is_pdl $pa->reduce('mult',1), $pa->mv(1,0)->prodover; # test the new reduce features is_pdl $pa->reduce('+',0,1), $pa->sum; # reduce over list of dims is_pdl $pa->reduce(\&PDL::sumover), $pa->sumover; # use code refs done_testing; PDL-2.100/t/picnorgb.t0000644000175000017500000000644014727756302014335 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use PDL::IO::Pic; use PDL::ImageRGB; use PDL::Dbg; use File::Temp qw(tempdir); use File::Spec; use Test::More; use Test::PDL; sub rpic_unlink { my $file = shift; my $pdl = PDL->rpic($file); unlink $file; return $pdl; } sub rgb { $_[0]->getndims == 3 && $_[0]->getdim(0) == 3 } $PDL::debug = 1; my $iform = 'PNMRAW'; # change to PNMASCII to use ASCII PNM intermediate # output format # [FORMAT, extension, ushort-divisor, # only RGB/no RGB/any (1/-1/0), mxdiff] # no test of PCX format because seems to be severely brain damaged my %formats = ('PNM' => ['pnm',1,0,0.01], 'GIF' => ['gif',256,0,1.01], 'TIFF' => ['tif',1,0,0.01], # 'RAST' => ['rast',256,0,1.01], # 'SGI' => ['rgb',1,0,0.01], ); # only test PNM format # netpbm has too many bugs on various platforms my @allowed = (); for ('PNM') { push @allowed, $_ if PDL->rpiccan($_) && defined $formats{$_} } plan skip_all => 'No tests' if !@allowed; note "Testable formats on this platform:\n ".join(',',@allowed)."\n"; my $im1 = pdl([[0,65535,0], [256,256,256], [65535,256,65535]])->ushort; my $im2 = byte $im1/256; # make the resulting file at least 12 byte long # otherwise we run into a problem when reading the magic (Fix!) # FIXME my $im3 = PDL::byte [[0,0,255,255,12,13],[1,4,5,6,11,124], [100,0,0,0,10,10],[2,1,0,1,0,14],[2,1,0,1,0,14], [2,1,0,1,0,14]]; if ($PDL::debug) { note $im1; $im1->px; note $im2; $im2->px; note $im3>0; $im3->px; } # for some reason the pnmtotiff converter coredumps when trying # to do the conversion for the ushort data, haven't yet tried to # figure out why my $tmpdir = tempdir( CLEANUP => 1 ); sub tmpfile { File::Spec->catfile($tmpdir, $_[0]); } foreach my $format (sort @allowed) { note " ** testing $format format **\n"; my $form = $formats{$format}; my $tushort = tmpfile("tushort.$form->[0]"); my $tbyte = tmpfile("tbyte.$form->[0]"); my $tbin = tmpfile("tbin.$form->[0]"); eval { $im1->wpic($tushort,{IFORM => "$iform"}) } unless $format eq 'TIFF'; SKIP: { my $additional = ''; if ($format ne 'TIFF' && $@ =~ /maxval is too large/) { $additional = ' (recompile pbmplus with PGM_BIGGRAYS!)'; } skip "Error: '$@'$additional", 2 if $@; $im2->wpic($tbyte,{IFORM => "$iform"}); $im3->wpic($tbin,{COLOR => 'bw', IFORM => "$iform"}); my $in1 = rpic_unlink($tushort) unless $format eq 'TIFF'; my $in2 = rpic_unlink($tbyte); my $in3 = rpic_unlink($tbin); if ($format ne 'TIFF') { my $scale = ($form->[2] || rgb($in1) ? $im1->dummy(0,3) : $im1); my $comp = $scale / PDL::ushort($form->[1]); is_pdl $comp,$in1,$form->[3]; } { my $comp = ($form->[2] || rgb($in2) ? $im2->dummy(0,3) : $im2); is_pdl $comp,$in2; } { my $comp = ($form->[2] || rgb($in3) ? ($im3->dummy(0,3)>0)*255 : ($im3 > 0)); $comp = $comp->ushort*$in3->max if $format eq 'SGI' && $in3->max > 0; is_pdl $comp,$in3; } if ($PDL::debug) { note $in1->px unless $format eq 'TIFF'; note $in2->px; note $in3->px; } } } done_testing; PDL-2.100/t/imagergb.t0000644000175000017500000000112014727756302014275 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use PDL::LiteF; use PDL::ImageRGB; use PDL::Dbg; is_pdl bytescl(float(1..5),100), byte(1..5); is_pdl bytescl(float(1,2,3,4,5),-100), byte([0,25,50,75,100]); is_pdl rgbtogr(pdl([1,1,1],[1,0.5,0.7],[0.1,0.2,0.1])), pdl([1,0.67,0.16]), {atol=>1e-2}; { my $im = byte('1 2 3;0 3 0'); my $lut = byte('0 0 0;10 1 10;2 20 20;30 30 3'); # also works: $lut->indexND(sequence(1,3)->append($im->slice('*1,*3'))) my $interl = byte('[10 1 10;2 20 20;30 30 3] [0 0 0;30 30 3;0 0 0]'); is_pdl interlrgb($im,$lut),$interl; } done_testing; PDL-2.100/t/compression.t0000755000175000017500000000223314727756302015072 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use PDL::LiteF; use PDL::Compression; use PDL::IO::FITS; my $m51 = rfits('lib/PDL/Demos/m51.fits'); my ($y, $xsize, undef, $len) = $m51->rice_compress; is $len->max->sclr, 373, 'right maximum length'; my $m51_2 = eval { $y->rice_expand($len, $xsize) }; if (is $@, '', 'no error') { is_pdl $m51, $m51_2, 'decompress same as original'; } my $expected = pdl(byte, '[[126 122 122 128 128 124 124 128 128 128 127 126 126 127 127 128 124 124 123 123 122 122 121 121 120 120 119 119 118 118 117 117 118 118 117 116 115 114 113 113 116 115 115 114 114 113 112 112 111 111 110 110 110 110 110 110 109 109 110 110 110 111 111 111]]'); my $compressed_correct = pdl(byte, '[[126 48 24 0 96 48 14 179 32 54 219 109 147 85 96 91 91 126 206 112]]'); my $got = eval { $compressed_correct->rice_expand($compressed_correct->dim(0), 64) }; is $@, '', 'no error'; is_pdl $got, $expected, 'decompress correct version gives right answer'; ($y, $xsize, undef, $len) = $expected->rice_compress(32); $got = eval { $y->rice_expand($len, $xsize) }; is $@, '', 'no error'; is_pdl $got, $expected, 'decompress same as original (2)'; done_testing; PDL-2.100/t/fastraw.t0000644000175000017500000000662114727756302014202 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::PDL; use File::Temp qw(tempdir); use File::Spec::Functions; use PDL::IO::FastRaw; # PDL::Core::set_debugging(1); kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. my $tmpdir = tempdir( CLEANUP=>1 ); my $name = catfile($tmpdir, "tmp0"); my $name_hdr = "$name.hdr"; my $header = catfile($tmpdir, "headerfile" . $$); sub startdata { pdl [2,3],[4,5],[6,7] } sub cleanfiles { unlink for grep -f, $name, $name_hdr, $header } # save an ndarray to disk my $x = startdata(); writefraw($x,$name); ok((-f $name and -f ($name_hdr)), "Writing should create a file and header file"); # read it back, and make sure it gives the same ndarray my $y = readfraw($name); is_pdl $x, $y, "A ndarray and its saved copy should be about equal"; # Clean things up a bit undef $x; undef $y; cleanfiles(); # save an ndarray to disk $x = startdata(); writefraw($x,"$name.g"); my $x1 = pdl [10,11]; gluefraw($x1,"$name.g"); $y = readfraw("$name.g"); is_pdl $y, pdl([2,3],[4,5],[6,7],[10,11]), "glued data correct"; unlink "$name.g", "$name.g.hdr"; # Clean things up a bit undef $x; undef $y; # test the use of a custom header for writing $x = startdata(); writefraw($x,$name,{Header => $header}); ok -f $header, "writefraw should create the special header file when specified"; # test the use of a custom header for reading $y = readfraw($name,{Header => $header}); is_pdl $x, $y, "Should be able to read given a specified header"; # some mapfraw tests SKIP: { writefraw($x = startdata(), $name); my $c = eval { mapfraw($name) }; if ($@) { diag("$@"); if ($@ =~ m/mmap not supported/) { skip('no mmap support', 5); } } # compare mapfraw ndarray with original ndarray is_pdl $x, $c, "A ndarray and its mapfraw representation should be about equal"; # modifications should be saved when $c goes out of scope $c += 1; undef $c; $y = readfraw($name); is_pdl $x+1,$y, "Modifications to mapfraw should be saved to disk no later than when the ndarray ceases to exist"; # We're starting a new test, so we'll remove the files we've created so far # and clean up the memory, just to be super-safe undef $x; undef $y; cleanfiles(); # test creating a pdl via mapfraw # First create and modify the ndarray $x = mapfraw($name, {Creat => 1, Datatype => float, Dims => [3,2]}); ok $x->allocated, 'mapfraw-ed shows is allocated'; $x += xvals $x; $x += 0.1 * yvals $x; # save the contents undef $x; undef $y; # Load it back up and see if the values are what we expect $y = readfraw($name); is_pdl $y, float([[0,1,2],[0.1,1.1,2.1]]), "mapfraw should be able to create new ndarrays"; # test the created type ok($y->type == float, 'type should be of the type we specified (float)'); # mapfraw custom header tests # Clean things up a bit undef $x; undef $y; cleanfiles(); # test the use of a custom header for writing $x = startdata(); writefraw($x,$name,{Header => $header}); ok(-f $header, "writefraw should create the special header file when specified"); $c = eval { mapfraw($name,{Header => $header}) }; if ($@) { diag("$@"); if ($@ =~ m/mmap not supported/) { skip('no mmap support', 1); } } # test custom headers for mapfraw is_pdl $x, $c, "mapfraw works with a specified header"; } done_testing; PDL-2.100/t/storable_new_amd64.dat0000644000175000017500000000030714727756302016512 0ustar osboxesosboxespst0 PDLAPDL_B   abcd hPDL_D I@I@J@J@K@K@L@PDL-2.100/t/dumper.t0000644000175000017500000000533414727756302014027 0ustar osboxesosboxesuse strict; use warnings; use PDL::IO::Dumper; use Test::More; use Test::PDL; use Config; use PDL::LiteF; ########### Dump several items and make sure we get 'em back... # a: trivial # b: 0-d # c: inline # d: advanced expr my $s; # Need a value greater than the uuencode dump threshold. # Currently 25 but may change in future. my $big_size = int (5 + sqrt $PDL::IO::Dumper::med_thresh); my @big_dims = ($big_size, $big_size); # Small thresh is currently 8 my $med_size = int (2 + sqrt $PDL::IO::Dumper::small_thresh); my @med_dims = ($med_size, $med_size); eval { $s = sdump({a=>3,b=>pdl(4),c=>xvals(3,3),d=>xvals(@med_dims)}) }; is $@, '', 'Call sdump()' or diag("Call sdump() output string:\n$s\n"); my $x = eval $s; is $@, '', 'Can eval dumped data code' or diag("The output string was '$s'\n"); isa_ok $x, 'HASH', 'HASH was restored'; cmp_ok $x->{a}, '==', 3, 'SCALAR value restored ok'; is_pdl $x->{b}, pdl(4), '0-d PDL restored ok'; is_pdl $x->{c}, xvals(3,3), '3x3 PDL restored ok'; is_pdl $x->{d}, xvals(@med_dims), '"medium" sized PDL restored ok'; ########## Dump a uuencoded expr and try to get it back... # e: uuencoded expr eval { $s = sdump({e=>xvals(@big_dims)}) }; is $@, '', 'sdump() of "big" PDL to test uuencode dumps'; $x = eval $s; is $@, '', 'Can eval dumped "big" PDL' or diag 'string: ', $s; ok((ref $x eq 'HASH'), 'HASH structure for uuencoded "big" PDL restored'); is_pdl $x->{e}, xvals(@big_dims), 'Verify "big" PDL restored data'; ########## Check header dumping... my $y; eval { $x = xvals(2,2); $x->sethdr({ok=>1}); $x->hdrcpy(1); $y = xvals(@big_dims); $y->sethdr({ok=>2}); $y->hdrcpy(0); $s = sdump([$x,$y,yvals(@big_dims)]); }; is $@, '', 'Check header dumping'; $x = eval $s; is $@, '', 'ARRAY can restore'; is ref($x), 'ARRAY' or diag explain $s; ok eval { $x->[0]->hdrcpy() == 1 && $x->[1]->hdrcpy() == 0 }, 'Check hdrcpy() persist'; ok eval { ($x->[0]->gethdr()->{ok}==1) && ($x->[1]->gethdr()->{ok}==2) }, 'Check gethdr() values persist'; # GH508 { # need 10 vals to trigger GH508 my $x = xvals(10); my $y1 = $x; my $y2 = 2*$x; my $y3 = $x*$x; my %plots = ( 'x1'=>$x, 'y1'=>$y1, 'x2'=>$x, 'y2'=>$y2, 'x3'=>$x, 'y3'=>$y3, ); my $as_string = sdump \%plots; my $restored = eval $as_string; my @nulls = grep {!defined $restored->{$_}} sort keys %$restored; is_deeply \@nulls, [], 'none of the restored items are undef'; # test a dump with uuencoded content my $u = xvals(@big_dims); my @ndarrays = ($u, $u); $as_string = sdump \@ndarrays; $restored = eval $as_string; @nulls = grep {!defined $_} @$restored; is_deeply \@nulls, [], 'none of the restored uuencoded items are undef'; } done_testing; PDL-2.100/t/primitive-selector.t0000644000175000017500000001625614744321614016357 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use Test::PDL; subtest 'where' => sub { subtest 'where' => sub { my $y = PDL->pdl( 4, 3, 1, 0, 0, 0, 0, 5, 2, 0, 3, 6 ); my $c = ( $y->xvals ) + 10; is_pdl $y->where( $y > 4 ), PDL->pdl( 5, 6 ), ">"; is_pdl $c->where($y), PDL->pdl( 10, 11, 12, 17, 18, 20, 21 ), "mask"; }; subtest 'where_both' => sub { my $y = sequence(10) + 2; my ( $big, $small ) = where_both( $y, $y > 5 ); $big += 2, $small -= 1; is_pdl $big, pdl('[8 9 10 11 12 13]'), 'big + 2 is right'; is_pdl $small, pdl('[1 2 3 4]'), 'small - 2 is right'; is_pdl $y, pdl('[1 2 3 4 8 9 10 11 12 13]'), 'dataflow affected orig'; }; subtest 'whereND_both' => sub { my ( $t, $f ) = whereND_both(sequence(2,2,2), pdl(0,1)); is_pdl $t, pdl('[1;3] [5;7]'), 'nonzero vals'; is_pdl $f, pdl('[0;2] [4;6]'), 'zero vals'; }; subtest 'whereND' => sub { is_deeply( [ zeroes( 2, 3, 1 )->whereND( pdl '0 0' )->dims ], [ 0, 3, 1 ] ); is_deeply( [ zeroes( 2, 0 )->whereND( pdl '1 1' )->dims ], [ 2, 0 ] ); subtest '1D' => sub { my $x = sequence( 4, 3, 2 ); my $y = pdl( 0, 1, 1, 0 ); my $c = whereND( $x, $y ); is_pdl $c, pdl(q[[[1 2] [5 6] [9 10]] [[13 14] [17 18] [21 22]]]); }; subtest 'nD' => sub { my $x = sequence( 4, 3, 2 ); my $y = pdl q[ 0 0 1 1 ; 0 1 0 0 ; 1 0 0 0 ]; my $c = whereND( $x, $y ); is_pdl $c, pdl(q[2 3 5 8 ; 14 15 17 20]), "[4,3]"; }; subtest 'vs where' => sub { my $x = sequence( 2, 2, 2 ); for my $y ( pdl('[[[0 0][0 0]][[0 0][0 0]]]'), pdl('[[[0 0][0 0]][[0 0][0 1]]]'), pdl('[[[0 0][0 0]][[0 1][0 1]]]'), ) { my $c = whereND( $x, $y ); my $where = where( $x, $y ); is_pdl $c->flat, $where, "vs where"; } }; subtest 'lvalue' => sub { # Make sure whereND functions as an lvalue: my $x = sequence( 2, 3 ); lives_ok { $x->whereND(pdl( 0, 1 )) *= -1 } 'lvalue multiply'; is_pdl $x, pdl('0 -1;2 -3;4 -5'), 'works'; }; subtest 'sf.net bug 3415115' => sub { # sf.net bug #3415115, whereND fails to handle all zero mask case my $x = sequence( 4, 3 ); my $y = zeros(4); my $c = whereND( $x, $y ); ok( $c->isempty, 'all-zeros mask' ); }; }; }; subtest 'which' => sub { subtest 'which' => sub { subtest 'heterogenous values' => sub { my $y = PDL->pdl( 4, 3, 1, 0, 0, 0, 0, 5, 2, 0, 3, 6 ); is_pdl $y->which, PDL->pdl(indx, 0, 1, 2, 7, 8, 10, 11), "heterogenous values"; }; ok zeroes(3)->which->isempty, 'all zeroes returns empty'; # Test bad handling in selector subtest 'bad value' => sub { my $y = xvals(3); is_pdl $y->which, indx( 1, 2 ), "only good"; setbadat $y, 1; is_pdl $y->which, indx( [2] ), "good & bad"; setbadat $y, 0; setbadat $y, 2; is( $y->which->nelem, 0, "only bad" ); }; my $empty = zeroes(indx, 0); is_pdl which(ones(4) > 2), $empty, 'which 1D -> 1D, empty, type indx'; is_pdl which(ones(4,3) > 2), $empty, 'which 2D -> 1D'; }; subtest 'which_both' => sub { my $which_both_test = pdl( 1, 4, -2, 0, 5, 0, 1 ); my ( $nonzero, $zero ) = which_both($which_both_test); is_pdl $nonzero, pdl(indx, 0, 1, 2, 4, 6 ), 'nonzero indices'; is_pdl $zero, pdl(indx, 3, 5), 'zero indices'; }; subtest 'whichND_both' => sub { my ( $nonzero, $zero ) = whichND_both(PDL::MatrixOps::identity(2)); is_pdl $nonzero, indx('0 0; 1 1'), 'nonzero indices'; is_pdl $zero, indx('1 0; 0 1'), 'zero indices'; }; subtest 'whichover' => sub { my $a = pdl q[3 4 6 3 2 3 5 6 1 7]; my $b = $a->uniq; my $c = +($a->dummy(0) == $b)->transpose; my $expected = pdl q[ [ 8 -1 -1 -1 -1 -1 -1 -1 -1 -1] [ 4 -1 -1 -1 -1 -1 -1 -1 -1 -1] [ 0 3 5 -1 -1 -1 -1 -1 -1 -1] [ 1 -1 -1 -1 -1 -1 -1 -1 -1 -1] [ 6 -1 -1 -1 -1 -1 -1 -1 -1 -1] [ 2 7 -1 -1 -1 -1 -1 -1 -1 -1] [ 9 -1 -1 -1 -1 -1 -1 -1 -1 -1] ]; my $got = $c->whichover; is_pdl $got, $expected, 'whichover'; $c->inplace->whichover; is_pdl $c, $expected, 'whichover inplace'; }; subtest 'whichND' => sub { subtest 'Nontrivial case gives correct coordinates' => sub { my $r = xvals( 10, 10 ) + 10 * yvals( 10, 10 ); my $x = whichND( $r % 12 == 0 ); my $got; is_deeply( $got = $x->unpdl, [ [ 0, 0 ], [ 2, 1 ], [ 4, 2 ], [ 6, 3 ], [ 8, 4 ], [ 0, 6 ], [ 2, 7 ], [ 4, 8 ], [ 6, 9 ] ] ) or diag 'got: ', explain $got; is $x->type, 'indx', 'returns indx-type'; }; subtest 'Empty case gives matching Empty' => sub { my $r = xvals( 10, 10 ) + 10 * yvals( 10, 10 ); my $x = whichND( $r * 0 ); is $x->nelem, 0, "whichND( 0*\$r ) gives an Empty PDL"; is_deeply( [ $x->dims ], [ 2, 0 ], "whichND( 0*\$r ) is 2x0" ); is $x->type, 'indx', "whichND( 0*\$r) type is indx"; }; subtest 'Scalar PDLs are treated as 1-PDLs' => sub { my $x = whichND( pdl(5) ); is $x->nelem, 1, "whichND scalar PDL"; is $x, 0, "whichND scalar PDL"; is $x->type, 'indx', "returns indx ndarray for scalar ndarray mask"; }; subtest 'Scalar empty case returns a 1-D vector of size 0' => sub { my $x = whichND( pdl(0) ); is $x->nelem, 0, "whichND of 0 scalar is empty"; is_deeply [ $x->dims ], [0], "whichND of 0 scalar: return 0 dim size is 0"; is $x->type, 'indx', "returns indx-type ndarray for scalar empty case"; }; subtest 'Empty case returns Empty' => sub { my $y = whichND( which( pdl(0) ) ); is $y->nelem, 0, "whichND of Empty mask"; is $y->type, 'indx', "returns indx-type ndarray for empty case"; }; subtest 'whichND(Empty[2x0x2]) should return Empty[3x0]' => sub { my $y = whichND( zeroes( 2, 0, 2 ) ); is_deeply [ $y->dims ], [ 3, 0 ]; }; subtest 'regression' => sub { my $r = zeroes( 7, 7 ); $r->set( 3, 4, 1 ); is_deeply( $r->whichND->unpdl, [ [ 3, 4 ] ], 'was failing on 32-bit' ); }; subtest 'torture test' => sub { is_pdl scalar whichND(PDL->sequence(10,10,3,4) == 203), pdl(indx,[[3,0,2,0]]); }; }; }; subtest 'uniq' => sub { is_pdl sequence(4)->uniq, sequence(4), 'heterogeneous'; is_pdl ones(4)->uniq, ones(1), 'repeated homogenous'; is_pdl empty()->uniq, empty(), 'empty'; is_pdl pdl( [ [1] ] )->uniq, ones(1), '2-deep uniq flattens'; # Data::Frame relies }; subtest 'uniqind' => sub { my $x = pdl( [ 0, 1, 2, 2, 0, 1 ] ); my $y = $x->uniqind; is_deeply( $y->unpdl, [ 0, 1, 3 ] ); is $y->ndims, 1, "uniqind"; subtest 'SF bug 3076570' => sub { my $y = pdl( 1, 1, 1, 1, 1 )->uniqind; # SF bug 3076570 is_pdl $y, indx( [0] ), 'uniqind'; }; }; done_testing; PDL-2.100/t/constants.t0000644000175000017500000000056614727756302014551 0ustar osboxesosboxes# Simple tests for PDL::Constants use strict; use warnings; use Test::More; use PDL::Constants qw(PI E DEGRAD); # just checks values, assumes constant part is ok ok( abs( PI - 3.14159265358979 ) < 0.0001, 'PI is defined'); ok( abs( E - 2.71828182845905 ) < 0.0001, 'E is defined'); ok( abs( DEGRAD - 57.295779513082321 ) < 0.0001, 'DEGRAD is defined'); done_testing(); PDL-2.100/t/ppt-30_sharing_from_threads.t0000644000175000017500000000525514727756302020030 0ustar osboxesosboxesuse strict; use warnings; BEGIN { use Config; if (! $Config{'useithreads'}) { print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); exit(0); } if (defined $Devel::Cover::VERSION) { print("1..0 # Skip: Devel::Cover no like ithreads\n"); exit(0); } } # Tests if the threads can create data and share amongst themselves use Test::More; use Test::Exception; use PDL::LiteF; use PDL::Parallel::threads qw(retrieve_pdls); use PDL::Parallel::threads::SIMD qw(parallelize parallel_id parallel_sync); # Run the parallel block in which the threads create and share each other's # data my $N_threads = 5; my @data_is_correct : shared; my @could_get_data : shared; my @bad_is_correct : shared; parallelize { my $pid = parallel_id; # Create data that is unique to this thread my $pdl = ones(10) * $pid; $pdl->share_as("data$pid"); my $bad = ones(cfloat, 5); $bad->badvalue(17); $bad->setbadat(2); $bad->share_as("bad$pid"); # We will get the data from the *previous* thread (modulo the number of # threads, of course: circular boundary conditions) my $thread_to_grab = $pid - 1; $thread_to_grab = $N_threads - 1 if $pid == 0; # Synchronize; make sure all the threads have had a chance to create # their data parallel_sync; # This should be in an eval block in case the data pull fails eval { # Pull in the data: my $to_test = retrieve_pdls("data$thread_to_grab"); $could_get_data[$pid] = 1; # Make sure it's what we expected $data_is_correct[$pid] = all($to_test == $thread_to_grab)->sclr or diag("For thread $pid, expected ${thread_to_grab}s but got $to_test"); $to_test = retrieve_pdls("bad$thread_to_grab"); my $isbad = $to_test->isbad; $bad_is_correct[$pid] = all($isbad == pdl(0,0,1,0,0))->sclr || diag "got=$isbad\nto_test=$to_test"; 1; } or do { diag("data pull for pid $pid failed: $@"); $could_get_data[$pid] = 0; $data_is_correct[$pid] = 0; $bad_is_correct[$pid] = 0; }; } $N_threads; my @expected = (1) x $N_threads; is_deeply(\@could_get_data, \@expected, 'Threads could access data created by sibling threads') or diag("expected all 1s, actually got @could_get_data"); is_deeply(\@data_is_correct, \@expected, 'Data created by sibling threads worked correctly') or diag("expected all 1s, actually got @data_is_correct"); is_deeply(\@bad_is_correct, \@expected, 'Data created by sibling threads badflags survived correctly') or diag("expected all 1s, actually got @data_is_correct"); # Make sure the retrieval causes a croak for (1..$N_threads-1) { throws_ok { retrieve_pdls("data$_") } qr/was created in a thread that has ended or is detached/ , "Retrieving shared data created by already-terminated thread $_ croaks"; } done_testing(); PDL-2.100/t/picrgb.t0000644000175000017500000000556014727756302014002 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::PDL; use PDL::IO::Pic; use PDL::ImageRGB; use PDL::Dbg; use File::Temp qw(tempdir); use File::Spec; sub rpic_unlink { my $file = shift; my $pdl = PDL->rpic($file); unlink $file; return $pdl; } sub depends_on { note "ushort is ok with $_[0]\n" if $PDL::IO::Pic::converter{$_[0]}->{ushortok}; return 1 if $PDL::IO::Pic::converter{$_[0]}->{ushortok}; return 256; } sub mmax { return $_[0] > $_[1] ? $_[0] : $_[1] } $PDL::debug = 0; $PDL::IO::Pic::debug = 0; my $iform = 'PNMRAW'; # change to PNMASCII to use ASCII PNM intermediate # output format # [FORMAT, extension, ushort-divisor, # only RGB/no RGB/any (1/-1/0), mxdiff] # no test of PCX format because seems to be severely brain damaged my %formats = ('PNM' => ['pnm',1,0,0.01], 'GIF' => ['gif',256,0,1.01], 'TIFF' => ['tif',1,0,0.01], 'RAST' => ['rast',256,0,0.01], # 'SGI' => ['rgb',1,1,0.01], 'PNG' => ['png',1,1,0.01], ); # only test PNM format # netpbm has too many bugs on various platforms my @allowed = (); ## for ('PNM') { push @allowed, $_ for (sort keys %formats) { if (PDL->rpiccan($_) && PDL->wpiccan($_) && defined $formats{$_}) { push @allowed, $_; } } plan skip_all => "No tests" if !@allowed; note "Testable formats on this platform:\n".join(',',@allowed)."\n"; my $im1 = ushort pdl [[[0,0,0],[256,65535,256],[0,0,0]], [[256,256,256],[256,256,256],[256,256,256]], [[2560,65535,2560],[256,2560,2560],[65535,65534,65535]]]; my $im2 = byte ($im1/256); if ($PDL::debug){ note $im1; note $im2; } my $tmpdir = tempdir( CLEANUP => 1 ); sub tmpfile { File::Spec->catfile($tmpdir, $_[0]); } foreach my $form (sort @allowed) { note "** testing $form format **\n"; my $arr = $formats{$form}; my $tushort = tmpfile("tushort.$arr->[0]"); my $tbyte = tmpfile("tbyte.$arr->[0]"); eval { $im1->wpic($tushort,{IFORM => $iform}); }; SKIP: { my $additional = ''; if ($@ =~ /maxval is too large/) { $additional = ' (recompile pbmplus with PGM_BIGGRAYS!)'; } skip "Error: '$@'$additional", 2 if $@; $im2->wpic($tbyte,{IFORM => $iform}); my $determined_format; $determined_format = imageformat($tushort); is($determined_format, $form, "image $tushort is format $form"); my $in1 = rpic_unlink($tushort); $determined_format = imageformat($tbyte); is($determined_format, $form, "image $tbyte is format $form"); my $in2 = rpic_unlink($tbyte); my $comp = $im1 / PDL::ushort(mmax(depends_on($form),$arr->[1])); is_pdl $in1, $comp, {atol=>$arr->[3], test_name=>$form, require_equal_types => 0}; is_pdl $in2, $im2; if ($PDL::debug) { note $in1->px; note $in2->px; } } } done_testing; PDL-2.100/t/01-pptest.t0000644000175000017500000003712614740772324014271 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker::Config; # to pick up EUMM-targeted config overrides use Test::More $Config{usedl} ? () : (skip_all => 'No dynaload; double-blib static build too difficult'); use File::Spec; use IPC::Cmd qw(run); use Cwd; use File::Basename; use File::Path; my %PPTESTFILES = ( 'Makefile.PL' => <<'EOF', use strict; use warnings; use ExtUtils::MakeMaker; use PDL::Core::Dev; my @pack = (["tests.pd", qw(Tests PDL::Tests), '', 1]); sub MY::postamble { pdlpp_postamble(@pack); }; # Add genpp rule my %hash = pdlpp_stdargs(@pack); $hash{OBJECT} .= ' ppcp$(OBJ_EXT)'; WriteMakefile(%hash); EOF 'ppcp.c' => <<'EOF', #include "pdl.h" /* to test the $P vaffining */ void ppcp(PDL_Byte *dst, PDL_Byte *src, int len) { int i; for (i=0;i <<'EOF', # make sure the deprecation mechanism throws warnings pp_deprecate_module( infavor => "PDL::Test::Fancy" ); our $VERSION = '0.01'; # so the Makefile.PL's VERSION_FROM picks it up pp_setversion(qq{'0.01'}); # this doesn't use $VERSION only to check a bug is fixed pp_add_macros(SUCC => sub { "($_[0] + 1)" }); pp_addhdr(' void ppcp(PDL_Byte *dst, PDL_Byte *src, int len); '); # test the $P vaffine behaviour # when 'phys' flag is in. pp_def('foop', Pars => 'byte [phys]a1(n); byte [o,phys]b(n)', GenericTypes => [B], Code => 'ppcp($P(b),$P(a1),$SIZE(n));', Doc => ' =for ref Sample standard deviation. =cut ', ); # test single-used phys dim of 1 ok pp_def('foop1', Pars => 'byte a1(z); byte [o,phys]b(n)', GenericTypes => [B], Code => 'ppcp($P(b),$P(a1),$SIZE(n));', ); # float qualifier # and also test if numerals in variable name work pp_def( 'fsumover', Pars => 'a1(n); float [o]b();', GenericTypes => ['D'], Code => 'PDL_Float tmp = 0; loop(n) %{ tmp += $a1(); %} $b() = tmp;' ); # test GENERIC with type+ qualifier pp_def( 'nsumover', Pars => 'a(n); int+ [o]b();', GenericTypes => [qw(B S U L F D)], Code => '$GENERIC(b) tmp = 0; loop(n) %{ tmp += $a(); %} $b() = tmp;' ); pp_def("gelsd", Pars => '[io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); [o,phys]s(r=CALC(PDLMIN($SIZE(m),$SIZE(n)))); int [o,phys]rank();int [o,phys]info()', GenericTypes => ['F'], Code => '$CROAK("croaking");' ); pp_def('succ', Pars => 'a(); [o] b()', GenericTypes => ['F'], Code => '$b() = $SUCC($a());', ); # test whitespace problem with POD and pp_addxs pp_addxs( '', <<'EOXS' ); int just_one() CODE: RETVAL = 1; OUTPUT: RETVAL =pod =begin comment A comment. =end comment =cut EOXS # test whitespace problem with pp_line_numbers and pp_add_boot pp_add_boot pp_line_numbers(__LINE__, q{ /* nothing happening here */ }); # test XS args with OtherPars pp_def('gl_arrows', Pars => 'coords(tri=3,n); int indsa(); int indsb();', GenericTypes => ['F'], OtherPars => 'float headlen; float width;', Code => ';', # do nothing ); # test XS args with funky Pars ordering pp_def('polyfill_pp', Pars => 'int [io] im(m,n); float ps(two=2,np); int col()', GenericTypes => ['F'], Code => ';', # do nothing ); # test valid non-single-letter GenericTypes arg pp_def("rice_compress", Pars => 'in(n); [o]out(m); int[o]len(); lbuf(n)', GenericTypes =>['B','S','US','L'], Code => ';', # do nothing ); pp_def('output_op', Pars => 'in(n=2)', OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', GenericTypes => ['F'], Code => ' pdl_datatypes dt = $PDL(in)->datatype; ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); ', ); pp_def('output_op2', Pars => 'in(n=2); [o] out()', OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', GenericTypes => ['F'], Code => ' pdl_datatypes dt = $PDL(in)->datatype; ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); ', ); pp_def('output_op3', Pars => 'in(n=2); [o] out()', OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', GenericTypes => ['F'], Code => ' pdl_datatypes dt = $PDL(in)->datatype; ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); ', PMCode => 'sub PDL::output_op3 { goto &PDL::_output_op3_int }', ); pp_def('incomp_dim', Pars => '[o] a();', OtherPars => 'PDL_Indx d[];', GenericTypes => ['F'], Code => '$a() = $COMP(d_count);', ); pp_addhdr(' typedef NV NV_ADD1; typedef HV* NV_HR; typedef char thing; '); pp_add_typemaps(string=><<'EOT'); TYPEMAP NV_ADD1 T_NV_ADD1 NV_HR T_HVREF thing* T_PTROBJ INPUT T_NV_ADD1 $var = SvNV($arg) + 1 OUTPUT T_NV_ADD1 sv_setnv($arg, $var - 1); EOT pp_def('typem', Pars => 'int [o] out()', OtherPars => '[io] NV_ADD1 v1; NV_HR v2; thing *ptr', GenericTypes => ['F'], Code => '$out() = $COMP(v1); $COMP(v1) = 8;', ); pp_def('incomp_in', Pars => '[o] out()', OtherPars => 'pdl *ins[]', GenericTypes => ['F'], RedoDimsCode => <<'EOC', pdl **ins = $COMP(ins); PDL_Indx i; for (i = 0; i < $COMP(ins_count); i++) { pdl *in = ins[i]; PDL_RETERROR(PDL_err, PDL->make_physdims(in)); if (in->ndims != 1) $CROAK("input ndarray %"IND_FLAG" has %"IND_FLAG" dims, not 1", i, in->ndims); if (!$PRIV(bvalflag) && (in->state & PDL_BADVAL)) $PRIV(bvalflag) = 1; } EOC Code => <<'EOC', pdl **ins = $COMP(ins); PDL_Indx i; for (i = 0; i < $COMP(ins_count); i++) PDL_RETERROR(PDL_err, PDL->make_physical(ins[i])); $out() = 0; for (i = 0; i < $COMP(ins_count); i++) { pdl *in = ins[i]; PDL_Indx j; #define X_CAT_INNER(datatype_in, ctype_in, ppsym_in, ...) \ PDL_DECLARE_PARAMETER_BADVAL(ctype_in, in, (in), 1, ppsym_in) \ for(j=0; jnvals; j++) { \ if ($PRIV(bvalflag) && PDL_ISBAD2(in_datap[j], in_badval, ppsym_in, in_badval_isnan)) continue; \ $out() += in_datap[j]; \ } PDL_GENERICSWITCH(PDL_TYPELIST_ALL, in->datatype, X_CAT_INNER, $CROAK("Not a known data type code=%d", in->datatype)) #undef X_CAT_INNER } EOC ); pp_def('incomp_out', Pars => 'in(n)', OtherPars => 'PDL_Indx howmany; [o] pdl *outs[]', GenericTypes => ['F'], HandleBad => 1, CallCopy => 0, GenericTypes => [PDL::Types::ppdefs_all()], Code => <<'EOC', pdl **outs = malloc(($COMP(outs_count) = $COMP(howmany)) * sizeof(pdl*)); $COMP(outs) = outs; PDL_Indx i, ndims = $PDL(in)->ndims, dims[ndims]; for (i = 0; i < ndims; i++) dims[i] = $PDL(in)->dims[i]; for (i = 0; i < $COMP(outs_count); i++) { pdl *o = outs[i] = PDL->pdlnew(); if (!o) { for (i--; i >= 0; i--) PDL->destroy(outs[i]); free(outs); $CROAK("Failed to create ndarray"); } o->datatype = $PDL(in)->datatype; PDL_err = PDL->setdims(o, dims, ndims); if (PDL_err.error) { for (; i >= 0; i--) PDL->destroy(outs[i]); free(outs); return PDL_err; } PDL_err = PDL->allocdata(o); if (PDL_err.error) { for (; i >= 0; i--) PDL->destroy(outs[i]); free(outs); return PDL_err; } PDL_DECLARE_PARAMETER_BADVAL($GENERIC(in), o, (o), 1, $PPSYM(in)) loop(n) %{ o_datap[n] = $in(); %} } EOC ); pp_def('index_prec', # check $a(n=>x+1) works Pars => 'in(n); [o]out()', GenericTypes => ['F'], Code => 'loop (n) %{ if (n > 1) $out() += $in(n=>n-1); %}', ); pp_def("diff_central", Pars => 'double x(); double [o] res();', GenericTypes => ['F'], OtherPars => 'SV* function;', Code => ';', ); # previously in t/inline-comment-test.t pp_addpm(pp_line_numbers(__LINE__-1, q{ sub myfunc { } })); pp_def('testinc', Pars => 'a(); [o] b()', GenericTypes => ['F'], Code => q{ /* emulate user debugging */ /* Why doesn't this work???!!!! */ threadloop %{ /* printf(" %f, %f\r", $a(), $b()); printf(" Here\n"); */ /* Sanity check */ $b() = $a() + 1; %} }, ); # make sure that if the word "broadcastloop" appears, later automatic broadcastloops # will not be generated, even if the original broadcastloop was commented-out pp_def('testinc2', Pars => 'a(); [o] b()', GenericTypes => ['F'], Code => q{ /* emulate user debugging */ /* Why doesn't this work???!!!! */ /* threadloop %{ printf(" %f, %f\r", $a(), $b()); printf(" Here\n"); %} */ /* Sanity check */ $b() = $a() + 1; }, ); pp_def('or2', Pars => 'a(); b(); [o]c();', OtherPars => 'int swap; char *ign; int ign2', OtherParsDefaults => { swap => 0, ign=>'""', ign2=>0 }, GenericTypes => ['F'], ArgOrder => 1, Code => '$c() = $a() | $b();', GenericTypes => [qw(A B S U L K N P Q)], ); # from HMM pp_def('logadd', Pars => 'a(); b(); [o]c()', GenericTypes => [qw(F D LD)], Inplace=>['a'], ##-- can run inplace on a() Code => ';', ); pp_def('ftr', Pars => 'a()', GenericTypes => ['F'], OtherPars => 'char* filename; int Loops; int Delay', OtherParsDefaults => {Loops=>0, Delay=>4}, Code => 'sv_setiv(perl_get_sv("main::DelayVAL",TRUE), $COMP(Delay));', FtrCode => " sv_setiv(perl_get_sv(\"main::FOOTERVAL\",TRUE), 1);\n", ); pp_def('ftrPM', Pars => 'a(); [o]b()', GenericTypes => ['F'], Code => ';', HdrCode => " sv_setiv(perl_get_sv(\"main::HEADERVAL\",TRUE), 1);\n", FtrCode => " sv_setiv(perl_get_sv(\"main::FOOTERVAL\",TRUE), 1);\n", PMCode => <<'EOPM', sub PDL::ftrPM { my ($a, $b) = @_; $b //= PDL->null; PDL::_ftrPM_int($a, $b); $b; } EOPM ); pp_done; # this tests the bug with a trailing comment and *no* newline EOF 't/all.t' => <<'EOF', use strict; use warnings; use Test::More; use Test::Warn; BEGIN { $ENV{PDL_AUTOPTHREAD_TARG} = 1 } # for continue-in-broadcastloop test use PDL::LiteF; use PDL::Types; use PDL::Dbg; use Test::PDL -require_equal_types => 0; BEGIN { warning_like{ require PDL::Tests; PDL::Tests->import; } qr/deprecated.*PDL::Test::Fancy/, "PP deprecation should emit warnings"; } my $x = xvals(zeroes(byte, 2, 4)); my $y; # $P() affine tests foop($x,($y=null)); is_pdl $x,$y; foop($x->transpose,($y=null)); is_pdl $x->transpose,$y; my $vaff = $x->dummy(2,3)->xchg(1,2); foop($vaff,($y=null)); is_pdl $vaff,$y; eval { foop($x,($y=pdl([1]))) }; isnt $@, '', '[phys] with multi-used mismatched dim of 1 throws exception'; eval { foop(pdl([1]),($y=pdl([1]))) }; is $@, '', '[phys] with multi-used matched dim of 1 no exception'; eval { foop1($x,($y=pdl([[1],[1],[1],[1]]))) }; is $@, '', '[phys] with single-used dim of 1 no exception'; # float qualifier $x = ones(byte,3000); fsumover($x,($y=null)); is( $y->get_datatype, $PDL_F ); is( $y->at, 3000 ); # int+ qualifier for (byte,short,ushort,long,float,double) { $x = ones($_,3000); nsumover($x,($y=null)); is( $y->get_datatype, (($PDL_L > $_->[0]) ? $PDL_L : $_->[0]) ); is( $y->at, 3000 ); } { my @msg; local $SIG{__WARN__} = sub { push @msg, @_ }; eval { nan(2,2)->gelsd(nan(2,2), -3) }; like $@, qr/croaking/, 'right error message'; is_deeply \@msg, [], 'no warnings' or diag explain \@msg; } polyfill_pp(zeroes(5,5), ones(2,3), 1); eval { polyfill_pp(ones(2,3), 1) }; like $@, qr/Usage/; is succ(2)."", 3, 'test pp_add_macros works'; output_op([5,7], my $v0, my $v1); is_deeply [$v0,$v1], [5,7], 'output OtherPars work'; ($v0, $v1) = output_op([5,7]); is_deeply [$v0,$v1], [5,7], 'output OtherPars work 1a'; eval { output_op(sequence(2,3), my $v0, my $v1) }; isnt $@, '', 'broadcast with output OtherPars throws'; output_op2([5,7], my $n=PDL->null, my $v0_2, my $v1_2); is_deeply [$v0_2,$v1_2], [5,7], 'output OtherPars work 2'; (undef, $v0_2, $v1_2) = output_op2([5,7]); is_deeply [$v0_2,$v1_2], [5,7], 'output OtherPars work 2a'; eval { output_op2(sequence(2,3), my $n=PDL->null, my $v0_2, my $v1_2) }; like $@, qr/Can't broadcast/, 'broadcast with output OtherPars throws 2'; output_op3([5,7], my $out3 = PDL->null, my $v0_3, my $v1_3); is_deeply [$v0_3,$v1_3], [5,7], 'output OtherPars work 3' or diag "got: ",$v0_3," ",$v1_3; incomp_dim(my $o = PDL->null, [0..3]); is "$o", 4; $o = incomp_dim([0..3]); is "$o", 4; my $ptrObj = bless \(my $thing = 75), 'thingPtr'; $o = typem(my $oth = 3, {}, $ptrObj); is "$o", 4; is "$oth", 7; typem($o = PDL->null, $oth = 3, {}, $ptrObj); is "$o", 4; is "$oth", 7; eval {typem($o = PDL->null, $oth = 3, [], $ptrObj);}; like $@, qr/^typem:.*not a HASH reference/i; incomp_in($o = PDL->null, [sequence(3), sequence(byte, 4)]); is "$o", 9; $o = incomp_in([sequence(3), sequence(byte, 4)]); is "$o", 9; my $one_bad = sequence(byte, 4); $one_bad->badflag(1); $one_bad->badvalue(2); $o = incomp_in([sequence(3), $one_bad]); is "$o", 7; incomp_in($o = PDL->null, []); is "$o", 0; incomp_in($o = PDL->null, undef); is "$o", 0; eval { incomp_in($o = PDL->null, 'hello') }; isnt $@, ''; incomp_out(sequence(3), 2, my $nds); is 0+@$nds, 2; is +($nds->[0]//'undef').'', "[0 1 2]"; $nds = incomp_out(sequence(3), 2); is 0+@$nds, 2; is +($nds->[0]//'undef').'', "[0 1 2]"; is index_prec(sequence(2,6)->slice('(1)')).'', 24, 'index precedence OK'; eval { diff_central(pdl(1), sub {}) }; is $@, ''; { my $x = sequence(3,3); my $y = $x->testinc; ok(all ($y == $x+1), 'Sanity check runs correctly'); # Test the inability to comment-out a broadcastloop. This is documented on the # 11th page of the PDL::PP chapter of the PDL book. If somebody ever fixes this # wart, this test will fail, in which case the book's text should be updated. $y = $x->testinc2; TODO: { # Note: This test appears to fail on Cygwin and some flavors of Linux. local $TODO = 'This test inexplicably passes on some machines'; ok(not (all $y == $x + 1), 'WART: commenting out a broadcastloop does not work') or diag("\$x is $x and \$y is $y"); } } eval { is ''.or2(pdl(1), pdl(1), 0), '1' }; is $@, ''; eval { ldouble(4)->logadd(3) }; is $@, ''; undef $main::FOOTERVAL; undef $main::DelayVAL; ftr(1, "file"); is $main::FOOTERVAL, 1; is $main::DelayVAL, 4; undef $main::HEADERVAL; undef $main::FOOTERVAL; ftrPM(1); is $main::HEADERVAL, 1; is $main::FOOTERVAL, 1; done_testing; EOF ); do_tests(\%PPTESTFILES); sub do_tests { my ($hash, $error_re, $dir) = @_; in_dir( sub { hash2files(File::Spec->curdir, $hash); local $ENV{PERL5LIB} = join $Config{path_sep}, @INC; run_ok(qq{"$^X" Makefile.PL}); run_ok(qq{"$Config{make}" test}, $error_re); }, $dir, ); } sub run_ok { my ($cmd, $error_re) = @_; my $res = run(command => $cmd, buffer => \my $buffer); if ($error_re) { ok !$res, 'Fails to build if invalid'; like $buffer, $error_re, 'Fails with expected error'; return; } if (!$res) { ok 0, $cmd; diag $buffer; return; } ok 1, $cmd; } sub hash2files { my ($prefix, $hashref) = @_; while(my ($file, $text) = each %$hashref) { # Convert to a relative, native file path. $file = File::Spec->catfile(File::Spec->curdir, $prefix, split m{\/}, $file); my $dir = dirname($file); mkpath $dir; my $utf8 = ($] < 5.008 or !$Config{useperlio}) ? "" : ":utf8"; open(my $fh, ">$utf8", $file) || die "Can't create $file: $!"; print $fh $text; close $fh; } } sub in_dir { my $code = shift; my $dir = shift || File::Spec->catdir(File::Spec->curdir, './.pptest/sub'); # /sub is so top Makefile.PL no see as subdir mkpath $dir; # chdir to the new directory my $orig_dir = getcwd(); chdir $dir or die "Can't chdir to $dir: $!"; # Run the code, but trap the error so we can chdir back my $return; my $ok = eval { $return = $code->(); 1; }; my $err = $@; # chdir back chdir $orig_dir or die "Can't chdir to $orig_dir: $!"; # rethrow if necessary die $err unless $ok; return $return; } done_testing; PDL-2.100/t/flexraw-iotypes.t0000644000175000017500000000076514744321614015671 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use PDL::Types ':All'; use PDL::IO::FlexRaw; use File::Temp; use Test::More; use Test::PDL; our @types = grep $_ != indx(), types(); my $data = File::Temp::tmpnam(); for my $type (@types) { print "checking type $type...\n"; my $pdl = sequence $type, 10; my $hdr = writeflex $data, $pdl; writeflexhdr($data,$hdr); my $npdl = eval {readflex $data}; is $pdl->type, $npdl->type; is_pdl $pdl, $npdl; } unlink $data, "${data}.hdr"; done_testing; PDL-2.100/t/pic-rim.t0000644000175000017500000000164714744321614014067 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use PDL::IO::Pic; use Test::More; use Test::PDL; use File::Temp qw(tempdir); use File::Spec; my $fmt = uc(my $ext = 'pnm'); my $file = File::Spec->catfile(tempdir( CLEANUP => 1 ), "ushort.$ext"); test_pdl(sequence(3,3)->ushort * 213, 0, $file); test_pdl(sequence(3,3,3)->ushort * 213, 1, $file); test_pdl(sequence(3,4,4)->ushort * 213, 1, $file); done_testing; sub test_pdl { my ($in, $expect_reorder, $file) = @_; my $orig_info = $in->info; $in->wpic($file, {FORMAT => $fmt}); my $out1 = rim($file, {FORMAT => $fmt}); my $out2 = PDL->null; rim($out2, $file, {FORMAT => $fmt}); my $out3 = PDL->rpic($file, {FORMAT => $fmt}); if ($expect_reorder) { $_ = $_->mv(-1,0) for $out1, $out2 } is_pdl $out1, $in, "\$out1 & \$in are the same $orig_info"; is_pdl $out2, $in, "\$out2 & \$in are the same $orig_info"; is_pdl $out3, $in, "\$out3 & \$in are the same $orig_info"; } PDL-2.100/t/primitive-vsearch.t0000644000175000017500000003661314727756302016200 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use Test::PDL; # Some of these tests are based upon those in Chapter 5 of Programming # Pearls, by J. Bentley # choose a non-factor of two odd number for the length my $N = 723; my $ones = ones($N); my $idx = sequence(indx,$N); my $x = $idx * 10; # create ordered duplicates so can test insertion points. This creates # 7 sequential duplicates of the values 0-99 my $ndup = 7; my $xdup = double long sequence( $ndup * 100 ) / $ndup; # get insertion points and values my ( $xdup_idx_insert_left, $xdup_idx_insert_right, $xdup_values ) = do { my ( $counts, $values ) = do { my @q = $xdup->rle; where( @q, $q[0] > 0 ) }; ( $counts->cumusumover - $counts->at(0), $counts->cumusumover, $values ); }; # The tests are table driven, with appropriate inputs and outputs for # forward and reverse sorted arrays. The tests sort the input array # against itself, so we have a very good idea of which indices should # be returned. Most of the tests use that. There are also specific # tests for the endpoints as specified in the documentation, which # may be easier for humans to parse and validate. my %search = ( sample => { all_the_same_element => $N - 1, # finds right-most element forward => { idx => $idx, x => $x, equal => $idx, nequal_m => $idx, nequal_p => do { my $t = $idx + 1; $t->set( -1, $t->at(-1) - 1 ); $t }, xdup => { set => $xdup, idx => $xdup_idx_insert_left, values => $xdup_values, }, docs => [ ' V <= xs[0] : i = 0 ' => [ ( 0, -1, 0 ), ( 0, 0, 0 ), ], 'xs[0] < V <= xs[-1] : i s.t. xs[i-1] < V <= xs[i]' => [ ( 0, 1, 1 ), ( 1, 0, 1 ), ( -1, 0, $N - 1 ), ], 'xs[-1] < V : i = $xs->nelem -1 ' => [ ( -1, 0, $N - 1 ), ( -1, 1, $N - 1 ), ], ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx, nequal_m => $idx, nequal_p => do { my $t = $idx - 1; $t->set( 0, 0 ); $t }, xdup => { set => $xdup->slice( [ -1, 0 ] ), idx => $xdup->nelem - 1 - $xdup_idx_insert_left, values => $xdup_values, }, docs => [ ' V > xs[0] : i = 0 ' => [ ( 0, 1, 0 ) ], 'xs[0] >= V > xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [ ( 0, 0, 0 ), ( 0, -1, 0 ), ( 1, 0, 1 ), ], 'xs[-1] >= V : i = $xs->nelem - 1 ' => [ ( -1, 0, $N - 1 ), ( -1, -1, $N - 1 ), ], ], } }, insert_leftmost => { all_the_same_element => 0, forward => { idx => $idx, x => $x, equal => $idx, nequal_m => $idx, nequal_p => $idx + 1, xdup => { set => $xdup, idx => $xdup_idx_insert_left, values => $xdup_values, }, docs => [ ' V <= xs[0] : i = 0 ' => [ ( 0, -1, 0 ), ( 0, 0, 0 ) ], 'xs[0] < V <= xs[-1] : i s.t. xs[i-1] < V <= xs[i]' => [ ( 0, 1, 1 ), ( 1, 0, 1 ), ( -1, 0, $N - 1 ), ], 'xs[-1] < V : i = $xs->nelem ' => [ ( -1, 1, $N ), ], ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx, nequal_m => $idx, nequal_p => $idx - 1, xdup => { set => $xdup->mslice( [ -1, 0 ] ), idx => $xdup->nelem - 1 - $xdup_idx_insert_left, values => $xdup_values, }, docs => [ ' V > xs[0] : i = -1 ' => [ ( 0, 1, -1 ), ], 'xs[0] >= V >= xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [ ( 0, 0, 0 ), ( 0, -1, 0 ), ], 'xs[-1] >= V : i = $xs->nelem -1 ' => [ ( -1, 0, $N - 1 ), ( -1, -1, $N - 1 ), ], ], }, }, insert_rightmost => { all_the_same_element => $N, forward => { idx => $idx, x => $x, equal => $idx + 1, nequal_m => $idx, nequal_p => $idx + 1, xdup => { set => $xdup, idx => $xdup_idx_insert_right, values => $xdup_values, idx_offset => -1, # returns index of element *after* the value }, docs => [ ' V < xs[0] : i = 0 ' => [ ( 0, -1, 0 ) ], 'xs[0] <= V < xs[-1] : i s.t. xs[i-1] <= V < xs[i]' => [ ( 0, 0, 1 ), ( 0, 1, 1 ), ( 1, 0, 2 ), ], 'xs[-1] <= V : i = $xs->nelem ' => [ ( -1, 0, $N ), ( -1, 1, $N ), ], ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx - 1, nequal_m => $idx, nequal_p => $idx - 1, xdup => { set => $xdup->mslice( [ -1, 0 ] ), idx => $xdup->nelem - 1 - $xdup_idx_insert_right, values => $xdup_values, idx_offset => +1, # returns index of element *after* the value }, docs => [ ' V >= xs[0] : i = -1 ' => [ ( 0, 1, -1 ), ( 0, 0, -1 ), ], 'xs[0] > V >= xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [ ( 0, -1, 0 ), ( -1, 1, $N - 2 ), ( -1, 0, $N - 2 ), ], 'xs[-1] > V : i = $xs->nelem -1 ' => [ ( -1, -1, $N - 1 ) ] ], }, }, match => { all_the_same_element => ($N) >> 1, forward => { idx => $idx, x => $x, equal => $idx, nequal_m => -( $idx + 1 ), nequal_p => -( $idx + 1 + 1 ), xdup => { set => $xdup, values => $xdup_values, }, docs => [ 'V < xs[0] : i = -1' => [ ( 0, -1, -1 ), ], 'V == xs[n] : i = n' => [ ( 0, 0, 0 ), ( -1, 0, $N - 1 ) ], 'xs[0] > V > xs[-1], V != xs[n] : -(i+1) s.t. xs[i] > V > xs[i+1]' => [ ( 0, 1, -( 1 + 1 ) ), ( 1, -1, -( 1 + 1 ) ), ( 1, 1, -( 2 + 1 ) ), ( -1, -1, -( $N - 1 + 1 ) ), ], ' V > xs[-1] : -($xs->nelem - 1 + 1)' => [ ( -1, 1, -( $N + 1 ) ), ] ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx, nequal_m => -( $idx + 1 ), nequal_p => -( $idx + 1 - 1 ), xdup => { set => $xdup->mslice( [ -1, 0 ] ), values => $xdup_values, }, docs => [ 'V > xs[0] : i = 0' => [ ( 0, 1, 0 ), ], 'V == xs[n] : i = n' => [ ( 0, 0, 0 ), ( -1, 0, $N - 1 ) ], 'xs[0] < V < xs[-1], V != xs[n] : -(i+1) s.t. xs[i-1] > V > xs[i]' => [ ( 0, -1, -( 0 + 1 ) ), ( 1, 1, -( 0 + 1 ) ), ( 1, -1, -( 1 + 1 ) ), ( -1, -1, -( $N - 1 + 1 ) ), ], ' xs[-1] > V: -($xs->nelem - 1 + 1)' => [ ( -1, -1, -( $N - 1 + 1 ) ), ] ], }, }, bin_inclusive => { all_the_same_element => $N - 1, forward => { idx => $idx, x => $x, equal => $idx, nequal_m => $idx - 1, nequal_p => $idx, xdup => { set => $xdup, idx => $xdup_idx_insert_left + $ndup - 1, values => $xdup_values, }, docs => [ ' V < xs[0] : i = -1 ' => [ ( 0, -1, -1 ), ], 'xs[0] <= V < xs[-1] : i s.t. xs[i] <= V < xs[i+1]' => [ ( 0, 0, 0 ), ( 0, 1, 0 ), ( 1, -1, 0 ), ( 1, 0, 1 ), ( -1, -1, $N - 2 ), ], 'xs[-1] <= V : i = $xs->nelem - 1 ' => [ ( -1, 0, $N - 1 ), ( -1, 1, $N - 1 ), ] ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx, nequal_m => $idx + 1, nequal_p => $idx, xdup => { set => $xdup->mslice( [ -1, 0 ] ), idx => $xdup->nelem - ( 1 + $xdup_idx_insert_left + $ndup - 1 ), values => $xdup_values, }, docs => [ ' V >= xs[0] : i = 0 ' => [ ( 0, 1, 0 ), ( 0, 0, 0 ) ], 'xs[0] > V >= xs[-1] : i s.t. xs[i+1] > V >= xs[i]' => [ ( 0, -1, 1 ), ( 1, 1, 1 ), ( 1, 0, 1 ), ( 1, -1, 2 ), ( -1, 0, $N - 1 ), ], 'xs[-1] > V : i = $xs->nelem -1 ' => [ ( -1, -1, $N ) ], ], }, }, bin_exclusive => { all_the_same_element => -1, forward => { idx => $idx, x => $x, equal => $idx - 1, nequal_m => $idx - 1, nequal_p => $idx, xdup => { set => $xdup, idx => $xdup_idx_insert_left - 1, values => $xdup_values, idx_offset => 1, }, docs => [ ' V <= xs[0] : i = -1 ' => [ ( 0, -1, -1 ), ( 0, 0, -1 ), ], 'xs[0] < V <= xs[-1] : i s.t. xs[i] < V <= xs[i+1]' => [ ( 0, 1, 0 ), ( 1, -1, 0 ), ( 1, 0, 0 ), ( 1, 1, 1 ), ( -1, -1, $N - 2 ), ( -1, 0, $N - 2 ), ], 'xs[-1] < V : i = $xs->nelem - 1 ' => [ ( -1, 1, $N - 1 ), ], ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx + 1, nequal_m => $idx + 1, nequal_p => $idx, xdup => { set => $xdup->mslice( [ -1, 0 ] ), idx => $xdup->nelem - ( 1 + $xdup_idx_insert_left - 1 ), values => $xdup_values, idx_offset => -1, }, docs => [ ' V > xs[0] : i = 0 ' => [ ( 0, 1, 0 ), ], 'xs[0] > V > xs[-1] : i s.t. xs[i-1] >= V > xs[i]' => [ ( 0, 0, 1 ), ( 0, -1, 1 ), ( -1, 1, $N - 1 ), ], 'xs[-1] >= V : i = $xs->nelem -1 ' => [ ( -1, 0, $N ), ( -1, -1, $N ), ], ], }, }, ); for my $mode ( sort keys %search ) { my $data = $search{$mode}; subtest $mode => sub { my ( $got, $exp ); for my $sort_direction (qw[ forward reverse ]) { subtest $sort_direction => sub { my $so = $data->{$sort_direction} or plan( skip_all => "not testing $sort_direction!\n" ); is_pdl vsearch( $so->{x}, $so->{x}, { mode => $mode } ), $so->{equal}, 'equal elements'; my $badmask = $so->{x}->random < 0.25; my $badx = $so->{x}->setbadif( $badmask ); my $bad_eq = $so->{equal}->setbadif( $badmask ); is_pdl vsearch( $badx, $so->{x}, { mode => $mode } ), $bad_eq, 'equal elements w/ bad vals'; is_pdl vsearch( $so->{x} - 5, $so->{x}, { mode => $mode } ), $so->{nequal_m}, 'non-equal elements x[i] < xs[i] (check lower bound)'; is_pdl vsearch( $so->{x} + 5, $so->{x}, { mode => $mode } ), $so->{nequal_p}, 'non-equal elements x[i] > xs[i] (check upper bound)'; # duplicate testing. # check for values. note that the rightmost routine returns # the index of the element *after* the last duplicate # value, so we need an offset is_pdl $so->{xdup}{set}->index( vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode => $mode } ) + ( $so->{xdup}{idx_offset} || 0 ) ), $so->{xdup}{values}, 'duplicates values'; # if there are guarantees about which duplicates are returned, test it if ( exists $so->{xdup}{idx} ) { is_pdl vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode => $mode } ), $so->{xdup}{idx}, 'duplicate indices'; } if ( exists $so->{docs} ) { while ( my ( $label, $inputs ) = splice( @{ $so->{docs} }, 0, 2 ) ) { while (@$inputs) { my ( $idx, $offset, $exp ) = splice( @$inputs, 0, 3 ); my $value = $so->{x}->at($idx) + $offset; is vsearch( $value, $so->{x}, { mode => $mode } ) ->sclr, $exp, "$label: ($idx, $offset)"; } } } }; } is_pdl vsearch( $ones, $ones, { mode => $mode } )->uniq->squeeze, pdl($data->{all_the_same_element}), 'all the same element'; }; } # test vsearch API to ensure backwards compatibility { my $vals = random(100); my $xs = sequence(100) / 99; # implicit output ndarray my $indx0 = vsearch( $vals, $xs ); my $ret = vsearch( $vals, $xs, my $indx1 = PDL->null() ); is( $ret, undef, "no return from explicit output ndarray" ); is_pdl $indx0, $indx1, 'explicit ndarray == implicit ndarray'; } subtest regressions => sub { subtest '$xs->is_empty' => sub { lives_ok { pdl( [0] )->vsearch_bin_inclusive( pdl( [] ) ) }; }; }; done_testing; PDL-2.100/t/flexraw.t0000644000175000017500000001213314727756302014176 0ustar osboxesosboxes# flexraw's read/write tests, copied from fastraw's tests. # There are still many tests to write; see the notes at the bottom # of this document. use PDL::LiteF; # PDL::Core::set_debugging(1); kill INT,$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. use strict; use warnings; use Test::More; use Test::PDL; use File::Temp qw(tempdir); use File::Spec::Functions; use PDL::IO::FlexRaw; $PDL::debug = 0; # Get a temporary directory and file name, which obviously we'll need for testing # saving and reading of data. my $tmpdir = tempdir( CLEANUP=>1 ); my $name = catfile($tmpdir, "tmp0"); # Set up the working filename and make sure we're working with a clean slate: # **TEST 2** save an ndarray to disk my $x = pdl [2,3],[4,5],[6,7]; my $header = eval { writeflex($name, $x) }; ok((-f $name), "writeflex should create a file"); my $header_bis = [ { %{$header->[0]}, Dims => [2, undef] } ]; eval { readflex($name, [@$header_bis, @$header_bis]) }; like $@, qr/>1 header/, 'readflex only allows undef dim when only one hash'; my $x_bis = readflex($name, $header_bis); is_pdl $x_bis, $x, "read back with undef highest dim correct"; # **TEST 3** save a header to disk eval { writeflexhdr($name, $header) }; ok(-f "$name.hdr", "writeflexhdr should create a header file"); # **TEST 4** read it back, and make sure it gives the same ndarray my $y = eval { readflex($name) }; is_pdl $x, $y, "A ndarray and its saved copy should be about equal"; # **TEST 5** save two ndarrays to disk my ($c1, $c2) = ([0,0,0,0],[0,0,0,0]); my $c = pdl [$c1,$c2]; my $d = pdl [1,1,1]; my $cdname = $name . 'cd'; $header = eval { writeflex($cdname, $c, $d) }; ok((-f $cdname), "writeflex saves 2 pdls to a file"); # **TEST 6** save a header to disk eval { writeflexhdr($cdname, $header) }; ok(-f "$cdname.hdr", "writeflexhdr create a header file"); # **TEST 7** read it back, and make sure it gives the same ndarray # This is sf.net bug #3375837 "_read_flexhdr state machine fails" my (@cd) = eval { no warnings; readflex($cdname) }; is 0+@cd, 2, 'sf.net bug 3375837'; is_pdl $cd[0], $c, 'sf.net bug 3375837'; is_pdl $cd[1], $d, 'sf.net bug 3375837'; # Clean up for another test unlink $cdname, $cdname . '.hdr'; # just to be absolutely sure { my $gname = $name.'g'; local $PDL::IO::FlexRaw::writeflexhdr = 1; eval { writeflex($gname, $d, $c) }; # 2D last so can append my @dc = eval { readflex($gname) }; is_pdl $dc[0], $d; is_pdl $dc[1], $c; my $e = pdl(2,2,2,2); eval { glueflex($gname, $e) }; is $@, '', 'no error glueflex'; @dc = eval { readflex($gname) }; is_pdl $dc[0], $d; is_pdl $dc[1], pdl($c1,$c2,$e); } # some mapflex tests SKIP: { my $c = eval { mapflex($name) }; if ($@) { diag("$@"); if ($@ =~ m/mmap not supported/) { skip('no mmap support', 5); } } # **TEST 8** compare mapfraw ndarray with original ndarray is_pdl $x, $c, "An ndarray and its mapflex representation should be about equal"; # **TEST 9** modifications should be saved when $c goes out of scope # THIS TEST FAILS. # This failure is recorded in sf.net bug 3031068. # Presently, making $c go out of scope does not free the memory # mapping associated with mapflex, so this modification is never # saved to the file (or at least it's not saved immediately). $c += 1; undef $c; $y = readflex($name); is_pdl $x+1, $y, "Modifications to mapfraw should be saved to disk no later than when the ndarray ceases to exist"; # We're starting a new test, so we'll remove the files we've created so far # and clean up the memory, just to be super-safe unlink $name, $name . '.hdr'; undef $x; undef $y; # **TEST 10** test creating a pdl via mapfraw # First create and modify the ndarray $header = [{NDims => 2, Dims => [3,2], Type => 'float'}]; # Fix this specification. $x = mapflex($name, $header, {Creat => 1}); writeflexhdr($name, $header); ok(defined($x), 'mapflex create ndarray'); skip('no mapflex ndarray to check', 2) unless defined $x; $x += xvals $x; $x += 0.1 * yvals $x; # save the contents undef $x; # Load it back up and see if the values are what we expect $y = readflex($name); # **TEST 11** is_pdl $y, float([[0,1,2],[0.1,1.1,2.1]]), "mapfraw should be able to create new ndarrays"; undef $x; undef $y; # cleanup # test for bug mentioned in https://perlmonks.org/?node_id=387256 my $p1 = sequence(5); my $header1 = eval { writeflex($cdname, $p1) }; is $@, '', 'no error'; writeflexhdr($cdname, $header1); my $p2 = sequence(5) + 8; my $header2 = eval { writeflex($name, $p2) }; is $@, '', 'no error'; writeflexhdr($name, $header2); $p1 = mapflex($cdname); is $p1.'', '[0 1 2 3 4]', 'right value before second mapflex'; $p2 = mapflex($name); is $p1.'', '[0 1 2 3 4]', 'still right value after second mapflex'; is $p2.'', '[8 9 10 11 12]', 'second ndarray values right'; undef $p1; undef $p2; unlink $cdname, $cdname . '.hdr'; } # Clean things up a bit unlink $name, $name . '.hdr'; # Test the file header options: # Tests to write still: # Test using file handles instead of file names # test read_flexhdr # test gzip stuff done_testing; PDL-2.100/t/primitive-misc.t0000644000175000017500000000760414740772324015473 0ustar osboxesosboxesuse Test::More; use PDL::LiteF; use PDL::Types; use Test::PDL; use Test::Exception; # subtest is making $@ be blank even after a die subtest hist => sub { my $y = pdl( 0.7422, 0.0299, 0.6629, 0.9118, 0.1224, 0.6173, 0.9203, 0.9999, 0.1480, 0.4297, 0.5000, 0.9637, 0.1148, 0.2922, 0.0846, 0.0954, 0.1379, 0.3187, 0.1655, 0.5777, 0.3047 ); is_pdl scalar $y->hist(0, 1, 0.1), pdl("3 5 1 2 1 2 2 1 0 4"), 'hist works'; }; subtest norm => sub { my $x = pdl('[[i 2+3i] [4+5i 6+7i]]'); is_pdl $x->norm, pdl( [ [ 0.267261 * i, 0.534522 + 0.801783 * i ], [ 0.356348 + 0.445435 * i, 0.534522 + 0.623609 * i ], ] ), 'native complex norm works'; }; subtest glue => sub { my $x = xvals( 2, 2, 2 ); my $y = yvals( 2, 2, 2 ); my $c = zvals( 2, 2, 2 ); is_deeply $x->glue( 1, $y, $c )->unpdl, [ [ [ 0, 1 ], [ 0, 1 ], [ 0, 0 ], [ 1, 1 ], [ 0, 0 ], [ 0, 0 ] ], [ [ 0, 1 ], [ 0, 1 ], [ 0, 0 ], [ 1, 1 ], [ 1, 1 ], [ 1, 1 ] ] ]; }; subtest 'fibonacci' => sub { is_pdl fibonacci(15), pdl('1 1 2 3 5 8 13 21 34 55 89 144 233 377 610'), 'Fibonacci sequence'; }; subtest 'indadd' => sub { my $a1 = pdl( 1, 2, 3 ); my $ind = pdl( 1, 4, 6 ); my $sum = zeroes(10); indadd( $a1, $ind, $sum ); is_pdl $sum, my $exp = pdl('0 1 0 0 2 0 3 0 0 0'), "indadd"; eval {indadd($a1, indx(-1), $sum)}; like $@, qr/invalid index/, 'invalid index right error'; is_pdl $sum, $exp, "indadd same after invalid ind"; my $bad_ind = indx('0 1 2'); $bad_ind->badvalue(0); $bad_ind->badflag(1); throws_ok {indadd($a1, $bad_ind, $sum)} qr/bad index/, "[io] but no [o] still gets bvalflag set with $bad_ind"; is_pdl $sum, $exp, "indadd same after bad ind"; }; subtest 'one2nd' => sub { my $a1 = zeroes( 3, 4, 5 ); my $indices = pdl( 0, 1, 4, 6, 23, 58, 59 ); my ( $x, $y, $z ) = $a1->one2nd($indices); is_pdl $x, indx( 0, 1, 1, 0, 2, 1, 2 ), "one2nd x"; is_pdl $y, indx( 0, 0, 1, 2, 3, 3, 3 ), "one2nd y"; is_pdl $z, indx( 0, 0, 0, 0, 1, 4, 4 ), "one2nd z"; }; subtest approx_artol => sub { my $got_str = '1e-5 1e-6 1e-7 BAD 1; 1.00000005 -1.0000001 1.00002 NaN NaN'; my $fgot = pdl($got_str); my $fexpected = pdl('0 0 0 BAD NaN; 1 -1 1 NaN 1'); my $exp_a_mask = pdl('0 1 1 1 0; 1 1 0 1 0'); my $got_a = $fgot->approx_artol($fexpected, 1e-6); ok all($got_a == $exp_a_mask), 'atol right' or diag "got=$got_a\nexp=$exp_a_mask"; (my $got_str_cplx = $got_str) =~ s/ /+0i /; my $got_a_cplx = pdl($got_str_cplx)->approx_artol($fexpected, 1e-6); ok all($got_a_cplx == $exp_a_mask), 'complex atol right' or diag "got=$got_a_cplx\nexp=$exp_a_mask"; my $got_r = $fgot->approx_artol($fexpected, 0, 1e-6); my $exp_r_mask = pdl('0 0 0 1 0; 1 1 0 1 0'); ok all($got_r == $exp_r_mask), 'rtol right' or diag "got=$got_r\nexp=$exp_r_mask"; my $fgot_badoff = $fgot->copy; $fgot_badoff->badflag(0); my $exp_badoff_mask = pdl('0 1 1 0 0; 1 1 0 1 0'); my $got_badoff = $fgot_badoff->approx_artol($fexpected, 1e-6); ok all($got_badoff == $exp_badoff_mask), 'atol right with badflag off' or diag "got=$got_badoff\nexp=$exp_badoff_mask"; $fexpected = long( 4,5,6,-1,8,9 )->inplace->setvaltobad(-1); $fgot = long( 4,5,6,7,-1,9 )->inplace->setvaltobad(-1); $got_a = $fgot->approx_artol($fexpected, 1e-6); $exp_a_mask = pdl('1 1 1 0 0 1'); ok all($got_a == $exp_a_mask), 'bad values pattern' or diag "got=$got_a\nexp=$exp_a_mask"; $got_a = inf(1)->approx_artol(inf(1)); $exp_a_mask = pdl([1]); ok all($got_a == $exp_a_mask), 'inf matches inf' or diag "got=$got_a\nexp=$exp_a_mask"; $got_a = pdl('inf bad')->approx_artol(pdl('inf bad')); $exp_a_mask = pdl([1,1]); ok all($got_a == $exp_a_mask), 'inf,bad matches inf,bad' or diag "got=$got_a\nexp=$exp_a_mask"; ok all(approx_artol i,i), 'i is approx i'; ok !all(approx_artol i,5*i), 'i is not approx 5i'; }; done_testing; PDL-2.100/t/ops-bitwise.t0000644000175000017500000000075114727756302014776 0ustar osboxesosboxesuse strict; use warnings; # Run ops.t with the experimental ‘bitwise’ feature enabled. BEGIN { if ("$]" < 5.022) { print "1..0 # skip Requires Perl 5.22\n"; exit; } } use feature 'bitwise'; use FindBin; open my $fh, "$FindBin::Bin/ops.t" or die "Cannot read $FindBin::Bin/ops.t: $!"; my $source = do { local $/; <$fh> }; close $fh; $source =~ s/use warnings;\K/no warnings 'experimental::bitwise';/; eval "#line 1 t/ops.t-run_by_ops-bitwise.t\n$source"; die $@ if $@; PDL-2.100/t/diskcache.t0000644000175000017500000000152714727756302014451 0ustar osboxesosboxesuse strict; use warnings; use PDL; use File::Temp 'tempdir'; use File::Spec; use Test::More tests => 4; use Test::Exception; # Temp directory name. The catfile() call adds a trailing dir # separator (e.g. "/" on POSIX). my $d = File::Spec->catfile(tempdir(CLEANUP=>1),""); ##1 Make sure the library loads use PDL::DiskCache; ## Make a DiskCache object ##exercises STORE, sync, and DESTROY lives_ok { my($pa) = diskcache(["${d}1","${d}2","${d}3"],{verbose=>1}); $pa->[0] = zeroes(10,10); $pa->[1] = xvals(10,10); $pa->[2] = yvals(10,10); 1; } "Make a DiskCache object"; ok( (-e "${d}1") && (-e "${d}2") && (-e "${d}3"), "3 files written"); my $pb; lives_ok { ($pb) = diskcache(["${d}1","${d}2","${d}3"],{ro=>1}); } 'could read files'; ok( ($pb->[0]->sum == 0) && ($pb->[1]->sum == xvals(10,10)->sum), 'files read correctly' ); # end PDL-2.100/t/primitive-random.t0000644000175000017500000000203414732354473016012 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use Test::PDL; subtest 'random' => sub { subtest 'random and srandom' => sub { srandom 5; my $r1 = random 10; srandom 5; my $r2 = random 10; is_pdl $r1, $r2, "random and srandom"; }; subtest 'grandom and srandom' => sub { srandom 10; my $r1 = grandom 10; srandom 10; my $r2 = grandom 10; is_pdl $r1, $r2, "grandom and srandom"; }; }; subtest 'types' => sub { subtest 'random' => sub { my $type; lives_ok { $type = random()->type } 'random()'; is( $type, 'double', 'defaults to double' ); }; subtest 'randsym' => sub { my $type; lives_ok { $type = randsym()->type } 'randsym()'; is( $type, 'double', 'defaults to double' ); }; }; subtest 'regressions' => sub { # Test some operations with empty ndarrays lives_ok { random( 1, 1, 0 )->type } 'empty ndarray'; # used to segfault }; done_testing; PDL-2.100/t/storable.t0000644000175000017500000001125014741247543014336 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use Storable qw/freeze thaw retrieve/; use PDL::LiteF; use PDL::Dbg; use PDL::IO::Storable; my $x = sequence(2,2); my $serialized = freeze $x; my $oldx = thaw $serialized; is_pdl $x, $oldx, 'PDL freeze/thaw'; $x = double(1); $serialized = freeze $x; my $dthaw = thaw $serialized; is_pdl $dthaw, $x, 'PDL freeze/thaw of PDL scalar'; my $data = { key1 => 1, key2 => sequence(3), key3 => 'hallo', }; my $dfreeze = freeze $data; $dthaw = thaw $dfreeze; isa_ok($dthaw, 'HASH'); # we got a HASH back is_pdl $dthaw->{key2}, $data->{key2}, 'PDL in structure'; my $phash = bless {PDL => sequence 3}, 'PDL'; can_ok($phash, 'freeze'); my $pfreeze = $phash->freeze; my $phthaw = thaw $pfreeze; is_pdl $phthaw, $phash, 'PDL has-a works with freeze/thaw'; isa_ok $phthaw, 'HASH', 'PDL is a hash'; my $seq1 = sequence(3); my $seq1_tf = thaw(freeze($seq1)); $seq1->slice('1') .= 9; is_pdl $seq1, pdl(0,9,2); is_pdl $seq1_tf, sequence(3), 'mutate orig no change thawed object'; # Test that dclone results in a new object # i.e. that dclone(.) == thaw(freeze(.)) my $seq2 = sequence(4); my $seq2_dc = Storable::dclone($seq2); $seq2->slice('2') .= 8; is_pdl $seq2, pdl(0,1,8,3); is_pdl $seq2_dc, sequence(4), 'mutate orig no change dcloned object'; { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; thaw( freeze pdl([]) ); is "@w", '', 'no warnings'; } # Now test reading from files testLoad($_) foreach( qw(t/storable_new_amd64.dat t/storable_old_amd64.dat) ); { my $pdl = sequence(long,5); my $native_frozen = freeze $pdl; my $f2 = $native_frozen; is_pdl thaw($native_frozen), sequence(long,5), "thawed native"; my $one = substr($native_frozen, -40, 4); # count from back as Storable uses platform data sizes $one = pack "N", unpack "V", $one; my $data = substr($native_frozen, -20, 20); $data = pack "N*", unpack "V*", $data; substr $f2, -40, 4, $one; substr $f2, -20, 20, $data; is_pdl thaw($f2), sequence(long,5), "thawed byte-swapped"; } # packages supporting Types::Serialiser protocol { # add to if needed my @possibles = qw/Sereal CBOR::XS JSON::MaybeXS/; my @serialisers; for my $module (@possibles) { if (eval "require $module") { if ($module eq 'JSON::MaybeXS') { my $impl = eval { $module->JSON }; note("JSON::XS wants data to encode, JSON::PP wants encoded: can't work with JSON::PP"), next if ($impl || '') eq 'JSON::PP'; } push @serialisers, $module; } else { note "package $module not available for serialisation, not testing it"; } } if (!@serialisers) { note "No serialisation modules installed that support the Types::Serialiser protocol, skipping those tests"; } my @ndarrays = ( [ xvals => xvals(2, 2) ], [ cdouble => pdl(cdouble, 2, 3) ], [ cdouble2 => xvals(cdouble, 3, 5) + 10 - 2 * xvals(3, 5) * i ], [ indx => pdl(indx, 2, 3) ], [ ldouble => pdl(ldouble, 2, 3) ], ); my ($encoder, $decoder); foreach my $serialiser (@serialisers) { if ($serialiser eq 'Sereal') { $encoder = Sereal::Encoder->new({ freeze_callbacks => 1 }); $decoder = Sereal::Decoder->new({ freeze_callbacks => 1 }); } elsif ($serialiser eq 'CBOR::XS') { $encoder = CBOR::XS->new; $decoder = CBOR::XS->new; } elsif ($serialiser eq 'JSON::MaybeXS') { $encoder = JSON::MaybeXS->new(allow_tags => 1); $decoder = JSON::MaybeXS->new(allow_tags => 1); } foreach my $pair (@ndarrays) { my ($name, $ndarray) = @$pair; my $frozen = $encoder->encode($ndarray); my $thawed = $decoder->decode($frozen); is_pdl($thawed, $ndarray, "$name thawed correctly using $serialiser"); } } } done_testing; # tests loading some files made on different architectures. All these files were # made with this: # # use PDL; # use PDL::IO::Storable; # use Storable qw(nstore); # my $x = sequence(3,3)->byte * sequence(3)->byte; # my $y = 50 + sequence(7)->double; # nstore [$x, 'abcd', $y], "/tmp/tst.dat"; # # I make sure these all were read correctly sub testLoad { my $filename = shift; # if we're on a big endian machine, the old-style data will be bogus so I skip # the tests in that case SKIP: { if ( $filename =~ /_old_/ ) { my ($byte0) = unpack( 'C*', pack( 'l', 1 )); if ( $byte0 == 0 ) { skip "On a big endian machine the old stored files will be bogus", 7; } } my $x = retrieve $filename; is 0+@$x, 3, "Reading an array-ref of size 3 from file '$filename'"; is_pdl $x->[0], byte [[0,1,4], [0,4,10], [0,7,16]]; is $x->[1], 'abcd', "Reading a correct string from file '$filename'"; is_pdl $x->[2], 50 + sequence(7); } } PDL-2.100/t/bad.t0000644000175000017500000005051714753736717013273 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Math; use PDL::Types qw(types); use Test::Warn; use Test::PDL; sub abstol { {atol=>1.0e-4, test_name=>$_[0]} } { my $a_bad = pdl double, '[1 BAD 3]'; my $b_double = zeroes double, 3; $a_bad->assgn($b_double); ok $b_double->badflag, 'b_double badflag set'; is $b_double.'', '[1 BAD 3]', 'b_double got badval'; my $b_float = zeroes float, 3; $a_bad->assgn($b_float); ok $b_float->badflag, 'b_float badflag set'; is $b_float.'', '[1 BAD 3]', 'b_float got badval'; } # check default behaviour (ie no bad data) # - probably overkill # my $x = pdl(1,2,3); is( $x->badflag(), 0, "no badflag" ); my $y = pdl(4,5,6); my $c = $x + $y; is( $c->badflag(), 0, "badflag not set in a copy" ); is( $c->sum(), 21, "sum() works on non bad-flag ndarrays" ); # is the flag propagated? $x->badflag(1); ok( $x->badflag(), "bad flag is now set" ); $c = $x + $y; ok( $c->badflag(), "bad flag is propagated" ); is( $c->sum(), 21, "sum is still 21 with badflag set" ); $x->badflag(0); $y->badflag(1); $c = $x + $y; ok( $c->badflag(), "badflag propagates on rhs of 'x+y'" ); # how about copies/vaffines/whatever $x = rvals( long, 7, 7, {Centre=>[2,2]} ); $y = $x; is( $y->badflag, 0, "badflag not set in a copy" ); $x->badflag(1); $y = $x; ok( $y->badflag, "badflag is now set in a copy" ); $x->badflag(0); $y = $x->slice('2:5,3:4'); $c = $y->slice('0:1,(0)'); is( $y->badflag, 0, "slice handling okay with no badflag" ); $x->badflag(1); # let's check that it gets through to a child of a child ok( $c->badflag, "badflag propagated through to a child" ); # can we change bad values is( byte->badvalue, byte->orig_badvalue, "byte bad value is set to the default value" ); byte->badvalue(23); is( byte->badvalue, 23, "changed bad value for byte" ); byte->badvalue( byte->orig_badvalue ); # check setbadat() $x = pdl(1,2,3,4,5); $x->setbadat(2); is_pdl $x, pdl("[1 2 BAD 4 5]"), "setbadat worked"; $y = $x->copy; is_pdl $y, pdl("[1 2 BAD 4 5]"), "y correct bad before set_datatype"; $y->set_datatype(ushort->enum); is_pdl $y, ushort("[1 2 BAD 4 5]"), "y correct bad after set_datatype"; $y = $x->copy; $y->badvalue('nan'); $y->setbadat(2); is $y."", "[1 2 BAD 4 5]", "y correct bad before set_datatype with badval=nan"; my $z = $y->convert(ushort); is_pdl $z, ushort("[1 2 BAD 4 5]"), "non-inplace converting NaN-badvalued pdl preserves badvals"; $y->set_datatype(ushort->enum); is_pdl $y, ushort("[1 2 BAD 4 5]"), "y correct bad after set_datatype with badval=nan"; # now check that badvalue() changes the ndarray # (only for integer types) $x = convert($x,ushort); is_pdl $x, ushort("[1 2 BAD 4 5]"), "before change badvalue"; my $badval = $x->badvalue; $x->badvalue(44); is_pdl $x, ushort("[1 2 BAD 4 5]"), "changed badvalue"; $x->badflag(0); is_pdl $x, ushort("[1 2 44 4 5]"), "can remove the badflag setting"; # restore the badflag $x->badflag(1); is_pdl $x, ushort("[1 2 BAD 4 5]"), "still 'bad' w/changed badvalue"; $x = byte(1,2,3); $x->badflag(1); $y = byte('1 BAD 3'); is( PDL::Core::string($y), "[1 BAD 3]", "can convert bad values to a string" ); # does addition work is_pdl $x + $y, byte('2 BAD 6'), "addition propagates the bad value"; # does conversion of bad types work $c = float($y); is_pdl $c, float("[1 BAD 3]"), "type conversion retains bad flag and values"; is_pdl sum($c), float(4), " and the sum"; $x = byte('1 2 BAD BAD 5 6 BAD 8 9'); is_pdl $x->isbad, long("0 0 1 1 0 0 1 0 0"), "isbad() works"; is_pdl $x->isgood, long("1 1 0 0 1 1 0 1 1"), "isgood() works"; is $x->nbad, 3, "nbad() works"; is $x->ngood, 6, "ngood() works"; $x = byte('BAD BAD; BAD 0; 0 0'); is_pdl $x->nbadover, indx("[2 1 0]"), "nbadover() works"; is_pdl $x->ngoodover, indx("[0 1 2]"), "ngoodover() works"; # check dataflow (or vaffine or whatever it's called) $x = byte('1 2 BAD 4 5; BAD 0 1 2 BAD'); $y = $x->slice(',(1)'); is( sum($y), 3, "sum of slice works" ); $y++; is_pdl $x, byte("1 2 BAD 4 5; BAD 1 2 3 BAD"), "inplace addition of slice flows back to parent"; $x = byte->badvalue * ones(byte,3,2); is $x->type, 'byte', "datatype remains a byte"; $x->badflag(1); is_pdl PDL::zcover($x), byte("[BAD BAD]"), "zcover() okay"; $x->set(1,1,1); $x->set(2,1,1); is_pdl PDL::zcover($x), byte("[BAD 0]"), " and still okay"; # 255 is the default bad value for a byte array # $x = byte(1,2,255,4,5); is( $x->median, 4, "median() works on good ndarray" ); $x->badflag(1); is( $x->median, 3, "median() works on bad biddle" ); # as random() creates numbers between 0 and 1 it won't # accidentally create a bad value by chance (the default # bad value for a double is a very negative number). $x = random(20); $x->badflag(1); is $x->check_badflag, 0, "check_badflag did not find a bad value"; # check out stats, since it uses several routines # and setbadif $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); my @s = $y->stats(); is_pdl $s[0], pdl(61.9375), abstol("setbadif/stats test 1"); is_pdl $s[1], pdl(27.6079), abstol("setbadif/stats test 2"); is_pdl $s[2], pdl(66.5), "setbadif/stats test 3"; is_pdl $s[3], pdl(22), "setbadif/stats test 4"; is_pdl $s[4], pdl(98), "setbadif/stats test 5"; is_pdl $s[6], pdl(26.7312), abstol("setbadif/stats test 6"); ok !$x->badflag, 'badflag not set on input after setbadif'; # how about setbadtoval empty()->setbadtoval(20); # shouldn't segfault ok $y->badflag, 'badflag on'; is_pdl $y->setbadtoval(20), pdl(qw(42 47 98 20 22 96 74 41 79 76 96 20 32 76 25 59 20 96 32 20)), "setbadtoval() worked"; ok $y->badflag, 'badflag still on'; # and inplace? $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); $y->inplace->setbadtoval(20); is_pdl $y, pdl(qw(42 47 98 20 22 96 74 41 79 76 96 20 32 76 25 59 20 96 32 20)), " and inplace"; # ditto for copybad $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); $c = copybad( $x, $y ); is_pdl $c->isbad, long("[0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 1]"), "isbad() worked"; $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); $x->inplace->copybad( $y ); is_pdl $x->isbad, long("[0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 1]"), " and inplace"; $x = zeroes(20,30); $y = $x->slice('0:10,0:10'); $c = $y->slice(',(2)'); ok !$c->badflag, 'no badflag on slice-child of good'; $x->badflag(1); ok $c->badflag, 'badflag on same slice-child of good set to bad'; $c->badflag(0); ok !$x->badflag, 'badflag now off for slice-parent of bad slice-child set to good'; $x = pdl '1 BAD'; ok any($x > 0), 'any with some badvals just omits them'; ok all($x > 0), 'all with some badvals just omits them'; ## $x->inplace->setbadif( $x % 2 ) does NOT work because ## ($x % 2) is performed inplace - ie the flag is set for ## that function # ##$x = sequence(3,3); ##$x->inplace->setbadif( $x % 2 ); ###$x = $x->setbadif( $x % 2 ); # for when not bothered about inplace ##ok( PDL::Core::string( $x->clump(-1) ), ## "[0 BAD 2 BAD 4 BAD 6 BAD 8]" ); # ## look at propagation of bad flag using inplace routines... $x = sequence( byte, 2, 3 ); $x = $x->setbadif( $x == 3 ); $y = $x->slice("(1),:"); $x->inplace->setbadtoval(3); is( $x->badflag, 0, "direct pdl badflag cleared using inplace setbadtoval()" ); is( $y->badflag, 0, "child pdl badflag cleared using inplace setbadtoval()" ); $x = sequence( byte, 2, 3 ); $y = $x->slice("(1),:"); my $mask = sequence( byte, 2, 3 ); $mask = $mask->setbadif( ($mask % 3) == 2 ); $x->inplace->copybad( $mask ); is( $y->badflag, 1, "badflag propagated using inplace copybad()" ); # test some of the qsort functions $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); my $ix = qsorti( $y ); is_pdl $y->index($ix), pdl("[22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD]"), "qsorti() okay" ; # check comparison/bit operators in ops.pd $x = pdl('2 4 BAD'); is_pdl abs( $x - pdl(2.001,3.9999,234e23) ) > 0.01, pdl("[0 0 BAD]"), "abs() and >"; is_pdl byte('1 2 BAD 4') << 2, byte("[4 8 BAD 16]"), "<<"; $x = pdl([1,2,3]); $x->badflag(1); $y = $x->assgn; is( $y->badflag, 1, "assgn propagated badflag"); $x->badflag(0); is( $y->badflag, 1, "assgn is not a deep copy for the badflag"); $x = pdl q[BAD]; is( PDL::Core::string($x), 'BAD', 'can convert PDL to string' ); is( $x->at, 'BAD', 'at() returns BAD for a bad value' ); isnt( $x->sclr, 'BAD', 'sclr() ignores bad value' ); $x = pdl 4; $x->badflag(1); $x->badvalue(4); is( $x->at, 'BAD', 'at() returns BAD for a bad value with non-default badvalue' ); is( $x->sclr, 4, 'sclr() ignores bad value' ); is_pdl isbad(bessj0(pdl('0.5 BAD 0'))), long("[0 1 0]"), "bessj0()"; $y = bessjn(pdl('BAD 0.8'),3); # broadcast over n() is_pdl $y, pdl('BAD 0.010246'), "broadcast over bessjn()"; $x = pdl( 0.01, 0.0 ); $x->badflag(1); is_pdl erfi($x), pdl(0.00886,0), {atol=>0.001, test_name=>"erfi()"}; # I haven't changed rotate, but it should work anyway is_pdl byte('0 1 BAD 4 5')->rotate(2), byte("[4 5 0 1 BAD]"), "rotate()"; # check norm $x = float('2 BAD 2 2'); is_pdl $x->norm, $x/sqrt(sum($x*$x)), abstol("norm()"); # propagation of badflag using inplace ops (ops.pd) # test biop fns $x = sequence(3,3); $c = $x->slice(',(1)'); $y = $x->setbadif( $x % 2 ); $x->inplace->plus($y,0); is_pdl $c, pdl("[BAD 8 BAD]"), "inplace biop - plus()"; # test bifunc fns $x = sequence(3,3); $c = $x->slice(',(1)'); $y = $x->setbadif( $x % 3 != 0 ); $x->inplace->power($y,0); is_pdl $c, pdl("[27 BAD BAD]"), "inplace bifunc - power()"; # test histogram (using hist) $x = pdl('1 BAD 3 4 5 4 3 2 2 1'); is_pdl scalar hist($x, 0, 6, 1), pdl("[0 2 2 2 2 1]"), "hist()"; is_pdl $x->isfinite, long("[1 0 1 1 1 1 1 1 1 1]"), "isfinite()"; # histogram2d $x = long(1,1,1,2,2); $y = long('BAD 1 1 1 1'); my @c = ( 1,0,3 ); is_pdl scalar histogram2d($x,$y,@c,@c), long("[0 0 0;0 2 2;0 0 0]"), "histogram2d()"; # badmask: inplace $x = pdl("0 1 BAD 3 4"); $x->inplace->badmask(0); is_pdl $x, pdl("[0 1 0 3 4]"), "inplace badmask()"; # setvaltobad $x = sequence(10) % 4; $x->inplace->setvaltobad( 1 ); is_pdl $x, pdl('0 BAD 2 3 0 BAD 2 3 0 BAD'), "inplace setvaltobad()"; $x->inplace->setbadtonan; is_pdl $x, pdl('0 nan 2 3 0 nan 2 3 0 nan'), "inplace setvaltonan()"; # check setvaltobad for non-double ndarrays is_pdl float(1..4)->setvaltobad(2), float('1 BAD 3 4'), "setvaltobad for float ndarray"; is_pdl double(1..4)->setvaltobad(2), double('1 BAD 3 4'), "setvaltobad for double ndarray"; my $inf2b = pdl('0 inf nan'); $inf2b->inplace->setinftobad; is_pdl $inf2b, pdl('0 BAD nan'), "inplace setinftobad()"; my $x_copy = pdl('0 inf 2 3 0 nan 2 3 0 nan'); $x_copy->inplace->setnonfinitetobad; is_pdl $x_copy, pdl('0 BAD 2 3 0 BAD 2 3 0 BAD'), "inplace setnonfinitetobad"; # simple test for setnantobad # - could have a 1D FITS image containing # NaN's and then a simple version of rfits # (can't use rfits as does conversion!) $x->inplace->setnantobad; is_pdl $x, pdl('0 BAD 2 3 0 BAD 2 3 0 BAD'), "inplace setnantobad"; # check that we can change the value used to represent # missing elements for floating points (earlier tests only did integer types) # is( float->badvalue, float->orig_badvalue, "default bad value for floats matches" ); is( float->badvalue(23), 23, "changed floating-point bad value" ); float->badvalue( float->orig_badvalue ); $x = sequence(4); $x->badvalue(3); $x->badflag(1); $y = $x->slice('2:3'); is( $y->badvalue, 3, "can propagate per-ndarray bad value"); is( $y->sum, 2, "and the propagated value is recognised as bad"); $x->badvalue(2); is "$x", '[0 1 BAD 3]', 'change badvalue, badness right in orig'; is( $y->badvalue, 2, "per-ndarray bad value propagated after change"); $x = sequence(4); is ($x->badvalue, double->orig_badvalue, "no long-term effects of per-ndarray changes [1]"); for my $t (map +([$_, undef], [$_, 'nan']), grep !$_->integer, types()) { my $p = sequence $t->[0], 2; $p->badvalue($t->[1]) if defined $t->[1]; $p->setbadat(1); my $msg = "badvalue works right $t->[0], bv=".join '', grep $_, explain($t->[1]); eval {is $p.'', '[0 BAD]', $msg}; is $@, '', $msg; } ## Name: "isn't numeric in null operation" warning could be more helpful ## ## # The following code calls the PDL::Ops::eq() function via the operator # overload for the eq operator. Because the Perl eq operator is usually used # for strings, the default warning of "isn't numeric in null operation" is # confusing. Comparing a PDL against a string should give a more useful # warning. my $numeric_warning = qr/not numeric nor a PDL/; my $no_warning = undef; sub check_eq_warnings { my ($string, $warning) = @_; $warning ||= qr/^\s*$/; my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $dummy = pdl() eq $string; like "@w", $warning; @w = (); $dummy = $string eq pdl(); like "@w", $warning; @w = (); } subtest "String 'x' is not numeric and should warn" => sub { check_eq_warnings('x', $numeric_warning); }; subtest "String 'nancy' is not numeric and should warn" => sub { check_eq_warnings('nancy', $numeric_warning); }; subtest "String 'inf' is numeric" => sub { check_eq_warnings('inf', $no_warning); }; subtest "String 'nan' is numeric" => sub { check_eq_warnings('nan', $no_warning); }; TODO: { # implementing this might require checking for strings that can be made into PDLs local $TODO = "Using the eq operator with the string 'bad' might be a good feature"; subtest "String 'bad' is numeric (in PDL)" => sub { check_eq_warnings('bad', $no_warning); }; } ## Issue information ## ## Name: scalar PDL with badvalue always compares BAD with perl scalars ## ## ## subtest "Issue example code" => sub { my $x = pdl(1, 2, 3, 0); $x->badflag(1); $x->badvalue(0); # bad value for $x is now set to 0 is_pdl $x, pdl("[1 2 3 BAD]"), "PDL with bad-value stringifies correctly"; my ($m, $s) = stats($x); is_pdl $m, pdl(2), "Mean of [1 2 3] is 2"; is_pdl $s, pdl(1), "And std. dev is 1"; $s->badflag(1); $s->badvalue(0); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; is_pdl $s > 0, pdl(1), "is 1 > 0? -> true"; is_pdl $s < 0, pdl(0), "is 1 < 0? -> false"; is_pdl $s == 0, pdl(0), "is 1 == 0? -> false"; ok scalar(@warnings), 'bad gave warnings'; }; subtest "Badvalue set on 0-dim PDL + comparison operators" => sub { my $val = 2; my $badval_sclr = 5; my $p_val = pdl($val); $p_val->badflag(1); $p_val->badvalue($badval_sclr); is_pdl $p_val, pdl($val), "Sanity test"; my @values_to_compare = ( $badval_sclr, $badval_sclr + 1, $badval_sclr - 1 ); subtest "Comparing a 0-dim PDL w/ a scalar should be the same as comparing a scalar w/ a scalar" => sub { for my $cmpval_sclr (@values_to_compare) { subtest "Bad value for PDL $p_val is $badval_sclr and we are comparing with a scalar of value $cmpval_sclr" => sub { is_pdl $p_val < $cmpval_sclr, pdl(0+($val < $cmpval_sclr)), "$val < $cmpval_sclr"; is_pdl $p_val == $cmpval_sclr, pdl(0+($val == $cmpval_sclr)), "$val == $cmpval_sclr"; is_pdl $p_val > $cmpval_sclr, pdl(0+($val > $cmpval_sclr)), "$val > $cmpval_sclr"; }; } }; subtest "Comparing a 0-dim PDL w/ bad value with a 0-dim PDL without bad value set should not set BAD" => sub { for my $not_bad_sclr (@values_to_compare) { subtest "Bad value for PDL $p_val is $badval_sclr and we are comparing with a PDL of value $not_bad_sclr, but with no badflag" => sub { my $p_not_bad = pdl($not_bad_sclr); $p_not_bad->badflag(0); # should not have bad flag my $lt_p = $p_val < $p_not_bad; is_pdl $lt_p, pdl(0+( $val < $not_bad_sclr)), "$val < $not_bad_sclr"; ok $lt_p->badflag, "cmp for < does set badflag"; my $eq_p = $p_val == $p_not_bad; is_pdl $eq_p, pdl(0+( $val == $not_bad_sclr)), "$val == $not_bad_sclr"; ok $eq_p->badflag, "cmp for == does set badflag"; my $gt_p = $p_val > $p_not_bad; is_pdl $gt_p, pdl(0+( $val > $not_bad_sclr)), "$val > $not_bad_sclr"; ok $gt_p->badflag, "cmp for > does set badflag"; }; } }; }; subtest "stats() badvalue behavior" => sub { my $stats_data = [ { name => "stats() should not set the badflag for output with only one badvalue", func => \&stats, input => do { pdl [1, 2, 3] }, badvalue => 2, string => "[1 BAD 3]", mean => "2", badflag => 1, }, { name => "stats() should set the badflag for output with all badvalues and mean should be BAD" , func => \&stats, input => do { pdl [1, 1, 1] }, badvalue => 1, string => "[BAD BAD BAD]", mean => "BAD", badflag => 1, }, { name => "and statsover() on a row of BAD values", func => \&statsover, input => do { zeroes(3,3)->yvals+1 }, badvalue => 1, string => do { my $p_str = <<'EOF'; [ [BAD BAD BAD] [ 2 2 2] [ 3 3 3] ] EOF }, mean => "[BAD 2 3]", badflag => 1, }, { name => "and statsover() on a diagonal of BAD values", func => \&statsover, input => do { my $p = ones(3,3)*2; $p->diagonal(0,1) .= 1; $p }, string => do { my $p_str = <<'EOF'; [ [BAD 2 2] [ 2 BAD 2] [ 2 2 BAD] ] EOF }, badvalue => 1, mean => "[2 2 2]", badflag => 1, } ]; for my $case (@$stats_data) { subtest $case->{name} => sub { my $p = $case->{input}; $p->badflag(1); $p->badvalue($case->{badvalue}); note "\$p = $p"; is( "$p", $case->{string}, "stringifies properly"); my $m = $case->{func}->($p); note "\$m = $m"; is( "$m", $case->{mean}, "Mean of \$p" ); is( $m->badflag, $case->{badflag}, "Mean does @{[ ('not ')x!!( ! $case->{badflag} ) ]}have badflag set"); }; } }; subtest "Comparison between a vector and scalar" => sub { my $p = pdl [1, 2, 3, 4]; $p->badflag(1); $p->badvalue(2); note "\$p = $p"; is( "$p", "[1 BAD 3 4]", "PDL vector (with bv = 2)"); is( "" . ( $p > 1 ), '[0 BAD 1 1]', "compare PDL against (scalar = 1)"); is( "" . ( $p > 2 ), '[0 BAD 1 1]', "compare PDL against (scalar = 2)" ); is( "" . ( $p > 3 ), '[0 BAD 0 1]', "compare PDL against (scalar = 3)"); is( "" . ( $p > 4 ), '[0 BAD 0 0]', "compare PDL against (scalar = 4)"); }; subtest "Throw a warning when badvalue is set to 0 or 1 and a comparison operator is used" => sub { my $warn_msg_re = qr/badvalue is set to 0 or 1/; # We do not need to change the contents of this PDL. # Only the value of badvalue changes. my $p = pdl([0, 1, 2]); $p->badflag(1); subtest "Badvalue set to 0" => sub { $p->badvalue(0); warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 0 and == operator"; }; subtest "Badvalue set to 1" => sub { $p->badvalue(1); warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 1 and == operator"; }; subtest "Badvalue set to 2" => sub { $p->badvalue(2); warning_like { $p == 1 } undef, "No warning thrown for badval == 2 and == operator"; }; subtest "Badvalue set to 0 and other operators" => sub { $p->badvalue(0); warning_like { $p > 1 } $warn_msg_re, "A warning thrown for badval == 0 and > operator"; warning_like { $p >= 1 } $warn_msg_re, "A warning thrown for badval == 0 and >= operator"; warning_like { $p < 1 } $warn_msg_re, "A warning thrown for badval == 0 and < operator"; warning_like { $p <= 1 } $warn_msg_re, "A warning thrown for badval == 0 and <= operator"; warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 0 and == operator"; warning_like { $p != 1 } $warn_msg_re, "A warning thrown for badval == 0 and != operator"; warning_like { $p + 1 } undef, "No warning thrown for badval == 0 and + operator"; }; }; subtest "locf" => sub { my $withbad = pdl '[BAD 1 BAD 3 BAD 5]'; my $locf = $withbad->locf; is $locf."", '[0 1 1 3 3 5]', 'locf worked'; }; subtest "badvalues for native complex" => sub { my $pdl = pdl '1+i'; $pdl->badflag(1); $pdl->badvalue($pdl); is "$pdl", "BAD", 'set badvalue with complex ndarray'; $pdl->badvalue($pdl->sclr); is "$pdl", "BAD", 'set badvalue with complex Perl scalar' or diag "badvalue:", $pdl->badvalue->info, "=", $pdl->badvalue; }; subtest "badvalue propagated to different-typed child not break them" => sub { my $pd = pdl 7; my $pl = $pd->_convert_int(long->enum); $pd->badvalue(inf()); eval { $pl->dump }; is $@, '', 'badval propagate to different-typed child not break it'; }; done_testing; PDL-2.100/t/pp_line_numbers.t0000644000175000017500000000326614727756302015716 0ustar osboxesosboxes# DO NOT MODIFY - IT IS VERY FINICKY; see notes below. use strict; use warnings; # Five tests for each of two types: use Test::More tests => 10; use PDL::PP qw(foo::bar foo::bar foobar); # Add some tests for pp_line_numbers: pp_def(test1 => Pars => 'a(n)', Code => pp_line_numbers (__LINE__, q{/* line 13, First line */ threadloop %{ /* line 15, Line after broadcastloop */ loop (n) %{ /* line 17, Line after loop */ %} /* line 19, Line after close of loop */ %} /* line 21, Line after close of broadcastloop */ }), GenericTypes => [qw(F D)], ); pp_done; unlink 'foobar.pm'; # Analyze the output of pp_line_numbers by checking the line numbering in # foobar.xs. Note that the line *after* the #line directive is assigned the # number of the #line directive. See http://gcc.gnu.org/onlinedocs/cpp/Line-Control.html my ($line, $file) = (1, 'foobar.xs'); open my $fh, '<', 'foobar.xs'; LINE: while(<$fh>) { # Take note of explicit line directives if (/#line (\d+) ".*"/) { ($line, $file) = ($1, $2); next LINE; } # look for items to check: if (m|/\* line (\d+), (.*?) \*/|) { my ($actual_line, $description) = ($1, $2); is($line, $actual_line, $description); } $line++; } close $fh; unlink 'foobar.xs'; __END__ This test is very finicky because it uses __LINE__, but it also explicitly indicates the line numbers in the /* comments */. As such, if you add a line of text (comment or code) before or within the pp_def, all of the line numbers in the /* comments */ will be off. It's a minor headache to adjust them, so please just don't mess with this test, unless of course you wish to fix it. :-) --DCM, December 13, 2011 PDL-2.100/t/matrix.t0000644000175000017500000000170114744204234014020 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More; use Test::PDL; use PDL::Matrix; use PDL::MatrixOps; my $m = mpdl([[1,2,1],[2,0,3],[1,1,1]]); # matrix with determinant 1 my $tol = 1e-6; note "determinant: ",$m->det; is_pdl $m->det, pdl(1), "det"; is_pdl $m->determinant, pdl(1), "determinant"; isa_ok identity($m), 'PDL::Matrix', 'identity of mpdl right class'; isa_ok my $from_scalar = identity(vpdl 3), 'PDL::Matrix', 'identity of mpdl right class'; is $from_scalar.'', <inv; my $gotmethmul = $gotmeth x $v; isa_ok $gotmeth, 'PDL::Matrix', '$mpdl->inv right class'; is_pdl $gotmethmul, $expected, '$mpdl->inv mult correct'; done_testing; PDL-2.100/t/fft.t0000644000175000017500000000354514744321614013305 0ustar osboxesosboxesuse strict; use warnings; use PDL; use PDL::FFT; use Test::More; use Test::Exception; use Test::PDL -atol => 0.01, -require_equal_types => 0; foreach my $type(double,float,cdouble,cfloat){ my $pa = pdl($type,1,-1,1,-1); my $pb = zeroes($type,$pa->dims); fft($pa,$pb); is_pdl $pa, pdl($type,0,0,4,0), "fft for type $type"; ifft($pa,$pb); is_pdl $pa, pdl($type,1,-1,1,-1), "ifft for type $type"; } my $pa = rfits("lib/PDL/Demos/m51.fits"); { my $pb = $pa->copy; my $pc = $pb->zeroes; my $pd=czip($pb, $pc); fft($pb,$pc); ifft($pb,$pc); fft($pd); ifft($pd); is_pdl $pc, $pb->zeroes, "fft zeroes"; is_pdl $pd->im, $pb->zeroes, "fft zeroes using complex ndarrays"; is_pdl $pa, $pb, "original image recovered"; } { my $x = xvals( 10, 10 ) + yvals( 10, 10 ) * 10; my $index = cat( 3 + xvals( 5, 5 ) * 0.25, 7 + yvals( 5, 5 ) * 0.25 ) ->reorder( 2, 0, 1 ); is_pdl $x->long->interpND($index, {method=>'f'}), long('36 36 34 34 35; 51 51 49 49 50; 52 51 49 49 51; 33 33 31 31 32; 26 26 24 24 25'); } { my $pb = $pa->copy; my $pc = $pb->zeroes; my $pd=czip($pb, $pc); fftnd($pb,$pc); ifftnd($pb,$pc); is_pdl $pc, $pb->zeroes, "fftnd zeroes"; is_pdl $pa, $pb, "fftnd real image"; fftnd($pd); ifftnd($pd); is_pdl $pd, $pb, "fftnd native complex image with imag zeroes"; } { my $pb = $pa->slice("1:35,1:69"); my $pc = $pb->copy; fftnd($pb,$pc); ifftnd($pb,$pc); is_pdl $pc, $pb, "fftnd real and imaginary"; is_pdl $pa->slice("1:35,1:69"), $pb, "fftnd original restored"; } { my $pb = $pa->copy; # Test real ffts realfft($pb); realifft($pb); is_pdl $pa, $pb, "realfft"; } # Test that errors are properly caught throws_ok {fft(sequence(10))} qr/Did you forget/, 'fft offers helpful message when only one argument is supplied'; #16 throws_ok {ifft(sequence(10))} qr/Did you forget/, 'ifft offers helpful message when only one argument is supplied'; #17 done_testing; PDL-2.100/t/tp-import_options.t0000644000175000017500000000703614727756302016242 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Deep; use Test::Exception; use PDL::Types 'types'; my @warns; $SIG{__WARN__} = sub {push @warns, @_}; is "@warns", "", "no warnings"; require Test::PDL; @warns = (); # we should start out without an 'is_pdl' function ok ! __PACKAGE__->can( 'is_pdl' ); # use Test::PDL ''; package t1; ::cmp_deeply \%Test::PDL::DEFAULTS, { atol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), require_equal_types => 1, rtol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), }; ::ok ! __PACKAGE__->can( 'is_pdl' ); # use Test::PDL; package t2; Test::PDL->import(); ::cmp_deeply \%Test::PDL::DEFAULTS, { atol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), require_equal_types => 1, rtol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), }; ::ok __PACKAGE__->can( 'is_pdl' ); # use Test::PDL -require_equal_types => 0; package t3; Test::PDL->import( -require_equal_types => 0 ); ::cmp_deeply \%Test::PDL::DEFAULTS, { atol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), require_equal_types => 0, rtol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), }; $Test::PDL::DEFAULTS{require_equal_types} = 1; # explicitly reset so no need reload ::ok __PACKAGE__->can( 'is_pdl' ); # use Test::PDL -atol => 1e-8; package t4; Test::PDL->import( -atol => 1e-8 ); ::cmp_deeply \%Test::PDL::DEFAULTS, { atol => ::code( sub { abs( $_[0]/1e-8 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), require_equal_types => 1, rtol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), }; ::ok __PACKAGE__->can( 'is_pdl' ); # use Test::PDL -atol => 1e-8, -require_equal_types => 0, 'is_pdl'; package t5; Test::PDL->import( -atol => 1e-8, -require_equal_types => 0, 'is_pdl' ); ::cmp_deeply \%Test::PDL::DEFAULTS, { atol => ::code( sub { abs( $_[0]/1e-8 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), require_equal_types => 0, rtol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), }; ::ok __PACKAGE__->can( 'is_pdl' ); # "reset" package t5; Test::PDL->import( -atol => 1e-6, -require_equal_types => 1, -rtol => 1e-6 ); ::cmp_deeply \%Test::PDL::DEFAULTS, { atol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), require_equal_types => 1, rtol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), }; ::ok __PACKAGE__->can( 'is_pdl' ); # use Test::PDL -rtol => 1e-8; package t5; Test::PDL->import( -rtol => 1e-8 ); ::cmp_deeply \%Test::PDL::DEFAULTS, { atol => ::code( sub { abs( $_[0]/1e-6 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), require_equal_types => 1, rtol => ::code( sub { abs( $_[0]/1e-8 - 1 ) < 1e-6 ? 1 : ( 0, 'tolerance beyond specified value' ) } ), }; ::ok __PACKAGE__->can( 'is_pdl' ); # use Test::PDL -whatever => 42; package t6; ::throws_ok { Test::PDL->import( -whatEver => 42 ) } qr/\binvalid name whatEver\b/; ::ok ! __PACKAGE__->can( 'is_pdl' ); ::is "@warns", "", "no warnings"; ::done_testing; PDL-2.100/t/primitive-clip.t0000644000175000017500000000220714727756302015464 0ustar osboxesosboxesuse Test::More; use PDL::LiteF; sub IM { PDL->new( [ [ 1, 2, 3, 3, 5 ], [ 2, 3, 4, 5, 6 ], [ 13, 13, 13, 13, 13 ], [ 1, 3, 1, 3, 1 ], [ 10, 10, 2, 2, 2, ] ] ); } is_deeply( IM->hclip(5)->unpdl, [ [ 1, 2, 3, 3, 5 ], [ 2, 3, 4, 5, 5 ], [ 5, 5, 5, 5, 5 ], [ 1, 3, 1, 3, 1 ], [ 5, 5, 2, 2, 2, ] ], 'hclip' ); is_deeply( IM->lclip(5)->unpdl, [ [ 5, 5, 5, 5, 5 ], [ 5, 5, 5, 5, 6 ], [ 13, 13, 13, 13, 13 ], [ 5, 5, 5, 5, 5 ], [ 10, 10, 5, 5, 5, ] ], 'lclip' ); is_deeply( IM->clip( 5, 7 )->unpdl, [ [ 5, 5, 5, 5, 5 ], [ 5, 5, 5, 5, 6 ], [ 7, 7, 7, 7, 7 ], [ 5, 5, 5, 5, 5 ], [ 7, 7, 5, 5, 5, ] ], 'clip' ); subtest 'with NaN badvalue' => sub { my $im = sequence(3); $im->badvalue( nan() ); $im->badflag(1); $im->set( 1, nan() ); my $clipped = $im->lclip(0); is_deeply $clipped->unpdl, [0, 'BAD', 2], 'ISBAD() works when badvalue is NaN'; }; done_testing; PDL-2.100/t/inlinepdlpp.t0000644000175000017500000000244014744321614015035 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; BEGIN { my $inline_test_dir = './.inlinepdlpp'; mkdir $inline_test_dir unless -d $inline_test_dir; eval { require Inline; require Inline::C; Inline->import(Config => DIRECTORY => $inline_test_dir, FORCE_BUILD => 1); 1; } || plan skip_all => "Skipped: Inline or Inline::C not installed"; note "Inline Version: $Inline::VERSION\n"; eval { Inline->VERSION(0.43) }; plan skip_all => "Skipped: not got Inline >= 0.43" if $@; } use PDL::LiteF; # use Inline 'INFO'; # use to generate lots of info eval { Inline->bind(Pdlpp => <<'EOF') }; # simple PP definition pp_def('testinc', Pars => 'a(); [o] b()', Code => '$b() = $a() + 1;' # wow, that's complicated ); # this tests the bug with a trailing comment and *no* newline EOF is $@, '', 'bind no error'; my $x = sequence(3,3); my $y = $x->testinc; is myshape($x), myshape($y), 'myshape eq'; is_pdl $y, $x+1; sub myshape { join ',', $_[0]->dims } eval { Inline->bind(Pdlpp => <<'EOF', PACKAGE => 'Other::Pkg') }; pp_addxs(<<'EOXS'); int add1 (parm) int parm CODE: RETVAL = parm + 1; OUTPUT: RETVAL EOXS EOF is $@, '', 'bind no error'; my $r = eval { Other::Pkg::add1(4) }; is $@, '', 'call no error'; is $r, 5, 'correct result'; done_testing; PDL-2.100/t/io-stl-cube.stl0000644000175000017500000000261114727756302015210 0ustar osboxesosboxessolid cube facet normal 0 0 0 outer loop vertex 0 0 0 vertex 0 1 0 vertex 1 1 0 endloop endfacet facet normal 0 0 0 outer loop vertex 0 0 0 vertex 1 1 0 vertex 1 0 0 endloop endfacet facet normal 0 0 0 outer loop vertex 0 0 0 vertex 0 0 1 vertex 0 1 1 endloop endfacet facet normal 0 0 0 outer loop vertex 0 0 0 vertex 0 1 1 vertex 0 1 0 endloop endfacet facet normal 0 0 0 outer loop vertex 0 0 0 vertex 1 0 0 vertex 1 0 1 endloop endfacet facet normal 0 0 0 outer loop vertex 0 0 0 vertex 1 0 1 vertex 0 0 1 endloop endfacet facet normal 0 0 0 outer loop vertex 0 0 1 vertex 1 0 1 vertex 1 1 1 endloop endfacet facet normal 0 0 0 outer loop vertex 0 0 1 vertex 1 1 1 vertex 0 1 1 endloop endfacet facet normal 0 0 0 outer loop vertex 1 0 0 vertex 1 1 0 vertex 1 1 1 endloop endfacet facet normal 0 0 0 outer loop vertex 1 0 0 vertex 1 1 1 vertex 1 0 1 endloop endfacet facet normal 0 0 0 outer loop vertex 0 1 0 vertex 0 1 1 vertex 1 1 1 endloop endfacet facet normal 0 0 0 outer loop vertex 0 1 0 vertex 1 1 1 vertex 1 1 0 endloop endfacet endsolid cube PDL-2.100/t/image2d.t0000644000175000017500000002121614731223132014021 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL; use PDL::Image2D; use PDL::FFT; use Test::PDL; # compare fft convolutions with direct method { my $pa = rfits("lib/PDL/Demos/m51.fits"); { my $pk = ones(5,5); my $pb = conv2d($pa,$pk); my $kk = kernctr($pa,$pk); fftconvolve( my $pi=$pa->copy, $kk ); is_pdl $kk, $pa->zeroes->double, "kernctr"; is_pdl $pi, $pb, "fftconvolve"; } { my $pk = pdl[ [ 0.51385498, 0.17572021, 0.30862427], [ 0.53451538, 0.94760132, 0.17172241], [ 0.70220947, 0.22640991, 0.49475098], [ 0.12469482, 0.083892822, 0.38961792], [ 0.27722168, 0.36804199, 0.98342896], [ 0.53536987, 0.76565552, 0.64645386], [ 0.76712036, 0.7802124, 0.82293701] ]; my $pb = conv2d($pa,$pk); my $kk = kernctr($pa,$pk); fftconvolve( my $pi=$pa->copy, $kk ); is_pdl $kk, $pa->zeroes->double, "kernctr weird kernel"; is_pdl $pi, $pb, "fftconvolve weird kernel"; } } my $mask = pdl( [[0,0,0,0,0],[0,0,1,1,0],[0,0,0,0,0],[0,0,1,1,0],[0,0,0,0,0]], [[0,0,0,0,0],[0,1,0,1,0],[0,0,1,1,0],[0,0,0,0,0],[0,0,0,0,0]], ); my $crops = pdl(indx, [2,3,1,3], [1,3,1,2], ); is_pdl crop($mask->slice(',,(1)')), $crops->slice(',(1)'), 'mask non-broadcast'; is_pdl crop($mask), $crops, 'mask broadcast'; my $ans = pdl( [ 3, 7, 11, 21, 27, 33, 39, 45, 51, 27], [ 3, 5, 13, 21, 27, 33, 39, 45, 51, 27], [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27] ); my $x = xvals zeroes 10,3; $x->setbadat(2,1); is_pdl conv2d($x, pdl([1,2],[2,1])), $ans, "conv2d()"; $x = pdl '0 0 0 0 0; 0 1 1 1 0; 0 1 BAD 1 0; 0 1 1 1 0; 0 0 0 0 0'; $ans = pdl '0 0 0 0 0; 0 0 2 0 0; 0 1 5 2 0; 0 0 4 0 0; 0 0 0 0 0'; is_pdl med2d($x, sequence(3,3)), $ans, "med2d()"; { my $ans = pdl( [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27], [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27], [ 3, 9, 15, 21, 27, 33, 39, 45, 51, 27] ); is_pdl conv2d(xvals(10,3), pdl([1,2],[2,1])), $ans, "conv2d xvals"; } { my $pb = sequence(3,3); is_pdl conv2d(pdl('0 0 0; 0 1 0; 0 0 0'),$pb), $pb, "conv2d trivial kernel"; } { my $pa = ones(3,3); my $pb = sequence(3,3); is_pdl conv2d($pb,$pa,{Boundary => 'Reflect'}), pdl('12 18 24; 30 36 42; 48 54 60'), "conv2d reflect"; is_pdl conv2d($pb,$pa,{Boundary => 'Replicate'}), pdl('12 18 24; 30 36 42; 48 54 60'), "conv2d replicate"; is_pdl conv2d($pb,$pa,{Boundary => 'Truncate'}), pdl('8 15 12; 21 36 27; 20 33 24'), "conv2d truncate"; } { my $ones = ones(3,3); my $realmask=$ones/9; my $realseq=sequence(3,3); my $imagmask=$realmask*i(); my $imagseq=$realseq*i(); my $imag_exp = $ones*4*i(); is_pdl $realseq->conv2d($realmask), $ones*4, "Real matrix real mask"; is_pdl $imagseq->conv2d($realmask), $imag_exp, "Imag matrix real mask"; is_pdl $realseq->conv2d($imagmask), $imag_exp, "Real matrix imag mask"; is_pdl $imagseq->conv2d($imagmask), cdouble($ones*-4), "Imag matrix imag mask"; } { # max2d_ind my $pa = 100 / (1.0 + rvals(5,5)); $pa = $pa * ( $pa < 90 ); my @ans = $pa->max2d_ind(); is_deeply \@ans, [50,1,2], "max2d_ind" or diag explain \@ans; } { # centroid2d my $pa = 100.0 / rvals( 20, 20, { Centre => [ 8, 12.5 ] } ); $pa = $pa * ( $pa >= 9 ); my @ans = $pa->centroid2d( 10, 10, 20 ); is_pdl $ans[0], pdl(8.432946), "centroid2d (0)"; # numbers calculated by an independent program is_pdl $ans[1], pdl(11.756724), "centroid2d (1)"; } { # med2d my $pa = zeroes(5,5); my $t = $pa->slice("1:3,1:3"); $t .= ones(3,3); my $pb = sequence(3,3); my $ans = pdl ( [0,0,0,0,0],[0,0,1,0,0],[0,1,4,2,0],[0,0,4,0,0],[0,0,0,0,0]); is_pdl med2d($pa,$pb), $ans, "med2d"; { # med2df my $pa = sequence(10,10); is_pdl med2df($pa,3,3,{Boundary=>'Truncate'})->slice("1:-2,1:-2"), $pa->slice("1:-2,1:-2"), "med2df"; } } { # patch2d my $pa = ones(5,5); my $mask = zeroes(5,5); $mask->set(2,2,1); is_pdl patch2d($pa,$mask), $pa, "patch2d 1-element no-op"; # note: # with no bad values, any bad pixel which has no good neighbours # has its value copied # $mask->slice('1:3,1:3') .= 1; my $pans = $pa->copy; note $pa, $mask, patch2d($pa,$mask); is_pdl patch2d($pa,$mask), $pans, "patch2d 2d slice no-op"; $pa = ones(5,5); # patchbad2d: bad data $pa->slice('1:3,1:3') .= $pa->badvalue; $pa->badflag(1); # should sort out propagation of badflag my $ans = ones(5,5); $ans->set(2,2,$ans->badvalue); $ans->badflag(1); is_pdl patchbad2d($pa), $ans, "patchbad2d"; # patchbad2d: good data $pa = sequence(5,5); is_pdl patchbad2d($pa), $pa, "patchbad2d good data"; # max2d_ind $pa = 100 / (1.0 + rvals(5,5)); $pa = $pa->setbadif( $pa > 90 ); my @ans = $pa->max2d_ind(); is_deeply \@ans, [50,1,2], "max2d_ind bad data" or diag explain \@ans; # centroid2d $pa = 100.0 / rvals( 20, 20, { Centre => [ 8, 12.5 ] } ); $pa = $pa->setbadif( $pa < 9 ); @ans = $pa->centroid2d( 10, 10, 20 ); is_pdl $ans[0], pdl(8.432946), "centroid2d bad data (0)"; # numbers should be same as when set < 9 to 0 is_pdl $ans[1], pdl(11.756724), "centroid2d bad data (1)"; } { # box2d bug test my $one = random(10,10); my $box = cat $one,$one,$one; my $bav = $one->box2d(3,3,0); my $boxav = $box->box2d(3,3,0); # all 2D averages should be the same is_pdl $bav->sum->slice('*3'),$boxav->clump(2)->sumover, "box2d"; } { my $pa = pdl([0,1,1,0,1],[1,0,1,0,0],[0,0,0,1,0],[1,0,0,0,0],[0,1,0,1,1]); is(cc8compt($pa)->max, 4, 'cc8compt'); is(cc4compt($pa)->max, 7, 'cc4compt'); dies_ok { ccNcompt($pa,5); } "ccNcompt(5) fails"; lives_ok { ccNcompt($pa,8) } "ccNcompt(8) succeeds"; } { my $im = (xvals(25,25)+yvals(25,25)) % 2; my $seg_b = cc4compt(byte $im); ok($seg_b->type >= long, "cc4compt type>=long"); is_pdl $seg_b, cc4compt($im)->long, "cc4compt results don't wrap for byte type"; } { # pnpoly my $px = pdl(0,3,1); my $py = pdl(0,1,4); my $im2 = (my $im = zeroes(5,5))->copy; my $im_mask = pnpoly($im->xvals,$im->yvals,$px,$py); my $inpixels = indx q[ 1 1 ; 1 2 ; 1 3 ; 2 1 ; 2 2 ]; is_pdl whichND($im_mask)->qsortvec, $inpixels, "pnpoly old style, correct pixels inside"; # Make sure the PDL pnpoly and the PP pnpoly give the same result my $ps = $px->cat($py)->transpose; is_pdl $im_mask, $im->pnpoly($ps)->longlong, "pnpoly old style vs new style"; # Trivial test to make sure the polyfills using the pnpoly algorithm are working $im .= 0; polyfillv($im2,$ps,{'Method'=>'pnpoly'}) .= 22; is_pdl polyfill($im,$ps,22,{'Method'=>'pnpoly'}), $im2, "polyfill using pnpoly algorithm"; # Trivial test to make sure the polyfills are working $im .= 0; $im2 .= 0; polyfillv($im2,$ps) .= 25; polyfill($im,$ps,25); is_pdl $im, $im2, "polyfill using default algorithm"; } ####################### #warp2d and friends {#this just runs the example in the documentation my $x = pdl( 0, 0, 100, 100 ); my $y = pdl( 0, 100, 100, 0 ); # get warped to these positions my $u = pdl( 10, 10, 90, 90 ); my $v = pdl( 10, 90, 90, 10 ); # shift of origin + scale x/y axis only my $fit = byte( [ [1,1], [0,0] ], [ [1,0], [1,0] ] ); my ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2, { FIT => $fit } ); is_pdl $px,pdl([-12.5,1.25],[0,0]),'px fitwarp2d linear restricted'; is_pdl $py,pdl([-12.5,0],[1.25,0]),'py fitwarp2d linear restricted'; # Compared to allowing all 4 terms ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2 ); is_pdl $px, pdl([-12.5,1.25],[0,0]),'px fitwarp2d linear unrestricted'; is_pdl $py, pdl([-12.5,0],[1.25,0]),'py fitwarp2d linear unrestricted'; # A higher-degree polynomial should not affect the answer much, but # will require more control points $x = $x->glue(0,pdl(50,12.5, 37.5, 12.5, 37.5)); $y = $y->glue(0,pdl(50,12.5, 37.5, 37.5, 12.5)); $u = $u->glue(0,pdl(73,20,40,20,40)); $v = $v->glue(0,pdl(29,20,40,40,20)); my ( $px3, $py3 ) = fitwarp2d( $x, $y, $u, $v, 3 ); my ($x3,$y3) = applywarp2d($px3,$py3,$u,$v); is_pdl $x3,$x, {atol=>1e-4, test_name=>'px fitwarp2d quadratic unrestricted'}; is_pdl $y3,$y, {atol=>1e-4, test_name=>'py fitwarp2d quadratic unrestricted'}; #define a simple grid image my $img = (xvals(50,50) % 8 == 5 ) * (yvals(50,50) % 9 == 6); #stretch the y control points out a bit, and offset them too. ($u,$v) = whichND($img)->double->using(0,1); # get the control points my $shift = $img->range([1,1],[$img->dims],'p'); # shift 1 horiz and vert #get the control points of the shifted image ($x,$y) = whichND($shift)->mv(0,-1)->double->dog; # fits of order 1,2,3, with/without restriction to shift-and-scale-only foreach my $deg (2,3,4) { my $fit = zeroes(byte,$deg,$deg,2); $fit->slice(':,(0),(0)') .= byte(1); $fit->slice('(0),:,(1)') .= byte(1); foreach my $unrestrict ('un', '') { my ($pxn,$pyn) = fitwarp2d($x,$y,$u,$v,$deg,$unrestrict?{}:{FIT=>$fit}); my $out = warp2d($shift,$pxn,$pyn); is_pdl $out,$img, {atol=>1e-3, test_name=>"warp2d ${unrestrict}restricted deg $deg values"}; is_pdl $out->rint, $img, "warp2d ${unrestrict}restricted deg $deg rint exact"; } } } done_testing; PDL-2.100/t/ppt-20_simd.t0000644000175000017500000000464614727756302014576 0ustar osboxesosboxesuse strict; use warnings; BEGIN { use Config; if (! $Config{'useithreads'}) { print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); exit(0); } if (defined $Devel::Cover::VERSION) { print("1..0 # Skip: Devel::Cover no like ithreads\n"); exit(0); } } use Test::More; use Test::Warn; #use PDL; use PDL::Parallel::threads::SIMD qw(parallelize parallel_sync parallel_id); my $N_threads = 20; use threads; # Test basic croaking behavior for function calls that should not work warning_is { my $pid = parallel_id; } 'Cannot get parallel_id outside of a parallelized block' , 'parallel_id not allowed outside of parallelize block'; warning_is { parallel_sync; } 'Cannot call parallel_sync outside of a parallelized block' , 'parallel_sync not allowed outside of parallelize block'; # Create five threads that each spawn five threads my @after_first_block : shared; my @after_second_block : shared; my @pids : shared; my @recursive_simd_allowed : shared; my @workspace : shared; parallelize { # Get the pid and log the presence my $pid = parallel_id; $pids[$pid] = 1; $workspace[$pid] = $pid + 1; # First barrier sync: make sure everybody has updated workspace parallel_sync; # Make sure that the previosu pid set the correct value before we reached # this point. my $pid_to_check = $pid - 1; $pid_to_check = $N_threads - 1 if $pid_to_check < 0; $after_first_block[$pid] = 1; $after_first_block[$pid] = 0 if $workspace[$pid_to_check] != $pid_to_check + 1; # Update the workspace value $workspace[$pid_to_check] = -$pid; # Second barrier sync: make sure we could perform the first check and # the assignment parallel_sync; # Make sure that the newly changed value, from the other thread, is # correct here. $pid_to_check = $pid + 1; $pid_to_check = 0 if $pid_to_check == $N_threads; $after_second_block[$pid] = 1; $after_second_block[$pid] = 0 if $workspace[$pid] != -$pid_to_check; # Check recursive parallelized block eval { parallelize { my $a = 1; } 5; $recursive_simd_allowed[$pid] = 1; } or do { $recursive_simd_allowed[$pid] = 0; }; } $N_threads; my @expected = (1) x $N_threads; is_deeply(\@after_first_block, \@expected, 'First barrier synchronization works'); is_deeply(\@after_second_block, \@expected, 'Second barrier synchronization works'); @expected = (0) x $N_threads; is_deeply(\@recursive_simd_allowed, \@expected, 'Recursive paralleliztion not (yet) allowed'); done_testing; PDL-2.100/t/croak.t0000644000175000017500000000353414727756302013632 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More; use Test::Exception; # PDL::Core::set_debugging(1); my $pb = pdl [[1,1,1],[2,2,2]]; { # we are using more dims than are available throws_ok { my $pc = $pb->slice(':,:,:,(1)'); $pc->make_physical(); } qr/too many dims/i; } { # now see if we survive the destruction of this invalid trans my $pb = zeroes(5,3,3); lives_ok { my $pc = $pb->slice(":,:,1") }; } { my $pb = pdl [[1,1,1],[2,2,2]]; lives_ok { my $pc = $pb->dummy(5,1); $pc->make_physical(); }; } { my $pb = zeroes(5,3,3); lives_ok { my $pc = $pb->slice(":,:,1"); }; } # This test case points out a problem in the freeing # of used memory in 1.90_01 lives_ok { my $pa = pdl (1,2); my $pb = pdl [[1,2],[1,2],[1,2]]; my $pc = $pa->slice(',*3'); $pc->make_physical; $pc = $pb->clump(2); $pb->make_physical; $pc->make_physical; }; lives_ok { my $pa = zeroes 4,5; my $pb = $pa->slice('1:3:2,2:4:2'); $pb .= ones(2,2); note $pa; }; # tests for error checking of input args to PP compiled function { my $pb=pdl([1,2,3])->long; my $pa=[1,2,3]; lives_ok { PDL::Ufunc::sumover($pa,$pb) } 'sumover with ndarrays of compatible dimensions does not die'; } { my $paa=3; my $pa=\$paa; throws_ok { PDL::Ufunc::sumover($pa,$paa) } qr/Error - tried to use an unknown/; } { throws_ok { PDL::Ufunc::sumover({}) } qr/Hash given as a pdl \(HASH\) - but not \{PDL} key/; throws_ok { PDL::Ufunc::sumover(bless {}, 'Foo') } qr/Hash given as a pdl \(Foo\) - but not \{PDL} key/; } { my $pc = 0; throws_ok { PDL::Ufunc::sumover(\$pc) } qr/Error - tried to use an unknown/; } # This is something that would cause an exception on 1.91_00: # when the original was undef'd, xchghashes would barf. lives_ok { my $pa = xvals zeroes(5,5); my $pb = $pa->slice(':,2:3'); $pa = 1; # Undefine orig. a $pb += 1; } "no barf when parent of slice undefined"; done_testing; PDL-2.100/t/tp-eq_pdl_clean.t0000644000175000017500000000310214727756302015551 0ustar osboxesosboxesuse strict; use warnings; use Test::More; eval { require Capture::Tiny }; plan skip_all => 'Capture::Tiny not found' if $@; my $expected_stderr = ''; # first capture the output of a program that does *not* call eq_pdl() # this is to work around warnings that might be emitted by other modules (e.g., # File::Map on some platforms complaining about the :all tag) { my $rc; my( $stdout, $stderr ) = Capture::Tiny::capture( sub { my @cmd = ( $^X, '-Ilib', '-MTest::PDL=eq_pdl', '-e1' ); $rc = system @cmd; } ); cmp_ok $rc, '==', 0, 'system() succeeded'; is $stdout, '', 'no output on stdout'; $expected_stderr = $stderr; } # test that eq_pdl() doesn't produce any output so it can safely be used in non-test code { my $rc; my( $stdout, $stderr ) = Capture::Tiny::capture( sub { my @cmd = ( $^X, '-Ilib', '-MTest::PDL=eq_pdl', '-e', 'scalar eq_pdl(3,4)' ); $rc = system @cmd; } ); cmp_ok $rc, '==', 0, 'system() succeeded'; is $stdout, '', 'eq_pdl() does not produce output on stdout'; is $stderr, $expected_stderr, 'eq_pdl() does not produce output on stderr'; } # test that eq_pdl() doesn't produce any output in list context so it can safely be used in non-test code { my $rc; my( $stdout, $stderr ) = Capture::Tiny::capture( sub { my @cmd = ( $^X, '-Ilib', '-MTest::PDL=eq_pdl', '-e', '(eq_pdl(3,4))' ); $rc = system @cmd; } ); cmp_ok $rc, '==', 0, 'system() succeeded'; is $stdout, '', 'eq_pdl() does not produce output on stdout in list context'; is $stderr, $expected_stderr, 'eq_pdl() does not produce output on stderr in list context'; } done_testing; PDL-2.100/t/io-stl-ascblender1.stl0000644000175000017500000000203514727756302016455 0ustar osboxesosboxessolid Apple'sFinder and Blender can read facet normal 0.84410374399741939 -0.34963905512334476 -0.40649895510566048 outer loop vertex 0.0017237013671547174 0.10291291773319244 -0.0015311292372643948 vertex 0.0019548346754163504 0.10463636368513107 -0.0025335513055324554 vertex 0.0024375757202506065 0.10463636368513107 -0.0015311292372643948 endloop endfacet facet normal 0.60368325273783552 -0.25005312352273268 -0.75699403285652889 outer loop vertex 0.0013823517365381122 0.10325426608324051 -0.0025335513055324554 vertex 0.00076726125553250313 0.10386935621500015 -0.0032272490207105875 vertex 0.0010849653044715524 0.10463636368513107 -0.0032272490207105875 endloop endfacet facet normal 0.60368283778508947 -0.25005334258074174 -0.75699429141040397 outer loop vertex 0.0013823517365381122 0.10325426608324051 -0.0025335513055324554 vertex 0.0010849653044715524 0.10463636368513107 -0.0032272490207105875 vertex 0.0019548346754163504 0.10463636368513107 -0.0025335513055324554 endloop endfacet endsolid PDL-2.100/t/inline-with.t0000644000175000017500000000432114727756302014755 0ustar osboxesosboxes# This test checks this works: use Inline with => 'PDL'; # Also that the XS code in PDL::API works. use strict; use warnings; use Test::More; use PDL::LiteF; my $inline_test_dir; # First some Inline administrivia. BEGIN { # Test for Inline and set options $inline_test_dir = './.inlinewith'; mkdir $inline_test_dir unless -d $inline_test_dir; # See if Inline loads without trouble, or bail out eval { require Inline; require Inline::C; require Parse::RecDescent; # As of 2024, GHA is caching locallib without this but only on 5.10. Inline::C is broken without it Inline->import (Config => DIRECTORY => $inline_test_dir , FORCE_BUILD => 1); # Inline->import ('NOCLEAN'); 1; } or do { plan skip_all => "Skipped: Inline or Inline::C not installed"; }; if( $Inline::VERSION < 0.83 ) { plan skip_all => "Skipped: Inline has ILSM-finding bug"; } } use File::Path; END { if ($^O =~ /MSWin32/i) { for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) { if ($DynaLoader::dl_modules[$i] =~ /inline_with_t/) { DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]); } } } } SKIP: { #use Inline 'INFO'; # use to generate lots of info use_ok 'Inline', with => 'PDL' or skip 'with PDL failed', 3; eval { Inline->bind(C => <<'EOF') }; static pdl* new_pdl(int datatype, PDL_Indx dims[], int ndims) { pdl *p = PDL->pdlnew(); if (!p) return p; pdl_error err = PDL->setdims(p, dims, ndims); /* set dims */ if (err.error) { PDL->destroy(p); return NULL; } p->datatype = datatype; /* and data type */ err = PDL->allocdata(p); /* allocate the data chunk */ if (err.error) { PDL->destroy(p); return NULL; } return p; } pdl* myfloatseq() { PDL_Indx dims[] = {5,5,5}; pdl *p = new_pdl(PDL_F,dims,3); if (!p) return p; PDL_Float *dataf = (PDL_Float *) p->data; PDL_Indx i; /* dimensions might be 64bits */ for (i=0;i<5*5*5;i++) dataf[i] = i; /* the data must be initialized ! */ return p; } EOF is $@, '', 'bind no error' or skip 'Inline C failed', 2; note "Inline Version: $Inline::VERSION\n"; ok 1, 'compiled'; my $pdl = myfloatseq(); note $pdl->info,"\n"; is $pdl->dims, 3, 'dims correct'; } done_testing; PDL-2.100/t/niceslice-utilcall.t0000644000175000017500000000062014727756302016271 0ustar osboxesosboxesuse strict; use warnings; # Run niceslice.t with Filter::Util::Call engine BEGIN { $ENV{PDL_NICESLICE_ENGINE} = 'Filter::Util::Call'; $::UC = $::UC = 1; } use FindBin; open my $fh, "$FindBin::Bin/niceslice.t" or die "Cannot read $FindBin::Bin/niceslice.t: $!"; my $source = do { local $/; <$fh> }; close $fh; eval "#line 1 t/niceslice.t-run_by_niceslice-utilcall.t\n$source"; die $@ if $@; PDL-2.100/t/io-stl-cube_binary.stl0000644000175000017500000000125414727756302016556 0ustar osboxesosboxescube ??????????????????????????????????????????????????????PDL-2.100/t/primitive-append.t0000644000175000017500000000200514727756302016000 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; is_deeply( append( zeroes( 2, 0 ), zeroes( 3, 0 ) )->shape->unpdl, [ 5, 0 ], 'multi-dim empty shape' ); is_deeply( append( pdl( 1, 2, 3, 4 ), 2 )->unpdl, [ 1, 2, 3, 4, 2 ], '[4], [1]' ); subtest '$output = append (null,null) ' => sub { my $output = append( null, null ); ok !$output->isnull, 'returns non-null'; ok $output->isempty, 'returns empty'; }; subtest 'append(null, null, $output)' => sub { my $output = zeroes(1); append( null, null, $output ); is_deeply( $output->unpdl, [0], q{user's ndarray is unchanged} ); }; subtest types => sub { is( append( zeroes( float, 2, 0 ), zeroes( 3, 0 ) )->type, 'float', 'float + double = float' ); my $b1 = indx( 1, 2 ); is $b1->type, 'indx', '$indx_pdl is an indx pdl'; $b1 = $b1->append(-1); is $b1->type, 'indx', 'append($indx_pdl, -1) returns an indx pdl'; is $b1. '', '[1 2 -1]', 'append($indx_pdl, -1) correct content'; }; done_testing; PDL-2.100/t/tp-is_pdl.t0000644000175000017500000001633714727756302014433 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Builder::Tester; use Test::Exception; use PDL; use Test::PDL; my @warns; $SIG{__WARN__} = sub {push @warns, @_}; my ( $got, $expected ); my $values_not_match = '/#\s+\d+\/\d+\s+values do not match\n(.|\n)*/'; $expected = 3; $got = long( 3,4 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( '/#\s+expected value is not an ndarray\n(.|\n)*/' ); is_pdl( $got, $expected ); test_test( 'rejects non-ndarray arguments' ); $expected = short( 1,2 ); $got = -2; test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( '/#\s+received value is not an ndarray\n(.|\n)*/' ); is_pdl( $got, $expected ); test_test( 'rejects non-ndarray arguments' ); $expected = long( 3,4 ); $got = pdl( 3,4 ); test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected, { require_equal_types => 0 } ); test_test( 'all else being equal, compares equal on differing types when \'require_equal_types\' is false' ); $expected = long( 3,4 ); $got = pdl( 3,4 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( '/#\s+types do not match \([\']require_equal_types[\'] is true\)\n(.|\n)*/' ); is_pdl( $got, $expected, { require_equal_types => 1 } ); test_test( 'catches type mismatch, but only when \'require_equal_types\' is true' ); $expected = long( 3 ); $got = long( 3,4 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( '/#\s+dimensions do not match in number\n(.|\n)*/' ); is_pdl( $got, $expected ); test_test( 'catches dimensions mismatches (number of dimensions)' ); $expected = zeroes( double, 3,4 ); $got = zeroes( double, 3,4,1 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( '/#\s+dimensions do not match in number\n(.|\n)*/' ); is_pdl( $got, $expected ); test_test( 'does not treat degenerate dimensions specially' ); $expected = long( [ [3,4],[1,2] ] ); $got = long( [ [3,4,5], [1,2,3] ] ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( '/#\s+dimensions do not match in extent\n(.|\n)*/' ); is_pdl( $got, $expected ); test_test( 'catches dimensions mismatches (extent of dimensions)' ); $expected = long( 4,5,6,-1,8,9 )->inplace->setvaltobad( -1 ); $got = long( 4,5,6,7,-1,9 )->inplace->setvaltobad( -1 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( $values_not_match ); is_pdl( $got, $expected ); test_test( 'catches bad value pattern mismatch' ); $expected = long( 4,5,6,7,8,9 ); $got = long( 4,5,6,7,-8,9 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( $values_not_match ); is_pdl( $got, $expected ); test_test( 'catches value mismatches for integer data' ); $expected = pdl( 4,5,6,7,8,9 ); $got = pdl( 4,5,6,7,-8,9 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( $values_not_match ); is_pdl( $got, $expected ); test_test( 'catches value mismatches for floating-point data' ); $expected = pdl( 4,5,6,7,8,9 ); $got = pdl( 4,5,6,7,8.001,9 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( $values_not_match ); is_pdl( $got, $expected ); test_test( 'approximate comparison for floating-point data fails correctly at documented default tolerance of 1e-6' ); $expected = pdl( 4,5,6,7,8,9 ); $got = pdl( 4,5,6,7,8.0000001,9 ); test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected ); test_test( 'approximate comparison for floating-point data succeeds correctly at documented default tolerance of 1e-6' ); $expected = pdl( 4,5,6,7,8,9 ); $got = pdl( 4,5,6,7,8.001,9 ); test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected, { atol => 1e-2 } ); test_test( 'approximate comparison for floating-point data succeeds correctly at user-specified tolerance of 1e-2' ); $expected = pdl( 0,1,2,3,4 ); $got = sequence 5; test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected ); test_test( 'succeeds when it should succeed' ); $expected = null; $got = null; test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected ); test_test( 'null == null' ); $expected = null; $got = pdl( 1,2,3 ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +4 ); test_err( '/#\s+dimensions do not match in extent/' ); test_err( '/#\s+got:.*/' ); test_err( '/#\s+expected:\s+Null/' ); is_pdl( $got, $expected, { require_equal_types => 0 } ); test_test( 'pdl( ... ) != null' ); $expected = pdl( 1,2,3 ); $got = null; test_out( "not ok 1 - ndarrays are equal" ); test_fail( +4 ); test_err( '/#\s+dimensions do not match in extent/' ); test_err( '/#\s+got:\s+Null/' ); test_err( '/#\s+expected:.*/' ); is_pdl( $got, $expected, { require_equal_types => 0 } ); test_test( 'null != pdl( ... )' ); note 'mixed-type comparisons'; $expected = double( 0,1,2.001,3,4 ); $got = long( 0,1,2,3,4 ); test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected, { atol => 1e-2, require_equal_types => 0 } ); test_test( 'succeeds correctly for long/double' ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( $values_not_match ); is_pdl( $got, $expected, { atol => 1e-6, require_equal_types => 0 } ); test_test( 'fails correctly for long/double' ); $expected = short( 0,1,2,3,4 ); $got = float( 0,1,2.001,3,4 ); test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected, { atol => 1e-2, require_equal_types => 0 } ); test_test( 'succeeds correctly for float/short' ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( $values_not_match ); is_pdl( $got, $expected, { atol => 1e-6, require_equal_types => 0 } ); test_test( 'fails correctly for float/short' ); $expected = float( 0,-1,2.001,3,49999.998 ); $got = double( 0,-0.9999,1.999,3,49999.999 ); test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected, { atol => 1e-2, require_equal_types => 0 } ); test_test( 'succeeds correctly for double/float' ); test_out( "not ok 1 - ndarrays are equal" ); test_fail( +2 ); test_err( $values_not_match ); is_pdl( $got, $expected, { atol => 1e-6, require_equal_types => 0 } ); test_test( 'fails correctly for double/float' ); note 'miscellaneous'; $expected = pdl( 0,1,2,3,4 ); $got = sequence 5; test_out( "ok 1 - insert custom test name" ); is_pdl( $got, $expected, 'insert custom test name' ); test_test( 'custom test name is displayed correctly' ); test_out( "ok 1 - insert custom test name" ); is_pdl( $got, $expected, { test_name => 'insert custom test name' } ); test_test( 'custom test name is also displayed correctly when supplied as an option hash' ); # Although the next test may appear strange, the case it tests can be produced # by the following test: # is_pdl hist( pdl(2,3,4,5) ), pdl(1,1,1,1); # Since hist() returns two ndarrays in list context, the expected ndarray ends up # as the third argument. Since this is probably not what the user intended, an # error is raised. throws_ok { is_pdl( $got, $expected, pdl(1,1,1,1) ) } qr/^error in arguments: third argument is an ndarray at /, 'third argument is an ndarray'; throws_ok { is_pdl( $got, $expected, 1e-4, "label" ) } qr/^error in arguments: > 3 given/, '>3 argument given'; $expected = long( 4,5,6,7,8,9 ); $expected->badflag( 1 ); $got = long( 4,5,6,7,8,9 ); $got->badflag( 0 ); test_out( "ok 1 - ndarrays are equal" ); is_pdl( $got, $expected ); test_test( "isn't fooled by differing badflags" ); is "@warns", "", "no warnings"; done_testing; PDL-2.100/t/scope.t0000644000175000017500000000274114727756302013643 0ustar osboxesosboxes# Test if we can still do scopes ok - multiple uses etc.. # Also see that PDL loaders get the correct symbols. use strict; use warnings; use Test::More; { package A; our $pa; # note "A: ",%A::,"\n"; use PDL; $pa = zeroes 5,5; # note "A: %A::\n"; # note "AC: ",(bless {},A)->can("zeroes"),"\n"; } ok((bless {},'A')->can("zeroes")); { package B; use PDL; } #note "B: ",%B::,"\n"; #note "B: ",%B::,"\n"; # $pb = zeroes 5,5; # note "BC: ",(bless {},B)->can("zeroes"),"\n"; ok((bless {},'B')->can("zeroes")); { package C; use PDL::Lite; } ok(!((bless {},'C')->can("zeroes"))); { package D; use PDL::Lite; } ok(!((bless {},'D')->can("zeroes"))); { package E; use PDL::LiteF; } ok((bless {},'E')->can("zeroes")); { package F; use PDL::LiteF; } ok((bless {},'F')->can("zeroes")); ok(!((bless {},'C')->can("imag"))); ok(!((bless {},'D')->can("imag"))); ok(!((bless {},'E')->can("imag"))); ok(!((bless {},'F')->can("imag"))); # Can PDL::Lite be loaded twice? # The first import was interfering with the second. { package mk1; use PDL::Lite; sub x { return PDL->pdl (1..10); } } { package mk2; use PDL::Lite; sub x { return PDL->pdl (11..20); } } foreach my $name (qw /x barf pdl piddle null/) { ok (mk1->can($name), "Sub loaded: mk1::" . $name); ok (mk2->can($name), "Sub loaded: mk2::" . $name); } # now try calling one of those functions eval { my $x = mk1::pdl(0, 1) }; is $@, '', 'the imported pdl function ACTUALLY WORKS'; done_testing; PDL-2.100/t/io-misc.t0000644000175000017500000001346514732354473014076 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use PDL::IO::Misc; use File::Temp qw( tempfile tempdir ); use Test::More; use Test::PDL; my $tempd = tempdir( CLEANUP => 1 ) or die "Couldn't get tempdir\n"; my ($fileh,$file) = tempfile( DIR => $tempd ); for my $type (PDL::Types::types()) { ok $type->bswap, "$type has bswap"; } ############# Test rcols with colsep and missing fields ################### print $fileh <',' }; }; is_pdl $x, pdl('1 2 3 4 5; 6 7 8 -1 10; 11 -1 13 14 15'), "rcols with undefval and missing cols"; unlink($file) || warn "Could not unlink $file: $!"; ############# Test rcols with filename and pattern ############# ($fileh,$file) = tempfile( DIR => $tempd ); print $fileh <; # Now apply rcols: $x = eval { rcols $fh }; is $@, '', 'rcols does not die on a used file handle'; close $fh; ############### Test rgrep with FILEHANDLE ##################### ($fileh,$file) = tempfile( DIR => $tempd ); print $fileh <type->bswap->($x); is_pdl $x, short(768), "bswap Type method"; eval {$x->bswap8}; like $@, qr/Tried to/, 'bswap of greater than ndarray type-size gives error'; ############# Test rasc ############# ($fileh,$file) = tempfile( DIR => $tempd ); print $fileh <null; $x->rasc($file,20); is_pdl $x, pdl('0.231862613 0.20324005 0.067813045 0.040103501 0.438047631 0.283293628 0.375427346 0.195821617 0.189897617 0.035941205 0.339051483 0.096540854 0.25047197 0.579782013 0.236164184 0.221568561 0.009776015 0.290377604 0.785569601 0.260724391'), "rasc on null ndarray"; $y = zeroes(float,20,2); $y->rasc($file); is_pdl $y, float('0.231862613 0.20324005 0.067813045 0.040103501 0.438047631 0.283293628 0.375427346 0.195821617 0.189897617 0.035941205 0.339051483 0.096540854 0.25047197 0.579782013 0.236164184 0.221568561 0.009776015 0.290377604 0.785569601 0.260724391; 0 0 0 0 0 0 0 0 0 0'), "rasc on existing ndarray"; eval { $y->rasc("file_that_does_not_exist") }; like $@, qr/Can't open/, "rasc on non-existant file"; unlink($file) || warn "Could not unlink $file: $!"; # clean up ####################################################### # Tests of rcols() options # EXCLUDE/INCLUDE/LINES/DEFTYPE/TYPES ($fileh,$file) = tempfile( DIR => $tempd ); print $fileh < '/^-/' }; is_pdl $x, pdl([-5]), "rcols: include pattern"; is_pdl $y, pdl([6]), "rcols: include pattern"; ($x,$y) = rcols $file,0,1, { LINES => '-2:0' }; is_pdl $x, pdl(-5,3,1), "rcols: lines option"; is_pdl $y, pdl(6,4,2), "rcols: lines option"; use PDL::Types; ($x,$y) = rcols $file, { DEFTYPE => long }; is_pdl $x, long(1,3,-5,7), "rcols: deftype option"; is_pdl $y, long(2,4,6,8), "rcols: deftype option"; ($x,$y) = rcols $file, { TYPES => [ ushort ] }; is_pdl $x, ushort(1,3,-5,7), "rcols: types option"; is_pdl $y, double(2,4,6,8), "rcols: types option"; # capturing problem in PDL::CCS my $ix = PDL->rcols($file, [0,1], { TYPES => [ indx ], IGNORE => qr/^\s*#/ }); is_pdl $ix, indx('1 3 -5 7; 2 4 6 8'), "rcols: types option"; isa_ok $PDL::IO::Misc::deftype, "PDL::Type", "PDL::IO::Misc::deftype"; is $PDL::IO::Misc::deftype, 'double', "PDL::IO::Misc::deftype check"; $PDL::IO::Misc::deftype = short; ($x,$y) = rcols $file; is( $x->get_datatype, short->enum, "rcols: can read in as 'short'" ); unlink($file) or warn "Could not unlink $file: $!"; ($fileh,$file) = tempfile( DIR => $tempd ); eval { wcols $x, $y, $fileh }; is $@, '', "wcols"; unlink($file) or warn "Could not unlink $file: $!"; ($fileh,$file) = tempfile( DIR => $tempd ); eval { wcols $x, $y, $fileh, {FORMAT=>"%0.3d %0.3d"}}; is $@, '', "wcols FORMAT option"; unlink($file) or warn "Could not unlink $file: $!"; ($fileh,$file) = tempfile( DIR => $tempd ); eval { wcols "%d %d", $x, $y, $fileh;}; is $@, '', "wcols format_string"; unlink($file) or warn "Could not unlink $file: $!"; ($fileh,$file) = tempfile( DIR => $tempd ); eval { wcols "arg %d %d", $x, $y, $fileh, {FORMAT=>"option %d %d"};}; is $@, '', "wcols format_string override"; open $fileh,"<",$file or warn "Can't open $file: $!"; readline *$fileh; # dump first line like readline($fileh), qr/^arg/, "wcols format_string obeyed"; unlink($file) or warn "Could not unlink $file: $!"; done_testing; __DATA__ 1 2 # comment line 3 4 -5 6 7 8 PDL-2.100/t/ufunc.t0000644000175000017500000002704414771135562013653 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Types; use Test::PDL; my $p = pdl([]); $p->setdims([1,0]); $p->qsortvec; # shouldn't segfault! my $p2d = pdl([[1,2],[3,4],[1,3],[1,2],[3,3]]); is $p2d->dice_axis(1,$p2d->qsortveci).'', $p2d->qsortvec.'', "qsortveci"; my $ind_double = zeroes($p2d->dim(1)); $p2d->qsortveci($ind_double); # shouldn't segfault! is $ind_double.'', '[3 0 2 4 1]'; eval { empty()->medover }; # shouldn't segfault isnt $@, '', 'exception for percentile on empty ndarray'; eval { sequence(3, 3)->medover(my $o = null, my $t = null); }; isnt $@, '', 'a [t] Par cannot be passed'; my $med_dim = 5; is_pdl sequence(10,$med_dim,$med_dim)->medover, sequence($med_dim,$med_dim)*10+4.5, 'medover'; my $x = pdl(0,0,6,3,5,0,7,14,94,5,5,8,7,7,1,6,7,13,10,2,101,19,7,7,5); # sf.net bug #2019651 # Test a range of values is_pdl $x->pctover(-0.5), pdl(0), "pct below 0 for 25-elem pdl"; is_pdl $x->pctover( 0.0), pdl(0), "pct equal 0 for 25-elem pdl"; is_pdl $x->pctover( 0.9), pdl(17), "pct equal 0.9 for 25-elem pdl [SF bug 2019651]"; is_pdl $x->pctover( 1.0), pdl(101), "pct equal 1 for 25-elem pdl"; is_pdl $x->pctover( 2.0), pdl(101), "pct above 1 for 25-elem pdl"; is_pdl sequence(10)->pctover(0.2 ), pdl(1.8), "20th percentile of 10-elem ndarray [SF bug 2753869]"; is_pdl sequence(10)->pctover(0.23), pdl(2.07), "23rd percentile of 10-elem ndarray [SF bug 2753869]"; ok( ( eval { pdl([])->qsorti }, $@ eq '' ), "qsorti coredump,[SF bug 2110074]"); for ( [ pdl(0,0,6,3,5,0,7,14,94,5,5,8,7,7,1,6,7,13,10,2,101,19,7,7,5), pdl('0 0 0 1 2 3 5 5 5 5 6 6 7 7 7 7 7 7 8 10 13 14 19 94 101'), ], # sf.net bug #2019651 [ pdl([55]), pdl([55]) ], [ pdl(55,55), pdl(55,55) ], [ sequence(10)->rotate(1), sequence(10) ], [ pdl('0 1 2 BAD 4 5 6 7 8 9'), pdl('0 1 2 4 5 6 7 8 9 BAD') ], [ pdl('0 BAD 4'), pdl('0 4 BAD') ], [ pdl('BAD 4'), pdl('4 BAD') ], [ pdl('[BAD]'), pdl('[BAD]') ], [ pdl("0 -100 BAD 100"), pdl('-100 0 100 BAD') ], # test qsort moves values with BAD components to end [ pdl('1 2;0 500;2 3;4 2;3 4;3 5'), pdl('0 500;1 2;2 3;3 4;3 5;4 2') ], [ pdl('1 2;0 500;2 3;4 BAD;3 4;3 5'), pdl('0 500;1 2;2 3;3 4;3 5;4 BAD') ], [ pdl("0 0;-100 0;BAD 0;100 0"), pdl('-100 0; 0 0; 100 0; BAD 0') ], # test qsortvec moves vectors with BAD components to end - GH#252 ) { my ($in, $exp) = @$_; my $meth = $in->ndims > 1 ? 'qsortvec' : 'qsort'; # assume broadcast works is_pdl $in->copy->$meth, $exp, "non-inplace qsort $in"; my $in_copy = $in->copy; $in_copy->inplace->$meth; is_pdl $in_copy, $exp, "inplace qsort $in"; $meth .= "i"; my $inds = $in->$meth; is_pdl $in->dice_axis(-1, $inds), $exp, "$in $meth"; } # Test sf.net bug 379 "Passing qsort an extra argument causes a segfault" # (also qsorti, qsortvec, qsortveci) eval { random(15)->qsort(5); }; isnt($@, '', "qsort extra argument"); eval { random(15)->qsorti(5); }; isnt($@, '', "qsorti extra argument"); eval {random(10,4)->qsortvec(5); }; isnt($@, '', "qsortvec extra argument"); eval {random(10,4)->qsortveci(2); }; isnt($@, '', "qsortveci extra argument"); #but the dimension size checks for those cases shouldn't derail trivial qsorts: is_pdl pdl(5)->qsort, pdl([5]),'trivial qsort'; is_pdl pdl(8)->qsorti, indx([0]),'trivial qsorti'; is_pdl pdl(42,41)->qsortvec, pdl(42,41)->dummy(1),'trivial qsortvec'; is_pdl pdl(53,35)->qsortveci,indx([0]),'trivial qsortveci'; # test for sf.net bug report 3234141 "max() fails on nan" # NaN values are handled inconsistently by min, minimum, max, maximum... # { my $nan = nan(); my $x = pdl($nan, 0, 1, 2); my $y = pdl(0, 1, 2, $nan); is "".$x->min, '0', 'min leading nan'; is "".$y->min, '0', 'min trailing nan'; is "".$x->max, '2', 'max leading nan'; is "".$y->max, '2', 'max trailing nan'; is join(" ", $x->minmax), '0 2', 'minmax leading nan'; is join(" ", $y->minmax), '0 2', 'minmax trailing nan'; } my $empty = empty(); is_pdl $empty->maximum, sbyte('BAD'), "max of empty nonbad float gives BAD"; # test bad value handling with max $empty->badflag(1); is_pdl $empty->maximum, sbyte('BAD'), "bad flag gets set on max over an empty dim"; is_pdl $empty->magnover, float('BAD'), "bad flag gets set on empty magnover"; is_pdl zeroes(4)->magnover, pdl(0), 'magnover correct for real zeroes'; is_pdl sequence(4)->magnover, pdl(3.741657), 'magnover correct for real sequence'; is_pdl +(sequence(4)+i())->magnover, cdouble(4.242640), 'magnover correct for complex'; #Test subroutines directly. #set up ndarrays my $f=pdl(1,2,3,4,5); my $g=pdl (0,1); my $h=pdl(1, 0,-1); my $i=pdl (1,0); my $j=pdl(-3, 3, -5, 10); #Test percentile routines is_pdl $f->pct(.5), pdl(3), 'PDL::pct 50th percentile'; is_pdl $g->pct(.76), pdl(0.76), 'PDL::pct interpolation test'; is_pdl $i->pct(.76), pdl(0.76), 'PDL::pct interpolation not in order test'; is_pdl $f->oddpct(.5), pdl(3), 'PDL::oddpct 50th percentile'; is_pdl $f->oddpct(.79), pdl(4), 'PDL::oddpct intermediate value test'; is_pdl $h->oddpct(.5), pdl(0), 'PDL::oddpct 3-member 50th percentile with negative value'; is_pdl $j->oddpct(.1), pdl(-5), 'PDL::oddpct negative values in-between test'; #Test oddmedian is_pdl $g->oddmedian, pdl(0), 'Oddmedian 2-value ndarray test'; is_pdl $h->oddmedian, pdl(0), 'Oddmedian 3-value not in order test'; is_pdl $j->oddmedian, pdl(-3), 'Oddmedian negative values even cardinality'; #Test mode and modeover $x = pdl([1,2,3,3,4,3,2],1); is_pdl $x->mode, longlong(0), "mode"; is_pdl $x->modeover, longlong(3,0), "modeover"; #the next 4 tests address GitHub issue #248. # .... 0000 1010 # .... 1111 1100 #OR:.... 1111 1110 = -2 is longlong([10,0,-4])->borover(), -2, "borover with no BAD values"; # .... 1111 1111 # .... 1111 1010 # .... 1111 1100 #AND: .... 1111 1000 = -8 is( longlong([-6,~0,-4])->bandover(), -8, "bandover with no BAD values"); # 0000 1010 # 1111 1100 #OR:1111 1110 = 254 if the accumulator in BadCode is an unsigned char is( pdl([10,0,-4])->setvaltobad(0)->borover(), -2, "borover with BAD values"); # 1111 1010 # 1111 1100 #AND: 1111 1000 = 248 if the accumulator in BadCode is an unsigned char is( pdl([-6,~0,-4])->setvaltobad(~0)->bandover(), -8, "bandover with BAD values"); # 0000 0110 # 1111 1110 #XOR: 1111 1000 = -8 is( longlong([6, 0, -2])->bxorover(), -8, "bxorover with no BAD values"); is( longlong([6, 0, -2])->setvaltobad(0)->bxorover(), -8, "bxorover with BAD values"); is( longlong([6, 0, -2])->bxor(), -8, "bxor"); is( longlong([-1, 0, 2])->xorover(), 0, "xorover with no BAD values"); is( longlong([-1, 0, 2])->setvaltobad(0)->xorover(), 0, "xorover with BAD values"); is( longlong([-1, 0, 2])->xorall(), 0, "xorall"); { # all calls to functions that handle finding minimum and maximum should return # the same values (i.e., BAD). NOTE: The problem is that perl scalar values # have no 'BAD' values while pdls do. We need to sort out and document the # differences between routines that return perl scalars and those that return # pdls. my $bad_0dim = pdl(q|BAD|); is( "". $bad_0dim->min, 'BAD', "does min returns 'BAD'" ); isnt( "". ($bad_0dim->minmax)[0], "". $bad_0dim->min, "does minmax return same as min" ); is( "". ($bad_0dim->minmaximum)[0], "". $bad_0dim->min, "does minmaximum return same as min" ); } is ushort(65535)->max, 65535, 'max(highest ushort value) should not be BAD'; { is_pdl empty(indx)->long->avg, long(0), "avg of long Empty"; is_pdl empty(indx)->double->average, nan(), "average double Empty"; } # provide independent copies of test data. sub X { PDL->pdl( [ [ 5, 4, 3 ], [ 2, 3, 1.5 ] ] ) } is_pdl X->average(), PDL->pdl( [ 4, 2.1666666 ] ), "average"; is_pdl X->sumover(), PDL->pdl( [ 12, 6.5 ] ), "sumover"; is_pdl X->prodover(), PDL->pdl( [ 60, 9 ] ), "prodover"; # provide independent copies of test data. sub IM { PDL->new( [ [ 1, 2, 3, 3, 5 ], [ 2, 3, 4, 5, 6 ], [ 13, 13, 13, 13, 13 ], [ 1, 3, 1, 3, 1 ], [ 10, 10, 2, 2, 2, ] ] ); } subtest 'minmax' => sub { my @minMax = IM->minmax; is $minMax[0], 1, "minmax min"; is $minMax[1], 13, "minmax max"; }; is_pdl ones(byte, 3000)->dsumover, pdl(3000); subtest 'minimum_n_ind' => sub { subtest 'usage' => sub { my $p = pdl [ 1, 2, 3, 4, 7, 9, 1, 1, 6, 2, 5 ]; my $q = zeroes 5; minimum_n_ind $p, $q; is_pdl $q, pdl(indx, 0, 6, 7, 1, 9), "usage 1"; $q = minimum_n_ind( $p, 5 ); is_pdl $q, pdl(indx, 0, 6, 7, 1, 9), "usage 2"; minimum_n_ind( $p, $q = null, 5 ); is_pdl $q, pdl(indx, 0, 6, 7, 1, 9), "usage 3"; }; subtest 'BAD' => sub { my $p = pdl '[1 BAD 3 4 7 9 1 1 6 2 5]'; my $q = zeroes 5; minimum_n_ind $p, $q; is $q. '', '[0 6 7 9 2]', "BAD"; }; subtest 'insufficient good' => sub { my $p = pdl '[1 BAD 3 4 BAD BAD]'; my $q = zeroes 5; minimum_n_ind $p, $q; is $q. '', '[0 2 3 BAD BAD]', "insufficient good"; }; subtest 'bad & good' => sub { my $p = pdl '[1 BAD 3 4 BAD BAD 3 1 5 8 9]'; my $q = zeroes 5; minimum_n_ind $p, $q; is $q. '', '[0 7 2 6 3]', "some bad, sufficient good"; } }; subtest partial => sub { my $a = (sequence(4,4) + 2) ** 2; is_pdl $a->partial(0), pdl('-8 6 8 -6; -16 14 16 -14; -24 22 24 -22; -32 30 32 -30'), "partial(0)"; is_pdl $a->partial(0,{d=>'f'}), pdl('4 5 7 9; 36 13 15 17; 100 21 23 25; 196 29 31 33'), "partial(0,f)"; is_pdl $a->partial(1), pdl('-80 -88 -96 -104; 48 56 64 72; 80 88 96 104; -48 -56 -64 -72'), "partial(1)"; is_pdl $a->partial(1,{d=>'f'}), pdl('4 9 16 25; 32 40 48 56; 64 72 80 88; 96 104 112 120'), "partial(1,f)"; }; subtest numdiff => sub { my $a = sequence(5) + 2; is_pdl $a->numdiff, pdl(2, 1, 1, 1, 1), "numdiff"; $a->inplace->numdiff; is_pdl $a, pdl(2, 1, 1, 1, 1), "numdiff inplace"; }; subtest diffcentred => sub { my $a = sequence(6) + 2; is_pdl $a->diffcentred, pdl(-2, 1, 1, 1, 1, -2), "diffcentred"; is_pdl +($a**2)->diffcentred, pdl('-20 6 8 10 12 -16'), "diffcentred of x^2"; $a->setbadat(2); is_pdl +($a**2)->diffcentred, pdl('-20 BAD 8 BAD 12 -16'), "diffcentred of x^2 with bad"; }; subtest diff2 => sub { my $got = pdl('[BAD 2 3 4]')->diff2; is "$got", "[2 1 1]", 'first bad'; $got = pdl('[BAD BAD 3 4]')->diff2; is "$got", "[BAD 3 1]", 'first 2 bad'; $got = pdl('[2 BAD 3 4]')->diff2; is "$got", "[BAD 1 1]", 'second bad'; $got = pdl('[2 3 BAD 4]')->diff2; is "$got", "[1 BAD 1]", 'third bad'; $got = pdl('[2 BAD BAD 4]')->diff2; is "$got", "[BAD BAD 2]", 'middle 2 bad'; $got = pdl('[2 3 4 BAD]')->diff2; is "$got", "[1 1 BAD]", 'last bad'; $got = pdl('[BAD BAD 4]')->diff2; is "$got", "[BAD 4]", 'only 1 good'; $got = pdl('[BAD BAD]')->diff2; is "$got", "[BAD]", 'none good'; eval {empty()->diff2}; like $@, qr/diff2/, 'empty gives good error'; $got = pdl(1)->diff2; is "$got", "Empty[0]", 'single-element gives empty'; }; subtest intover => sub { for ([1,0], [2,0.5], [3,2], [4,4.5], [5,8], [6,12.5], [7,18]) { my ($size, $exp) = @$_; is_pdl sequence($size)->intover, pdl($exp), "intover $size"; } }; subtest firstnonzeroover => sub { my $a = pdl '0 0 3 4; 0 5 0 1'; is_pdl $a->firstnonzeroover, pdl(3, 5), "firstnonzeroover"; }; # Some (!) of these fail when exported: subtest core_functions => sub { ok approx(sin(1), &CORE::sin(1)), 'sin 1'; # ! ok approx(cos(1), &CORE::cos(1)), 'cos 1'; # ! ok approx(sqrt(2), &CORE::sqrt(2)), 'sqrt 2'; # ! ok approx(exp(1), &CORE::exp(1)), 'exp 1'; ok approx(log(2), &CORE::log(2)), 'log 2'; ok approx(atan2(1, 1), &CORE::atan2(1, 1)), 'atan2 1, 1'; }; done_testing; PDL-2.100/t/basic.t0000644000175000017500000001012414747224245013603 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::PDL; my $x0 = pdl( [ 2, 1, 2 ], [ 1, 0, 1 ], [ 2, 1, 2 ] ); is_pdl rvals(3,3), $x0->sqrt, "centered rvals"; is_pdl rvals(3,3,{squared=>1}), $x0, "centered rvals squared"; my $x1 = pdl( [ 8, 5, 4 ], [ 5, 2, 1 ], [ 4, 1, 0 ] ); is_pdl rvals(3,3,{centre=>[2,2]}), $x1->sqrt, "non-centered rvals"; is_pdl rvals(3,3,{center=>[2,2]}), $x1->sqrt, "centre/center synonyms"; is_pdl rvals(3,3,{ceNteR=>[2,2]}), $x1->sqrt, "ceNteR option capitalization"; is_pdl rvals(3,3,{center=>[2,2],squared=>1}), $x1, "both center and squared options"; is_pdl rvals(3,3,{center=>pdl(2,2)}), $x1->sqrt, "rvals with center as ndarray"; is_pdl ndcoords(2,2), pdl('[0 0; 1 0] [0 1; 1 1]'); is_pdl PDL::Basic::ndcoords(2,2), pdl('[0 0; 1 0] [0 1; 1 1]'); # test (x|y|z)(lin|log)vals: shape and values { my $a1=zeroes(101,51,26); my $x = $a1->xlinvals(0.5,1.5); my $y = $a1->ylinvals(-2,-1); my $z = $a1->zlinvals(-3,2); is_pdl $x->shape, $a1->shape, "xlinvals shape"; is_pdl $y->shape, $a1->shape, "ylinvals shape"; is_pdl $z->shape, $a1->shape, "zlinvals shape"; is_pdl $x->uniqvec->flat, pdl(50..150)/100, "xlinvals values"; is_pdl $y->mv(1,0)->uniqvec->flat, pdl(-100..-50)/50, "ylinvals values"; is_pdl $z->mv(2,0)->uniqvec->flat, pdl(0..25)/5-3, "zlinvals values"; $a1->inplace->xvals; is_pdl $a1->slice('(10),(0),(0)'), pdl(10), 'inplace xvals works'; my $lin1 = eval { zeroes(1)->xlinvals(5,10) }; is $@, '', 'can have length-one *linvals'; is_pdl $lin1, pdl([5]), 'length-one *linvals gives starting point'; eval { zeroes(0)->xlinvals(5,10) }; like $@, qr/at least/, 'cannot have length-zero dim *linvals'; my $byte_xvals = ones( byte, 300 )->xvals; is $byte_xvals->type, 'double', 'byte->xvals type double'; is $byte_xvals->at(280), 280,'non-overflow xvals from byte ndarray'; is xvals(short, 2)->type, 'short', 'xvals respects specified type'; } { my $x = zeroes(11,6,8); my $xl = $x->xlogvals(1e2,1e12); my $yl = $x->ylogvals(1e-3,1e2); my $zl = $x->zlogvals(1e-10,1e-3); is_pdl $xl->shape, $x->shape, "xlogvals shape"; is_pdl $yl->shape, $x->shape, "ylogvals shape"; is_pdl $zl->shape, $x->shape, "zlogvals shape"; is_pdl $xl->uniqvec->flat->log10,pdl(2..12),"xlogvals values"; is_pdl $yl->mv(1,0)->uniqvec->flat->log10,pdl(-3..2),"ylogvals values"; is_pdl $zl->mv(2,0)->uniqvec->flat->log10,pdl(-10..-3),"zlogvals values"; my $log1 = eval { zeroes(1)->xlogvals(5,10) }; is $@, '', 'can have length-one *logvals'; is_pdl $log1, pdl([5]), 'length-one *logvals gives starting point'; eval { zeroes(0)->xlogvals(5,10) }; like $@, qr/at least/, 'cannot have length-zero *logvals'; } is_pdl axisvals(zeroes(3,4,5,6),3), pdl(0..5)->slice('*3,*4,*5'), "4-dimensional axisvals"; { my $x = pdl [15.4,15.8,16.01,16.9,16.1,15.2,15.4,16.2,15.4,16.2,16.4]; eval { hist ($x,15,15,0.1) }; # shouldn't segfault! isnt $@, '', 'error thrown'; my ($hx,$h) = hist ($x,15,17,0.1); is_pdl $hx, pdl(qw/15.05 15.15 15.25 15.35 15.45 15.55 15.65 15.75 15.85 15.95 16.05 16.15 16.25 16.35 16.45 16.55 16.65 16.75 16.85 16.95/), "bin centers"; is_pdl $h, pdl(qw/0 1 0 0 3 0 0 0 1 0 1 3 0 1 0 0 0 0 1 0/), "hist vals"; } { my $x = pdl( qw{ 13 10 13 10 9 13 9 12 11 10 10 13 7 6 8 10 11 7 12 9 11 11 12 6 12 7} ); my $wt = pdl( qw{ -7.4733817 -3.0945993 -1.7320649 -0.92823577 -0.34618392 -1.3326057 -1.3267382 -0.032047153 0.067103333 -0.11446796 -0.72841944 0.95928255 1.4888114 0.17143622 0.14107419 -1.6368404 0.72917 -2.0766962 -0.66708236 -0.52959271 1.1551274 0.079184 1.4068289 0.038689811 0.87947996 -0.88373274 } ); my ( $hx, $h ) = whist ($x, $wt, 0, 20, 1 ); is_pdl $hx, pdl(q{0.5 1.5 2.5 3.5 4.5 5.5 6.5 7.5 8.5 9.5 10.5 11.5 12.5 13.5 14.5 15.5 16.5 17.5 18.5 19.5 }), "weighted bin centers"; is_pdl $h, pdl(qw{ 0 0 0 0 0 0 0.21012603 -1.4716175 0.14107419 -2.2025149 -6.5025629 2.0305847 1.5871794 -9.5787698 0 0 0 0 0 0 }), "weighted hist vals"; } is_pdl xvals(zeroes 3,2), pdl '0 1 2; 0 1 2'; is_pdl pdl(indx, [9,8,7])->sequence, pdl(indx,0..2), "sequence as instance-method should preserve type, dims, right values"; done_testing; PDL-2.100/t/pdl_from_string.t0000644000175000017500000002267214744204234015716 0ustar osboxesosboxes# This tests the new PDL constructor with a string argument. # There are three goals from the new functionality: (1) to allow # MATLAB to use familiar syntax to create arrays, (2) to allow # cut-n-paste of PDL print output as input for scripts and programs, # and (3) to allow easy ways to construct nan and inf values in ndarrays. # (4) to allow complex numbers to be round-tripped in native # complex (i.e. Math::Complex) format use strict; use warnings; use Test::More; use Config; use PDL::LiteF; use Test::PDL; isa_ok pdl("[1,2]"), "PDL", qq{pdl("[1,2]") returns an ndarray}; # Basic Tests # is_pdl pdl([1,2]), pdl("[1,2]"), qq{pdl(ARRAY REF) equals pdl("ARRAY REF")}; my $compare = pdl([ [1, 0, 8], [6, 3, 5], [3, 0, 5], [2, 4, 2] ]); my $test_string = <setbadif(1)); my $infty = pdl('inf'); my $min_inf = pdl('-inf'); my $bad = pdl('bad'); is_pdl $infty, inf(), "pdl 'inf' works by itself"; is_pdl $min_inf, -inf(), "pdl '-inf' works by itself"; is_pdl $min_inf, -$infty, "pdl '-inf' == -pdl 'inf'"; is_pdl pdl('nan'), nan(), "pdl 'nan' works by itself"; ok $bad->isbad, "pdl 'bad' works by itself" or diag "pdl 'bad' gave me $bad"; # Checks for windows strings: is_pdl pdl(q[1.#INF]), inf(), "pdl '1.#INF' works"; is_pdl pdl(q[-1.#IND]), nan(), "pdl '-1.#IND' works"; # Pi and e checks # my $expected = pdl(1)->exp; is_pdl pdl(q[e]), $expected, 'q[e] returns exp(1)'; is_pdl pdl(q[E]), $expected, 'q[E] returns exp(1)'; $expected = pdl(1, exp(1)); is_pdl pdl(q[1 e]), $expected, 'q[1 e] returns [1 exp(1)]'; is_pdl pdl(q[1 E]), $expected, 'q[1 E] returns [1 exp(1)]'; $expected = pdl(exp(1), 1); is_pdl pdl(q[e 1]), $expected, 'q[e 1] returns [exp(1) 1]'; is_pdl pdl(q[E 1]), $expected, 'q[E 1] returns [exp(1) 1]'; $expected = pdl(1, exp(1), 2); is_pdl pdl(q[1 e 2]), $expected, 'q[1 e 2] returns [1 exp(1) 2]'; is_pdl pdl(q[1 E 2]), $expected, 'q[1 E 2] returns [1 exp(1) 2]'; # Already checked all the permutations of e, so just make sure that it # properly substitutes pi $expected = pdl(1, 4 * atan2(1,1)); is_pdl pdl(q[1 pi]), $expected, 'q[1 pi] returns [1 4*atan2(1,1)]'; is_pdl pdl(q[1 PI]), $expected, 'q[1 PI] returns [1 4*atan2(1,1)]'; is_pdl pdl(q[pi 1]), pdl(4 * atan2(1,1), 1), 'q[pi 1] returns [4*atan2(1,1) 1]'; # Security checks # # Check croaking on arbitrary bare-words: eval {pdl q[1 foobar 2]}; isnt($@, '', 'croaks on arbitrary string input'); eval {pdl q[$a $b $c]}; isnt($@, '', 'croaks with non-interpolated strings'); # Install a function that knows if it's been executed. { my $e_was_run = 0; sub PDL::Core::e { $e_was_run++ } sub PDL::Core::e123 { $e_was_run++ } for my $to_check (q[1 e 2], q[1 +e 2], q[1 e+ 2], q[1e 2], q[1e+ 2], q[1+e 2], q[1+e+ 2], q[1 e123 2] ) { $e_was_run = 0; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e in [$to_check]"); } } ############################### # Useful croaking output - 36 # ############################### eval{ pdl q[1 l 3] }; like($@, qr/found disallowed character\(s\) 'l'/, 'good error when invalid character is specified'); eval{ pdl q[1 po 3] }; like($@, qr/found disallowed character\(s\) 'po'/, 'good error when invalid characters are specified'); # checks for croaking behavior for consecutive signs like +-2: eval{ pdl q[1 +-2 3] }; like $@, qr/found a \w+ sign/, 'Good error when consecutive signs'; eval{ pdl q[1 -+2 3] }; like $@, qr/found a \w+ sign/, 'Good error when consecutive signs'; foreach my $special (qw(bad inf pi e)) { foreach my $append (qw(2 e l)) { for my $str ("$special$append", "$append$special") { eval {pdl qq[1 $str 2]}; my $re = $str eq 'e2' ? qr/exponentiation/ : $str eq '2e' ? qr/Incorrect/ : qr/larger word/; like $@, $re, "Good error for '$str'"; } } } ## Issue information ## ## Name: BAD value parsing breakage ## ## Parsing of BAD values fails to set the correct BAD value when parsing from ## the string "[BAD]". ## ## ## # input string -> expected string my $cases = { q|BAD| => q|BAD|, q|BAD BAD| => q|[BAD BAD]|, q|BAD BAD BAD| => q|[BAD BAD BAD]|, q|[BAD]| => q|[BAD]|, q|[ BAD ]| => q|[BAD]|, q|[BAD BAD]| => q|[BAD BAD]|, q|[ BAD BAD ]| => q|[BAD BAD]|, }; while( my ($case_string, $expected_string) = each %$cases ) { my $bad_pdl = pdl( $case_string ); subtest "Testing case: $case_string" => sub { ok $bad_pdl->badflag, 'has badflag enabled'; ok $bad_pdl->isbad->all, 'all values in PDL are BAD'; is $bad_pdl->string, $expected_string, "PDL stringifies ok"; }; } is pdl(ushort, ['-5'])."", "[65531]", "ushort-typed ['-5'] converted right"; is pdl(ushort, '[-5]')."", "[65531]", "ushort-typed '[-5]' converted right"; is pdl(ushort, [-5])."", "[65531]", "ushort-typed [-5] converted right"; # capture indx() on big-endian - https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1092246 is pdl(indx, 2)."", "2", "indx-typed 2 packed/upd_data-ed right"; done_testing; # Basic 2D array # pdl> p $x = pdl q[ [ 1, 2, 3 ], [ 4, 5, 6 ] ]; # pdl> p $x = pdl q[ 1 2 3 ; 4 5 6 ] # pdl> p $x = pdl '[ [ 1, 2, 3 ], [ 4, 5, 6 ] ]'; # # [ # [1 2 3] # [4 5 6] # ] # Basic 1D array # pdl> p $y = pdl [ 1, 2, 3, 4, 5, 6 ] # pdl> p $y = pdl q[ 1 2 3 4 5 6 ] # pdl> p $y = pdl q[1,2,3,4,5,6] # [1 2 3 4 5 6] # 1D array with signs # pdl> p $c = pdl [ 7, -2, +5 ] # pdl> p $c = pdl q[ 7 -2 +5 ] # pdl> p $c = pdl q[ 7, -2, +5 ] # [7 -2 5] # 1D array with mixed ops and signs # pdl> p $d = pdl [ 7 - 2, +5 ] # pdl> p $d = pdl q[ 7 - 2 +5 ] # [5 5] # ...another # pdl> p $d = pdl [ 7, -2 + 5 ] # pdl> p $d = pdl q[ 7 -2 + 5 ] # [7 3] # 1D array with ops, not signs # pdl> p $d = pdl [ 7 - 2 + 5 ] # pdl> p $d = pdl q[ 7 - 2 + 5 ] # 10 # A [2,3,4] shape ndarray # pdl> p $d = pdl [ [ [0, 1], [4, 0], [0, 3] ], # [ [2, 0], [4, 0], [4, 1] ], # [ [0, 1], [3, 2], [1, 4] ], # [ [1, 2], [2, 2], [2, 1] ] ]; # # [ # [ # [0 1] # [4 0] # [0 3] # ] # [ # [2 0] # [4 0] # [4 1] # ] # [ # [0 1] # [3 2] # [1 4] # ] # [ # [1 2] # [2 2] # [2 1] # ] # ] # # ...the same, just different formatting... # # [ # [ [0 1] [4 0] [0 3] ] # [ [2 0] [4 0] [4 1] ] # [ [0 1] [3 2] [1 4] ] # [ [1 2] [2 2] [2 1] ] # ] # A 3x3 2D array # pdl> p pdl [ [1, 2, 3], [2, 1, 0], [2, 2, 1] ]; # pdl> p $e = pdl q[ [ 1 2 3 ] ; [ 2 1 0 ] ; [ 2 2 1 ] ]; # pdl> p pdl q[ 1 2 3 ; 2 1 0 ; 2 2 1 ] # this should be the same # # [ # [1 2 3] # [2 1 0] # [2 2 1] # ] PDL-2.100/t/slice.t0000644000175000017500000004417714770412067013635 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::PDL; # PDL::Core::set_debugging(1); # Useful for debugging. Removed by DJB whilst cleaning up the # tests # #sub kill_if_debug () { # kill INT,$$ if $ENV{UNDER_DEBUGGER}; #} my $x = (1+(xvals zeroes 4,5) + 10*(yvals zeroes 4,5)); is($x->at(2,2), 23, "x location (2,2) is 23"); my $y = $x->slice('1:3:2,2:4:2'); is_pdl $y,pdl([[22,24],[42,44]]); $y .= 0.5; is_pdl $y,pdl([[0.5,0.5],[0.5,0.5]]); is($x->at(1,2), 0.5); is($x->at(2,2), 23); # Check that nothing happened to other elems # test stringify $x = zeroes(3,3); my $line = $x->slice(':,(0)'); $x++; is("$line", '[1 1 1]', 'right value after collapsing slice (0)'); my $im = byte [[0,1,255],[0,0,0],[1,1,1]]; (my $im1 = null) .= $im->dummy(0,3); is_pdl $im1->clump(2)->slice(':,0:2'), byte('0 0 0 1 1 1 255 255 255; 0 0 0 0 0 0 0 0 0; 1 1 1 1 1 1 1 1 1'); # here we encounter the problem is_pdl $im1->clump(2)->slice(':,-1:0'), byte('1 1 1 1 1 1 1 1 1; 0 0 0 0 0 0 0 0 0; 0 0 0 1 1 1 255 255 255'); is_pdl +(xvals(10,10) + 0.1*yvals(10,10))->mslice('X',[6,7]), pdl([ [0.6, 1.6, 2.6, 3.6, 4.6, 5.6, 6.6, 7.6, 8.6, 9.6], [0.7, 1.7, 2.7, 3.7, 4.7, 5.7, 6.7, 7.7, 8.7, 9.7] ]); my $lut = pdl [[1,0],[0,1]]; $im = pdl indx, [1]; my $in = $lut->transpose->index($im->dummy(0)); is_pdl $in, pdl([[0,1]]); $in .= pdl 1; is_pdl $in, pdl([[1,1]]); is_pdl $lut, pdl([[1,0],[1,1]]); # Test of dice and dice_axis $x = sequence(10,4); is($x->dice([1,2],[0,3])->sum, 66, "dice"); is($x->dice([0,1],'X')->sum, 124, "dice 'X'"); # Test of dice clump compatibility my $xxx = PDL->new([[[0,0]],[[1,1]],[[2,2]]]); is_pdl $xxx->where($xxx == 0), pdl([0,0]), "dice clump base zero"; my $dice = $xxx->dice("X","X",[1,0]); is_pdl $dice->clump(-1), pdl([1,1,0,0]), "dice clump correct"; is_pdl $dice->where($dice == 0), pdl([0,0]), "dice clump where zero"; is_pdl zeroes(5,3,2)->reorder(2,1,0)->shape, indx([2,3,5]), "reorder"; $x = zeroes(3,4); $y = $x->dummy(-1,2); is(join(',',$y->dims), '3,4,2'); $x = pdl([1,1,1,3,3,4,4,1,1,2]); for my $in ( $x, $x->cat(map $x->rotate($_), 1..4) ) { rle($in,my $y=null,my $z=null); is_pdl rld($y,$z), $in,"rle with null input"; ($y,$z) = rle($in); is_pdl rld($y,$z), $in,"rle with return vals"; } $y = $x->mslice(0.5); is_pdl $y, pdl([1]), "mslice 1"; $y = mslice($x, 0.5); is_pdl $y, pdl([1]), "func mslice 1"; $y = $x->mslice([0.5,2.11]); is_pdl $y, pdl("[1 1 1]"), "mslice 2"; $x = zeroes(3,3); $y = $x->splitdim(3,3); eval { $y->make_physdims }; like($@, qr/splitdim:nthdim/, "make_physdim: Splitdim"); $y = $x->splitdim(-1,1); is_deeply [$y->dims], [3,1,3], 'splitdims negative nthdim works' or diag explain [$y->dims]; $y = $x->splitdim(1,1); is_deeply [$y->dims], [3,1,3], 'splitdims works' or diag explain [$y->dims]; $y = $x->splitdim(1,2); eval { $y->make_physdims }; like($@, qr/non-divisible/, "splitdims error non-divisible"); $x = sequence 5,5; $y = $x->diagonal(0,1); is("$y", "[0 6 12 18 24]", "diagonal"); $x = sequence 10; eval { $y = $x->lags(1,1,1)->make_physdims }; like($@, qr/lags:\s*dim out of range/, "make_physdim: out of range"); eval { $y = $x->lags(0,-1,1)->make_physdims }; like($@, qr/lags:\s*step must be positive/, "make_physdim: negative step"); eval { $y = $x->lags(0,1,11)->make_physdims }; like($@, qr/too large/, "make_physdim: too large"); $x = sequence(10); my $x1 = pdl(1,2); my $x2 = xvals(5,5)+10*yvals(5,5); my $x3 = xvals 20,20; my $x4 = zeroes(5,3,3); for ( [$x, "", $x, "Empty slice"], [$x, "5", pdl([5]), "simple slice"], [$x, "(5)", pdl(5), "single squish"], [$x, ":5", pdl(0,1,2,3,4,5), "empty first specifier"], [$x, "5:", pdl(5,6,7,8,9), "empty second specifier"], [$x, " 4:", pdl(4,5,6,7,8,9), "slice with whitespace 1"], [$x, " :4", pdl(0,1,2,3,4), "slice with whitespace 2"], [$x, " 3: 4 ", pdl(3,4), "slice with whitespace 3"], [$x, "0:-10", pdl([0]), "slice 0:-n picks first element"], [$x, "0:-14", qr/slice ends out of bounds/, "out of bounds"], [$x, [[pdl(7,6)->slice(1),0,0]], pdl(6), "slice did 'at'"], [$x, [[pdl([2]),pdl([7]),pdl([2])]], pdl(2,4,6), "slice did 'at' 2"], [$x1, "*3,", pdl([[1,1,1],[2,2,2]]), "dummy 0"], [$x1, ",*3", pdl([[1,2],[1,2],[1,2]]), "dummy 1"], [$x2, "1,2,(0)", [1,1], "squished 0th of non-existent dim"], [$x2, "1,2,(1)", qr/too many dims/i, "squished 1th of non-existent dim"], [$x2, "0:1,2:3,0", [2,2,1], "0th of non-existent dim"], [$x3, ["1:18:2,:",":,1:18:2","3:5,:",":,(0)"], pdl(7,9,11), "multiple slices"], [$x3, ["1:18:2,:",":,1:18:2","3:5,:",":,(1)"], pdl(7,9,11), "multiple slices 2"], [$x4, ":,:,1", [5,3,1], "single-coord slice"], [$x4, [":,:,1",":,:,2"], qr/out of bounds/, "slice bounds"], [PDL->null, "", qr/is null/, "null->slice"], [pdl([1]), [pdl([])], pdl([]), "slice 1-elt ndarray with empty"], [$x1, [pdl([])], pdl([]), "slice 2-elt ndarray with empty"], [$x1, [pdl(1)], pdl([2]), "slice 2-elt ndarray with length-1 ndarray"], [zeroes(2,1,0), [\[[],[0,0,0],[]]], zeroes(2,0), "squeeze empty"], [zeroes(2,0), ",0:-1", zeroes(2,0), "slice empty string syntax"], ) { my ($src, $sl, $exp, $label) = @$_; my $y = $src; $y = eval { $y->slice(ref($_) eq 'REF' ? @$$_ : $_)->make_physical } for ref $sl ? @$sl : $sl; like($@, $exp, "$label right error"), next if ref($exp) eq 'Regexp'; is $@, '', "$label works"; is_deeply([$y->dims], ref($exp) eq 'ARRAY' ? $exp : [$exp->dims], "$label dims right") or diag explain [$y->dims]; next if ref($exp) eq 'ARRAY'; is $y->nelem, $exp->nelem, "$label works right"; is_pdl $y, $exp, "$label works right"; } my $d = eval { $x2->slice("0:1,2:3,0")->xchg(0,2)->make_physical }; is $@, '', "slice->xchg"; is_deeply([$d->dims], [1,2,2], "permissive slice xchg dims right"); my $e = eval { $x2->dummy(6,2)->make_physical }; is $@, '', "dummy"; is_deeply([$e->dims], [5,5,1,1,1,1,2], "dummy dims right"); ############################## # Tests of indexND (Nowadays this is just another call to range) # Basic indexND operation my $source = 10*xvals(10,10) + yvals(10,10); my $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); eval { $x = $source->indexND( $index ) }; is $@, ''; is_pdl $x, pdl([23,45],[67,89]); is_pdl $source->indexND(zeroes(indx,2,0)), zeroes(0), 'indexND with empty returns right shape'; # Broadcast indexND operation $source = 100*xvals(10,10,2)+10*yvals(10,10,2)+zvals(10,10,2); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); eval { $x = $source->indexND($index) }; is $@, ''; is_pdl $x, pdl([[230,450],[670,890]],[[231,451],[671,891]]); # Tests of range operator $source = 10*xvals(10,10) + yvals(10,10); my $source3 = 10*xvals(3,3) + yvals(3,3); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); my $mt = zeroes(indx,0); my $dex = pdl(5,4,3); for ( [$source, [$index], [2,2], pdl([23,45],[67,89]), "simple"], [$source, [$index,3], [2,2,3,3], qr/out-of-bounds/, "out of bounds with scalar size"], [$source, [$index,3,"t"], [2,2,3,3], pdl([[89,99,0],[0,0,0],[0,0,0]]), "truncate size 3", sub {shift->slice("(1),(1)")}], [$source, [$index,3,"tp"], [2,2,3,3], pdl([[89,99,0],[80,90,0],[81,91,0]]), "truncate+periodic size 3", sub {shift->slice("(1),(1)")}], [$source3, [[-1,-1],[2,2],"p"], [2,2], pdl([[22,2],[20,0]]), "periodic size [2 2]", undef, sub {$_[0] .= 6}, [[6,10,6],[1,11,21],[6,12,6]]], [$source, [$index,3,["e","p"]], [2,2,3,3], pdl([[89,99,99],[80,90,90],[81,91,91]]), "extension+periodic list syntax size 3", sub {shift->slice("(1),(1)")}], [$dex, [$mt], [0], pdl([]), "scalar Empty[0] indices"], [$dex, [zeroes(1,0)], [0], pdl([]), "Empty[1,0] indices"], [$mt, [$dex,undef,'e'], [], indx(0), "empty source"], [$mt, [$mt], [0], pdl([]), "empty source and index"], [pdl(5,5,5,5), [$mt], [0], pdl([]), "non-empty source, empty index", sub {$_[0] .= 2}], ) { my ($src, $args, $exp_dims, $exp, $label, $exp_mod, $mutate, $mutate_exp) = @$_; $_ = $src->copy for $src, my $src_copy; my $y = eval { $src->range(@$args) }; is $@, '', "$label works"; fail("$label got undef back from range"), next if !defined $y; is_deeply([$y->dims], $exp_dims, "$label dims right") or diag explain [$y->dims]; eval { $y->make_physical }; like($@, $exp, "$label right error"), next if ref($exp) eq 'Regexp'; is $@, '', "$label works 2"; $y = $exp_mod->($y) if $exp_mod; is $y->nelem, $exp->nelem, "$label nelem right"; is_pdl $y, $exp, "$label right data"; is_pdl $src, $src_copy, "$label source not mutated"; next if !$mutate; $mutate->($y); is_pdl $src, pdl($mutate_exp), "$label src right data after mutation"; } # range on higher-dimensional for (4..6) { my @dims = (5) x $_; my $src = sequence @dims; my $idx = ndcoords indx, $src; my $out = eval {$src->range($idx, 2, 't')}; is $@, '', "range(@dims) got no error" or next; $out->make_physdims; my $expected = [@dims, (2) x $_]; is_deeply [$out->dims], $expected or diag explain [$out->dims]; } for my $start (0, 4, -4, 20, -20) { for my $stop (0, 4, -4, 20, -20) { # Generate a simple data ndarray and a bad slice of that ndarray my $data = sequence(10); my $slice = $data->slice("$start:$stop"); pass('Slice operation for properly formed slice does not croak'); # Calculate the expected dimension size: my $expected_dim_size; my $real_start = $start; $real_start += 10 if $start < 0; my $real_stop = $stop; $real_stop += 10 if $stop < 0; $expected_dim_size = abs($real_stop - $real_start) + 1 if 0 <= $real_stop and $real_stop < 10 and 0 <= $real_start and $real_start < 10; my $expected_outcome_description = defined $expected_dim_size ? 'is fine' : 'croaks'; my $dim1; # Should croak when we ask about the dimension: eval { $dim1 = $slice->dim(0) }; is($dim1, $expected_dim_size, "Requesting dim(0) on slice($start:$stop) $expected_outcome_description"); # Should *STILL* croak when we ask about the dimension: eval { $dim1 = $slice->dim(0) }; is($dim1, $expected_dim_size, "Requesting dim(0) a second time on slice($start:$stop) $expected_outcome_description"); # Calculate the expected value my $expected_value; $expected_value = $data->at($real_start) if defined $expected_dim_size; # Should croak when we ask about data my $value; eval { $value = $slice->at(0) }; is($value, $expected_value, "Requesting first element on slice($start:$stop) $expected_outcome_description"); } } { my @METHODS = qw(datachgd allocated has_vafftrans vaffine); sub vafftest { my ($addr2label, $all, $exp, $elabel) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; for (0..$#$all) { my ($x, $name, $xexp) = (@{$all->[$_]}[0,1], $exp->[$_]); for my $m (0..$#METHODS) { is $x->${\$METHODS[$m]}, $xexp->[$m], "$elabel: $name $METHODS[$m]"; } next if !(my $from = $xexp->[$#METHODS+1]); eval {is $addr2label->{$x->vaffine_from}, $from, "$elabel: $name vaffine_from"}; is $@, '', "$elabel: $name vaffine_from no error"; } } # Test vaffine optimisation my $root = zeroes(100,100); my $vaff = $root->slice('10:90,10:90'); my $vaff2 = $vaff->slice('5:8,5:8'); my $clumped = $vaff2->clump(-1); my $all = [[$vaff,'vaff'], [$vaff2,'vaff2'], [$clumped,'clumped']]; my %addr2label = map +($_->[0]->address=>$_->[1]), @$all, [$root,'root']; vafftest(\%addr2label, $all, [[0,0,0,0],[0,0,0,0],[1,0,0,0]], "start"); $vaff++; vafftest(\%addr2label, $all, [[0,0,1,1,'root'],[0,0,0,0],[1,0,0,0]], "vaff mutated"); $vaff2->make_physvaffine; vafftest(\%addr2label, $all, [[0,0,1,1,'root'],[0,0,1,1,'root'],[1,0,0,0]], "vaff2 vaffed"); $vaff->make_physical; vafftest(\%addr2label, $all, [[0,1,1,0,'root'],[0,0,0,0],[1,0,0,0]], "vaff physicalised"); $vaff2 += 1; vafftest(\%addr2label, $all, [[1,1,1,0,'root'],[0,0,1,1,'vaff'],[1,0,0,0]], "vaff2 mutated"); $vaff->make_physvaffine; vafftest(\%addr2label, $all, [[0,1,1,0,'root'],[0,0,1,1,'vaff'],[1,0,0,0]], "vaff physvaffined"); $clumped++; vafftest(\%addr2label, $all, [[1,1,1,0,'root'],[1,1,1,0,'vaff'],[1,1,0,0]], "clumped mutated"); $root->set(0,0,7); vafftest(\%addr2label, $all, [[1,1,1,0,'root'],[1,1,1,0,'vaff'],[1,1,0,0]], "root set()ed"); $vaff->make_physvaffine; vafftest(\%addr2label, $all, [[0,1,1,0,'root'],[1,1,1,0,'vaff'],[1,1,0,0]], "vaff physvaffined2"); $vaff2->make_physvaffine; vafftest(\%addr2label, $all, [[0,1,1,0,'root'],[0,1,1,0,'vaff'],[1,1,0,0]], "vaff2 physvaffined"); $clumped->make_physvaffine; vafftest(\%addr2label, $all, [[0,1,1,0,'root'],[0,1,1,0,'vaff'],[0,1,0,0]], "clumped physvaffined"); push @$all, [my $latevaff=$vaff2->slice(''), 'latevaff']; vafftest(\%addr2label, $all, [[0,1,1,0,'root'],[0,1,1,0,'vaff'],[0,1,0,0],[0,0,0,0]], "latevaff created"); $latevaff->make_physvaffine; vafftest(\%addr2label, $all, [[0,1,1,0,'root'],[0,1,1,0,'vaff'],[0,1,0,0],[0,0,1,1,'vaff2']], "latevaff physvaffined"); # capturing GH#461 $root = zeroes 2,2,2; my $clumped1 = $root->clump( 0,1 ); my $clumped2 = $clumped1->clump( 0,1 ); $all = [[$root,'root'], [$clumped1,'clumped1'], [$clumped2,'clumped2']]; %addr2label = map +($_->[0]->address=>$_->[1]), @$all; vafftest(\%addr2label, $all, [[0,1,0,0],[1,0,0,0],[1,0,0,0]], "start"); $clumped2->make_physvaffine; vafftest(\%addr2label, $all, [[0,1,0,0],[0,1,0,0],[0,1,0,0]], "clumped2 physvaff 1"); $root .= 3; vafftest(\%addr2label, $all, [[0,1,0,0],[1,1,0,0],[1,1,0,0]], "root assigned to"); $clumped2->make_physvaffine; vafftest(\%addr2label, $all, [[0,1,0,0],[0,1,0,0],[0,1,0,0]], "clumped2 physvaff 2"); is_pdl $clumped2, pdl("3 3 3 3 3 3 3 3"); # Make sure that vaffining is properly working: my $y = xvals(5,6,2) + 0.1 * yvals(5,6,2) + 0.01 * zvals(5,6,2); my $c = $y->copy->slice("2:3"); is_pdl $c, $c->copy; for ([0,1], [1,0], [1,1]) { my ($mv, $mult) = @$_; my $x_orig = pdl [1..4]; my $x_mv = $mv ? $x_orig->mv(-1,0) : $x_orig; my $x_slice = $x_mv->slice("0:2"); $x_slice->make_physvaffine; $x_slice *= 100 if $mult; my $y = PDL::_clump_int($x_slice,-1)->make_physvaffine; my $exp = pdl(map $_*($mult ? 100 : 1), 1..3); is_pdl pdl($x_slice->firstvals_nophys), $exp, "mv=$mv mult=$mult firstvals_nophys"; is_pdl $y, $exp, "mv=$mv mult=$mult clump"; } # test the bug alluded to in the comments in pdl_changed (pdlapi.c) # used to segfault my $xx=ones(double,3,4); my $sl1 = $xx->slice('(0)'); my $sl11 = $sl1->slice(''); my $sl2 = $xx->slice('(1)'); my $sl22 = $sl2->slice(''); my $roots = pdl '[1 -2396-2796i -778800+5024412i 2652376792-1643494392i -684394069604-217389559200i]'; # gives 4 roots of 599+699i PDL::polyroots($roots->re, $roots->im, $sl11, $sl22); is_pdl $xx->slice('(0)'), pdl(599)->dummy(0,4), "col=0" or diag "roots=$roots\n", "roots:", PDL::Core::pdump($roots); is_pdl $xx->slice('(1)'), pdl(699)->dummy(0,4), "col=1"; eval {(my $y = zeroes(3,6)) += sequence(6,6)->mv(1,0)->slice("1:-1:2")}; is $@, '', 'can += an mv->slice'; } # captured from https://www.perlmonks.org/?node_id=11153348 for ([0,0], [0,1], [1,0], [1,1]) { my ($phys_clump, $mutate_orig) = @$_; my $orig = zeroes 3,2,1; my $clump = $orig->clump(1,2); $clump->make_physvaffine if $phys_clump; ($mutate_orig ? $orig : $clump) .= 3; is_pdl $orig, pdl([[[(3)x3],[(3)x3]]]), "phys_clump=$phys_clump mutate_orig=$mutate_orig orig"; is_pdl $clump, pdl([[(3)x3],[(3)x3]]), "phys_clump=$phys_clump mutate_orig=$mutate_orig clump"; is_pdl $clump->uniqvec, pdl([[(3)x3]]), "phys_clump=$phys_clump mutate_orig=$mutate_orig uniqvec"; } my $pa = zeroes(7, 7); $pa->set(3, 4, 1); my $indices = $pa->which->dummy(0,$pa->getndims)->make_physical; my $s = $indices->index(0); $s %= 7; is $indices.'', "\n[\n [ 3 31]\n]\n", 'mutate indexed slice affects only right column'; { # captures behaviour in GH#467 my $x = sequence(1000); my $idx = random( $x->nelem) * $x->nelem; $x .= $x->index($idx); eval {$x->min}; is $@, '', 'no error assigning $x->index(..) to $x'; } ## rlevec(), rldvec(): 2d ONLY my $p = pdl([[1,2],[1,2],[1,2],[3,4],[3,4],[5,6]]); my ($pf,$pv) = rlevec($p); is_pdl $pf, my $pf_expect = indx([3,2,1,0,0,0]), "rlevec():counts"; is_pdl $pv, my $pv_expect = pdl([[1,2],[3,4],[5,6],[0,0],[0,0],[0,0]]), "rlevec():elts"; my $pd = rldvec($pf,$pv); is_pdl $pd, $p, "rldvec()"; is_pdl enumvec($p), indx([0,1,2,0,1,0]), "enumvec()"; is_pdl enumvecg($p), indx([0,0,0,1,1,2]), "enumvecg()"; ($pf,$pv) = rleND($p); is_pdl $pf, $pf_expect, "rleND():2d:counts"; is_pdl $pv, $pv_expect, "rleND():2d:elts"; $pd = rldND($pf,$pv); is_pdl $pd, $p, "rldND():2d"; ## rleND, rldND: Nd my $pnd1 = (1 *(sequence(long, 2,3 )+1))->slice(",,*3"); my $pnd2 = (10 *(sequence(long, 2,3 )+1))->slice(",,*2"); my $pnd3 = (100*(sequence(long, 2,3,2)+1)); my $p_nd = $pnd1->mv(-1,0)->append($pnd2->mv(-1,0))->append($pnd3->mv(-1,0))->mv(0,-1); my $pf_expect_nd = indx([3,2,1,1,0,0,0]); my $pv_expect_nd = zeroes($p_nd->type, $p_nd->dims); (my $tmp=$pv_expect_nd->slice(",,0:3")) .= $p_nd->dice_axis(-1,[0,3,5,6]); ## 9..10: test rleND(): Nd my ($pf_nd,$pv_nd) = rleND($p_nd); is_pdl $pf_nd, $pf_expect_nd, "rleND():Nd:counts"; is_pdl $pv_nd, $pv_expect_nd, "rleND():Nd:elts"; ## 11..11: test rldND(): Nd my $pd_nd = rldND($pf_nd,$pv_nd); is_pdl $pd_nd, $p_nd, "rldND():Nd"; ## 12..12: test enumvec(): nd my $v_nd = $p_nd->clump(2); my $k_nd = $v_nd->enumvec(); is_pdl $k_nd, indx([0,1,2,0,1,0,0]), "enumvec():Nd"; # from PDL::CCS tests revealing enumvec bug my $col = pdl("[5 5 4 4 4 3 3 3 3 2 2 2 1 1 0]")->transpose; is_pdl $col->enumvec, indx('[0 1 0 1 2 0 1 2 3 0 1 2 0 1 0]'), 'enumvec'; $col = pdl("[0 0 1 1 2 2 2 3 3 3 3 4 4 4 5 5]")->transpose; is_pdl $col->enumvec, indx('[0 1 0 1 0 1 2 0 1 2 3 0 1 2 0 1]'), 'enumvec 2'; $col = pdl("[0 0 1 1 2 2 2 3 3 3 3 4 4 4 5 5 6]")->transpose; is_pdl $col->enumvec, indx('[0 1 0 1 0 1 2 0 1 2 3 0 1 2 0 1 0]'), 'enumvec 3'; ## 13..17: test rldseq(), rleseq() my $lens = indx([qw(3 0 1 4 2)]); my $offs = (($lens->xvals+1)*100)->short; my $seqs = zeroes(short, 0); $seqs = $seqs->append(sequence(short,$_)) foreach ($lens->list); $seqs += $lens->rld($offs); is_pdl $lens->rldseq($offs), $seqs, "rldseq():data"; my ($len_got,$off_got) = $seqs->rleseq(); is $off_got->type, $seqs->type, "rleseq():type"; is_pdl $len_got->where($len_got), $lens->where($lens), "rleseq():lens"; is_pdl $off_got->where($len_got), $offs->where($lens), "rleseq():offs"; eval {meshgrid(sequence(2,2))}; like $@, qr/1-dimensional/, 'meshgrid rejects >1-D'; my @vecs = (xvals(3), xvals(4)+5, xvals(2)+10); my @mesh_got = meshgrid(@vecs); is_pdl $_->shape, indx([3,4,2]) for @mesh_got; is_pdl $mesh_got[$_]->mv($_,0)->slice(',(0),(0)'), $vecs[$_], "meshgrid $_" for 0..$#vecs; done_testing; PDL-2.100/t/ppt-02_non_threaded.t0000644000175000017500000000330614744321614016255 0ustar osboxesosboxes# Boilerplate use strict; use warnings; # Test declaration use Test::More; use Test::PDL -atol => 0; # Modules needed for actual testing use PDL::LiteF; use PDL::Parallel::threads qw(retrieve_pdls); ######################## # Direct comparison: 4 # ######################## # Create some memory with some irrational values. The goal here is to # perform a strict comparison between floating point values that have # something nontrivial across all its bits. my $data = (sequence(10)+1)->sqrt->share_as('Test::Set1'); my $to_compare = $data; is_pdl $to_compare, $data, 'A ndarray exactly equals itself'; # Now retrieve the value from the "off-site" storage $to_compare = retrieve_pdls('Test::Set1'); is_pdl $to_compare, $data, 'Retrieved value exactly equals original'; ########################### # Shared modifications: 2 # ########################### use PDL::NiceSlice; # Modify the original, see if it is reflected in the retrieved copy $data(3) .= -10; is_pdl $to_compare, $data, 'Modification to original is reflected in retrieved'; $to_compare(8) .= -50; is_pdl $to_compare, $data, 'Modification to retrieved is reflected in original'; ############################### # Undefine doesn't destroy: 3 # ############################### my $expected = pdl(1, -10, -50); # These need to line up with the my $idx = pdl(0, 3, 8); # indices and values used/set above undef($to_compare); is_pdl $data($idx), $expected, "Undeffing copy doesn't destroy data"; undef($data); my $new = retrieve_pdls('Test::Set1'); is_pdl $new($idx), $expected, "Can retrieve data even after undefing original"; PDL::Parallel::threads::free_pdls('Test::Set1'); is_pdl $new($idx), $expected, "Reference counting works"; done_testing; PDL-2.100/t/pdlchar.t0000644000175000017500000000242314727756302014144 0ustar osboxesosboxes## Test of PDL::Char subclass -- treating byte PDLs as matrices of fixed strings use Test::More; use PDL::LiteF; use PDL::Char; use strict; use warnings; { my $pa = PDL::Char->new ([[['abc', 'def', 'ghi'],['jkl', 'mno', 'qrs']], [['tuv', 'wxy', 'zzz'],['aaa', 'bbb', 'ccc']]]); my $stringized = $pa->string; my $comp = qq{[ [ [ 'abc' 'def' 'ghi' ] [ 'jkl' 'mno' 'qrs' ] ] [ [ 'tuv' 'wxy' 'zzz' ] [ 'aaa' 'bbb' 'ccc' ] ] ] }; is( $stringized, $comp); $pa->setstr(0,0,1, 'foo'); is( $pa->atstr(0,0,1), 'foo'); $pa->setstr(2,0,0, 'barfoo'); is( $pa->atstr(2,0,0), 'bar'); $pa->setstr(0,0,1, 'f'); is( $pa->atstr(0,0,1), "f"); my $pb = sequence (byte, 4, 5) + 99; $pb = PDL::Char->new($pb); $stringized = $pb->string; $comp = "[ 'cdef' 'ghij' 'klmn' 'opqr' 'stuv' ] \n"; is($stringized, $comp); } { # Variable-length string test my $varstr = PDL::Char->new( [ ["longstring", "def", "ghi"],["jkl", "mno", 'pqr'] ] ); # Variable Length Strings: Expected Results my $comp2 = "[ [ 'longstring' 'def' 'ghi' ] [ 'jkl' 'mno' 'pqr' ] ] "; is("$varstr", $comp2); } is +PDL::Char->new( "" ).'', q{'' }; { my $cp = PDL::Char->new(['aa'..'af'],['ba'..'bf']); my $got = $cp->dice('X',[0],[0]); is $got.'', "[\n [ 'aa' ] \n] \n", 'can dice a P:C'; } done_testing; PDL-2.100/t/matrixops.t0000644000175000017500000002724314735406614014561 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More; use Test::Exception; use Test::PDL; use PDL::MatrixOps; sub check_inplace { my ($in, $cb, $expected, $label) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my @expected_dims = $expected->dims; for my $inplace (0, 1) { my $in_copy = $in->copy; my $got; $inplace ? lives_ok { $cb->($in_copy->inplace); $got = $in_copy->copy } "$label inplace=$inplace runs" : lives_ok { $got = $cb->($in_copy) } "$label inplace=$inplace runs"; is_pdl $got, $expected, "$label inplace=$inplace"; } } { ### Check LU decomposition of a simple matrix my $pa = pdl([1,2,3],[4,5,6],[7,1,1]); my ($lu, $perm, $par); lives_ok { ($lu,$perm,$par) = lu_decomp($pa); } "lu_decomp 3x3 ran OK"; is($par, -1, "lu_decomp 3x3 correct parity"); is_pdl $perm, pdl(2,1,0), "lu_decomp 3x3 correct permutation"; my $l = $lu->copy; $l->diagonal(0,1) .= 1; $l->slice("2,1") .= 0; $l->slice("1:2,0") .= 0; my $u = $lu->copy; $u->slice("1,2") .= 0; $u->slice("0,1:2") .= 0; is_pdl matmult($l,$u)->slice(":,-1:0"), $pa, "LU = A (after depermutation)"; } { ### Check LU decomposition of an OK singular matrix my $pb = pdl([1,2,3],[4,5,6],[7,8,9]); my ($lu,$perm,$par) = lu_decomp($pb); is_pdl $lu, pdl('7 8 9; 0.142857 0.857142 1.714285; 0.571428 0.5 0'), "lu_decomp singular matrix"; } { ### Check inversion -- this also checks lu_backsub my $pa = pdl([1,2,3],[4,5,6],[7,1,1]); my $opt ={s=>1,lu=>\my @a}; my $inv_expected = pdl '0.055555556 -0.055555556 0.16666667; -2.1111111 1.1111111 -0.33333333; 1.7222222 -0.72222222 0.16666667'; check_inplace($pa, sub { inv($_[0], $opt) }, $inv_expected, "inv 3x3"); isa_ok $opt->{lu}[0], 'PDL', "inverse: lu_decomp first entry is an ndarray"; is_pdl matmult($inv_expected,$pa),identity(3),"matrix mult by its inverse gives identity matrix"; } { ### Check inv() with added broadcast dims (simple check) my $C22 = pdl([5,5],[5,7.5]); my $inv_expected = pdl([0.6, -0.4], [-0.4, 0.4]); check_inplace($C22, sub { $_[0]->inv }, $inv_expected, "inv 2x2"); check_inplace($C22->dummy(2,2), sub { $_[0]->inv }, $inv_expected->dummy(2,2), "inv 2x2 extra dim"); } { ### Check inv() for matrices with added broadcast dims (bug #3172882 on sf.net) my $a334 = pdl <<'EOF'; [ [ [ 1 0 4] [-1 -1 -3] [ 0 1 0] ] [ [ 4 -4 -5] [ 1 -5 -3] [-1 -2 0] ] [ [-2 2 -5] [-1 1 -3] [-4 3 -4] ] [ [-1 4 -4] [ 2 1 3] [-3 -4 -3] ] ] EOF my $a334inv; lives_ok { $a334inv = $a334->inv } "3x3x4 inv ran OK"; is_pdl matmult($a334,$a334inv),identity(3)->dummy(2,4), "3x3x4 inv"; } { my $idc = identity(zeroes(cdouble, 2, 2)); is $idc->type, 'cdouble'; } { # bug in inv for native-complex - GH#403 my $p = pdl [[ 1+i(), 0], [0, 2+2*i() ] ]; my $p_inv; lives_ok { $p_inv = $p->inv } "native-complex inv runs OK"; is_pdl matmult($p,$p_inv),identity(2)->cdouble, "native-complex inv"; } { ### Check LU backsubstitution (bug #2023711 on sf.net) my $pa = pdl([[1,2],[1,1]]); # asymmetric to see if need transpose my ($lu,$perm,$par); lives_ok { ($lu,$perm,$par) = lu_decomp($pa) } "lu_decomp 2x2 ran OK"; is $par, 1, "lu_decomp 2x2 correct parity"; is_pdl $perm, pdl(0,1), "lu_decomp 2x2 correct permutation"; my $bb = pdl([1,0], [3, 4]); my $xx_expected = pdl '-1 1; 5 -1'; check_inplace($bb, sub { lu_backsub($lu,$perm,$_[0]) }, $xx_expected, "lu_backsub"); my $got = $pa x $xx_expected->transpose; is_pdl $got, $bb->transpose, "A x actually == B"; } { my $A = identity(4) + ones(4, 4); $A->slice('2,0') .= 0; my $B = sequence(1, 4); my ($x) = simq($A->copy, $B->transpose, 0); $x = $x->inplace->transpose; is_pdl $A x $x, $B, 'simq right result'; } { ### Check attempted inversion of a singular matrix my $pb = pdl([1,2,3],[4,5,6],[7,8,9]); my $b2; lives_ok { $b2 = inv($pb,{s=>1}) } "inv of singular matrix should not barf if s=>1"; ok(!defined $b2, "inv of singular matrix undefined if s=>1"); } { ### Check that det will save lu_decomp and reuse it my $m1 = pdl [[1,2],[3,4]]; # det -2 my $opt1 = {lu=>undef}; is_pdl $m1->det($opt1), pdl(-2), "det([[1,2],[3,4]]"; is_pdl $opt1->{lu}[0]->index2d(0,0), pdl(3), "set lu"; my $m2 = pdl [[2,1],[4,3]]; # det 2 is_pdl $m2->det, pdl(2), "det([[2,1],[3,4]]"; is_pdl $m2->det($opt1), pdl(-2), "correctly used wrong lu"; } { ### Check broadcasted determinant -- simultaneous recursive det of four 4x4's my $pa = pdl([3,4,5,6],[6,7,8,9],[9,0,7,6],[4,3,2,0]); # det=48 my $pb = pdl([1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]); # det=1 my $c = pdl([0,1,0,0],[1,0,0,0],[0,0,1,0],[0,0,0,1]); # det=-1 my $d = pdl([1,2,3,4],[5,4,3,2],[0,0,3,0],[3,0,1,6]); # det=-216 my $e = ($pa->cat($pb)) -> cat( $c->cat($d) ); my $det = $e->determinant; is_pdl $det, pdl([48,1],[-1,-216]), "broadcasted determinant"; } { my $m2=pdl[[-2,-2,-2],[-1,-1,-2],[0,0,-2]]; isa_ok $m2->det, 'PDL', 'det of singular always returns ndarray'; } { ### Check identity and stretcher matrices... is_pdl identity(2), pdl('1 0; 0 1'), "identity matrix"; is_pdl identity(pdl 2), pdl('1 0; 0 1'), "identity matrix with scalar ndarray"; is_pdl identity(zeroes 2, 3), pdl('1 0; 0 1'), "identity matrix with dimensioned ndarray"; is_pdl identity(zeroes 2, 3, 4)->shape, indx([2,2,4]), "identity matrix with multi-dimensioned ndarray"; is_pdl stretcher(pdl(2,3)), pdl('2 0;0 3'), "stretcher 2x2"; is_pdl stretcher(pdl('2 3;3 4')), pdl('[2 0;0 3][3 0;0 4]'), "stretcher 2x2x2"; is_pdl stretcher(ldouble('0.14142135623731 0.14142135623731')), ldouble('0.14142135623731 0;0 0.14142135623731'), "stretcher ldouble 2x2"; } { ### Check eigens with symmetric my $pa = pdl([3,4],[4,-3]); ### Check that eigens runs OK my ($vec,$val); lives_ok { ($vec,$val) = eigens $pa } "eigens runs OK"; is_pdl $vec, pdl('[-0.4472 0.8944; 0.8944 0.4472]'), {atol=>1e-4, test_name=>'vec'}; is_pdl $val, pdl('[-5 5]'), {atol=>1e-4, test_name=>'val'}; } { ### Check computations on larger symmetric matrix with known eigenvalue sum. my $m = pdl( [ 1.638, 2.153, 1.482, 1.695, -0.557, -2.443, -0.71, 1.983], [ 2.153, 3.596, 2.461, 2.436, -0.591, -3.711, -0.493, 2.434], [ 1.482, 2.461, 2.5, 2.834, -0.665, -2.621, 0.248, 1.738], [ 1.695, 2.436, 2.834, 4.704, -0.629, -2.913, 0.576, 2.471], [-0.557, -0.591, -0.665, -0.629, 19, 0.896, 8.622, -0.254], [-2.443, -3.711, -2.621, -2.913, 0.896, 5.856, 1.357, -2.915], [ -0.71, -0.493, 0.248, 0.576, 8.622, 1.357, 20.8, -0.622], [ 1.983, 2.434, 1.738, 2.471, -0.254, -2.915, -0.622, 3.214]); my ($vec,$val) = eigens($m); is_pdl sum($val), pdl(61.308), {atol=>1e-3, test_name=>"eigens sum for 8x8 correct answer"}; } { my ($vec, $val) = eigens_sym(pdl ' 1 0.97129719 0.84976463; 0.97129719 1 0.85718032; 0.84976463 0.85718032 1 '); is_pdl $vec, pdl(' -0.69643754 -0.4153763 0.58518141; 0.71722723 -0.3760106 0.58668657; -0.023661283 0.82829859 0.55978709 '), {atol=>1e-4}; is_pdl $val, pdl '0.0285787023603916 0.184737309813499 2.78668427467346'; } { my ($vec, $val) = eigens_sym(pdl ' 6.16 6.92 6.48; 6.92 8.24 7.56; 6.48 7.56 9.44 '); is_pdl $vec, pdl(' 0.75308498 -0.41356731 0.51168848; -0.6578457 -0.46138793 0.59528162; 0.010102134 0.78490971 0.6195278 '), {atol=>1e-4}; is_pdl $val, pdl '0.202065318822861 1.58175909519196 22.056173324585'; } { my ($vec, $val) = eigens_sym(pdl ' 1 0.39340591 0.020299473 0.0708649 -0.2113158; 0.39340591 1 -0.0068287551 0.041056049 -0.16445125; 0.020299473 -0.0068287551 1 -0.12104955 -0.27936218; 0.0708649 0.041056049 -0.12104955 1 -0.19270414; -0.2113158 -0.16445125 -0.27936218 -0.19270414 1 '); is_pdl $vec, pdl(' 0.18062011 -0.7073149 -0.27969719 -0.23767039 0.57651043; 0.062941168 0.6977992 -0.36701876 -0.29014418 0.53872838; 0.56181779 0.078088453 -0.069022759 0.79253795 0.21303147; 0.43178295 0.081451098 0.81198071 -0.30588545 0.23248791; 0.67921943 0.0070585731 -0.35069916 -0.37100785 -0.52723279 '), {atol=>1e-4}; is_pdl $val, pdl '0.574989080429077 0.60359400510788 1.05055177211761 1.17390930652618 1.59695565700531'; } { #Check an asymmetric matrix: my $pa = pdl ([4,-1], [2,1]); my ($vec,$val) = eigens $pa; is_pdl $vec, cdouble('0.707106781186548 0.447213595499958; 0.707106781186548 0.894427190999916'); is_pdl $val, cdouble(3,2); } { #The below matrix has complex eigenvalues my ($rvec, $val) = eigens(pdl([1,1],[-1,1])); is_pdl $rvec, pdl('[0.707i -0.707i; 0.707 0.707]'), {atol=>1e-3}; is_pdl $val, pdl('[1-i 1+i]'), {atol=>1e-3}; } throws_ok { eigens(pdl '243 -54 0; 126 72 10; 144 -72 135') } qr/hqr2 function/; { #asymmetric case with complex eigenvectors my ($rvec, $val) = eigens(my $A = pdl '1 0 0 0; 0 1 0 0; 0 0 0 -1; 0 0 1 0'); is_pdl $val, pdl('-i i 1 1'); for my $i (0..3) { my ($vals, $vecs) = ($val->slice($i), $rvec->slice($i)); is_pdl $vals * $vecs, $A x $vecs; } } { #check singular value decomposition for MxN matrices (M=#rows, N=#columns): my $svd_in = pdl([3,1,2,-1],[-1,3,0,2],[-2,3,0,0],[1,3,-1,2]); { #2x2; my $this_svd_in = $svd_in->slice("0:1","0:1"); my ($u,$s,$v) = svd($this_svd_in); my $ess = zeroes($this_svd_in->dim(0),$this_svd_in->dim(0)); $ess->diagonal(0,1).=$s; is_pdl $this_svd_in, ($u x $ess x $v->transpose), "svd 2x2"; } { #3x3; my $this_svd_in = $svd_in->slice("0:2","0:2"); my ($u,$s,$v) = svd($this_svd_in); my $ess = zeroes($this_svd_in->dim(0),$this_svd_in->dim(0)); $ess->diagonal(0,1).=$s; is_pdl $this_svd_in, $u x $ess x $v->transpose, "svd 3x3"; } { #4x4; my $this_svd_in = $svd_in; my ($u,$s,$v) = svd($this_svd_in); my $ess =zeroes($this_svd_in->dim(0),$this_svd_in->dim(0)); $ess->diagonal(0,1).=$s; is_pdl $this_svd_in,($u x $ess x $v->transpose),"svd 4x4"; } { #3x2 my $this_svd_in = $svd_in->slice("0:1","0:2"); my ($u,$s,$v) = svd($this_svd_in); my $ess = zeroes($this_svd_in->dim(0),$this_svd_in->dim(0)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0,1); #generic diagonal is_pdl $this_svd_in, $u x $ess x $v->transpose, "svd 3x2"; } { #2x3 my $this_svd_in = $svd_in->slice("0:2","0:1"); my ($u,$s,$v) = svd($this_svd_in->transpose); my $ess = zeroes($this_svd_in->dim(1),$this_svd_in->dim(1)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$this_svd_in->dim(1)-1); #generic diagonal is_pdl $this_svd_in, $v x $ess x $u->transpose, "svd 2x3"; } } { # test inspired by Luis Mochan my $A = sequence(2, 2) + 1; my $A1 = $A->slice(',1:0'); # interchange two rows my $B = pdl(1,1); my $x_expected = pdl([[-1, 1]]); check_inplace($B, sub { lu_backsub($A->lu_decomp, $_[0]) }, $x_expected, "lu_backsub dims"); check_inplace($B, sub { lu_backsub($A1->lu_decomp, $_[0]) }, $x_expected, "lu_backsub dims 2"); my $got = $A x $x_expected->transpose; is_pdl $got,$B->transpose, "A x actually == B"; } { squaretotri(my $x=sequence(3,3), my $y=zeroes(6)); is $y.'', "[0 3 4 6 7 8]", 'squaretotri with output arg given'; eval {squaretotri($x, zeroes(7))}; like $@, qr/dim has size 7/; $y = squaretotri($x); is $y.'', "[0 3 4 6 7 8]", 'squaretotri with no output arg given'; is tritosquare($y).'', ' [ [0 0 0] [3 4 0] [6 7 8] ] ', 'tritosquare'; $y = squaretotri(sequence(3,3,2)); is $y.'', " [ [ 0 3 4 6 7 8] [ 9 12 13 15 16 17] ] ", 'squaretotri broadcasts right'; } { my $A = pdl '[1 2 3; 4 5 6; 7 8 9]'; my $up = pdl '[1 2 3; 0 5 6; 0 0 9]'; my $lo = pdl '[1 0 0; 4 5 0; 7 8 9]'; is_pdl $A->tricpy(0), $up, 'upper triangle #1'; tricpy($A, 0, my $got = null); is_pdl $got, $up, 'upper triangle #2'; is_pdl $A->tricpy, $up, 'upper triangle #3'; is_pdl $A->tricpy(1), $lo, 'lower triangle #1'; tricpy($A, 1, $got = null); is_pdl $got, $lo, 'lower triangle #2'; is_pdl $A->mstack($up), pdl('[1 2 3; 4 5 6; 7 8 9; 1 2 3; 0 5 6; 0 0 9]'); is_pdl sequence(2,3)->augment(sequence(3,3)+10), pdl('[0 1 10 11 12; 2 3 13 14 15; 4 5 16 17 18]'); my $B = pdl('[i 2+4i 3+5i; 0 3i 7+9i]'); is_pdl $B->t, pdl('[i 0; 2+4i 3i; 3+5i 7+9i]'); is_pdl $B->t(1), pdl('[-i 0; 2-4i -3i; 3-5i 7-9i]'); is_pdl sequence(3)->t, pdl('[0; 1; 2]'); is_pdl pdl(3)->t->shape, indx([1,1]); } done_testing; PDL-2.100/t/io-pnm.t0000644000175000017500000000425714744321614013726 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use PDL::IO::Pnm; use PDL::Dbg; use File::Temp qw(tempdir); use File::Spec; use Test::More; use Test::PDL; my $tmpdir = tempdir( CLEANUP => 1 ); sub rpnm_unlink { my ($data, $ext, $format, $raw) = @_; my $file = File::Spec->catfile($tmpdir, "temp.$ext"); wpnm($data, $file, $format, $raw); my $pdl = rpnm($file); unlink $file; open my $fh, '>', $file; wpnm($data, $fh, $format, $raw); close $fh; open $fh, '<', $file; my $pdl2 = rpnm($fh); is_pdl $pdl, $pdl2, 'rpnm from fh same as from disk file'; unlink $file; return $pdl; } $PDL::debug = $PDL::debug = 1 if defined($ARGV[0]) && $ARGV[0] =~ /-v/; # [FORMAT, extension, ushort-divisor, # only RGB/no RGB/any (1/-1/0), mxdiff] # no test of PCX format because seems to be severely brain damaged my @formats = ( ['PNM', 'pnm', 1, 0, 0.01], ['GIF', 'gif',256, 0, 0.01], ['TIFF','tif', 1, 0, 0.01],); my $im1 = ushort([[0,65535,0], [256,256,256], [65535,256,65535]]); my $im2 = byte($im1/256); # make the resulting file at least 12 byte long # otherwise we run into a problem when reading the magic (Fix!) my $im3 = byte [[0,0,255,255,12,13],[1,4,5,6,11,124], [100,0,0,0,10,10],[2,1,0,1,0,14],[2,1,0,1,0,14], [2,1,0,1,0,14]]; if ($PDL::debug) { note $im1; $im1->px; note $im2; $im2->px; note $im3>0; $im3->px; } # for some reason the pnmtotiff converter coredumps when trying # to do the conversion for the ushort data, haven't yet tried to # figure out why for my $raw (0,1) { foreach my $form (@formats) { my $in = rpnm_unlink($im2, $form->[1], 'PGM', $raw); my $comp = ($form->[3] ? $im2->dummy(0,3) : $im2); is_pdl $in,$comp; $comp = $form->[3] ? ($im3->dummy(0,3)>0)*255 : ($im3 > 0); $comp = $comp->ushort*65535 if $form->[0] eq 'SGI'; # yet another format quirk $in = rpnm_unlink($im3, $form->[1], 'PBM', $raw); is_pdl $in,$comp; next if $form->[0] eq 'GIF'; $in = rpnm_unlink($im1, $form->[1], 'PGM', $raw); my $scale = $form->[3] ? $im1->dummy(0,3) : $im1; $comp = $scale / $form->[2]; is_pdl $in, $comp, {atol=>$form->[4], test_name=>$form->[0]}; } } done_testing; PDL-2.100/t/nat_complex.t0000644000175000017500000001234714740772324015043 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use PDL::Core::Dev; use PDL::Types qw(ppdefs ppdefs_complex ppdefs_all); use Test::More; use Test::PDL; is_deeply [ ppdefs() ], [qw(A B S U L K N P Q F D E)]; is_deeply [ ppdefs_complex() ], [qw(G C H)]; is_deeply [ ppdefs_all() ], [qw(A B S U L K N P Q F D E G C H)]; my $ref = pdl([[-2,1],[-3,1]]); my $ref2 = squeeze(czip($ref->slice("0,"), $ref->slice("1,"))); my $x = i() -pdl (-2, -3); is($x->type, 'cdouble', 'type promotion i - ndarray'); is_pdl $x->im, $ref->slice("(1),:"), 'value from i - ndarray'; ok !$x->type->real, 'complex type not real'; ok double->real, 'real type is real'; ok !$x->sumover->type->real, 'sumover type=complex'; for (qw(conj re im)) { eval {double(5)->$_}; is $@, '', "NO error if give real data to $_"; } for (qw(carg)) { eval {double(5)->$_}; like $@, qr/must be complex/, "error if give real data to $_"; } eval {czip(cdouble(5),1)}; like $@, qr/must be real/, "error if give complex data to czip"; $x = cdouble(2,3); $x-=i2C(3); is type($x), 'cdouble', 'type promotion ndarray - i'; is $x->re->type, 'double', 'real real part'; my $y=cfloat($x); is type($y), 'cfloat', 'type conversion to cfloat'; is $y->re->type, 'float', 'real real part'; is_pdl $x->im, $ref->slice("(0),(1),*2"), 'value from ndarray - i'; is zeroes($_->[0], 2)->r2C->type, $_->[1], "r2C $_->[0] -> $_->[1]" for [byte, 'cdouble'], [long, 'cdouble'], [float, 'cfloat'], [cfloat, 'cfloat'], [double, 'cdouble'], [cdouble, 'cdouble']; my $got_double = double(-1, 2); my $got_r2C = $got_double->r2C; is ''.$got_r2C->re, ''.$got_double, 're(r2C) identical to orig'; my $got = r2C(1); is $got, 1, 'can give Perl numbers to r2C'; ok !$got->type->real, 'complex type'; $got = i2C(1); is $got, i(), 'can give Perl numbers to i2C'; ok !$got->type->real, 'complex type'; ok !i(2, 3)->type->real, 'i(2, 3) returns complex type'; for (float, double, ldouble, cfloat, cdouble, cldouble) { my $got = pdl $_, '[0 BAD]'; my $bv = $got->badvalue; my $obv = $got->orig_badvalue; is $got.'', '[0 BAD]', "$_ bad" or diag "bv=$bv, obv=$obv: ", explain [$bv, $obv]; is $got->isbad.'', '[0 1]', "$_ isbad"; # this captures a failure in IO/Flexraw/t/iotypes.t eval { ok $bv == $obv, 'can equality-check badvalue and orig_badvalue' }; is $@, '', 'no error from ==' or diag explain [$bv, $obv]; } { # dataflow from complex to real my $ar = $x->re; $ar++; is_pdl $x->re, -$ref->slice("0,")->squeeze + 1, 'complex to real dataflow'; my $ai = $x->im; $x+=i; my $expected = pdl(-2, -2); is_pdl $x->im, $expected, 'dataflow after conversion'; $ai++; is_pdl $x->im, $expected+1, 'dataflow after change ->im'; } # Check that converting from re/im to mag/ang and # back we get the same thing $x = $ref2->copy; my $a=abs($x); my $p=carg($x)->double; # force to double to avoid glibc bug 18594 is_pdl czip($a*cos($p), $a*sin($p)), $x, 'check re/im and mag/ang equivalence'; # Catan, Csinh, Ccosh, Catanh, Croots my $cabs = sqrt($x->re**2+$x->im**2); ok(abs($x)->type->real, 'Cabs type real'); is_pdl abs $x, $cabs, 'Cabs value'; is_pdl abs2($x), $cabs**2, 'Cabs2 value'; ok abs2(cdouble(5))->type->real, 'abs2 always real'; ok(carg($x)->type->real, 'Carg type real'); is_pdl carg($x), atan2($x->im, $x->re), 'Carg value'; is_pdl $x->cat($x->re->copy + 1), pdl('-2+i -3+i; -1 -2'), 'cat for complex'; if (PDL::Core::Dev::got_complex_version('pow', 2)) { is_pdl $x**2, $x * $x, '** op complex'; is_pdl $x->pow(2), $x * $x, 'complex pow'; is_pdl $x->power(2, 0), $x * $x, 'complex power'; my $z = pdl(0) + i()*pdl(0); $z **= 2; is_pdl $z, i2C(0), 'check that 0 +0i exponentiates correctly'; # Wasn't always so. my $r = r2C(-10); $r **= 2; is_pdl $r, r2C(100), 'check imaginary part exactly zero'; # Wasn't always so } my $asin_2 = PDL::asin(2).""; my $nan_re = qr/nan|ind/i; like $asin_2, $nan_re, 'perl scalar 2 treated as real'; $asin_2 = PDL::asin(2.0).""; like $asin_2, $nan_re, 'perl scalar 2.0 treated as real'; $asin_2 = PDL::asin(byte 2).""; like $asin_2, $nan_re, 'real byte treated as real'; $asin_2 = PDL::asin(double 2).""; like $asin_2, $nan_re, 'real double treated as real'; $asin_2 = PDL::asin(pdl 2).""; like $asin_2, $nan_re, 'pdl(2) treated as real'; if (PDL::Core::Dev::got_complex_version('asin', 1)) { my $c_asin_2 = PDL::asin(cdouble(2)).""; unlike $c_asin_2, qr/nan/i, 'asin of complex gives complex result'; } { # Check stringification of complex ndarray my $c = 9.1234 + 4.1234*i(); like($c->dummy(2,1).'', qr/9.123.*4.123/, 'stringify native complex'); } #test overloaded operators { my $less = czip(3, -4); my $equal = -1*(-3+4*i); my $more = czip(3, 2); my $zero_imag = r2C(4); eval { my $bool = $less<$more }; ok $@, 'exception on invalid operator'; eval { my $bool = $less<=$equal }; ok $@, 'exception on invalid operator'; ok($less==$equal,'equal to'); ok(!($less!=$equal),'not equal to'); eval { my $bool = $more>$equal }; ok $@, 'exception on invalid operator'; eval { my $bool = $more>=$equal }; ok $@, 'exception on invalid operator'; ok($zero_imag==4,'equal to real'); ok($zero_imag!=5,'neq real'); } is pdl(i)->type, 'cdouble', 'pdl(complex ndarray) -> complex-typed ndarray'; is pdl([i])->type, 'cdouble', 'pdl([complex ndarray]) -> complex-typed ndarray'; done_testing; PDL-2.100/t/autoload_func.pdl0000644000175000017500000000024514736571600015662 0ustar osboxesosboxes# Test file for autoloader.t no PDL::NiceSlice; sub autoload_func { my $x = shift; $::GLOBAL_VAR = '$COMP(max_it)'; return ($x**3 + 2); }; 1; # OK status PDL-2.100/t/pp_croaking.t0000644000175000017500000001142114740772324015016 0ustar osboxesosboxes# Test the error reporting for malformed PDL::PP code. use strict; use warnings; use Test::More; # Load up PDL::PP use PDL::PP qw(foo::bar foo::bar foobar); # Prevent file generation (does not prevent calling of functions) $PDL::PP::done = 1; eval {pp_addpm({At=>'Mid'}, "blah")}; like $@, qr/Middle/, 'pp_addpm says valid options'; # Check loop malformed call: eval {pp_def(test1 => Pars => 'a(n)', Code => 'loop %{ $a()++; %}')}; like $@, qr/Expected.*loop.*%\{/, 'loop without dim name should explain error'; # Check what looks like malformed var access in a string works: eval {pp_def(test1 => Pars => 'a(n)', Code => '$CROAK("$iisframe must be in range");')}; is $@, '', '$var without brackets in a string is not error'; #like $@, qr/Expected brackets/, 'var access without ()'; eval { pp_def( "func", Code => ';', Pars => "I(m);", ) }; like $@, qr/Invalid Pars name/; eval { pp_def( "func", Code => ';', Pars => "x(m);", OtherPars => 'int I;', ) }; like $@, qr/Invalid OtherPars name/; for ( 'short a(o,c); short [o]b(o,c)', ) { eval { pp_def( "func", Code => ';', Pars => $_, Inplace => 1) }; is $@, '', "Pars=>'$_'"; } for ( 'a(); int [o]mask();', 'r(m=2); float+ [o]p(m=2);', ) { eval { pp_def( "func", Code => ';', Pars => $_, Inplace => 1) }; like $@, qr/have different type specifications/, "Pars=>'$_'"; } eval { pp_def( "func", Code => ';', Pars => "[o] a();", Inplace => ['a'], ) }; like $@, qr/is actually output/; eval { pp_def( "func", Code => ';', Pars => "a(m);", Inplace => 1, ) }; like $@, qr/Inplace does not know name of output/; eval { pp_def( "func", Code => ';', Pars => "[o] a(m);", Inplace => 1, ) }; like $@, qr/Inplace does not know name of input/; eval { pp_def( "func", Code => ';', Pars => "[o] a(m);", Inplace => ['a', 'b', 'c'], ) }; like $@, qr/Inplace array-ref/; eval { pp_def( "func", Code => ';', Pars => "a(); [o] b();", Inplace => ['a', 'b'], ) }; is $@, ''; eval { pp_def( "func", Code => ';', Pars => "a(); b();", Inplace => ['a', 'b'], ) }; like $@, qr/Inplace output arg b not \[o]/; eval { pp_def( "func", Code => ';', Pars => "a(); [o] b(m);", Inplace => ['a', 'b'], ) }; like $@, qr/Inplace args a and b different number of dims/; eval { pp_def( "func", Code => ';', Pars => "a(n); [o] b(m);", Inplace => ['a', 'b'], ) }; is $@, '', 'different but non-fixed dims OK'; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m);", Inplace => ['a', 'b'], ) }; is $@, '', 'one fixed dim OK'; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", Inplace => ['a', 'b'], ) }; like $@, qr/Inplace Pars a and b inds n=2 and m=3 not compatible/; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", GenericTypes => [qw(B INVALID)], ) }; like $@, qr/INVALID/, 'invalid GenericTypes caught'; eval { pp_def( "func", Code => '$a(n);', Pars => "a(n=2); [o] b(m=3);", ) }; like $@, qr/no '=>' seen/, 'useful error when no "=>" in ndarray access'; eval { pp_def( "func", Code => '$a(n=>1 + 2);', Pars => "a(n=2); [o] b(m=3);", ) }; like $@, qr/func\).*no spaces/, 'useful error when no "=>" in ndarray access'; my @boilerplate = (my $pars = "a(n=2); [o] b(m=3)", "func", my $otherpars = "int x; char *y"); eval { PDL::PP::Signature->new(@boilerplate, {x=>0}, undef) }; isnt $@, '', 'error to give default for non-last params'; eval { PDL::PP::Signature->new(@boilerplate, {}, [qw(a x y)]) }; like $@, qr/missed params/; eval { PDL::PP::Signature->new(@boilerplate, {}, [qw(a x y b c)]) }; like $@, qr/too many params/; eval { PDL::PP::Signature->new(@boilerplate, {}, [qw(a x b y)]) }; like $@, qr/optional argument/; eval { PDL::PP::Signature->new(@boilerplate, {}, 1) }; is $@, '', 'non-ref true value OK'; eval { PDL::PP::Signature->new(@boilerplate, undef, [qw(a x y b)]) }; is $@, '', 'valid order OK'; my $got = PDL::PP::Signature->new( $pars, 'name', $otherpars, {}, 1 )->args_callorder; is_deeply $got, [qw(a x y b)], 'right reorder no defaults' or diag explain $got; is_deeply $got = PDL::PP::Signature->new( $pars, 'name', $otherpars, {x=>1}, 1 )->args_callorder, [qw(a y x b)], 'right reorder with default' or diag explain $got; is_deeply $got = PDL::PP::Signature->new( $pars, 'name', "[o] $otherpars; double z", {}, 1 )->args_callorder, [qw(a y z b x)], 'right reorder, output other, no defaults' or diag explain $got; is_deeply $got = PDL::PP::Signature->new( $pars, 'name', "[o] $otherpars; double z", {y=>'""'}, 1 )->args_callorder, [qw(a z y b x)], 'right reorder, output other, with default' or diag explain $got; eval { pp_def("rice_expand", Pars=>'in(n); [o]out(m);', OtherPars=>'IV dim0 => m; int blocksize', OtherParsDefaults=>{ blocksize=>32 }, GenericTypes=>['B','S','US','L'], Code => 'fits_rcomp$TBSUL(_byte,_short,_short,)();', ); }; is $@, ''; done_testing; PDL-2.100/t/io-stl-ascblender2.stl0000644000175000017500000000177314727756302016466 0ustar osboxesosboxessolid facet normal 0.84410374399741939 -0.34963905512334476 -0.40649895510566048 outer loop vertex 0.0017237013671547174 0.10291291773319244 -0.0015311292372643948 vertex 0.0019548346754163504 0.10463636368513107 -0.0025335513055324554 vertex 0.0024375757202506065 0.10463636368513107 -0.0015311292372643948 endloop endfacet facet normal 0.60368325273783552 -0.25005312352273268 -0.75699403285652889 outer loop vertex 0.0013823517365381122 0.10325426608324051 -0.0025335513055324554 vertex 0.00076726125553250313 0.10386935621500015 -0.0032272490207105875 vertex 0.0010849653044715524 0.10463636368513107 -0.0032272490207105875 endloop endfacet facet normal 0.60368283778508947 -0.25005334258074174 -0.75699429141040397 outer loop vertex 0.0013823517365381122 0.10325426608324051 -0.0025335513055324554 vertex 0.0010849653044715524 0.10463636368513107 -0.0032272490207105875 vertex 0.0019548346754163504 0.10463636368513107 -0.0025335513055324554 endloop endfacet endsolid PDL-2.100/t/subclass.t0000644000175000017500000001757514727756302014364 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More; # Test PDL Subclassing via hashes ########### First test normal subclassing ########### { package PDL::Derived; our @ISA = qw/PDL/; sub new { my $class = shift; bless {PDL=>shift, SomethingElse=>42}, $class; } } # Create a PDL::Derived instance my $z = PDL::Derived->new( ones(5,5) ) ; # PDL::Derived should have PDL properties $z++; ok(sum($z)==50, "derived object does PDL stuff"); # And should also have extra bits ok($$z{SomethingElse}==42, "derived has extra bits" ); # And survive destruction undef $z; ########### Now test magic subclassing i.e. PDL=code ref ########### { package PDL::Derived2; # This is a array of ones of dim 'Coeff' # All that is stored initially is "Coeff", the # PDL array is only realised when a boring PDL # function is called on it. One can imagine methods # in PDL::Derived2 doing manipulation on the Coeffs # rather than actualizing the data. our @ISA = qw/PDL/; sub new { my $class = shift; bless {Coeff=>shift, PDL=>\&cache, SomethingElse=>42}, $class; } # Actualize the value (demonstrating cacheing) # One can imagine expiring the cache if say, Coeffs change sub cache { my $self = shift; return $self->{Cache} if exists $self->{Cache}; $self->{Cache} = PDL->ones(@$self{qw(Coeff Coeff)})+2; } } # Create a PDL::Derived2 instance $z = PDL::Derived2->new(5); # PDL::Derived2 should have PDL properties $z++; ok(sum($z)==100, "derived2 has PDL properties"); # And should also have extra bits ok($$z{SomethingElse}==42, "derived2 has extra bits" ); # And survive destruction undef $z; ### tests for proper output value typing of the major ### categories of PDL primitive operations. ### For example: ### If $pdlderived is a PDL::derived object (subclassed from PDL), ### then $pdlderived->sumover should return a PDL::derived object. ### # Test PDL Subclassing via hashes ########### Subclass typing Test ########### ## First define a PDL-derived object: { package PDL::Derived3; our @ISA = qw/PDL::Hash/; sub new { my ($class, $data) = @_; return $class->SUPER::new($data) if ref($data) ne 'PDL'; # if not object, inherited constructor my $self = $class->initialize; $self->{PDL} = $data; $self; } ####### Initialize function. This over-ridden function is called by the PDL constructors sub initialize { my ($class) = @_; my $self = $class->SUPER::initialize; # copy the other stuff: $self->{someThingElse} = ref $class ? $class->{someThingElse} : 42; $self; } } ## Now check to see if the different categories of primitive operations ## return the PDL::Derived3 type. # Create a PDL::Derived3 instance isa_ok $z = PDL::Derived3->new(ones(5,5)), "PDL::Derived3", "create derived instance"; #### Check the type after incrementing: $z++; isa_ok $z, "PDL::Derived3", "check type after incrementing"; #### Check the type after performing sumover: isa_ok $z->sumover, "PDL::Derived3", "check type after sumover"; #### Check the type after adding two PDL::Derived3 objects: my $x = PDL::Derived3->new( ones(5,5) ) ; { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $w = $x + $z; isa_ok $w, "PDL::Derived3", "check type after adding"; is "@w", '', 'no warnings'; } #### Check the type after calling null: isa_ok +PDL::Derived3->null, "PDL::Derived3", "check type after calling null"; ##### Check the type for a biops2 operation: isa_ok +($x == $z), "PDL::Derived3", "check type for biops2 operation"; ##### Check the type for a biops3 operation: isa_ok +($x | $z), "PDL::Derived3", "check type for biops3 operation"; ##### Check the type for a ufuncs1 operation: isa_ok sqrt($z), "PDL::Derived3", "check type for ufuncs1 operation"; ##### Check the type for a ufuncs1f operation: isa_ok sin($z), "PDL::Derived3", "check type for ufuncs1f operation"; ##### Check the type for a ufuncs2 operation: isa_ok ! $z, "PDL::Derived3", "check type for ufuncs2 operation"; ##### Check the type for a ufuncs2f operation: isa_ok log $z, "PDL::Derived3", "check type for ufuncs2f operation"; ##### Check the type for a bifuncs operation: isa_ok $z**2, "PDL::Derived3", "check type for bifuncs operation"; ##### Check the type for a slicing operation: my $a1 = PDL::Derived3->new(1+(xvals zeroes 4,5) + 10*(yvals zeroes 4,5)); isa_ok $a1->slice('1:3:2,2:4:2'), "PDL::Derived3", "check type for slicing operation"; ##### Check that slicing with a subclass index works (sf.net bug #369) $a1 = sequence(10,3,2); my $idx = PDL::Derived3->new(2,5,8); ok(defined(eval 'my $r = $a1->slice($idx,"x","x");'), "slice works with subclass index"); ########### Test of method over-riding in subclassed objects ########### ### Global Variable used to tell if method over-riding worked ### $main::OVERRIDEWORKED = 0; ## First define a PDL-derived object: { package PDL::Derived4; our @ISA = qw/PDL::Hash/; sub new { my ($class, $data) = @_; return $class->SUPER::new($data) if ref($data) ne 'PDL'; # if not object, inherited constructor my $self = $class->initialize; $self->{PDL} = $data; return $self; } ####### Initialize function. This over-ridden function is called by the PDL constructors sub initialize { $::INIT_CALLED = 1; my $class = shift; my $self = $class->SUPER::initialize; # copy the other stuff: $self->{someThingElse} = ref $class ? $class->{someThingElse} : 42; $self; } ### Check of over-riding sumover ### This sumover should be called from PDL->sum. ### If the result is different from the normal sumover by $self->{SomethingElse} (42) then ### we will know that it has been called. sub sumover { my ($self, $out) = @_; return $self->SUPER::sumover + $self->{someThingElse} if !defined $out; # no-argument form of calling $self->SUPER::sumover($out); # if output arg given $out += $self->{someThingElse}; } # test of overriding methods. Calls inherited method and # sets the Global variable main::OVERRIDEWORKED if called for (qw(minmaximum inner which one2nd)) { eval <SUPER::$_(\@_); } EOF } } ###### Testing Begins ######### my $im = PDL::Derived4->new([ [ 1, 2, 3, 3 , 5], [ 2, 3, 4, 5, 6], [13, 13, 13, 13, 13], [ 1, 3, 1, 3, 1], [10, 10, 2, 2, 2,] ]); isa_ok $im, 'PDL::Derived4'; isa_ok $im->flat, 'PDL::Derived4'; { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; # Check overridden sumover called by sum: 134 if PDL::sumover called is $im->sum, 176, "PDL::sumover is called by sum"; is "@w", '', 'no warnings'; } ### Test over-ride of minmaximum: $main::OVERRIDEWORKED = 0; my @minMax = $im->minmax; is $main::OVERRIDEWORKED, 1, "over-ride of minmaximum"; ### Test over-ride of inner: ## Update to use inner, not matrix mult - CED 8-May-2010 $main::OVERRIDEWORKED = 0; my $matMultRes = $im->inner($im); is $main::OVERRIDEWORKED, 1, "over-ride of inner"; ### Test over-ride of which, one2nd $main::OVERRIDEWORKED = 0; # which ND test $a1= PDL::Derived4->sequence(10,10,3,4); ($x, my $y, $z, my $w) = whichND($a1 == 203)->mv(0,-1)->dog; is $main::OVERRIDEWORKED, 1, "whichND worked"; # whitebox test condition, uugh! # Check to see if the clip functions return a derived object: isa_ok $im->clip(5,7), "PDL::Derived4", "clip returns derived object"; isa_ok $im->hclip(5), "PDL::Derived4", "hclip returns derived object"; isa_ok $im->lclip(5), "PDL::Derived4", "lclip returns derived object"; $::INIT_CALLED = 0; my $im2 = $im + 1; ok $::INIT_CALLED, 'yes init'; $::INIT_CALLED = 0; $im++; ok !$::INIT_CALLED, 'no init'; ######## Test of Subclassed-object copying for simple function cases ######## # Set 'someThingElse' Data Member to 24. (from 42) $im->{someThingElse} = 24; # Test to see if simple functions (a functions # with signature sqrt a(), [o]b() ) copies subclassed object correctly. foreach my $op (qw(bitnot sqrt abs sin cos not exp log10)) { $w = $im->$op(); is $w->{someThingElse}, 24, "$op subclassed object correctly"; } done_testing; PDL-2.100/t/ppt-11_memory_mapped.t0000644000175000017500000000213614744321614016461 0ustar osboxesosboxesuse strict; use warnings; BEGIN { use Config; if (! $Config{'useithreads'}) { print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); exit(0); } if (defined $Devel::Cover::VERSION) { print("1..0 # Skip: Devel::Cover no like ithreads\n"); exit(0); } } use threads; use PDL::LiteF; use PDL::Parallel::threads qw(retrieve_pdls); use PDL::IO::FastRaw; use File::Temp qw(tempdir); use File::Spec::Functions; use Test::More; use Test::PDL; my $tmpdir = tempdir( CLEANUP=>1 ); my $name = catfile($tmpdir, "foo.dat"); my $N_threads = 10; mapfraw($name, {Creat => 1, Dims => [$N_threads], Datatype => double}) ->share_as('workspace'); # Spawn a bunch of threads that do the work for us use PDL::NiceSlice; threads->create(sub { my $tid = shift; my $workspace = retrieve_pdls('workspace'); $workspace($tid) .= sqrt($tid + 1); }, $_) for 0..$N_threads-1; # Reap the threads for my $thr (threads->list) { $thr->join; } my $expected = (sequence($N_threads) + 1)->sqrt; my $workspace = retrieve_pdls('workspace'); is_pdl $expected, $workspace, 'Sharing memory mapped ndarrays works'; done_testing; PDL-2.100/t/autoload.t0000644000175000017500000000200714736571600014331 0ustar osboxesosboxes# Test PDL::AutoLoader use strict; use warnings; use Test::More; use PDL::LiteF; use PDL::NiceSlice; use Test::PDL; plan skip_all => 'This test must be run from t/..' if !-f 't/autoload_func.pdl'; use_ok('PDL::AutoLoader'); #$PDL::debug = 1; our @PDLLIB = ("./t"); # this means you have to run the test from t/.. my $x = long(2 + ones(2,2)); is_pdl autoload_func($x), pdl('29 29; 29 29'), 'autoloaded func worked'; { no warnings 'once'; is $::GLOBAL_VAR, '$'.'COMP(max_it)', "NiceSlice didn't mangle text"; } #check that tilde expansion works (not applicable on MS Windows) SKIP: { skip "Inapplicable to MS Windows", 1 if $^O =~ /MSWin/i; my $tilde = (PDL::AutoLoader::expand_path('~'))[0]; my $get = $ENV{'HOME'} || (getpwnam( getlogin || getpwuid($<) ))[7]; my $glob = glob q(~); if ($glob !~ /^~/) { is($tilde, $glob, "Check tilde expansion (Got '$get' from (getpwnam(getpwuid(\$<)))[7] )"); } else { is($tilde, $get, "Check tilde expansion (Got '$glob' from glob ~"); } } done_testing; PDL-2.100/t/ppt-10_physical_piddles.t0000644000175000017500000001157614731223132017142 0ustar osboxesosboxesuse strict; use warnings; BEGIN { use Config; if (! $Config{'useithreads'}) { print("1..0 # Skip: Perl not compiled with 'useithreads'\n"); exit(0); } if (defined $Devel::Cover::VERSION) { print("1..0 # Skip: Devel::Cover no like ithreads\n"); exit(0); } } use threads; use threads::shared; use Test::More; use Test::PDL; use Test::Exception; use PDL::LiteF; use PDL::Parallel::threads qw(retrieve_pdls); # This is a somewhat complicated test script. The goals are to test the # following: # 1) Can we share data for any data type? # 2) Does each thread think it succeeded at setting the data? # 3) Does the end result confirm that each thread changed the data? # 4) Are we prevented from sharing slices? # # Here we allocate shared work space for each PDL data type. We then create # a collection of threads and have each thread modify the contents of one # part of the shared memory. # # While there, each thread does a number of things. It sets a value in the # shared memory, it confirms that the now-set value is correct, and it # builds the hash of expected values from such checks. That last part need # not be done in the threads explicitly, but it makes it easier to write. :-) # # After all the threads return, we check that all the values agree with what # we expect, which is fairly easy (though not entirely trivial) to construct # by hand. I encorporate square-roots into the calculations to ensure good # bit coverage of the tests, at least for the floating point numbers. # # The last step simply confirms that sharing slices croaks, a pretty easy # pair of tests. # Allocate workspace with one extra slot (to verify zeroeth element troubles) my $N_threads = 20; my %workspaces = ( c => sequence(byte, $N_threads, 2)->share_as('workspace_c'), s => sequence(short, $N_threads, 2)->share_as('workspace_s'), n => sequence(ushort, $N_threads, 2)->share_as('workspace_n'), l => sequence(long, $N_threads, 2)->share_as('workspace_l'), q => sequence(longlong, $N_threads, 2)->share_as('workspace_q'), f => sequence(float, $N_threads, 2)->share_as('workspace_f'), d => sequence($N_threads, 2)->share_as('workspace_d'), ); # Remove longlong if Perl doesn't like longlong types eval { pack('q*', 10); } or do { delete $workspaces{q}; }; ############################################### # Spawn a bunch of threads that work together # ############################################### use PDL::NiceSlice; my @success : shared; my @expected : shared; threads->create(sub { my $tid = shift; my (%expected_hash, %success_hash, %bits_hash); for my $type_letter (keys %workspaces) { my $workspace = retrieve_pdls("workspace_$type_letter"); # Build this up one thread at a time $expected_hash{$type_letter} = 1; # Have this thread touch one of the values, and have it double-check # that the value is correctly set my $val = pdl($tid+1)->sqrt + pdl(5)->sqrt; $val = $val->convert($workspace->type->enum); $workspace($tid) .= $val; my $to_test = zeros($workspace->type, 1); $to_test(0) .= $val; $success_hash{$type_letter} = ($workspace->at($tid,0) == $to_test->at(0)); } # Make sure the results for each type have a space in shared memory $expected[$tid] = shared_clone(\%expected_hash); $success[$tid] = shared_clone(\%success_hash); }, $_) for 0..$N_threads-1; # Reap the threads for my $thr (threads->list) { $thr->join; } ######################## # Now test the results # ######################## # Do all the threads think that they were successful at setting their value? is_deeply(\@success, \@expected, 'All threads changed their local values'); # Do the results of all but the zeroeth element agree with what we expect? for my $type_letter (keys %workspaces) { my $workspace = $workspaces{$type_letter}; my $type = $workspace->type; # Allocate the expected results with the proper type my $expected = zeroes($type, $N_threads, 2); # Perform the arithmetic using double precision (on the right side of # this asignment) before down-casting to the workspace's type $expected .= (zeroes($N_threads, 2)->xvals + 1)->sqrt + pdl(5)->sqrt; # Perform an exact comparison. The operations may have high bit coverage, # but they should also be free from bit noise, I hope. is_pdl $workspace, $expected, "Sharing $type ndarrays works"; } ###################################################### # Test croaking behavior for slices of various kinds # ###################################################### # Test what happens when we try to share a slice my $slice = $workspaces{d}->(2:-3); throws_ok { $slice->share_as('slice'); } qr/share_pdls: Could not share an ndarray under.*because the ndarray does not have any allocated memory/ , 'Sharing a slice croaks'; my $rotation = $workspaces{d}->rotate(5); throws_ok { $rotation->share_as('rotation') } qr/share_pdls: Could not share an ndarray under.*because the ndarray does not have any allocated memory/ , 'Sharing a rotation (slice) croaks'; done_testing(); PDL-2.100/t/core.t0000644000175000017500000011167514744321614013462 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use Test::PDL; use PDL::Math; # for polyroots with [phys] params, for dim compat tests use PDL::MatrixOps; # for simq with [phys] params, for dim compat tests use Config; use PDL::Types; use Math::Complex (); use Devel::Peek; for my $type (PDL::Types::types()) { ok defined pdl($type, 0), "constructing PDL of type $type"; ok $type->howbig, "$type has size"; } { my $p = sequence(100); # big enough to not fit in "value" field my $ref = $p->get_dataref; $p->reshape(3); # small enough now $p->upd_data; is_pdl $p, pdl('0 1 2'); my $other_numbers = (sequence(3)+6)->get_dataref; $p->update_data_from($$other_numbers); is_pdl $p, pdl('6 7 8'); $other_numbers = sequence(4)->get_dataref; eval {$p->update_data_from($$other_numbers)}; like $@, qr/but sv length/, 'error if update_data_from wrong size'; } { my $p = sequence(100); # big enough to not fit in "value" field is $p->datasv_refcount, 1; my $ref = $p->get_dataref; $ref = $p->get_dataref; is $p->datasv_refcount, 2; eval {PDL->new_around_datasv(0+$ref, -1)}; like $@, qr/negative/, 'no negative offset'; eval {PDL->new_around_datasv(0+$ref, 2000)}; like $@, qr/>=/, 'no too-big offset'; my $p2 = PDL->new_around_datasv(0+$ref); ok $p2->allocated; is $p2->nbytes, $p->type->howbig * $p->nelem; $p2->set_datatype($p->type->enum); $p2->setdims([$p->dims]); $p2->set_donttouchdata; is $p->datasv_refcount, 3; is $p2->datasv_refcount, 3; undef $p2; is $p->datasv_refcount, 2; undef $ref; is $p->datasv_refcount, 1; my $datasv_ref = \(' ' x 50); my $p3 = PDL->new_around_datasv(0+$datasv_ref, 3); is $p3->nbytes, 47; $p3 = PDL->new_around_datasv(0+$datasv_ref); ok $p3->allocated; $p3->set_datatype(byte->enum); $p3->setdims([50]); $p3->set_donttouchdata; my $refcount = $p3->datasv_refcount; # varies on some Perls is $p3->nbytes, 50; undef $datasv_ref; is $p3->datasv_refcount, $refcount - 1; } { eval {PDL->new_around_pointer(0, 10)}; like $@, qr/NULL pointer/; my $p1 = sequence(5); # too big for value my $p2 = PDL->new_around_pointer($p1->address_data, $p1->nbytes); $p2->set_datatype($p1->type->enum); $p2->setdims([5]); is_pdl $p2, sequence(5), 'new_around_pointer worked'; undef $p2; # make very sure this goes first } { my $pa = pdl 2,3,4; $pa->flowing; my $pb = $pa + $pa; is_pdl $pb, pdl '[4 6 8]'; $pa->set(0,50); is_pdl $pb, pdl '[100 6 8]'; ${$pa->get_dataref} = ${pdl(51,3,4)->get_dataref}; $pa->upd_data; is_pdl $pb, pdl('[102 6 8]'), 'after upd_data, change reflected'; $pa->update_data_from(${pdl(50,3,4)->get_dataref}); is_pdl $pb, pdl('[100 6 8]'), 'after update_data_from, change reflected'; eval {$pa->set_datatype(PDL::float()->enum)}; like $@, qr/ndarray has child/, 'set_datatype if has child dies'; $pb->set_datatype(PDL::float()->enum); $pa->set(0,60); is_pdl $pb, float('[100 6 8]'), 'dataflow broken by set_datatype'; } eval {PDL->inplace}; like $@, qr/called object method/, 'error on PDL->obj_method'; { isa_ok sequence(3)->readonly, 'PDL', 'returns object'; my $x = sequence(3); ok !$x->is_readonly, 'not readonly'; $x->readonly; ok $x->is_readonly, 'now is readonly'; is_pdl $x + 1, pdl '1 2 3'; eval {$x .= 5}; like $@, qr/is read-only/, 'assgn causes error'; eval {$x += 5}; like $@, qr/is read-only/, 'inplace causes error'; } { my $p = sequence(3); my $p2 = sequence(2); eval {$p->set(1,$p2)}; isnt $@, '', 'set(..., $multi_elt) should error'; } { my $p = sequence(5); is Devel::Peek::SvREFCNT($p), 1, 'right refcnt blessed ref'; is Devel::Peek::SvREFCNT($$p), 1, 'right refcnt pointer SV'; } for (@PDL::Core::EXPORT_OK) { next if $_ eq 'mslice'; # bizarrely, this is callable but not "defined" no strict 'refs'; ok defined &{"PDL::Core::$_"}, "PDL::Core-exported $_ exists"; } is sequence(3,2)->dup(0, 2).'', ' [ [0 1 2 0 1 2] [3 4 5 3 4 5] ] ', 'dup'; is sequence(3,2)->dupN(2, 3).'', ' [ [0 1 2 0 1 2] [3 4 5 3 4 5] [0 1 2 0 1 2] [3 4 5 3 4 5] [0 1 2 0 1 2] [3 4 5 3 4 5] ] ', 'dupN'; is sequence(3,2)->inflateN(2, 3).'', ' [ [0 0 1 1 2 2] [0 0 1 1 2 2] [0 0 1 1 2 2] [3 3 4 4 5 5] [3 3 4 4 5 5] [3 3 4 4 5 5] ] ', 'inflateN'; eval { zeroes(0)->max ? 1 : 0 }; like $@, qr/bad.*conditional/, 'badvalue as boolean is error'; { my $a_long = sequence long, 10; my $a_dbl = sequence 10; my $b_long = $a_long->slice('5'); my $b_dbl = $a_dbl->slice('5'); my $c_long = $a_long->slice('4:7'); my $c_dbl = $a_dbl->slice('4:7'); is $b_long->sclr, 5, "sclr test of 1-elem pdl (long)"; is $b_dbl->sclr, 5, "sclr test of 1-elem pdl (dbl)"; eval { $c_long->sclr }; like $@, qr/multielement ndarray in 'sclr' call/, "sclr failed on multi-element ndarray (long)"; eval { $c_dbl->sclr }; like $@, qr/multielement ndarray in 'sclr' call/, "sclr failed on multi-element ndarray (dbl)"; eval { my $d_long = $a_long->reshape(0,-3) }; like $@, qr/invalid dim size/, "reshape() failed with negative args (long)"; eval { my $d_dbl = $a_dbl->reshape(0,-3) }; like $@, qr/invalid dim size/, "reshape() failed with negative args (dbl)"; } eval { my $y = zeroes(1,3); $y .= sequence(2,3); }; isnt $@, '', 'scaling-up of output dim 1 throws error'; eval { my $y = zeroes(1); $y .= zeroes(0) + 1; }; isnt $@, '', 'scaling-down of output dim 1 throws error'; { # test reshape with no args my $x = ones 3,1,4; my $y = $x->reshape; ok eq_array( [ $y->dims ], [3,4] ), "reshape()"; } { # test reshape(-1) and squeeze my $x = ones 3,1,4; my $y = $x->reshape(-1); my $c = $x->squeeze; is_pdl $y->shape, indx([3,4]), "reshape(-1)"; is_pdl $y, $c, "squeeze"; $c++; # check dataflow in reshaped PDL is_pdl $y, $c, "dataflow"; # should flow back to y is_pdl $x, pdl(2)->slice('*3,*1,*4'), "dataflow"; } { my $d = pdl(5); # zero dim ndarray and reshape/squeeze is_pdl $d->reshape(-1)->shape, empty(indx), "reshape(-1) on 0-dim PDL gives 0-dim PDL"; is_pdl $d->reshape(1)->shape, indx([1]), "reshape(1) on 0-dim PDL gives 1-dim PDL"; is_pdl $d->reshape(1)->reshape(-1)->shape, empty(indx), "reshape(-1) on 1-dim, 1-element PDL gives 0-dim PDL"; } { # reshape test related to bug SF#398 "$pdl->hdr items are lost after $pdl->reshape" my $c = ones(25); $c->hdr->{demo} = "yes"; is($c->hdr->{demo}, "yes", "hdr before reshape"); $c->reshape(5,5); is($c->hdr->{demo}, "yes", "hdr after reshape"); } eval {zeroes(0,-2)}; like $@, qr/non-negative/, 'negative dim to zeroes gives clear error'; eval {empty->squeeze->dims}; is $@, '', 'can "squeeze" an empty'; eval {empty->copy->make_physical}; is $@, '', 'can physicalise the copy of an empty'; # capture ancient pptest.t test for Solaris segfault is_pdl norm(pdl 3,4), pdl(0.6,0.8), 'vector quasi-copy works'; # pptest for null input eval {(my $tmp=null) .= null}; like $@, qr/input.*null/; # pptest for OtherPars=>named dim is_pdl +(5*sequence(5))->maximum_n_ind(3), indx(4,3,2), 'named dim'; # pptest for dim with fixed value is_pdl crossp([1..3],[4..6]), longlong(-3,6,-3), {test_name=>'named dim=3', require_equal_types=>0}; eval {simq(null, zeroes(3), 0)}; like $@, qr/io.*null/; subtest 'dim compatibility' => sub { for ( # non-phys params [\&append, [zeroes(1), zeroes(1), zeroes(1)], 2, qr/dim has size 1/, 'output=[1]; required [2]. output too small'], [\&append, [pdl(1), pdl(2), null], 2, [ 1, 2 ], 'output=null; required [2]'], [\&append, [pdl(1), pdl(2), zeroes(2)], 2, [ 1, 2 ], 'output=[2]; required [2]'], [\&append, [zeroes(1), zeroes(1), zeroes(3)], 2, qr/dim has size 3/, 'output=[3]; required [2]. output too large'], [\&append, [zeroes(1), zeroes(0), zeroes()], 2, 0, 'output=scalar; required [1]'], [\&append, [zeroes(1), zeroes(1), zeroes()], 2, qr/can't broadcast/, 'output=scalar; required [2]. output too small'], [\&append, [zeroes(1), zeroes(1), zeroes(1,1)], 2, qr/dim has size 1/, 'output=[1,1]; required [2]. output too small'], [\&append, [pdl(1), pdl(2), zeroes(2,1)], 2, [[ 1, 2 ]], 'output=[2,1]; required [2]'], [\&append, [zeroes(1), zeroes(1), zeroes(3,1)], 2, qr/dim has size 3/, 'output=[3,1]; required [2]. output too large'], [\&append, [zeroes(1), zeroes(1), zeroes(1,2)], 2, qr/dim has size 1/, 'output=[1,2]; required [2]. output too small'], [\&append, [zeroes(1), zeroes(1), zeroes(2,2)], 2, [[ 0, 0 ], [ 0, 0 ]], 'output=[2,2]; required [2]. input without that dim broadcasted up'], [\&append, [zeroes(1,2), zeroes(1), zeroes(2,2)], 2, [[ 0, 0 ], [ 0, 0 ]], 'output=[2,2]; required [2]. one input without that dim broadcasted up'], [\&append, [zeroes(1,3), zeroes(1), zeroes(2,2)], 2, qr/Mismatch/, 'input=[1,3] output=[2,2]. input with mismatched broadcast dim'], [\&append, [zeroes(1,2), zeroes(1), zeroes(2,1)], 2, qr/implicit dim/, 'output=[2,1]; required [2,2]. output too small in broadcast dim'], [\&append, [zeroes(1,2), zeroes(1), zeroes(2)], 2, qr/implicit dim/, 'output=[2,1]; required [2,2]. output too small in broadcast implicit dim'], [\&append, [zeroes(1,2), zeroes(1,2), zeroes(2,1)], 2, qr/implicit dim/, 'output=[2,1]; required [2,2]. output too small in broadcast dim'], [\&append, [zeroes(1,2), zeroes(1,2), zeroes(2)->dummy(1,2)], 2, qr/implicit dim/, 'output=[2,*2]; required [2,2]. output into dummy implicit dim'], [\&append, [zeroes(1,2), zeroes(1,2), zeroes(2)->dummy(1,2)->make_physical], 2, qr/implicit dim/, 'output=[2,*2](phys); required [2,2]. output into dummy implicit dim'], [\&append, [zeroes(1,2), zeroes(1,2), zeroes(2)->dummy(0,2)], 2, qr/over dummy dim/, 'output=[*2,2]; required [2,2]. output into dummy active dim'], [\&append, [zeroes(1,2), zeroes(1,2), zeroes(2)->dummy(0,2)->make_physical], 2, qr/over dummy dim/, 'output=[*2,2](phys); required [2,2]. output into dummy active dim'], # phys params [\&polyroots, [ones(2), zeroes(2), zeroes(1), zeroes(1)], 2, [-1], '[phys] output=[1]'], [\&polyroots, [ones(2), zeroes(1), zeroes(), zeroes(1)], 2, qr/dim has size 1/, '[phys] output=[2] mismatch'], [\&polyroots, [ones(2), zeroes(1), zeroes(1), zeroes(1)], 2, qr/dim has size 1/, '[phys] output=[2] mismatch'], [\&polyroots, [ones(2), zeroes(2), zeroes(2), zeroes(2)], 2, qr/dim has size 2/, '[phys] output=[2] mismatch'], [\&polyroots, [ones(2), zeroes(2), zeroes(1,2), zeroes(1)], 2, qr/implicit dim/, '[phys] one outputs=[1,2],[1] no promote output implicit dims'], [\&polyroots, [ones(2), zeroes(2,2), zeroes(1,2), zeroes(1,2)], 2, [[-1],[-1]], '[phys] output=[1,2] ok broadcast over input'], [\&polyroots, [ones(2), zeroes(2,2), zeroes(1), zeroes(1,2)], 2, qr/implicit dim/, '[phys] output=[1,2] not ok broadcast over output implicit dim'], [\&polyroots, [ones(2), zeroes(2,2), zeroes(1,1), zeroes(1,2)], 2, qr/implicit dim/, '[phys] outputs=[1,1],[1,2] not ok broadcast over output explicit dim'], # phys params with (n,n) [\&simq, [identity(3)+1, sequence(3,1), null, null, 0], 2, [[-0.75,0.25,1.25]], '[phys] output=[3,3]'], [\&simq, [pdl([[2,1,1]]), sequence(3,1), null, null, 0], 2, qr/dim has size/, '[phys] input=[3,1] output=[3,3] no expand input phys multi-used dim of 1'], [\&simq, [identity(3)+1, sequence(3,2), null, null, 0], 2, qr/implicit dim/, '[phys] inputs:n,n=[3,3],n=[3,2] no broadcast over [io]'], ) { my ($func, $args, $exp_index, $exp, $label) = @$_; if (ref $exp eq 'Regexp') { throws_ok { $func->( @$args ) } $exp, $label; } else { $func->( @$args ); my $got = $args->[$exp_index]; is_pdl $got, pdl($exp), $label; } } }; { # test topdl { package # hide from PAUSE PDL::Trivial; our @ISA = qw(PDL); sub new {bless {PDL=>PDL->SUPER::new(@_[1..$#_])}} # like PDL::DateTime } my $subobj = PDL::Trivial->new(6); isa_ok $subobj, 'PDL::Trivial'; isa_ok +PDL->topdl($subobj), 'PDL::Trivial'; isa_ok $subobj->inplace, 'PDL::Trivial'; isa_ok +PDL->topdl(1), "PDL", "topdl(1) returns an ndarray"; isa_ok +PDL->topdl([1,2,3]), "PDL", "topdl([1,2,3]) returns an ndarray"; isa_ok +PDL->topdl(1,2,3), "PDL", "topdl(1,2,3) returns an ndarray"; is_pdl +PDL->topdl(1,2,3), pdl(1,2,3), "topdl(1,2,3) returns a 3-ndarray containing (1,2,3)"; eval {PDL->topdl({})}; isnt $@, '', 'topdl({}) no segfault'; } is_pdl pdl(1)->tocomplex, cdouble(1), 'tocomplex'; is_pdl cdouble(1)->tocomplex, cdouble(1), 'tocomplex already complex'; is_pdl float(1)->tocomplex, cfloat(1), 'tocomplex float'; is_pdl cfloat(1)->tocomplex, cfloat(1), 'tocomplex float already complex'; # stringification { my $x = pdl( -3..2 ) + 1e7; my $x_indx = $x->indx; is $x_indx.'', "[9999997 9999998 9999999 10000000 10000001 10000002]"; my $x_indx_bad = $x_indx->copy; $x_indx_bad->setbadat($_) for 1, 4; is $x_indx_bad.'', "[9999997 BAD 9999999 10000000 BAD 10000002]"; is +($x_indx - 10).'', "[9999987 9999988 9999989 9999990 9999991 9999992]"; is +($x_indx)->splitdim(0,3).'', "\n[\n [ 9999997 9999998 9999999]\n [ 10000000 10000001 10000002]\n]\n"; is +($x_indx - 10)->splitdim(0,3).'', "\n[\n [9999987 9999988 9999989]\n [9999990 9999991 9999992]\n]\n"; is +($x_indx_bad)->splitdim(0,3).'', "\n[\n [ 9999997 BAD 9999999]\n [ 10000000 BAD 10000002]\n]\n"; is +($x_indx_bad - 10)->splitdim(0,3).'', "\n[\n [9999987 BAD 9999989]\n [9999990 BAD 9999992]\n]\n"; my $x_double = where( $x, $x > 1e7 - 4 ); is $x_double.'', "[9999997 9999998 9999999 10000000 10000001 10000002]"; is +($x_double - 10).'', "[9999987 9999988 9999989 9999990 9999991 9999992]"; is +($x_double)->splitdim(0,3).'', "\n[\n [ 9999997 9999998 9999999]\n [ 10000000 10000001 10000002]\n]\n"; is +($x_double - 10)->splitdim(0,3).'', "\n[\n [9999987 9999988 9999989]\n [9999990 9999991 9999992]\n]\n"; my $x_long = where( long($x), $x > 1e7 - 4 ); is $x_long.'', "[9999997 9999998 9999999 10000000 10000001 10000002]"; is +($x_long - 10).'', "[9999987 9999988 9999989 9999990 9999991 9999992]"; is +($x_long)->splitdim(0,3).'', "\n[\n [ 9999997 9999998 9999999]\n [10000000 10000001 10000002]\n]\n"; is +($x_long - 10)->splitdim(0,3).'', "\n[\n [9999987 9999988 9999989]\n [9999990 9999991 9999992]\n]\n"; my $fracs = sequence(9) / 16; is $PDL::doubleformat, "%10.8g"; is $fracs.'', "[0 0.0625 0.125 0.1875 0.25 0.3125 0.375 0.4375 0.5]"; is $fracs->string($PDL::doubleformat).'', "[ 0 0.0625 0.125 0.1875 0.25 0.3125 0.375 0.4375 0.5]"; { local $PDL::doubleformat = '%8.2g'; is $fracs.'', "[0 0.0625 0.125 0.1875 0.25 0.3125 0.375 0.4375 0.5]"; is $fracs->string($PDL::doubleformat).'', "[ 0 0.062 0.12 0.19 0.25 0.31 0.38 0.44 0.5]"; } # from Data::Frame { my $_pdl_stringify_temp = PDL::Core::pdl([[0]]); my $_pdl_stringify_temp_single = PDL::Core::pdl(0); sub element_stringify { my ($self, $element) = @_; return $_pdl_stringify_temp_single->set(0, $element)->string if $self->ndims == 0; # otherwise ( $_pdl_stringify_temp->set(0,0, $element)->string =~ /\[(.*)\]/ )[0]; } } sub element_stringify_max_width { my ($self) = @_; my @vals = @{ $self->uniq->unpdl }; my @lens = map { length element_stringify($self, $_) } @vals; max( pdl @lens )->sclr; } for (1.23456789, 1.2345678901, 1.23456789012) { my $ndim = length( pdl([ $_ ])->string ) - 2; is element_stringify_max_width(pdl([ $_ ])), $ndim, "length right for [$_]"; is element_stringify_max_width(pdl([[ $_ ]])), $ndim, "length right for [[$_]]"; } } # test $PDL::undefval support in pdl (bug #886263) is $PDL::undefval, 0, "default value of \$PDL::undefval is 0"; { my $x = [ [ 2, undef ], [3, 4 ] ]; my $y = pdl($x); my $c = pdl([[2, 0],[3, 4]]); is_pdl $y, $c, "undef converted to 0 (dbl)"; is_deeply $x, [[2,undef],[3,4]], "pdl() has not changed input array"; is_pdl long($x), long($c), "undef converted to 0 (long)"; } { local($PDL::undefval) = -999; my $x = [ [ 2, undef ], [3, 4 ] ]; my $y = pdl($x); my $c = pdl('2 -999; 3 4'); is_pdl $y, $c, "undef converted to -999 (dbl)"; is_pdl long($x), long($c), "undef converted to -999 (long)"; }; { # Funky constructor cases # pdl of a pdl is_pdl pdl(pdl(5)), pdl(5), "pdl() can piddlify an ndarray"; is_pdl pdl(null), null, 'pdl(null) gives null'; is_pdl pdl(null, null), zeroes(0,2), 'pdl(null, null) gives empty'; # pdl of mixed-dim pdls: pad within a dimension is_pdl pdl( zeroes(5), ones(3) ), pdl([0,0,0,0,0],[1,1,1,0,0]),"Piddlifying two ndarrays concatenates them and pads to length"; # pdl of mixed-dim pdls: pad a whole dimension is_pdl pdl( [[9,9],[8,8]], xvals(3)+1 ), pdl([[[9,9],[8,8],[0,0]] , [[1,0],[2,0],[3,0]] ]),"can concatenate mixed-dim ndarrays"; # pdl of mixed-dim pdls: a hairier case is_pdl pdl([1], pdl[2,3,4], pdl[5]), pdl([[[1,0,0],[0,0,0]],[[2,3,4],[5,0,0]]]),"Can concatenate mixed-dim ndarrays: hairy case"; } # same thing, with undefval set differently { local($PDL::undefval) = 99; my $c = pdl undef; is_pdl $c, pdl(99), "explicit, undefval of 99 works"; $c = pdl [1], pdl[2,3,4], pdl[5]; is_pdl $c, pdl([[[1,99,99],[99,99,99]],[[2,3,4],[5,99,99]]]), "implicit, undefval works for padding"; $PDL::undefval = undef; $c = pdl undef; is_pdl $c, pdl(0), "explicit, undefval of undef falls back to 0"; $c = pdl [1], [2,3,4]; is_pdl $c, pdl([1,0,0],[2,3,4]), "implicit, undefval of undef falls back to 0"; $PDL::undefval = inf; $c = pdl undef; is_pdl $c, inf, "explicit, undefval of PDL scalar works"; $c = pdl [1], [2,3,4]; is_pdl $c, pdl([1,inf,inf],[2,3,4]), {rtol=>0, test_name=>"implicit, undefval of a PDL scalar works"}; } { # empty pdl cases my $x = eval {zeroes(2,0,1);}; is($@, '', "zeroes accepts empty PDL specification"); my $y = pdl($x,sequence(2,0,1)); is_pdl $y->shape, indx(2,0,1,2), "concatenating two empties gives an empty"; $y = pdl($x,sequence(2,1,1)); is_pdl $y->shape, indx(2,1,1,2), "concatenating an empty and a nonempty treats the empty as a filler"; $y = pdl($x,5); is_pdl $y->shape, indx(2,1,1,2), "concatenating an empty and a scalar on the right works"; $y = pdl(5,$x); is_pdl $y, pdl([[[5,0]]],[[[0,0]]]), "concatenating an empty and a scalar on the left gives the right answer"; } # cat problems eval {cat(1, pdl(1,2,3), {}, 6)}; isnt $@, '', 'cat barfs on non-ndarray arguments'; like $@, qr/Arguments 0, 2 and 3 are not ndarrays/, 'cat correctly identifies non-ndarray arguments'; eval {cat(1, pdl(1,2,3))}; like $@, qr/Argument 0 is not an ndarray/, 'cat uses good grammar when discussing non-ndarrays'; { my $two_dim_array = cat(pdl(1,2), pdl(1,2)); eval {cat(pdl(1,2,3,4,5), $two_dim_array, pdl(1,2,3,4,5), pdl(1,2,3))}; isnt($@, '', 'cat barfs on mismatched ndarrays'); like($@, qr/The dimensions of arguments 1 and 3 do not match/ , 'cat identifies all ndarrays with differing dimensions'); like ($@, qr/\(argument 0\)/, 'cat identifies the first actual ndarray in the arg list'); eval {cat(pdl(1,2,3), pdl(1,2))}; like($@, qr/The dimensions of argument 1 do not match/ , 'cat uses good grammar when discussing ndarray dimension mismatches'); eval {cat(1, pdl(1,2,3), $two_dim_array, 4, {}, pdl(4,5,6), pdl(7))}; isnt($@, '', 'cat barfs combined screw-ups'); like($@, qr/Arguments 0, 3 and 4 are not ndarrays/ , 'cat properly identifies non-ndarrays in combined screw-ups'); like($@, qr/arguments 2 and 6 do not match/ , 'cat properly identifies ndarrays with mismatched dimensions in combined screw-ups'); like($@, qr/\(argument 1\)/, 'cat properly identifies the first actual ndarray in combined screw-ups'); } is_pdl cat(pdl(1),pdl(2,3)), pdl([1,1],[2,3]), "cat does the right thing with catting a 0-pdl and 2-pdl together"; { my $lo=sequence(long,5)+32766; my $so=sequence(short,5)+32766; my $fl=sequence(float,5)+float(0.2); # 0.2 is an NV so now a double my $by=sequence(byte,5)+253; my @list = ($lo,$so,$fl,$by); my $c2 = cat(@list); is($c2->type,'float','concatenating different datatypes returns the highest type'); is_pdl $_, shift @list, {require_equal_types=>0, test_name=>"cat/dog symmetry for values"} for $c2->dog; my ($dogcopy) = $c2->dog({Break=>1}); $dogcopy++; is_pdl $dogcopy, $c2->slice(':,(0)')+1, 'Break means copy'; # not lo as cat no flow my ($dogslice) = $c2->dog; $dogslice++; is_pdl $dogslice, $c2->slice(':,(0)'), 'no Break means dataflow'; eval {pdl([3])->dog(5)}; like $@, qr/Usage/, "error if excess args"; for ([[], qr/at least/], [[5]], [[4,5]]) { my ($dims, $err) = @$_; my @d = eval {zeroes(@$dims)->dog}; like($@, $err, "right error (@$dims)"), next if $err; is 0+@d, $dims->[-1], "works (@$dims)"; } @list = pdl('[3;0;2;0]')->mv(0,-1)->dog; is 0+@list, 1, "dog on pure-vaff works"; } zeroes(1,1000)->dog; # no segfault please { my $x = sequence(byte,5); $x->inplace; ok $x->is_inplace,"original item inplace-d true inplace flag"; eval { $x->inplace(1) }; is $@, '', 'passing spurious extra args no error'; my $y = $x->copy; ok $x->is_inplace,"original item true inplace flag after copy"; ok !$y->is_inplace,"copy has false inplace flag"; $y++; is_pdl $y, sequence(byte,5)+1,"copy returns severed copy of the original thing if inplace is set"; ok $x->is_inplace,"original item still true inplace flag"; ok !$y->is_inplace,"copy still false inplace flag"; is_pdl $x, sequence(byte,5),"copy really is severed"; } { # new_or_inplace my $x = sequence(byte,5); my $y = $x->new_or_inplace; is_pdl $y, $x, "new_or_inplace with no pref returns something like the orig."; $y++; is_pdl $y, $x+1, "new_or_inplace with no inplace flag returns something disconnected from the orig."; $y = $x->new_or_inplace("float,long"); is $y->type, 'float',"new_or_inplace returns first type in case of no match"; $y = $x->inplace->new_or_inplace; $y++; is_pdl $y, $x, "new_or_inplace returns the original thing if inplace is set"; ok !$y->is_inplace,"new_or_inplace clears the inplace flag"; } { # check empty creation is empty(float)->type, 'float', 'empty(float) works'; my $empty = empty(); is $empty->type->enum, 0, 'empty() gives lowest-numbered type'; is $empty->nelem, 0, "you can make an empty PDL with zeroes(0)"; like "$empty", qr/Empty/, "an empty PDL prints 'Empty'"; my $null = null; is $null->nbytes, 0, 'a null has 0 nbytes'; is $null->info, 'PDL->null', "null ndarray's info is 'PDL->null'"; my $mt_info = $empty->info; $mt_info =~m/\[([\d,]+)\]/; my $mt_info_dims = pdl("$1"); ok(any($mt_info_dims==0), "empty ndarray's info contains a 0 dimension"); { is($PDL::infoformat, "%C: %T %D", "check default info format"); local $PDL::infoformat = "default info format for %C"; is(pdl(2, 3)->info, "default info format for PDL", "use default info format"); } ok($null->isnull, "a null ndarray is null"); ok($null->isempty, "a null ndarray is empty") or diag $null->info; ok(!$empty->isnull, "an empty ndarray is not null"); ok($empty->isempty, "an empty ndarray is empty"); eval { $null->long }; like $@, qr/null/, 'null->long gives right error'; } { my $x = short(3,4,5,6); eval { $x->reshape(2,2);}; is($@, '', "reshape succeeded in the normal case"); is_pdl $x, short([[3,4],[5,6]]), "reshape moved the elements to the right place"; my $y = $x->slice(":,:"); eval { $y->reshape(4); }; unlike $@, qr/Can't/, "reshape doesn't fail on a PDL with a parent"; my $nzai = zeroes(indx,6)->slice(''); eval {$nzai = $nzai->reshape(30)}; is $@, '', 'no reshape error'; } { my $pb = sequence(2,3); is(($pb->dims)[0], 2); is(($pb->dims)[1], 3); note $pb; is $pb->at(1,1), 3; is $pb->at(1,2), 5; eval {$pb->at(2,1)}; like $@, qr/Position 2 at dimension 0 out of range/; is $pb->at(-1,2), 5; } for my $array ( 1, [], [1..3], [[[1,2], [3,4]], [[5,6], [7,8]], [[9,10], [11,12]]], ) { my ($expected, $got) = ref $array ? $array : [$array]; # scalar not round-tripped right but back-compat is_deeply $got = pdl($array)->unpdl, $expected, "back convert ".join('', explain $array) or diag explain $got; } SKIP: { skip("your perl hasn't 64bit int support", 6) if $Config{ivsize} < 8; { my $neg = -684394069604; my $straight_pdl = pdl($neg); my $multed = pdl(1) * $neg; is $straight_pdl, $multed, 'upgrade of large negative SV to ndarray' or diag "straight:", $straight_pdl->info, " mult:", $multed->info; } { my $fromuv_r = pdl('10223372036854775507'); ok $fromuv_r > 0, 'UV real > 0'; my $fromuv_c = pdl('10223372036854775507i'); ok $fromuv_c->im > 0, 'UV complex->real > 0' or diag "fromuv_c=$fromuv_c\nfromuv_c->im=", $fromuv_c->im, "\nfromuv_r=$fromuv_r"; $fromuv_c = pdl('2+10223372036854775507i'); ok $fromuv_c->im > 0, 'UV complex->real > 0 with some real' or diag "fromuv_c=$fromuv_c\nfromuv_c->im=", $fromuv_c->im, "\nfromuv_r=$fromuv_r"; } my $input = [ -9223372036854775808, #min int64 -9000000000000000001, -9000000000000000002, -9000000000000000003, -9000000000000000004, -9000000000000000005, -8999999999999999999, -8999999999999999998, -8999999999999999997, -8999999999999999996, -1000000000000000001, -2147483648, #min int32 2147483647, #max int32 4294967295, #max uint32 1000000000000000001, 9000000000000000001, 9000000000000000002, 9000000000000000003, 9000000000000000004, 9000000000000000005, 8999999999999999999, 8999999999999999998, 8999999999999999997, 8999999999999999996, 9223372036854775807, #max int64 ]; is_deeply(longlong($input)->unpdl, $input, 'back convert of 64bit integers'); my $small_pdl = longlong([ -9000000000000000001, 9000000000000000001 ]); is($small_pdl->at(0), -9000000000000000001, 'at/1'); is(PDL::Core::at_c($small_pdl, [1]), 9000000000000000001, 'at_c back-compat'); is(PDL::Core::at_bad_c($small_pdl, [1]), 9000000000000000001, 'at_bad_c/1'); $small_pdl->set(0, -8888888888888888888); PDL::Core::set_c($small_pdl, [1], 8888888888888888888); is($small_pdl->at(0), -8888888888888888888, 'at/2'); is(PDL::Core::at_bad_c($small_pdl, [1]), 8888888888888888888, 'at_bad_c/2'); is_deeply($small_pdl->unpdl, [ -8888888888888888888, 8888888888888888888 ], 'unpdl/small_pdl'); } { my $big_ushort = ushort(65535); is $big_ushort->badflag, 0, 'max ushort value badflag'; is PDL::Core::at_bad_c($big_ushort, []), 65535, 'max ushort value not "BAD" per se'; } { my $x = cdouble(2, 3); PDL::Core::set_c($x, [1], i); is $x.'', '[2 i]', 'set_c can take ndarray value'; } { my $x = cdouble(2, Math::Complex::i()); is $x.'', '[2 i]', 'type constructor can take Math::Complex value'; $x = pdl(Math::Complex::cplx(2, 0), Math::Complex::i()); is $x.'', '[2 i]', 'pdl defaults to cdouble if Math::Complex values'; $x = pdl([Math::Complex::cplx(2, 0), Math::Complex::i()]); is $x.'', '[2 i]', 'pdl defaults to cdouble if Math::Complex values in arrayref'; } sub hdr_test { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($pb, $hdr, $method) = @_; $method ||= 'gethdr'; note "pb: ", explain my $pbh=$pb->$method; is_deeply($pbh,$hdr); } { my $pa = zeroes(20); $pa->hdrcpy(1); my $hdr = {Field1=>'arg1', Field2=>'arg2'}; $pa->sethdr($hdr); note "pa: ", explain $pa->gethdr(); ok($pa->hdrcpy); hdr_test($pa+1, $hdr); hdr_test(ones(20) + $pa, $hdr); hdr_test($pa->slice('0:5'), $hdr); hdr_test($pa->copy, $hdr); $pa->hdrcpy(0); hdr_test($pa->slice('3'), {}, 'hdr'); hdr_test($pa->slice('3'), undef); } { my $pa = pdl 42.4; note "A is $pa"; is($pa->get_datatype,$PDL_D, "A is double"); my $pb = byte $pa; note "B (byte $pa) is $pb"; is($pb->get_datatype,$PDL_B, "B is byte"); is($pb->at(),42, 'byte value is 42'); my $pc = $pb * 3; is($pc->get_datatype, $PDL_B, "C also byte"); note "C ($pb * 3) is $pc"; my $pd = $pb * 600.0; is($pd->get_datatype, $PDL_D, "pdl-ed NV is double, D promoted to double"); note "D ($pb * 600) is $pd"; my $pi = 4*atan2(1,1); my $pe = $pb * $pi; is($pe->get_datatype, $PDL_D, "E promoted to double (needed to represent result)"); note "E ($pb * PI) is $pe"; my $pf = $pb * "-2.2"; is($pf->get_datatype, $PDL_D, "F check string handling"); note "F ($pb * string(-2.2)) is $pf"; } { for my $type ( { typefunc => *byte , size => 1 }, { typefunc => *short , size => 2 }, { typefunc => *ushort, size => 2 }, { typefunc => *long , size => 4 }, { typefunc => *float , size => 4 }, { typefunc => *double, size => 8 }, ) { is $type->{typefunc}()->howbig, $type->{size}, 'howbig method works'; my $pdl = $type->{typefunc}(42); # build a PDL with datatype $type->{type} is( PDL::Core::howbig( $pdl->get_datatype ), $type->{size} ); is $pdl->type, $type->{typefunc}->().'', 'pdl has right type'; is_pdl $pdl->convert(longlong), longlong(42), 'converted to longlong same value'; $pdl->inplace->convert(longlong); is_pdl $pdl, longlong(42), 'inplace convert worked'; } } { is_pdl pdl(-3)->ushort, ushort(-3), 'convert negative to ushort right'; ok pdl(-3)->ushort, 'convert negative to ushort non-zero'; my $p = pdl(-3); $p->inplace->convert(ushort); is_pdl $p, ushort(-3), 'inplace convert negative to ushort right'; ok $p, 'inplace convert negative to ushort non-zero'; } for (['ones', 1], ['zeroes', 0], ['nan', '.*NaN'], ['inf', '.*Inf'], ['i', 'i', 'cdouble']) { my ($name, $val, $type) = @$_; no strict 'refs'; my $g = eval { $name->() }; is $@, '', "$name works with no args"; is_deeply [$g->dims], [], 'no args -> no dims'; ok !$g->isnull, 'no args -> not null'; ok !$g->isempty, 'no args -> not empty'; like $g.'', qr/^$val/i, "$name() gives back right value"; my $g1 = eval { $name->(2) }; is $@, '', "$name works with 1 args"; is_deeply [$g1->dims], [2], 'right dims'; # from PDL::Core docs of zeroes my (@dims, $w) = (1..3); $w = $name->(byte, @dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'byte'; ok $w->allocated, "$name(type, dims) is allocated"; $w = $name->(@dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'double'; ok $w->allocated, "$name(dims) is allocated"; $w = PDL->$name(byte, @dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'byte'; ok $w->allocated, "PDL->$name(type, dims) is allocated"; $w = PDL->$name(@dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'double'; ok $w->allocated, "PDL->$name(dims) is allocated"; my $pdl = ones(float, 4, 5); $w = $pdl->$name(byte, @dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'byte'; # usage type (ii): my $y = ones(@dims); $w = $name->($y); is_deeply [$w->dims], \@dims; $w = $y->$name; is_deeply [$w->dims], \@dims; next if $val =~ /\D/; my $exp = pdl($val)->slice('*1,*2,*3'); $w = $y->copy; $name->(inplace $w); is_pdl $w, $exp, $name; $w = $y->copy; $w->inplace->$name; is_pdl $w, $exp, $name; } is short(1)->zeroes->type, 'short', '$existing->zeroes right type'; eval { PDL->is_inplace }; # shouldn't infinite-loop isnt $@, '', 'is_inplace as class method throws exception'; { my $s = sequence(3); is $s->trans_parent, undef, 'trans_parent without trans undef'; my $slice = $s->slice; isnt +(my $tp=$slice->trans_parent), undef, 'trans_parent with trans defined'; is 0+$s->trans_children, 1, 'scalar trans_children'; is ${($s->trans_children)[0]}, $$tp, 'correct trans_children'; my @parents = $tp->parents; is ${$parents[0]}, $s->address, 'correct parent ndarray'; my @children = $tp->children; is ${$children[0]}, $slice->address, 'correct child ndarray'; my $vtable = $tp->vtable; isnt $vtable->name, undef, 'trans vtable has a name'; isnt PDL::Core::pdump($slice), undef, 'pdump works'; isnt PDL::Core::pdump_trans($tp), undef, 'pdump_trans works'; isnt PDL::Core::pdumphash($slice), undef, 'pdumphash works with ndarray'; isnt PDL::Core::pdumphash($tp), undef, 'pdumphash works with trans'; my @pn = $vtable->par_names; is 0+@pn, 2, 'par_names returned 2 things'; my $roots = pdl '[1 2i 3i 4i 5i]'; eval {PDL::Core::pdump($roots)}; # gave "panic: attempt to copy freed scalar" is $@, ''; } { my $x = sequence 3; my $y = $x->flowing + 1; isnt $y->trans_parent, undef, '$y has parent'; isnt PDL::Core::pdumphash($x), undef, 'pdumphash works'; isnt $y->trans_parent, undef, '$y still has parent after pdumphash'; $x += 3; is_pdl $x, pdl("[3 4 5]"), '$x right value'; is_pdl $y, pdl("[4 5 6]"), '$y right value'; ok !$y->fflows, 'y not "flowing"'; $y->flowing; ok $y->fflows, 'y "flowing" on'; my $z = $y + 1; isnt $z->trans_parent, undef, 'z has trans_parent'; ok !$y->fflows, 'y "flowing" off again'; eval {$y += 4}; isnt $@, '', 'error on assigning to ndarray with inward but no outward flow'; my $oneway_slice = $y->slice('0:1'); is_pdl $oneway_slice, pdl '[4 5]'; eval {$oneway_slice .= 11}; isnt $@, '', 'error on assigning into one-way slice'; ok $y->flowing->_convert_int(cdouble->enum)->fflows, 'flowing -> converted has "flowing" on'; } { my $x = sequence 3; my $c = $x->_convert_int(cdouble->enum); isnt $c->trans_parent, undef, 'converted has trans_parent'; $c++; is_pdl $x, pdl(1..3); my $cf = $c->_convert_int(cfloat->enum); isnt $cf->trans_parent, undef, 'converted2 has trans_parent'; $cf++; is_pdl $x, pdl(2..4); } { my $o_float = PDL::plus(float(1), float(2)); is_pdl $o_float, float(3); # 3-arg is (a,b,swap); 4-arg is (a,b,output,swap) PDL::plus(float(1), float(2), $o_float = null, 0); is_pdl $o_float, float(3); PDL::plus(float(1), float(2), my $o_double = double(0), 0); is_pdl $o_double, pdl(3); is 0+$o_double->trans_children, 0, 'no trans_children from non-flowing'; PDL::plus(my $i_float = float(1)->flowing, float(2), $o_double = double(0), 0); is +($i_float->trans_children)[0]->vtable->name, 'converttypei_new', 'input trans_children[0] is convert output type > inputs'; is_pdl $o_double, pdl(3); is $o_double->trans_parent->vtable->name, 'PDL::Ops::plus', 'right trans_parent from flowing output type > inputs'; is 0+$o_double->trans_children, 0, '0 trans_children on output from flowing'; PDL::plus(my $i_double = double(1)->flowing, double(2), $o_float = float(0), 0); is +($i_double->trans_children)[0]->vtable->name, 'converttypei_new', 'input.trans_children[0] IS convert from flowing output type < inputs'; is_pdl $o_float, float(3), 'output right from flowing output type < inputs'; is $o_float->trans_parent->vtable->name, 'PDL::Ops::plus', 'trans_parent of output is plus from flowing output type < inputs'; is 0+$o_float->trans_children, 0, '0 trans_children on output from flowing output type < inputs'; is_pdl +(sequence(2,2)->simq(pdl('4 9'),0))[0], pdl('-1.5 4'), 'unconverted [io] works'; is_pdl +(sequence(2,2)->float->simq(pdl('4 9'),0))[0], pdl('-1.5 4'), 'converted [io] works'; my $double_mask = double('0 0 1 1 1 1 1'); $double_mask &= double('1 1 1 1 1 0 0'); is_pdl $double_mask, double('0 0 1 1 1 0 0'); eval {PDL::eqvec(double([1,2]), double([1,2]), float(0)->slice(''))}; like $@, qr/cannot convert/, "error when flowing xform given non-available-typed output with parent"; PDL::eqvec(double([1,2])->flowing, double([1,2]), $o_float = float(0)); is 0+$o_float->trans_children, 0, 'converted output of flowing xform has no trans_children'; is $o_float->trans_parent->vtable->name, 'converttypei_new', 'converted output of flowing xform has convert trans_parent'; is_pdl $o_float, float(1), 'converted output of flowing xform has right value'; PDL::eqvec(double([1,2],3,4)->flowing, double([1,2],3,5), my $o_byte = byte([0,0,0])); is 0+$o_byte->trans_children, 0, 'converted output of flowing xform has no trans_children'; is $o_byte->trans_parent->vtable->name, 'converttypei_new', 'converted output of flowing xform has convert trans_parent'; is_pdl $o_byte, byte([1,1,0]), 'converted output of flowing xform has right value'; { my $in = byte('1 2 3 4 5 6 7 8 9 10'); my $got = $in->zeroes; my $exp = $in->copy; my $tmp = $exp->where( ! ($in % 2) ); $tmp .= 0; PDL::acosh( $in, $got ); is_pdl $got, byte('0 1 1 2 2 2 2 2 2 2'), "convert of thing with trans_children no NULL data"; } is_pdl PDL::and2(byte(3), byte(1)), byte(1), 'both input available-typed'; is_pdl PDL::and2(double(3), double(1)), longlong(1), 'both input non-available-typed'; is_pdl PDL::and2(byte(3), double(1)), longlong(1), 'inputs one avail, one non-available-typed -> last-given type'; for ([\&float,\&cfloat,\&cdouble], [\&double,\&cdouble,\&cfloat], [\&ldouble,\&cldouble]) { my ($rt, $ct, $other_ct) = @$_; my $o_cmplx = czip($rt->(3), $rt->(2)); is_pdl $o_cmplx, $ct->('3+2i'), 'right answer from no supplied output '.$rt->(); czip($rt->(3), $rt->(2), $o_cmplx = $ct->(0)); is_pdl $o_cmplx, $ct->('3+2i'), 'right answer from supplied output '.$rt->(); $o_cmplx = czip($rt->(3)->flowing, $rt->(2)); is_pdl $o_cmplx, $ct->('3+2i'), 'right answer from flowing, no supplied output '.$rt->(); czip($rt->(3)->flowing, $rt->(2), $o_cmplx = $ct->(0)); is_pdl $o_cmplx, $ct->('3+2i'), 'right answer from flowing, supplied output '.$rt->(); eval {czip($rt->(3)->flowing, $rt->(2), $ct->(0)->slice(''))}; is $@, '', 'no error when supply right-typed output with parent to flowing '.$rt->(); next if !$other_ct; czip($rt->(3)->flowing, $rt->(2), $o_cmplx = $other_ct->(0)); is_pdl $o_cmplx, $other_ct->('3+2i'), 'right answer from flowing, input '.$rt->().', supplied output '.$other_ct->(); } } my $notouch = sequence(4); $notouch->set_donttouchdata; eval { $notouch->setdims([2,2]); $notouch->make_physical; }; is $@, '', 'setdims to same total size of set_donttouchdata should be fine'; eval { $notouch->setdims([3,2]); $notouch->make_physical; }; isnt $@, '', 'setdims/make_physical to different size of set_donttouchdata should fail'; my $sliced = sequence(4)->slice(''); eval { $sliced->setdims([3,2]) }; like $@, qr/but has trans_parent/, 'setdims on pdl with trans_parent is error'; eval { pdl(3)->getbroadcastid($_) }, isnt $@, '', "getbroadcastid($_) out of range gives error" for -2, 5; done_testing; PDL-2.100/t/00-report-prereqs.t0000644000175000017500000001347614727756302015750 0ustar osboxesosboxesuse strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.020 # THEN modified with more info by Ed J for PDL project use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do 't/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; if ( $source && $HAS_CPAN_META ) { if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } } else { $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have Where Howbig/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $filename = File::Spec->catfile($prefix, $file); my $have = MM->parse_version( $filename ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have, $prefix, (-s $filename)]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing", '', 0]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); my $ll = _max( map { length $_->[3] } @reports ); # location my $sl = _max( map { length $_->[4] } @reports ); # size if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl, "-" x $ll, "-" x $sl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl, "-" x $ll, "-" x $sl]; push @full_reports, map { sprintf(" %*s %*s %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2], -$ll, $_->[3], $sl, $_->[4]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( @dep_errors ) { diag join("\n", "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", "The following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: PDL-2.100/t/niceslice.t0000644000175000017500000001264514744321614014465 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use PDL::LiteF; #BEGIN { $PDL::NiceSlice::debug = $PDL::NiceSlice::debug_filter = 1 } require PDL::NiceSlice; # these are accessible inside sub my $pa = sequence 10; my $pb = pdl(1); my $c = PDL->pdl(7,6); my $idx = pdl 1,4,5; my $rg = pdl(2,7,2); require Filter::Simple; require PDL::NiceSlice::FilterSimple; my $fs_like = Filter::Simple::gen_std_filter_for(code_no_comments => \&PDL::NiceSlice::FilterSimple::code_no_comments); $fs_like = sub { $_ = PDL::NiceSlice::findslice($_, $PDL::NiceSlice::debug_filter) } if $::UC; sub translate_and_run { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($txt, $expected_error) = @_; $expected_error ||= qr/^$/; my $retval = eval { local $_ = $txt; $fs_like->('main'); my $etxt = $_; # note "$txt -> \n\t$etxt\n"; $etxt =~ s/^\s*print\b/die/; my $retval = eval $etxt; die $@ if $@; $retval; }; like $@, $expected_error, 'error as expected'; $retval; } $pb = translate_and_run '$pa((5));'; cmp_ok($pb->at, '==', 5); $pb = translate_and_run '$pa->((5));'; cmp_ok($pb->at, '==', 5); $pb = translate_and_run '$pa(($c(1)->at(0)));'; is_pdl $pb, pdl(6); # the latest versions should do the 'at' automatically $pb = translate_and_run '$pa(($c(1)));'; is_pdl $pb, pdl(6); $c = translate_and_run '$pa(:);'; is_pdl $c, $pa; $pb = translate_and_run '$pa($idx);'; is_pdl $pb, $idx; # use 1-el ndarrays as indices my $cmp = pdl(2,4,6); $pb = translate_and_run '$pa($rg(0):$rg(1):$rg(2));'; is_pdl $pb, $cmp; # mix ranges and index ndarrays $pa = sequence 5,5; $idx = pdl 2,3,0; $cmp = $pa->slice('-1:0')->dice_axis(1,$idx); translate_and_run '$pb = $pa(-1:0,$idx);'; is_pdl $pb, $cmp; # # modifiers # $pa = sequence 10; $pb = translate_and_run '$pa($pa<3;?)' ; is_pdl $pb, pdl(0,1,2); # flat modifier $pa = sequence 3,3; $pb = translate_and_run '$pa(0:-2;_);'; is_pdl $pb, sequence 8; # where modifier cannot be mixed with other modifiers $pa = sequence 10; $pb = translate_and_run '$pa($pa<3;?_)', qr/more than 1/; # more than one identifier $pa = sequence 3,3; $pb = translate_and_run '$pa(0;-|)'; eval {$pb++}; is_pdl $pb, 3*sequence(3)+1; ok($pa->at(0,0) == 0) or diag $pa; # do we ignore whitespace correctly? $c = translate_and_run '$pa(0; - | )'; is_pdl $c, $pb-1; # empty modifier block $pa = sequence 10; $pb = translate_and_run '$pa(0; )'; is $pb, $pa->at(0); # modifiers repeated $pb = translate_and_run '$pa(0;-||)', qr/twice or more/; $pa = sequence(3); translate_and_run 'my $x = 1 / 2; $pa = $pa((2)); $x =~ /\./;'; is_pdl $pa, pdl(2), '/ not treated as starting a regex'; $pa = sequence(3); translate_and_run 'my $x = (0.5 + 0.5) / 2; $pa = $pa((2)); $x =~ /\./;'; is_pdl $pa, pdl(2), '/ not treated as starting a regex even after paren'; # foreach/for blocking $pa = ''; translate_and_run "foreach \n" . ' $pb(1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); $pa = ''; translate_and_run 'for $pb(1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); $pa = ''; translate_and_run 'for my $pb(1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); $pa = ''; translate_and_run 'for our $pb(1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); $pa = ''; # foreach and whitespace translate_and_run 'foreach my $pb (1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); # foreach and embedded expression $pa = ''; translate_and_run 'my $t = ones 10; foreach my $type ( $t(0)->list ) { $pa .= $type }'; is($pa, '1'); # block method access translation $pa = pdl(5,3,2); $c = translate_and_run 'my $method = "dim"; $pa->$method(0)'; is($c, $pa->dim(0)); translate_and_run <<'EOF'; sub f { my ($pa, $pb) = @_; $pa <<= 2; $pb >>= 1; } EOF pass '<<= followed by >>= not blow up NiceSlice'; translate_and_run <<'EOF'; $pb = $pa << 1; $pb += $pa(0); EOF pass '<< followed by 1 then blank'; # # todo ones # # whitespace tolerance $pa= sequence 10; translate_and_run '$c = $pa (0)'; is($c, $pa->at(0)); # comment tolerance translate_and_run << 'EOT'; $c = $pa-> # comment (0); EOT is($c, $pa->at(0)); translate_and_run << 'EOT'; $c = $pa-> # comment # comment line 2 (0); EOT is($c, $pa->at(0)); $pa = ''; # foreach and whitespace + comments translate_and_run << 'EOT'; foreach my $pb # a random comment thrown in (1,2,3,4) {$pa .= $pb;} EOT is($pa, '1234'); # test for correct header propagation $pa = ones(10,10); my $h = {NAXIS=>2, NAXIS1=>100, NAXIS=>100, COMMENT=>"Sample FITS-style header"}; $pa->sethdr($h); $pa->hdrcpy(1); translate_and_run '$pb = $pa(1:2,pdl(0,2));'; if ( !$@ ) { my %bh = %{$pb->gethdr}; my (@bhkeys) = sort keys %bh; my %hh = %{$h}; my (@hhkeys) = sort keys %hh; ok(join("",@bh{@bhkeys}) eq join("",@hh{@hhkeys})); } $pa = ones(10); my $ai = translate_and_run 'my $i = which $pa < 0; $pa($i);'; ok(isempty $ai ); translate_and_run <<'EOF'; my $p = {y => 1}; { $pa=ones(3,3,3); my $f = do { my $i=1; my $v=$$p{y}-$i; $pb = $pa(,$i,) }; } EOF pass 'obscure bug where "y" treated as tr/// in 2-deep {}'; if (!$::UC) { # this is broken in the FilterUtilCall module so don't test it my $expected = q{ CREATE TABLE $table ( CHECK ( yr = $yr ) ) INHERITS ($schema.master_table) }; my $got = translate_and_run 'q{ CREATE TABLE $table ( CHECK ( yr = $yr ) ) INHERITS ($schema.master_table) }'; is $got, $expected, 'NiceSlice leaves strings alone'; } { use PDL::NiceSlice; if (!$::UC) { my $data = join '', ; like $data, qr/we've got data/, "we've got data"; } } done_testing; __DATA__ we've got data PDL-2.100/t/primitive-matmult.t0000644000175000017500000000461314744321614016214 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use Test::PDL; use PDL::LiteF; # provide independent copies of test data. sub IM { PDL->new( [ [ 1, 2, 3, 3, 5 ], [ 2, 3, 4, 5, 6 ], [ 13, 13, 13, 13, 13 ], [ 1, 3, 1, 3, 1 ], [ 10, 10, 2, 2, 2, ] ] ); } is_pdl IM() x IM(), pdl(' [ 97 106 63 71 69] [125 140 87 100 97] [351 403 299 338 351] [ 33 43 33 42 41] [ 78 102 102 116 142] '), "matrix multiplication"; subtest 'complex' => sub { # complex matmult my $cm1 = pdl('1 1+i 1'); my $cm2 = pdl('2 3 i')->transpose; is_pdl $cm1 x $cm2, pdl('[[5+4i]]'), 'complex matmult'; throws_ok { scalar $cm1->transpose x $cm2 } qr/mismatch/, 'good error on mismatch matmult'; }; sub PA { pdl [ [ 1, 2, 3, 0 ], [ 1, -1, 2, 7 ], [ 1, 0, 0, 1 ] ] } sub PB { pdl [ [ 1, 1 ], [ 0, 2 ], [ 0, 2 ], [ 1, 1 ] ] } sub PC { pdl [ [ 1, 11 ], [ 8, 10 ], [ 2, 2 ] ] } sub EQ { float [ [ 1, 1, 1, 1 ] ] } subtest 'test fiducials: 3x4 x 4x2' => sub { is_pdl PA() x PB(), PC(); matmult( PA, PB, my $res = null ); is_pdl $res, PC, 'res=null'; }; subtest 'sliced input' => sub { my $pa_sliced = PA->dummy( 0, 3 )->dummy( -1, 3 )->make_physical->slice('(1),,,(1)'); is_pdl $pa_sliced x PB, PC; }; subtest 'output = zeroes(2,3)' => sub { my $res = zeroes( 2, 3 ); matmult( PA, PB, $res ); is_pdl $res, PC, 'res=zeroes'; }; subtest 'output = ones(2,3)' => sub { my $res = ones( 2, 3 ); matmult( PA, PB, $res ); is_pdl $res, PC, 'res=ones'; }; # Check collapse: output should be a 2x1... is_pdl EQ() x PB(), pdl( [ [ 2, 6 ] ] ), '([4x1] x [2x4] -> [2x1])'; # Check dimensional exception: mismatched dims should throw an error throws_ok { PB() x EQ(); } qr/mismatch in matmult/, '[2x4] x [4x1] --> error (2 != 1)'; is_pdl PB() x 2, PB() * 2, 'ndarray x Perl scalar'; is_pdl pdl(3) x PB(), PB() *3, '1D ndarray x ndarray'; subtest 'nans' => sub { my $A = pdl '[1 nan 0; 0 1 0; 0 0 1]'; my $B = PDL->sequence(2,3); my $C = $A x $B; $C->inplace->setnantobad; $C->inplace->setbadtoval(6); is_pdl $C, pdl '[6 6; 2 3; 4 5]'; }; subtest 'badvals' => sub { my $A = pdl '[1 BAD 0; 0 1 0; 0 0 1]'; my $B = PDL->sequence(2,3); my $C = $A x $B; $C->inplace->setbadtoval(6); is_pdl $C, pdl '[6 6; 2 3; 4 5]'; }; done_testing; PDL-2.100/t/fits.t0000644000175000017500000002600214744321614013464 0ustar osboxesosboxesuse strict; use warnings; use File::Basename; use PDL::LiteF; use PDL::Core ':Internal'; # For howbig() use Test::More; use Test::PDL; use Test::Exception; use PDL::IO::FITS; require File::Spec; require File::Temp; my $fs = 'File::Spec'; sub cfile { return $fs->catfile(@_)} my %tmp_opts = (TMPDIR => 1, UNLINK => 1); my (undef, $file) = File::Temp::tempfile(%tmp_opts); ################ Test rfits/wfits ######################## my $t = long xvals(zeroes(11,20))-5; wfits($t, $file); # without a header my $t2 = rfits $file; unlike $t2->hdr->{COMMENT}, qr/HASH/, 'no "HASH" garbage in written header'; # note: keywords are converted to uppercase my %hdr = ('Foo'=>'foo', 'Bar'=>42, 'NUM'=>'0123',NUMSTR=>['0123']); $t->sethdr(\%hdr); wfits($t, $file); $t2 = rfits $file; is_pdl $t2, $t, 'w/rfits round-trip'; my $h = $t2->gethdr; is $$h{FOO}, "foo", "header check on FOO"; is $$h{BAR}, 42, "header check on BAR"; is $$h{'NUM'}+1, 124, "header check on NUM"; is $$h{'NUMSTR'}, '0123', "header check on NUMSTR"; unlink $file; SKIP: { eval { require Astro::FITS::Header }; skip "Astro::FITS::Header not installed", 79 if $@; ########### Rudimentary table tests ################ # note: # the tests do not directly test the output file, # instead they write out a file, read it back in, and # compare to the data used to create the file. # So it is more of a "self consistent" test. unless($PDL::Astro_FITS_Header) { # Astro::FITS::Header is not present, ignore table tests for(1..59){ok(1,"Test skipped (no binary table support without Astro::FITS::Header)");} } else { # Astro::FITS::Header exists my $x = long( 1, 4, 9, 32 ); my $y = double( 2.3, 4.3, -999.0, 42 ); my $table = { COLA => $x, COLB => $y }; wfits $table, $file; my $table2 = rfits $file; unlink $file; ok( defined $table2, "Read of table returned something" ); #5 is( ref($table2), "HASH", "which is a hash reference" ); #6 is( $$table2{tbl}, "binary", "and appears to be a binary TABLE" );#7 ok( exists $$table2{COLA} && exists $$table2{COLB}, "columns COLA and COLB exist" ); #8 is( $$table2{hdr}{TTYPE1}, "COLA", "column #1 is COLA" ); #9 is( $$table2{hdr}{TFORM1}, "1J", " stored as 1J" ); #10 is( $$table2{hdr}{TTYPE2}, "COLB", "column #2 is COLB" ); #11 is( $$table2{hdr}{TFORM2}, "1D", " stored as 1D" ); #12 is_pdl $x, $$table2{COLA}, "COLA"; #13-16 is_pdl $y, $$table2{COLB}, "COLB"; #17-20 $table = { BAR => $x, FOO => $y, hdr => { TTYPE1 => 'FOO', TTYPE2 => 'BAR' } }; $table2 = {}; wfits $table, $file; $table2 = rfits $file; ok( defined $table2 && ref($table2) eq "HASH" && $$table2{tbl} eq "binary", "Read in the second binary table" ); #21 is( $$table2{hdr}{TTYPE1}, "FOO", "column #1 is FOO" ); #22 is( $$table2{hdr}{TFORM1}, "1D", " stored as 1D" ); #23 is( $$table2{hdr}{TTYPE2}, "BAR", "column #2 is BAR" ); #24 is( $$table2{hdr}{TFORM2}, "1J", " stored as 1J" ); #25 is_pdl $x, $$table2{BAR}, "BAR"; #26-29 is_pdl $y, $$table2{FOO}, "FOO"; #30-33 # try out more "exotic" data types $x = byte(12,45,23,0); $y = short(-99,100,0,32767); my $c = ushort(99,32768,65535,0); my $d = [ "A string", "b", "", "The last string" ]; my $e = float(-999.0,0,0,12.3); ##my $f = float(1,0,-1,2) + i * float( 0,1,2,-1 ); $table = { ACOL => $x, BCOL => $y, CCOL => $c, DCOL => $d, ECOL => $e, ## FCOL => $f, }; $table2 = {}; wfits $table, $file; $table2 = rfits $file; ok( defined $table2 && ref($table2) eq "HASH" && $$table2{tbl} eq "binary", "Read in the third binary table" ); #34 my @elem = sort keys %$table2; my @expected = sort( qw( ACOL BCOL CCOL DCOL ECOL hdr tbl ) ); is_deeply \@elem, \@expected, "hash contains expected keys"; # convert the string array so that each element has the same length # (and calculate the maximum length to use in the check below) # my $dlen = 0; foreach my $str ( @$d ) { my $len = length($str); $dlen = $len > $dlen ? $len : $dlen; } foreach my $str ( @$d ) { $str .= ' ' x ($dlen-length($str)); } # note that, for now, ushort data is written out as a long (Int4) # instead of being written out as an Int2 using TSCALE/TZERO # my $i = 1; foreach my $colinfo ( ( ["ACOL","1B",$x], ["BCOL","1I",$y], ["CCOL","1J",$c->long], ["DCOL","${dlen}A",$d], ["ECOL","1E",$e], ## ["FCOL","1M",$f] ) ) { is( $$table2{hdr}{"TTYPE$i"}, $$colinfo[0], "column $i is $$colinfo[0]" ); #37,43,49,55,58 is( $$table2{hdr}{"TFORM$i"}, $$colinfo[1], " and is stored as $$colinfo[1]" ); #38,44,50,56,59 my $col = $$table2{$$colinfo[0]}; if ( UNIVERSAL::isa($col,"PDL") ) { is_pdl $col, $$colinfo[2], $$colinfo[0]; #39-42,45-48,51-54,60-63 } else { # Need to somehow handle the arrays since the data read in from the # file all have 15-character length strings (or whatever the length is) # is_deeply $col, $$colinfo[2], "$$colinfo[0] values agree (as an array reference)"; } $i++; } } ########### Check if r/wfits bugs are fixed ################ { local $| = 1; my $a1 = [1,2]; my $a2 = [[1,2],[1,2]]; my $p; my $q; my @target_bitpix = (8,16,32,-32,-64); my $bp_i = 0; for my $cref ( \(&byte, &short, &long, &float, &double) ) { for my $x ($a1,$a2) { $p = &$cref($x); unlink $file; $p->wfits($file); $q = PDL->rfits($file); my $flag = 1; if ( ${$p->get_dataref} ne ${$q->get_dataref} ) { $flag = 0; diag "\tnelem=",$p->nelem,"datatype=",$p->get_datatype; diag "\tp:", unpack("c" x ($p->nelem*howbig($p->get_datatype)), ${$p->get_dataref}); diag "\tq:", unpack("c" x ($q->nelem*howbig($q->get_datatype)), ${$q->get_dataref}); } is($q->hdr->{BITPIX},$target_bitpix[$bp_i],"BITPIX implicitly set to " . $target_bitpix[$bp_i]); ok($flag,"hash reference - type check: " . &$cref ); #64-73 } $bp_i++; } } { local $| = 1; my $p1= pdl [1,2]; my $p2= pdl [[1,2],[1,2]]; my $q; my @s; for my $i (8,16,32,-32,-64) { for my $p ($p2, $p1) { unlink $file; $p->wfits($file,$i); $q = PDL->rfits($file); @s = $q->stats; my $flag; if ($s[0] == 1.5 and $s[1] < 0.7072 and $s[1]>0.577) { $flag = 1; } else { $flag = 0; diag "s=@s\n"; diag "\tBITPIX=$i, nelem=", $p->nelem; diag "\tbug: $s[0] == 1.5 and $s[1] == 0.5"; diag "\tp:", unpack("c8" x $p->nelem, ${$p->get_dataref}); diag "\tq:", unpack("c" x abs($i/8*$q->nelem), ${$q->get_dataref}); } is($q->hdr->{BITPIX},$i,"BITPIX explicitly set to $i works"); ok($flag,"ndarray - bitpix=$i" ); #74-83 } } }; }; # end of SKIP block #### Check that discontinuous data (e.g. from fftnd) get written correctly. #### (Sourceforge bug 3299611) it is possible to store data in a PDL non-contiguously #### through the C API, by manipulating dimincs; fft uses this technique, which #### used to hose up fits output. SKIP:{ eval "use PDL::FFT"; skip "PDL::FFT not installed", 79 if $@; my $ar = sequence(10,10,10); my $ai = zeroes($ar); fftnd($ar,$ai); unlink $file; wfits($ar,$file); my $y = rfits($file); is_pdl $ar, $y, "fftnd output (non-contiguous in memory) is written correctly"; unlink $file; } ############################## # Check multi-HDU read/write my $x = sequence(5,5); my $y = rvals(5,5); our @aa; lives_ok { wfits([$x,$y],$file) } "wfits with multiple HDUs didn't fail"; lives_ok { @aa = rfits($file) } "rfits in list context didn't fail"; is_pdl $aa[0], $x, "first element reproduces written one"; is_pdl $aa[1], $y, "Second element reproduces written one"; unlink $file; ############################## # Rudimentary check for longlong support SKIP:{ eval "use PDL::Types"; our $PDL_LL; skip "Longlong not supported",5 unless ($PDL_LL//0); $x = rvals(longlong,7,7); eval { wfits($x, $file); }; is $@, '', "writing a longlong image succeeded"; eval { $y = rfits($file); }; is $@, '', "Reading the longlong image succeeded"; isa_ok $y->hdr, "HASH", "Reading the longlong image produced a PDL with a hash header"; is $y->hdr->{BITPIX}, 64, "BITPIX value was correct"; is_pdl $y, $x, "The new image matches the old one (longlong)"; unlink $file; } ############################### # Check that tilde expansion works my $tildefile = cfile('~',"PDL-IO-FITS-test_$$.fits"); # Only read/write the tildefile if the directory is writable. # Some build environments, like the Debian pbuilder chroots, use a non-existent $HOME. # See: https://github.com/PDLPorters/pdl/issues/238 if(-w dirname($tildefile)) { lives_ok { sequence(3,5,2)->wfits($tildefile) } "wfits tilde expansion didn't fail"; lives_ok { rfits($tildefile) } "rfits tilde expansion didn't fail"; $tildefile =~ s/^(~)/glob($1)/e; #use the same trick as in FITS.pm to resolve this filename. unlink($tildefile) or warn "Could not delete $tildefile: $!\n"; #clean up. } # test bad with r/wfits { (undef, my $fname) = File::Temp::tempfile( 'delmeXXXXX', SUFFIX => '.fits', %tmp_opts ); my $x = sequence(10)->setbadat(0); $x->wfits($fname); my $y = rfits($fname); is_pdl $y, $x, "wfits/rfits propagated bad flag and values"; # now force to integer $x->wfits($fname,16); $y = rfits($fname); is_pdl $y, $x->short, "integer wfits/rfits propagated bad flag and values"; } { my $m51 = rfits('t/m51.fits.fz'); is_pdl $m51->shape, indx([384,384]), 'right dims from compressed FITS file'; (undef, my $fname) = File::Temp::tempfile( 'delmeXXXXX', SUFFIX => '.fits', %tmp_opts ); if ($PDL::Astro_FITS_Header) { my $m51_tbl = rfits('t/m51.fits.fz',{expand=>0}); wfits($m51_tbl, $fname); my $m51_2 = rfits($fname); is_pdl $m51_2, $m51, 'read back written-out bintable FITS file'; $m51->wfits($fname, {compress=>1}); $m51_2 = rfits($fname); is_pdl $m51_2, $m51, 'read back written-out compressed FITS file'; $m51_2->hdrcpy(1); $m51_2 = $m51_2->dummy(2,3)->sever; $m51_2->hdr->{NAXIS} = 3; $m51_2->hdr->{NAXIS3} = 3; $m51_2->wfits($fname, {compress=>1}); my $m51_3 = rfits($fname); is_pdl $m51_3, $m51_2, 'read back written-out compressed RGB FITS file'; } } { my $hstr = join("\n",'A'..'G',''); # must end in newline (undef, my $f_out) = File::Temp::tempfile( 'delmeXXXXX', SUFFIX => '.fits', %tmp_opts ); my $x = xvals(10); $x->hdr->{'HISTORY'} = $hstr; $x->wfits($f_out); my $xr = rfits($f_out); my $hist = $xr->hdr->{'HISTORY'}; $hist = join '', map "$_\n", @$hist if ref $hist eq 'ARRAY'; $hist =~ s/ +$//gm; is($hist, $hstr, 'multi-line HISTORY correct with fresh header'); (undef, $f_out) = File::Temp::tempfile( 'delmeXXXXX', SUFFIX => '.fits', %tmp_opts ); # new one as Windows unable to remove my $m51 = rfits('t/m51.fits.fz'); $m51->hdr->{HISTORY} = $hstr; $m51->wfits($f_out); my $m51r = rfits($f_out); $hist = $m51r->hdr->{'HISTORY'}; $hist = join '', map "$_\n", @$hist if ref $hist eq 'ARRAY'; $hist =~ s/ +$//gm; is($hist, $hstr, 'multi-line HISTORY correct with pre-existing header'); } done_testing(); PDL-2.100/t/bool.t0000644000175000017500000000113314727756302013457 0ustar osboxesosboxesuse Test::More tests => 5; use Test::Exception; use PDL::LiteF; use strict; use warnings; # PDL::Core::set_debugging(1); kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. { my $pa = zeroes 1,1,1; ok !$pa, 'single-element multi-dim ndarray collapses'; } { my $pa = ones 3; throws_ok { print "oops\n" if $pa } qr/multielement/, 'multielement ndarray in conditional expression'; ok all $pa, 'all elements true'; } { my $pa = pdl byte, [ 0, 0, 1 ]; ok any($pa > 0), 'any element true'; } { my $pa = ones 3; my $pb = $pa + 1e-4; ok all(PDL::approx($pa, $pb, 1e-3)), 'approx'; } PDL-2.100/t/ops.t0000644000175000017500000002600214771135562013325 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Config; kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. use Test::Exception; use Test::PDL; require PDL::Core::Dev; kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. my $can_complex_power = PDL::Core::Dev::got_complex_version('pow', 2) && PDL::Core::Dev::got_complex_version('exp', 1); { my ($pa, $pb, $pc) = (xvals(3,5), yvals(3,5)); for ( [$pa,$pb,\$pc, sub { ${$_[2]} = $_[0] - $_[1] }, [1,-1]], [$pa,$pb,\$pc, sub { ${$_[2]} = PDL::minus($_[0], $_[1]) }, [1,-1]], [$pa,$pb,\$pc, sub { ${$_[2]} = PDL::minus($_[0], $_[1], 0) }, [1,-1]], [$pa,$pb,\$pc, sub { ${$_[2]} = PDL::minus($_[0], $_[1], 1) }, [-1,1]], [$pa,$pb,\$pc, sub { PDL::minus($_[0], $_[1], ${$_[2]}, 0) }, [1,-1]], [$pa,$pb,\$pc, sub { PDL::minus($_[0], $_[1], ${$_[2]}, 1) }, [-1,1]], ) { my ($in1, $in2, $outref, $sub, $exp) = @$_; $sub->($in1, $in2, $outref); ok($$outref->at(2,1) == $exp->[0], 'pdl subtraction 1'); ok($$outref->at(2,3) == $exp->[1], 'pdl subtraction 2'); throws_ok { $$outref->at(3,3); } qr/Position.*out of range/, 'invalid position'; } } is_pdl PDL::power(10,2), double(100), 'floating point op defaults to double'; { my $pd = pdl 5,6; is_pdl $pd - 1, pdl(4,5); is_pdl 1 - $pd, pdl(-4,-5); } # complex versions of above { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $pa = xvals(cdouble, 3, 5)+10 - 2*xvals(3, 5)*i; my $pb = yvals(cdouble, 3, 5)+10 - 2*yvals(3, 5)*i; my $pc = $pa + $pb; is_pdl cdouble(25 - 10*i) - cdouble(25 - 10*i), cdouble(0), 'pdl complex subtraction'; ok(approx($pc->double->at(2,2), 24), 'pdl complex addition 1'); is $pc->at(2,3), '25-10i', 'at stringifies complex'; ok(approx($pc->slice([2], [3]), cdouble(25 - 10*i)), 'pdl complex addition 2'); throws_ok { $pc->at(3,3); } qr/Position.*out of range/, 'invalid position'; is_deeply \@w, [], 'no warnings' or diag explain \@w; } { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $pd = cdouble 5,6; is_pdl $pd - 1, cdouble(4,5); is_pdl 1 - $pd, cdouble(-4,-5); is_deeply \@w, [], 'no warnings' or diag explain \@w; } # Now, test one operator from each group # biop1 tested already is_pdl pdl(0,1,2) > pdl(1.5), pdl(0,0,1); { my $pa = byte 0,1,3; my $pc = $pa << 2; is_pdl $pc, byte(0,4,12), 'left bitshift 2'; } { my $pa = pdl(16,64,9); my $pb = sqrt($pa); is_pdl $pb, pdl(4,8,3), 'sqrt of pdl(16,64,9)'; is_pdl $pa, pdl(16,64,9), 'a is unchanged'; # complex version if ($can_complex_power) { $pa = cdouble 16,64,9,-1; $pb = sqrt($pa); is_pdl $pb,cdouble(4,8,3,i()), 'sqrt of pdl(16,64,9,-1)'; is_pdl $pa, cdouble(16,64,9,-1), 'sqrt orig value ok'; is_pdl i()**2, cdouble(-1), 'i squared = -1'; } } { is_pdl(r2C(long(1)), cdouble(1), "r2C of long"); is_pdl(r2C(longlong(1)), cdouble(1), "r2C of longlong"); is_pdl(r2C(float(1)), cfloat(1), "r2C of float"); is_pdl(r2C(double(1)), cdouble(1), "r2C of double"); is_pdl(r2C(ldouble(1)), cldouble(1), "r2C of ldouble"); is_pdl(r2C(cfloat(1)), cfloat(1), "r2C of cfloat"); is_pdl(r2C(cdouble(1)), cdouble(1), "r2C of cdouble"); is_pdl(r2C(cldouble(1)), cldouble(1), "r2C of cldouble"); } is_pdl !pdl(1,0), pdl(0,1); is_pdl pdl(12,13,14,15,16,17) % 3, pdl(0,1,2,0,1,2); # Might as well test this also ok(all( approx((pdl 2,3),(pdl 2,3))),'approx equality 1'); ok(!all( approx((pdl 2,3),(pdl 2,4))),'approx equality 2'); { # Simple function tests my $pa = pdl(2,3); is_pdl exp($pa), pdl(7.3891,20.0855), {atol=>1e-2, test_name=>'exp'}; is_pdl sqrt($pa), pdl(1.4142, 1.7321), {atol=>1e-2, test_name=>'sqrt'}; } { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; # And and Or is_pdl pdl(1,0,1) & pdl(1,1,0), longlong(1,0,0), 'elementwise and'; is_pdl pdl(1,0,1) | pdl(1,1,0), longlong(1,1,1), 'elementwise or'; is_deeply \@w, [], 'no warnings' or diag explain \@w; } # atan2 is_pdl atan2(pdl(1,1), pdl(1,1)), ones(2) * atan2(1,1), 'atan2'; is_pdl PDL::atan2(pdl(1,1), pdl(1,1)), ones(2) * PDL::atan2(1,1), 'atan2'; { my $pa = sequence (3,4); my $pb = sequence (3,4) + 1; is_pdl $pa->or2($pb), $pa | $pb, 'or2'; is_pdl $pa->and2($pb), $pa & $pb, 'and2'; is_pdl $pb->minus($pa), $pb - $pa, 'explicit minus call'; is_pdl $pb - $pa, ones(3,4), 'pdl subtraction'; } # inplace tests { my $pa = pdl 1; my $sq2 = sqrt 2; # perl sqrt $pa->inplace->plus(1); is_pdl $pa, pdl(2), 'inplace plus'; my $warning_shutup = sqrt $pa->inplace; is_pdl $pa, pdl($sq2), 'inplace pdl sqrt vs perl scalar sqrt'; my $pb = pdl 4; is_pdl sqrt($pb->inplace), pdl(2), 'perl scalar vs inplace pdl sqrt'; $pa .= 1; eval {(my $tmp = $pa->inplace) += 1}; is $@, '', 'inplace += worked'; is_pdl $pa, pdl(2), 'inplace += right value after'; } eval { my $res = pdl(3) + undef }; like $@, qr/given undef/, 'error on overloaded op with undef arg'; eval { (my $t = pdl(3)) += undef }; like $@, qr/given undef/, 'error on overloaded op= with undef arg'; { # log10 now uses C library # check using scalars and ndarrays { my $pa = log10(110); my $pb = log(110) / log(10); ok(abs($pa-$pb) < 1.0e-5, 'log10 scalar'); if ($can_complex_power) { $pa = 20+10*i; $pb = log($pa); my $got = exp($pb); is_pdl $got, $pa, {atol=>1.0e-4, test_name=>'exp of log of complex scalar'}; } my $y = sequence(5,4)+2; # Create PDL is log(float($y))->type, 'float'; } { my $pa = log10(pdl(110,23)); my $pb = log(pdl(110,23)) / log(10); is_pdl $pa, $pb, 'log10 pdl'; log10(pdl(110,23), my $pc=null); is_pdl $pc, $pb, '2-arg log10 pdl'; # check inplace is_pdl pdl(110,23)->inplace->log10(), $pb, 'inplace pdl log10'; if ($can_complex_power) { is_pdl cdouble(110,23)->inplace->log/log(10), cdouble($pb), 'complex inplace pdl log10'; } } } { my $data = ones 5; $data &= 0; is_pdl $data, zeroes(5), 'and assign'; $data |= 1; is_pdl $data, ones(5), 'or assign'; is_pdl $data eq $data, ones(5), 'eq'; $data = ones cdouble, 5; $data+=i(); $data &= 0; is_pdl $data, zeroes(cdouble, 5), 'and assign complex'; } #### Modulus checks #### { #test signed modulus on small numbers # short/long/indx/longlong/float/double neg/0/pos % neg/0/pos my $pa = pdl(-7..7); my $pb = pdl(-3,0,3)->transpose; my $pc = cat(pdl("-1 0 -2 " x 5),zeroes(15),pdl("2 0 1 " x 5)); is_pdl short($pa) % short($pb), short($pc),'short modulus'; is_pdl long($pa) % long($pb), long($pc), 'long modulus'; is_pdl indx($pa) % indx($pb), indx($pc), 'indx modulus'; is_pdl longlong($pa) % longlong($pb), longlong($pc), 'longlong modulus' if $Config{ivsize} >= 8; is_pdl float($pa) % float($pb), float($pc), 'float modulus'; is_pdl double($pa) % double($pb), double($pc), 'double modulus'; } { #test unsigned modulus # byte/ushort 0/pos % 0/pos my $pa = xvals(15); my $pb = pdl(0,3)->transpose; my $pc = cat(zeroes(15),pdl("0 1 2 " x 5)); is_pdl byte($pa) % byte($pb), byte($pc), 'byte modulus'; is_pdl ushort($pa) % ushort($pb), ushort($pc), 'ushort modulus'; } { #and do the same for byte (unsigned char) and ushort my $BYTE_MAX = 255; my $USHORT_MAX = 65535; is_pdl byte($BYTE_MAX)%1, byte(0), 'big byte modulus'; is_pdl ushort($USHORT_MAX)%1, ushort(0), 'big ushort modulus'; } SKIP: { skip("your perl hasn't 64bit int support", 12) if $Config{ivsize} < 8; # SF bug #343 longlong constructor and display lose digits due to implicit double precision conversions cmp_ok longlong(10555000100001145) - longlong(10555000100001144), '==', 1, "longlong precision/1"; cmp_ok longlong(9000000000000000002) - longlong(9000000000000000001), '==', 1, "longlong precision/2"; cmp_ok longlong(-8999999999999999998) + longlong(8999999999999999999), '==', 1, "longlong precision/3"; cmp_ok longlong(1000000000000000001) - longlong(1000000000000000000), '==', 1, "longlong precision/4"; cmp_ok longlong(9223372036854775807) - longlong(9223372036854775806), '==', 1, "longlong precision/5"; cmp_ok longlong(9223372036854775807) + longlong(-9223372036854775808), '==',-1, "longlong precision/6"; # check ipow routine my $xdata = longlong(0xeb * ones(8)); my $n = sequence(longlong,8); is $n->type, 'longlong', 'sequence with specified type has that type'; my $exact = longlong(1,235,55225,12977875,3049800625,716703146875,168425239515625,39579931286171875); is_pdl ipow($xdata,$n), $exact, 'ipow'; #and for big numbers (bigger than INT_MAX=2147483647) my $INT_MAX = 2147483647; cmp_ok long($INT_MAX)%1 , '==', 0, "big long modulus: $INT_MAX % 1"; if ($Config{ptrsize} > 4) { cmp_ok indx($INT_MAX*4)%2 , '==', 0, "big indx modulus: @{[$INT_MAX*4]} % 2"; } cmp_ok longlong($INT_MAX*4)%2, '==', 0, "big longlong modulus: @{[$INT_MAX*4]} % 2"; cmp_ok ulonglong($INT_MAX*4)%2, '==', 0, "big ulonglong modulus: @{[$INT_MAX*4]} % 2"; #skip float intentionally here, since float($INT_MAX)!=$INT_MAX cmp_ok double($INT_MAX*4)%2 , '==', 0, "big double modulus: @{[$INT_MAX*4]} % 2"; my $u = pdl(ulonglong, [0,1]); my $compl = ~$u; is "$compl", '[18446744073709551615 18446744073709551614]', 'ULL get stringified right'; } is_pdl ~pdl(1,2,3), longlong('[-2 -3 -4]'), 'bitwise negation'; is_pdl pdl(1,2,3) ^ pdl(4,5,6), longlong('[5 7 5]'), 'bitwise xor'; is_pdl do {PDL::xor2(pdl(1,2,3), pdl(4,5,6), my $out = null, 0); $out}, longlong('[5 7 5]'), 'alias xor2'; { my $startgood = sequence(10); $startgood->slice('0:4') .= pdl('0 1 2 BAD 4'); is_pdl $startgood, pdl('0 1 2 BAD 4 5 6 7 8 9'), 'now badflag true'; } is_deeply [(zeroes(1,1,0) & zeroes(1,1,0))->dims], [1,1,0]; # used to segfault { no warnings 'once'; is *::plus{CODE}, undef, 'plus not exported'; is *::mult{CODE}, undef, 'mult not exported'; is *::minus{CODE}, undef, 'minus not exported'; is *::divide{CODE}, undef, 'divide not exported'; is *::gt{CODE}, undef, 'gt not exported'; is *::lt{CODE}, undef, 'lt not exported'; is *::le{CODE}, undef, 'le not exported'; is *::ge{CODE}, undef, 'ge not exported'; is *::eq{CODE}, undef, 'eq not exported'; is *::ne{CODE}, undef, 'ne not exported'; is *::shiftleft{CODE}, undef, 'shiftleft not exported'; is *::shiftright{CODE}, undef, 'shiftright not exported'; is *::or2{CODE}, undef, 'or2 not exported'; is *::and2{CODE}, undef, 'and2 not exported'; is *::xor{CODE}, undef, 'xor not exported'; is *::bitnot{CODE}, undef, 'bitnot not exported'; is *::power{CODE}, undef, 'power not exported'; is *::atan2{CODE}, undef, 'atan2 not exported'; is *::modulo{CODE}, undef, 'modulo not exported'; is *::spaceship{CODE}, undef, 'spaceship not exported'; is *::sqrt{CODE}, undef, 'sqrt not exported'; is *::sin{CODE}, undef, 'sin not exported'; is *::cos{CODE}, undef, 'cos not exported'; is *::not{CODE}, undef, 'not not exported'; is *::exp{CODE}, undef, 'exp not exported'; is *::log{CODE}, undef, 'log not exported'; ok defined(*::log10{CODE}), 'log10 exported'; is *::_rabs{CODE}, undef, '_rabs not exported'; ok defined(*::assgn{CODE}), 'assgn exported'; ok defined(*::carg{CODE}), 'carg exported'; ok defined(*::conj{CODE}), 'conj exported'; is *::re{CODE}, undef, 're not exported'; is *::im{CODE}, undef, 'im not exported'; is *::_cabs{CODE}, undef, '_cabs not exported'; ok defined(*::czip{CODE}), 'czip exported'; ok defined(*::ipow{CODE}), 'ipow exported'; ok defined(*::abs2{CODE}), 'abs2 exported'; ok defined(*::r2C{CODE}), 'r2C exported'; ok defined(*::i2C{CODE}), 'i2C exported'; } done_testing; PDL-2.100/t/constructor.t0000644000175000017500000001622614727756302015122 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::Exception; my $scalar = 1; my $pdl_e = pdl([]); my $pdl_s = pdl(2); my $pdl_v = pdl(3,4); my $pdl_vec2 = pdl([9,10]); my $pdl_m = pdl([5,6],[7,8]); my $pdl_row = pdl([[10,11]]); my $pdl_col = pdl([[12],[13]]); ############################## # Test the basics (21 tests) isa_ok($pdl_s, 'PDL'); is $pdl_s->ndims(), 0, "scalar goes to scalar PDL"; is $pdl_s, 2, "PDL gets assigned scalar value"; is $pdl_v->ndims(), 1, "vector dims"; is $pdl_v->dim(0), 2, "vector size is 2"; is !!($pdl_v->at(0)==3 && $pdl_v->at(1)==4), 1, "vector contents"; is $pdl_vec2->ndims(), 1, "vector2 dims"; is $pdl_vec2->dim(0),2, "vector2 size is 2"; is !!($pdl_vec2->at(0)==9 && $pdl_vec2->at(1)==10), 1, "vector2 contents"; is $pdl_m->ndims(), 2, "matrix dims"; is $pdl_m->dim(0), 2, "matrix is 2 wide"; is $pdl_m->dim(1), 2, "matrix is 2 high"; is !!($pdl_m->at(0,0)==5 && $pdl_m->at(1,0)==6 && $pdl_m->at(0,1)==7 && $pdl_m->at(1,1)==8), 1, "matrix contents"; is $pdl_row->ndims(), 2, "row dims"; is $pdl_row->dim(0), 2, "row is 2 wide"; is $pdl_row->dim(1), 1, "row is 1 tall"; is !!($pdl_row->at(0,0)==10 && $pdl_row->at(1,0)==11), 1, "row contents"; is $pdl_col->ndims(), 2, "col dims"; is $pdl_col->dim(0), 1, "col is 1 wide"; is $pdl_col->dim(1), 2, "col is 2 tall"; is !!($pdl_col->at(0,0)==12 && $pdl_col->at(0,1)==13), 1, "col contents"; ############################## # Test more complex array-ingestion case (6 tests) with padding my @a = (1,[2,3],[[4,5],[6,7]]); my $pdl_a = pdl(@a); my @testvals = ( [ [0,0,0], 1 ], [ [1,0,0], 0 ], [ [0,1,0], 0 ], [ [1,1,0], 0 ], [ [0,0,1], 2 ], [ [1,0,1], 0 ], [ [0,1,1], 3 ], [ [1,1,1], 0 ], [ [0,0,2], 4 ], [ [1,0,2], 5 ], [ [0,1,2], 6 ], [ [1,1,2], 7 ] ); is $pdl_a->ndims(), 3, 'complex array case dims'; is $pdl_a->dim(0), 2, 'complex dim 0'; is $pdl_a->dim(1), 2, 'complex dim 1'; is $pdl_a->dim(2), 3, 'complex dim 2'; my $test_ok = 1; for my $i(0..$#testvals) { $test_ok *= $pdl_a->at( @{$testvals[$i]->[0]} ) == $testvals[$i]->[1]; } is $test_ok, 1, "contents of complex array-ingestion case"; { local $PDL::undefval = 99; $pdl_a = pdl(@a); $test_ok = 1; for my $i(0..$#testvals) { $test_ok *= $pdl_a->at( @{$testvals[$i]->[0]} ) == ($testvals[$i]->[1] || 99); } is $test_ok, 1, "complex array-ingestion with variant padding"; } ############################## # Test some basic PDL-as-PDL cases ## Ingest a scalar PDL my $p = pdl($pdl_s); isa_ok($p, 'PDL'); is $p->ndims(), 0, "scalar PDL goes to scalar PDL"; is $p, $pdl_s, "pdl(pdl(2)) same as pdl(2)"; ## Ingest five scalar PDLs -- should make a 1-D array $p = pdl($pdl_s, $pdl_s, $pdl_s, $pdl_s, $pdl_s); isa_ok($p, 'PDL'); is $p->ndims(), 1, "two scalar PDLs -> a vector"; is $p->dim(0), 5, "5-vector"; is $p->at(0), $pdl_s, 'vector element 0 ok'; is $p->at(1), $pdl_s, 'vector element 1 ok'; is $p->at(2), $pdl_s, 'vector element 2 ok'; is $p->at(3), $pdl_s, 'vector element 3 ok'; is $p->at(4), $pdl_s, 'vector element 4 ok'; ## Ingest a vector PDL and a scalar PDL - should make a 2-D array $p = pdl($pdl_v, $pdl_s); isa_ok($p, 'PDL'); is $p->ndims(), 2, 'pdl($pdl_v, $pdl_s) -> 2x2 matrix'; is $p->dim(0), 2, '2 wide'; is $p->dim(1), 2, '2 high'; is $p->at(0,0), $pdl_v->at(0), "vector element 0 got copied OK"; is $p->at(1,0), $pdl_v->at(1), "vector element 1 got copied OK"; is $p->at(0,1), $pdl_s, "scalar copied OK"; is $p->at(1,1), $PDL::undefval, "scalar got padded OK"; ## Ingest a scalar PDL and a vector PDL - should make a 2-D array $p = pdl($pdl_s, $pdl_v); isa_ok($p, 'PDL'); is $p->ndims(), 2, 'pdl($pdl_s, $pdl_v) -> 2x2 matrix'; is $p->dim(0), 2, '2 wide'; is $p->dim(1), 2, '2 high'; is $p->at(0,0), $pdl_s, "scalar copied OK"; is $p->at(1,0), $PDL::undefval, "scalar got padded OK"; is $p->at(0,1), $pdl_v->at(0), "vector element 0 got copied OK"; is $p->at(1,1), $pdl_v->at(1), "vector element 1 got copied OK"; ## A more complicated case $p = pdl($pdl_s, 5, $pdl_v, $pdl_m, [$pdl_v, $pdl_v]); isa_ok($p,'PDL'); is $p->ndims(), 3, 'complicated case -> 3-d PDL'; is $p->dim(0), 2, 'complicated case -> dim 0 is 2'; is $p->dim(1), 2, 'complicated case -> dim 1 is 2'; is $p->dim(2), 5, 'complicated case -> dim 1 is 5'; @testvals = ([ [0,0,0], 2 ], [ [1,0,0], 0 ], [ [0,1,0], 0 ], [ [1,1,0], 0 ], [ [0,0,1], 5 ], [ [1,0,1], 0 ], [ [0,1,1], 0 ], [ [1,1,1], 0 ], [ [0,0,2], 3 ], [ [1,0,2], 0 ], [ [0,1,2], 4 ], [ [1,1,2], 0 ], [ [0,0,3], 5 ], [ [1,0,3], 6 ], [ [0,1,3], 7 ], [ [1,1,3], 8 ], [ [0,0,4], 3 ], [ [1,0,4], 4 ], [ [0,1,4], 3 ], [ [1,1,4], 4 ] ); $test_ok = 1; for my $i(0..$#testvals) { $test_ok *= $p->at(@{$testvals[$i]->[0]}) == $testvals[$i]->[1]; } is $test_ok, 1, "contents of complicated case"; ############################## # test empty PDLs. $p = pdl($pdl_e); is $p->nelem, 0, "piddlifying an empty ndarray yields 0 elements"; $p = pdl($pdl_e, $pdl_e); is $p->ndims, 2, "piddlifying two 0-PDLs makes a 2D-PDL"; is $p->dim(0),0, "piddlifying two empty ndarrays makes a 0x2-PDL"; is $p->dim(1),2, "piddlifying two empty ndarrays makes a 0x2-PDL"; eval { $p->at(0,0) }; like $@, qr/^Position.*out of range/, "can't index an empty PDL with at"; $p = pdl(pdl([4]),5); is $p->ndims, 2, "catenating a 1-PDL and a scalar yields a 2D PDL"; is $p->dim(0), 1, "catenating a 1-PDL and a scalar yields a 1x2-PDL"; is $p->dim(1), 2, "catenating a 1-PDL and a scalar yields a 1x2-PDL"; is $p->at(0,0), 4, "catenating a 1-PDL and a scalar does the Right Thing"; is $p->at(0,1), 5, "catenating a 1-PDL and a scalar does the Right Thing, redux"; $p = pdl($pdl_e, 5); is $p->ndims, 2, "catenating an empty and a scalar yields a 2D PDL"; is $p->dim(0), 1, "catenating an empty and a scalar yields a 1x2-PDL"; is $p->dim(1), 2, "catenating an empty and a scalar yields a 1x2-PDL"; is $p->at(0,0), $PDL::undefval, "padding OK for empty & scalar case"; is $p->at(0,1), 5, "scalar OK for empty & scalar"; $p = pdl(5, $pdl_e); is $p->ndims, 2, "catenating a scalar and an empty yields a 2D PDL"; is $p->dim(0), 1, "catenating a scalar and an empty yields a 1x2-PDL"; is $p->dim(1), 2, "catenating a scalar and an empty yields a 1x2-PDL"; is $p->at(0,0), 5, "scalar OK for scalar & empty"; is $p->at(0,1), $PDL::undefval, "padding OK for scalar & empty"; # This is from sf.net bug #3011879 my @c; $c[0][0]=pdl(0,4,2,1); $c[1][0]=pdl(0,0,1,1); $c[2][0]=pdl(0,0,0,1); $c[0][1]=pdl(0,0,3,1); $c[1][1]=pdl(0,0,2,1); $c[2][1]=pdl(5,1,1,1); my $d = pdl(@c); ############################## # test bad values my $x = pdl(3,4,5); $x=$x->setbadif($x==4); my $y = eval { pdl($x,5) }; is $@, '', "a badvalue PDL works in the constructor"; ok( $y->badflag, "bad value propagates from inner PDL to constructed PDL" ); is( $y->slice("(1),(0)").'', 'BAD', "bad value was passed in" ); ok( $y->at(1,1) == 0, "padding was correct" ); eval { $y = pdl(short, $x, 5) }; is $@, '', "constructed a short PDL"; is( $y->slice("(1),(0)").'', 'BAD', "bad value was translated" ); ok( $y->at(1,1) == 0, "padding was correct"); { # Tests for a segfault bug in PDL through 2.4.2 # (Thanks, Alexey!) my $x = pdl(1,2); my $y = bless \my $z,"ASFG"; throws_ok { $x != $y } qr/Error - tried to use an unknown/; } done_testing; PDL-2.100/t/func.t0000644000175000017500000000357214727756302013470 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::PDL; use PDL::LiteF; use PDL::Func qw(pchip spline); my $x = float( 1, 2, 3, 4, 5, 6, 8, 10 ); my $y = ($x * 3) * ($x - 2); my $xi = $x - 0.5; my $obj = PDL::Func->init( x => $x, y => $y ); is( $obj->scheme() , 'Linear', 'default scheme is linear' ); # 1 is_pdl $obj->interpolate( $xi ), pdl('-4.5 -1.5 4.5 16.5 34.5 58.5 126 216'), {atol=>1e-5, test_name=>'linear interpolate'}; is $obj->status, -1, 'non serious error from linear interpolate: extrapolation used'; is_pdl $obj->get( 'err' ), long('1 0 0 0 0 0 0 0'), 'same error as direct'; eval { $obj->gradient( $xi ); }; like $@ , qr/can not call gradient/, 'calling unavailable method'; $x = sequence(float,10); $y = $x*$x + 0.5; $obj->set( Interpolate => 'Hermite', x => $x, y => $y ); is( $obj->scheme() , 'Hermite' , 'scheme is Hermite'); is( $obj->get('bc'), 'simple' , 'boundary condition is simple'); is( $obj->status, 1 , 'no errors'); $xi = sequence(float,5) + 2.3; is_pdl $obj->interpolate( $xi ), $xi*$xi + 0.5, {atol=>0.04, test_name=>'interpolate'}; is( $obj->status, 1, 'status==1 after interpolate'); is_pdl scalar $obj->gradient( $xi ), 2*$xi, {atol=>0.04, test_name=>'gradient'}; is( $obj->status, 1, 'status==1 after gradient'); # see how they cope with broadcasting $y = cat( $x*$x+43.3, $x*$x*$x-23 ); $obj->set( x => $x, y => $y ); is( $obj->status , 1, 'broadcasting: status==1 after set'); my $ans = cat( $xi*$xi+43.3, $xi*$xi*$xi-23 ); is_pdl $obj->interpolate( $xi ), $ans, {atol=>6, test_name=>'broadcasting'}; is( $obj->status, 1 ,'broadcasting: status==1 after interpolate'); # non-simple boundary conditions $obj->set( bc => {} ); is_pdl $obj->interpolate( $xi ), $ans, {atol=>6, test_name=>'broadcasting non-simple'}; is_pdl pchip( $x, $y, $xi ), $ans, {atol=>6, test_name=>'pchip'}; is_pdl spline( $x, $y, $xi ), $ans, {atol=>6, test_name=>'spline'}; done_testing; PDL-2.100/utils/0000755000175000017500000000000014771136046013232 5ustar osboxesosboxesPDL-2.100/utils/scantree.pl0000644000175000017500000000477214727756302015411 0ustar osboxesosboxesuse strict; use warnings; use PDL::Doc; use Getopt::Std; use Config; use Cwd; require PDL; # always needed to pick up PDL::VERSION our $opt_v = 0; getopts('v'); my $dirarg = shift @ARGV; my $outdb = shift @ARGV; my $outindex = shift @ARGV; unless (defined $dirarg) { ($dirarg = $INC{'PDL.pm'}) =~ s/PDL\.pm$//i; umask 0022; print "DIR = $dirarg\n"; } my @dirs = split /,/,$dirarg; unless (defined $outdb) { $outdb = "$dirs[0]/PDL/pdldoc.db"; print "DB = $outdb\n"; } unlink $outdb if -e $outdb; my $onldc = PDL::Doc->new; $onldc->outfile($outdb); foreach my $dir (@dirs) { $onldc->scantree($dir."/PDL",$opt_v); $onldc->scan($dir."/PDL.pm",$opt_v) if (-s $dir."/PDL.pm"); } print STDERR "saving...\n"; $onldc->savedb(); my @mods = $onldc->search('module:',['Ref'],1); my @mans = $onldc->search('manual:',['Ref'],1); my @scripts = $onldc->search('script:',['Ref'],1); my $outdir = "$dirs[0]/PDL"; # ($outdir = $INC{'PDL.pm'}) =~ s/\.pm$//i; $outindex="$outdir/Index.pod" unless (defined $outindex); unlink $outindex if -e $outindex; # Handle read only file open my $podfh, ">", $outindex or die "couldn't open $outindex: $!"; my $pod; $pod = <<'EOPOD'; =head1 NAME PDL::Index - an index of PDL documentation =head1 DESCRIPTION A meta document listing the documented PDL modules and the PDL manual documents =head1 PDL manuals EOPOD $pod =~ s/^ //gm; print $podfh $pod; print $podfh "=over 4\n\n"; for (@mans) { my $ref = $_->[2]->{Ref}; $ref =~ s/Manual:/L<$_->[0]> -/; print $podfh "=item *\n\n$ref\n\n"; } $pod = <<'EOPOD'; =back =head1 PDL scripts EOPOD $pod =~ s/^ //gm; print $podfh $pod; print $podfh "=over 4\n\n"; for (@scripts) { my $ref = $_->[2]->{Ref}; $ref =~ s/Script:/L<$_->[0]|PDL::$_->[0]> -/; print $podfh "=item *\n\n$ref\n\n"; } $pod = <<'EOPOD'; =back =head1 PDL modules EOPOD $pod =~ s/^ //gm; print $podfh $pod; print $podfh "=over 4\n\n"; for (@mods) { my $ref = $_->[2]->{Ref}; next unless $_->[0] =~ /^PDL/; if( $_->[0] eq 'PDL'){ # special case needed to find the main PDL.pm file. $ref =~ s/Module:/L -/; print $podfh "=item *\n\n$ref\n\n"; next; } $ref =~ s/Module:/L<$_->[0]> -/; print $podfh "=item *\n\n$ref\n\n"; } $pod = <<'EOPOD'; =back =head1 HISTORY Automatically generated by scantree.pl for PDL version $PDL::VERSION. EOPOD $pod =~ s/^ //gm; print $podfh $pod; close $podfh; #add the newly-created PDL::Index to the doc database $onldc->scan($outindex,$opt_v) if (-s $outindex); $onldc->savedb(); 1; PDL-2.100/utils/perldlpp.pl0000755000175000017500000000262714727756302015427 0ustar osboxesosboxes#!/usr/bin/perl # use PDL::NiceSlice; my $prefile = ""; { local $/; $prefile = <>; } my ($postfile) = PDL::NiceSlice->perldlpp($prefile); print $postfile; __END__ =head2 perldlpp.pl =for ref Script to filter PDL::NiceSlice constructs from argument file to STDOUT =for usage perldlpp.pl file-w-niceslice.pm > file-no-niceslice.pm ( unix systems) perl perldlpp.pl file-w-niceslice.pm > file-no-niceslice.pm (win32 systems) C is a preprocessor script for perl module files to filter and translate the PDL::NiceSlice constructs. The name of the file(s) to be filtered is given as argument to the command and the result of the source filtering is output to STDOUT. One use for this script is to preprocess the .pm files installed for PDL to remove the requirement for PDL::NiceSlice filtering in the core PDL modules. This allows PDL to be used with environments such as C that are not compatible with source code filters. It is planned to add C support for this filter to the PDL configure, build, and install process. =for example # For example (using the unix shell): mkdir fixed # filter all pm files in this directory into fixed/ for pm in *.pm ; do perldlpp.pl $pm > fixed/$pm ; done Now the fixed/*.pm files have been PDL::NiceSlice processed and could be used to replace the original input files as "clean" (no source filter) versions. =cut 1; PDL-2.100/utils/doc-pp0000755000175000017500000000231514727756302014347 0ustar osboxesosboxes#!/usr/bin/env perl die "Usage: $0 outfile\n" if !@ARGV; use strict; use warnings; use PDL::PP qw(math.pd Math PDL::Math); PDL::PP::pp_def('dummy', Code=>'', Pars=>'a()'); # lazy-loads stuff use Graph; use GraphViz2; use Scalar::Util qw(refaddr); my $g = Graph->new; # should really be hypergraph but GraphViz2 not do yet $PDL::PP::deftbl = $PDL::PP::deftbl; # suppress warning for my $r (@{$PDL::PP::deftbl}) { my $r_addr = refaddr $r; my $r_label = ref($r) =~ s/^PDL::PP:://r; $g->set_vertex_attribute($r_addr, graphviz => { shape => 'box', label => $r_label }); $g->add_edge($_, $r_addr) for @{$r->{targets}}; for my $c (@{$r->{conditions}||[]}) { my $maybe = $c =~ s/\?//g; $g->add_edge($r_addr, $c); $g->set_edge_attribute($r_addr, $c, graphviz => { style => 'dashed' }, ) if $maybe; } } my ($fmt) = $ARGV[0] =~ /\.([^.]+)$/; $g->set_graph_attribute(graphviz=>{graph=>{rankdir=>'LR'}}); GraphViz2->from_graph($g)->run(format=>$fmt,output_file=>$ARGV[0]); =head1 NAME doc-pp - Generate graph of pp_def key dependencies with graphviz =head1 SYNOPSIS doc-pp deps.svg =head1 DESCRIPTION Uses L and L to visualise the dependencies between keys in L. PDL-2.100/utils/harness0000644000175000017500000001160514727756302014627 0ustar osboxesosboxesuse strict; use warnings; use PDL; use PDL::IO::GD; # for write_gif_anim, bigger file but nicer looking use PDL::Demos; use File::Path qw(mkpath); use File::Spec::Functions qw(catdir catfile splitpath updir); my $html_header = <<'EOF'; %s EOF my $html_footer = <<'EOF'; EOF my $index_header = <<'EOF';

Demos and Examples

On the following pages you'll find some examples of how to use PDL for basic computations and plotting purposes. Several of the examples are available as demos within perldl. For more details try:

 perldl> demo
EOF my ($name_pat, $name_glob) = qw(output-%d.png output-*.png); my $destroot = shift; die "Usage: $0 destroot [singledemo]" unless defined $destroot && -d $destroot; my $single_demo = shift; my @infos = map [PDL::Demos->info($_)], 'pdl', sort grep $_ ne 'pdl', $single_demo || PDL::Demos->keywords; @infos = grep $_->[0] eq 'pdl' || $_->[1] =~ /Simple|GSL/, @infos; my @this_output; sub do_output { push @this_output, map "$_", @_; } my @titles; for (@infos) { my ($kw, $blurb, $mod) = @$_; my $outdir = catdir($destroot, updir, updir, qw(images demos), $kw); print " $kw -> $outdir\n"; $ENV{PDL_SIMPLE_ENGINE} = 'gnuplot'; $ENV{PDL_SIMPLE_OUTPUT} = catfile($outdir, $name_pat); mkpath($outdir) or die "$outdir: $!" if !-d $outdir; unlink($_) or die "unlink $_: $!" for grep -f, glob catfile($outdir, $name_glob); PDL::Demos->init($kw); my ($vidcounter, @outframes, %seen_img) = 0; for my $frame (PDL::Demos->demo($kw)) { my ($cmd, $txt) = @$frame; my @lines = split /\n/, $txt; shift @lines until $lines[0] =~ /\S/; pop @lines until $lines[-1] =~ /\S/; die "No non-blank lines found in a frame of $kw, text '$txt'" if !@lines; if ($cmd eq 'comment') { my $final = join "\n", @lines; $final =~ s#\n\n+#\n

\n#g; push @outframes, [hyperlink($final)]; next; } my ($state, $chunk, @to_execute, @thisframe) = ($lines[0] =~ /^\s*#/ ? 'c' : 'w', ''); for (@lines) { if (/^\s*#+\s*(.*?)\s*#*\s*$/) { # words if ($state eq 'c') { chomp $chunk; push @thisframe, "

\n$chunk\n
" if $chunk; $chunk = ''; } $state = 'w'; $chunk .= $1 ? "$1\n" : "

\n"; } else { if ($state eq 'w') { chomp $chunk; push @thisframe, $chunk if $chunk; $chunk = ''; } $state = 'c'; $chunk .= "$_\n" if /\S/; push @to_execute, $_; } } chomp($chunk), push @thisframe, $state eq 'c' ? "

\n$chunk\n
" : $chunk if $chunk; if (@to_execute) { @this_output = (); s#^(\s*)print\b#do_output +#g for @to_execute; s#^(\s*)printf\b#do_output sprintf#g for @to_execute; my $exec_text = join "\n", "package $mod; *do_output=\\&main::do_output; sub do_output; no strict; use PDL;", @to_execute; eval $exec_text; die if $@; my $o = join('', @this_output)."\n"; $o =~ s/\A\n+|\n+\z//g; $o = "
\n$o\n
" if $o; my @this_imgs = map $_->[1], sort {$a->[0]<=>$b->[0]} map [/(\d+)/, $_], grep !$seen_img{$_}++, glob catfile($outdir, $name_glob); if (@this_imgs) { if (@this_imgs > 1) { my $multiframe = cat(map rpic($_), @this_imgs); my $vidfile = catfile($outdir, "vid-".++$vidcounter.".gif"); $multiframe->write_gif_anim($vidfile, 0, 10); unlink @this_imgs; delete @seen_img{@this_imgs}; # may reappear with new content @this_imgs = $vidfile; } $o .= sprintf qq{\n}, $kw, (splitpath $this_imgs[0])[2]; } push @thisframe, "

Output

\n$o" if $o; } $_ = hyperlink($_) for @thisframe; push @outframes, \@thisframe; } PDL::Demos->done($kw); rmdir $outdir if !glob catfile($outdir, $name_glob); open my $fh, ">", catfile($destroot, "$kw.html"); $blurb =~ s#\s*\(.*##; push @titles, [$kw, my $title = "$kw - $blurb"]; print $fh sprintf($html_header, $title), "

$title

\n\n", join("\n\n
\n", map join("\n", @$_), @outframes), "\n", $html_footer; } if (!$single_demo) { open my $fh, ">", catfile($destroot, "index.html"); print $fh $index_header, (map qq{
  • $_->[1]
    • \n}, @titles), $index_footer; } sub hyperlink { my ($text) = @_; $text =~ s#PDL::[a-zA-Z0-9_:]+#$&#g; $text =~ s#([^"])(https?:\S+)#$1$2#g; $text; } PDL-2.100/utils/address-pseudonymise0000755000175000017500000000037714727756302017342 0ustar osboxesosboxes#!/usr/bin/env perl use strict; use warnings; my $anon = @ARGV && $ARGV[0] eq '-x' && shift; my (%addr2number, $i); while (<>) { s:^==\d+==:==[PID]==:; s{0x([0-9a-f]+)}{ '[ADDR'.($anon ? '' : ($addr2number{$1} //= ++$i)).']' }gie; print; } PDL-2.100/README.md0000644000175000017500000001146214727756302013361 0ustar osboxesosboxes# Perl Data Language (PDL) ![PDL logo](https://pdlporters.github.io/images/icons/pdl.png) | Service | Build status | |:---------:|--------------:| | GitHub CI | [![Build Status](https://github.com/PDLPorters/pdl/workflows/perl/badge.svg?branch=master)](https://github.com/PDLPorters/pdl/actions?query=branch%3Amaster) | | Cirrus CI | [![Build Status](https://api.cirrus-ci.com/github/PDLPorters/pdl.svg?branch=master)](https://cirrus-ci.com/github/PDLPorters/pdl/master) | [![Coverage Status](https://coveralls.io/repos/PDLPorters/pdl/badge.png?branch=master)](https://coveralls.io/r/PDLPorters/pdl?branch=master) [![CPAN version](https://badge.fury.io/pl/PDL.svg)](https://metacpan.org/pod/PDL) PDL ("Perl Data Language") gives standard Perl the ability to *compactly* store and *speedily* manipulate the large N-dimensional data arrays which are the bread and butter of scientific computing. PDL turns Perl into a free, array-oriented, numerical language similar to (but, we believe, better than) such commercial packages as IDL and MatLab. One can write simple perl expressions to manipulate entire numerical arrays all at once. A simple interactive shell, `perldl`, is provided for use from the command line along with the `PDL` module for use in Perl scripts. WARNING: There is absolutely no warranty for this software package. See the file COPYING for details. ## Important reading Before sending us your questions, please see the following files for further information, and check for any [open issues](https://github.com/PDLPorters/pdl/issues). - [`PDL::InstallGuide`](https://metacpan.org/pod/PDL::InstallGuide): Basic installation instructions - `Changes`: A list of features or issues with regard to the current version, always worth checking! - [`PDL::Bugs`](https://metacpan.org/pod/PDL::Bugs): How to make a bug report, - [`PDL::FAQ`](https://metacpan.org/pod/PDL::FAQ): The FAQ in pod format. Try `perldoc PDL::FAQ` after installation. - [`PDL::QuickStart`](https://metacpan.org/pod/PDL::QuickStart): A quick overview of PDL. Try `perldoc PDL::QuickStart` after installation. - [`PDL::BadValues`](https://metacpan.org/pod/PDL::BadValues): A discussion of the bad value support in PDL - [`PDL::DeveloperGuide`](https://metacpan.org/pod/PDL::DeveloperGuide): How to participate in the development of PDL **Note:** Most PDL documentation is available online within the PDL shell, `perldl`. Try the `help` command within either shell. ## PDL -- the package The Perl Data Language (a.k.a. PerlDL or PDL) project aims to turn perl into an efficient numerical language for scientific computing. The PDL module gives standard perl the ability to **compactly** store and **speedily** manipulate the large N-dimensional data sets which are the bread and butter of scientific computing. e.g. `$x=$y+$c` can add two 2048x2048 images in only a fraction of a second. The aim is to provide tons of useful functionality for scientific and numeric analysis. Check the [pdl web site](https://pdl.perl.org) for more information. ## Installation Please read the installation guide linked above for information on how to install PDL. The `Changes` file contains important version specific information. Be *sure* to check for any [open issues](https://github.com/PDLPorters/pdl/issues) if you have any installation issues. Once you have built PDL and either installed it or done `make`, try either perl -Mblib blib/script/perldl from within the root of the PDL tree or just pdl if you have installed PDL already (`make install`) to get the interactive PDL shell. In this shell, `help` gives you access to PDL documentation for each function separately (`help help` for more about this) and `demo` gives you some basic examples of what you can do. ## Bug Reports You can check the existing PDL bugs on GitHub [here](https://github.com/PDLPorters/pdl/issues). The mailing list archives can be searched/read [here](https://pdl.perl.org/?page=mailing-lists). Questions about problems and possible bugs can be discussed via the pdl-general mailing list. This is very useful if you are not sure what you have is a bug or not. For example, the list is the place to go for install problems. If you need to post a problem report, and after checking with the pdl-general list that it *is* a bug, please use the GitHub issue tracker system following the guidance in [PDL::Bugs](https://metacpan.org/pod/PDL::Bugs). ## Notes Comments are welcome - so are volunteers to write code and documentation! Please contact the developers mailing list `pdl-devel@lists.sourceforge.net` ([subscription info](https://pdl.perl.org/?page=mailing-lists)) with ideas and suggestions. The PDL developers. ## Installation Reports: The [CPAN Testers' result page](https://www.cpantesters.org) provides a database showing the results of compiling PDL and many other CPAN packages on multiple platforms. PDL-2.100/GENERATED/0000755000175000017500000000000014771136047013371 5ustar osboxesosboxesPDL-2.100/GENERATED/PDL/0000755000175000017500000000000014771136071014005 5ustar osboxesosboxesPDL-2.100/GENERATED/PDL/Image2D.pm0000644000175000017500000011454514771136052015564 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Image2D.pd! Don't modify! # package PDL::Image2D; our @EXPORT_OK = qw( conv2d med2d med2df box2d patch2d patchbad2d max2d_ind centroid2d crop cc8compt cc4compt ccNcompt polyfill pnpoly polyfillv rotnewsz rot2d bilin2d rescale2d fitwarp2d applywarp2d warp2d warp2d_kernel ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Image2D ; #line 11 "lib/PDL/Image2D.pd" use strict; use warnings; =head1 NAME PDL::Image2D - Miscellaneous 2D image processing functions =head1 DESCRIPTION Miscellaneous 2D image processing functions - for want of anywhere else to put them. =head1 SYNOPSIS use PDL::Image2D; =cut use PDL; # ensure qsort routine available use PDL::Math; use Carp; my %boundary2value = (Reflect=>1, Truncate=>2, Replicate=>3); #line 52 "lib/PDL/Image2D.pm" =head1 FUNCTIONS =cut =head2 conv2d =for sig Signature: (a(m,n); kern(p,q); [o]b(m,n); indx [t]mapi(isize=CALC($SIZE(p) + $SIZE(m))); indx [t]mapj(jsize=CALC($SIZE(q) + $SIZE(n))); int opt) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for ref 2D convolution of an array with a kernel (smoothing) For large kernels, using a FFT routine, such as L, will be quicker. =for usage $new = conv2d $old, $kernel, {OPTIONS} =for example $smoothed = conv2d $image, ones(3,3), {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =pod Broadcasts over its inputs. =for bad Unlike the FFT routines, conv2d is able to process bad values. =cut sub PDL::conv2d { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: conv2d( a(m,n), kern(p,q), [o]b(m,n), {Options} )' if $#_<1 || $#_>2; my($x,$kern) = @_; my $c = $#_ == 2 ? $_[2] : $x->nullcreate; PDL::_conv2d_int($x,$kern,$c, (!($opt && exists $$opt{Boundary}))?0:$boundary2value{$$opt{Boundary}} ); return $c; } *conv2d = \&PDL::conv2d; =head2 med2d =for sig Signature: (a(m,n); kern(p,q); [o]b(m,n); double+ [t]tmp(pq=CALC($SIZE(p)*$SIZE(q))); indx [t]mapi(isize=CALC($SIZE(p) + $SIZE(m))); indx [t]mapj(jsize=CALC($SIZE(q) + $SIZE(n))); int opt) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref 2D median-convolution of an array with a kernel (smoothing) Note: only points in the kernel E0 are included in the median, other points are weighted by the kernel value (medianing lots of zeroes is rather pointless) =for usage $new = med2d $old, $kernel, {OPTIONS} =for example $smoothed = med2d $image, ones(3,3), {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =pod Broadcasts over its inputs. =for bad Bad values are ignored in the calculation. If all elements within the kernel are bad, the output is set bad. =cut #line 311 "lib/PDL/Image2D.pd" sub PDL::med2d { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: med2d( a(m,n), kern(p,q), [o]b(m,n), {Options} )' if $#_<1 || $#_>2; my($x,$kern) = @_; croak "med2d: kernel must contain some positive elements.\n" if all( $kern <= 0 ); my $c = $#_ == 2 ? $_[2] : $x->nullcreate; PDL::_med2d_int($x,$kern,$c, (!($opt && exists $$opt{Boundary}))?0:$boundary2value{$$opt{Boundary}} ); return $c; } #line 207 "lib/PDL/Image2D.pm" *med2d = \&PDL::med2d; =head2 med2df =for sig Signature: (a(m,n); [o]b(m,n); indx [t]mapi(isize=CALC($SIZE(p) + $SIZE(m))); indx [t]mapj(jsize=CALC($SIZE(q) + $SIZE(n))); IV p_size=>p; IV q_size=>q; int opt) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref 2D median-convolution of an array in a pxq window (smoothing) Note: this routine does the median over all points in a rectangular window and is not quite as flexible as C in this regard but slightly faster instead =for usage $new = med2df $old, $xwidth, $ywidth, {OPTIONS} =for example $smoothed = med2df $image, 3, 3, {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =pod Broadcasts over its inputs. =for bad C 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 sub PDL::med2df { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: med2df( a(m,n), [o]b(m,n), p, q, {Options} )' if $#_<2 || $#_>3; my($x,$p,$q) = @_; croak "med2df: kernel must contain some positive elements.\n" if $p == 0 && $q == 0; my $c = $#_ == 3 ? $_[3] : $x->nullcreate; &PDL::_med2df_int($x,$c,$p,$q, (!($opt && exists $$opt{Boundary}))?0:$boundary2value{$$opt{Boundary}} ); return $c; } *med2df = \&PDL::med2df; =head2 box2d =for sig Signature: (a(n,m); [o] b(n,m); int wx; int wy; int edgezero) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = box2d($a, $wx, $wy, $edgezero); box2d($a, $b, $wx, $wy, $edgezero); # all arguments given $b = $a->box2d($wx, $wy, $edgezero); # method call $a->box2d($b, $wx, $wy, $edgezero); =for ref fast 2D boxcar average =for example $smoothim = $im->box2d($wx,$wy,$edgezero=1); The edgezero argument controls if edge is set to zero (edgezero=1) or just keeps the original (unfiltered) values. C should be updated to support similar edge options as C and C etc. Boxcar averaging is a pretty crude way of filtering. For serious stuff better filters are around (e.g., use L with the appropriate kernel). On the other hand it is fast and computational cost grows only approximately linearly with window size. =pod Broadcasts over its inputs. =for bad C 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 *box2d = \&PDL::box2d; =head2 patch2d =for sig Signature: (a(m,n); int bad(m,n); [o]b(m,n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = patch2d($a, $bad); patch2d($a, $bad, $b); # all arguments given $b = $a->patch2d($bad); # method call $a->patch2d($bad, $b); =for ref patch bad pixels out of 2D images using a mask C<$bad> is a 2D mask array where 1=bad pixel 0=good pixel. Pixels are replaced by the average of their non-bad neighbours; if all neighbours are bad, the original data value is copied across. =pod Broadcasts over its inputs. =for bad This routine does not handle bad values - use L instead =cut *patch2d = \&PDL::patch2d; =head2 patchbad2d =for sig Signature: (a(m,n); [o]b(m,n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = patchbad2d($a); patchbad2d($a, $b); # all arguments given $b = $a->patchbad2d; # method call $a->patchbad2d($b); =for ref patch bad pixels out of 2D images containing bad values Pixels are replaced by the average of their non-bad neighbours; if all neighbours are bad, the output is set bad. If the input ndarray contains I bad values, then a straight copy is performed (see L). =pod Broadcasts over its inputs. =for bad patchbad2d handles bad values. The output ndarray I contain bad values, depending on the pattern of bad values in the input ndarray. =cut *patchbad2d = \&PDL::patchbad2d; =head2 max2d_ind =for sig Signature: (a(m,n); [o]val(); int [o]x(); int[o]y()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($val, $x, $y) = max2d_ind($a); max2d_ind($a, $val, $x, $y); # all arguments given ($val, $x, $y) = $a->max2d_ind; # method call $a->max2d_ind($val, $x, $y); =for ref Return value/position of maximum value in 2D image Contributed by Tim Jenness =pod Broadcasts over its inputs. =for bad Bad values are excluded from the search. If all pixels are bad then the output is set bad. =cut *max2d_ind = \&PDL::max2d_ind; =head2 centroid2d =for sig Signature: (im(m,n); x(); y(); box(); [o]xcen(); [o]ycen()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($xcen, $ycen) = centroid2d($im, $x, $y, $box); centroid2d($im, $x, $y, $box, $xcen, $ycen); # all arguments given ($xcen, $ycen) = $im->centroid2d($x, $y, $box); # method call $im->centroid2d($x, $y, $box, $xcen, $ycen); =for ref Refine a list of object positions in 2D image by centroiding in a box C<$box> is the full-width of the box, i.e. the window is C<+/- $box/2>. =pod Broadcasts over its inputs. =for bad Bad pixels are excluded from the centroid calculation. If all elements are bad (or the pixel sum is 0 - but why would you be centroiding something with negatives in...) then the output values are set bad. =cut *centroid2d = \&PDL::centroid2d; #line 708 "lib/PDL/Image2D.pd" =head2 crop =for ref Return bounding box of given mask in an C ndarray, so it can broadcast. Use other operations (such as L, or L with a colour vector) to create a mask suitable for your application. =for example $x1x2y1y2 = crop($image); =cut *crop = \&PDL::crop; sub PDL::crop { my ($mask) = @_; $mask->xchg(0,1)->orover->_which_int(my $out = null, null); $out->badflag(1); $out->badvalue(-1); my ($x1, $x2) = $out->minmaximum; $mask->orover->_which_int($out = null, null); $out->badflag(1); $out->badvalue(-1); my ($y1, $y2) = $out->minmaximum; $x1->cat($x2, $y1, $y2)->mv(-1,0); } #line 738 "lib/PDL/Image2D.pd" =head2 cc8compt =for ref Connected 8-component labeling of a binary image. Connected 8-component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. 8-component labeling includes all neighboring pixels. This is just a front-end to ccNcompt. See also L. =for example $segmented = cc8compt( $image > $threshold ); =head2 cc4compt =for ref Connected 4-component labeling of a binary image. Connected 4-component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. 4-component labling does not include the diagonal neighbors. This is just a front-end to ccNcompt. See also L. =for example $segmented = cc4compt( $image > $threshold ); =cut sub PDL::cc8compt{ return ccNcompt(shift,8); } *cc8compt = \&PDL::cc8compt; sub PDL::cc4compt{ return ccNcompt(shift,4); } *cc4compt = \&PDL::cc4compt; #line 587 "lib/PDL/Image2D.pm" =head2 ccNcompt =for sig Signature: (a(m,n); int+ [o]b(m,n); int con) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = ccNcompt($a, $con); ccNcompt($a, $b, $con); # all arguments given $b = $a->ccNcompt($con); # method call $a->ccNcompt($b, $con); =for ref Connected component labeling of a binary image. Connected component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. See also L and L. The connectivity parameter must be 4 or 8. =for example $segmented = ccNcompt( $image > $threshold, 4); $segmented2 = ccNcompt( $image > $threshold, 8); where the second parameter specifies the connectivity (4 or 8) of the labeling. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *ccNcompt = \&PDL::ccNcompt; #line 905 "lib/PDL/Image2D.pd" =head2 polyfill =for ref fill the area of the given polygon with the given colour. This function works inplace, i.e. modifies C. =for usage polyfill($im,$ps,$colour,[\%options]); The default method of determining which points lie inside of the polygon used is not as strict as the method used in L. Often, it includes vertices and edge points. Set the C option to change this behaviour. =for option Method - Set the method used to determine which points lie in the polygon. => Default - internal PDL algorithm => pnpoly - use the L algorithm =for example # Make a convex 3x3 square of 1s in an image using the pnpoly algorithm $ps = pdl([3,3],[3,6],[6,6],[6,3]); polyfill($im,$ps,1,{'Method' =>'pnpoly'}); =cut sub PDL::polyfill { my $opt; $opt = pop @_ if ref($_[-1]) eq 'HASH'; barf('Usage: polyfill($im,$ps,$colour,[\%options])') unless @_==3; my ($im,$ps,$colour) = @_; if($opt) { use PDL::Options qw(); my $parsed = PDL::Options->new({'Method' => undef}); $parsed->options($opt); if( $parsed->current->{'Method'} eq 'pnpoly' ) { PDL::pnpolyfill_pp($im,$ps,$colour); } } else { PDL::polyfill_pp($im,$ps,$colour); } return $im; } *polyfill = \&PDL::polyfill; #line 962 "lib/PDL/Image2D.pd" =head2 pnpoly =for ref 'points in a polygon' selection from a 2-D ndarray =for usage $mask = $img->pnpoly($ps); # Old style, do not use $mask = pnpoly($x, $y, $px, $py); For a closed polygon determined by the sequence of points in {$px,$py} the output of pnpoly is a mask corresponding to whether or not each coordinate (x,y) in the set of test points, {$x,$y}, is in the interior of the polygon. This is the 'points in a polygon' algorithm from L and vectorized for PDL by Karl Glazebrook. =for example # define a 3-sided polygon (a triangle) $ps = pdl([3, 3], [20, 20], [34, 3]); # $tri is 0 everywhere except for points in polygon interior $tri = $img->pnpoly($ps); With the second form, the x and y coordinates must also be specified. B< I >. $px = pdl( 3, 20, 34 ); $py = pdl( 3, 20, 3 ); $x = $img->xvals; # get x pixel coords $y = $img->yvals; # get y pixel coords # $tri is 0 everywhere except for points in polygon interior $tri = pnpoly($x,$y,$px,$py); =cut # From: http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html # # Fixes needed to pnpoly code: # # Use topdl() to ensure ndarray args # # Add POD docs for usage # # Calculate first term in & expression to use to fix divide-by-zero when # the test point is in line with a vertical edge of the polygon. # By adding the value of $mask we prevent a divide-by-zero since the & # operator does not "short circuit". sub PDL::pnpoly { barf('Usage: $mask = pnpoly($img, $ps);') unless(@_==2 || @_==4); my ($tx, $ty, $vertx, $verty) = @_; # if only two inputs, use the pure PP version unless( defined $vertx ) { barf("ps must contain pairwise points.\n") unless $ty->getdim(0) == 2; # Input mapping: $img => $tx, $ps => $ty return PDL::pnpoly_pp($tx,$ty); } my $testx = PDL::Core::topdl($tx)->dummy(0); my $testy = PDL::Core::topdl($ty)->dummy(0); my $vertxj = PDL::Core::topdl($vertx)->rotate(1); my $vertyj = PDL::Core::topdl($verty)->rotate(1); my $mask = ( ($verty>$testy) == ($vertyj>$testy) ); my $c = sumover( ! $mask & ( $testx < ($vertxj-$vertx) * ($testy-$verty) / ($vertyj-$verty+$mask) + $vertx) ) % 2; return $c; } *pnpoly = \&PDL::pnpoly; #line 1045 "lib/PDL/Image2D.pd" =head2 polyfillv =for ref return the (dataflowed) area of an image described by a polygon =for usage polyfillv($im,$ps,[\%options]); The default method of determining which points lie inside of the polygon used is not as strict as the method used in L. Often, it includes vertices and edge points. Set the C option to change this behaviour. =for option Method - Set the method used to determine which points lie in the polygon. => Default - internal PDL algorithm => pnpoly - use the L algorithm =for example # increment intensity in area bounded by $poly using the pnpoly algorithm $im->polyfillv($poly,{'Method'=>'pnpoly'})++; # legal in perl >= 5.6 # compute average intensity within area bounded by $poly using the default algorithm $av = $im->polyfillv($poly)->avg; =cut sub PDL::polyfillv :lvalue { my $opt; $opt = pop @_ if ref($_[-1]) eq 'HASH'; barf('Usage: polyfillv($im,$ps,[\%options])') unless @_==2; my ($im,$ps) = @_; barf("ps must contain pairwise points.\n") unless $ps->getdim(0) == 2; if($opt) { use PDL::Options qw(); my $parsed = PDL::Options->new({'Method' => undef}); $parsed->options($opt); return $im->where(PDL::pnpoly_pp($im, $ps)) if $parsed->current->{'Method'} eq 'pnpoly'; } PDL::polyfill_pp(my $msk = zeroes(long,$im->dims), $ps, 1); return $im->where($msk); } *polyfillv = \&PDL::polyfillv; #line 829 "lib/PDL/Image2D.pm" =head2 rot2d =for sig Signature: (im(m,n); float angle(); bg(); int aa(); [o] om(p,q)) Types: (byte) =for usage $om = rot2d($im, $angle, $bg, $aa); rot2d($im, $angle, $bg, $aa, $om); # all arguments given $om = $im->rot2d($angle, $bg, $aa); # method call $im->rot2d($angle, $bg, $aa, $om); =for ref rotate an image by given C =for example # rotate by 10.5 degrees with antialiasing, set missing values to 7 $rot = $im->rot2d(10.5,7,1); This function rotates an image through an C between -90 and + 90 degrees. Uses/doesn't use antialiasing depending on the C flag. Pixels outside the rotated image are set to C. Code modified from pnmrotate (Copyright Jef Poskanzer) with an algorithm based on "A Fast Algorithm for General Raster Rotation" by Alan Paeth, Graphics Interface '86, pp. 77-81. Use the C function to find out about the dimension of the newly created image ($newcols,$newrows) = rotnewsz $oldn, $oldm, $angle; L offers a more general interface to distortions, including rotation, with various types of sampling; but rot2d is faster. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *rot2d = \&PDL::rot2d; =head2 bilin2d =for sig Signature: (Int(n,m); [io] O(q,p)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage bilin2d($Int, $O); # all arguments given $Int->bilin2d($O); # method call =for ref Bilinearly maps the first ndarray in the second. The interpolated values are actually added to the second ndarray which is supposed to be larger than the first one. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *bilin2d = \&PDL::bilin2d; =head2 rescale2d =for sig Signature: (Int(m,n); [io] O(p,q)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage rescale2d($Int, $O); # all arguments given $Int->rescale2d($O); # method call =for ref The first ndarray is rescaled to the dimensions of the second (expanding or meaning values as needed) and then added to it in place. Nothing useful is returned. If you want photometric accuracy or automatic FITS header metadata tracking, consider using L instead: it does these things, at some speed penalty compared to rescale2d. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *rescale2d = \&PDL::rescale2d; #line 1331 "lib/PDL/Image2D.pd" =head2 fitwarp2d =for ref Find the best-fit 2D polynomial to describe a coordinate transformation. =for usage ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, $nf, { options } ) Given a set of points in the output plane (C<$u,$v>), find the best-fit (using singular-value decomposition) 2D polynomial to describe the mapping back to the image plane (C<$x,$y>). The order of the fit is controlled by the C<$nf> parameter (the maximum power of the polynomial is C<$nf - 1>), and you can restrict the terms to fit using the C option. C<$px> and C<$py> are C by C element ndarrays which describe a polynomial mapping (of order C) from the I C<(u,v)> image to the I C<(x,y)> image: x = sum(j=0,np-1) sum(i=0,np-1) px(i,j) * u^i * v^j y = sum(j=0,np-1) sum(i=0,np-1) py(i,j) * u^i * v^j The transformation is returned for the reverse direction (ie output to input image) since that is what is required by the L routine. The L routine can be used to convert a set of C<$u,$v> points given C<$px> and C<$py>. Options: =for options FIT - which terms to fit? default ones(byte,$nf,$nf) =begin comment old option, caused trouble THRESH - in svd, remove terms smaller than THRESH * max value default is 1.0e-5 =end comment =over 4 =item FIT C allows you to restrict which terms of the polynomial to fit: only those terms for which the FIT ndarray evaluates to true will be evaluated. If a 2D ndarray is sent in, then it is used for the x and y polynomials; otherwise C<< $fit->slice(":,:,(0)") >> will be used for C<$px> and C<< $fit->slice(":,:,(1)") >> will be used for C<$py>. =begin comment =item THRESH Remove all singular values whose value is less than C times the largest singular value. =end comment =back The number of points must be at least equal to the number of terms to fit (C<$nf*$nf> points for the default value of C). =for example # points in original image $x = pdl( 0, 0, 100, 100 ); $y = pdl( 0, 100, 100, 0 ); # get warped to these positions $u = pdl( 10, 10, 90, 90 ); $v = pdl( 10, 90, 90, 10 ); # # shift of origin + scale x/y axis only $fit = byte( [ [1,1], [0,0] ], [ [1,0], [1,0] ] ); ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2, { FIT => $fit } ); print "px = ${px}py = $py"; px = [ [-12.5 1.25] [ 0 0] ] py = [ [-12.5 0] [ 1.25 0] ] # # Compared to allowing all 4 terms ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2 ); print "px = ${px}py = $py"; px = [ [ -12.5 1.25] [ 1.110223e-16 -1.1275703e-17] ] py = [ [ -12.5 1.6653345e-16] [ 1.25 -5.8546917e-18] ] # A higher-degree polynomial should not affect the answer much, but # will require more control points $x = $x->glue(0,pdl(50,12.5, 37.5, 12.5, 37.5)); $y = $y->glue(0,pdl(50,12.5, 37.5, 37.5, 12.5)); $u = $u->glue(0,pdl(73,20,40,20,40)); $v = $v->glue(0,pdl(29,20,40,40,20)); ( $px3, $py3 ) = fitwarp2d( $x, $y, $u, $v, 3 ); print "px3 =${px3}py3 =$py3"; px3 = [ [-6.4981162e+08 71034917 -726498.95] [ 49902244 -5415096.7 55945.388] [ -807778.46 88457.191 -902.51612] ] py3 = [ [-6.2732159e+08 68576392 -701354.77] [ 48175125 -5227679.8 54009.114] [ -779821.18 85395.681 -871.27997] ] #This illustrates an important point about singular value #decompositions that are used in fitwarp2d: like all SVDs, the #rotation matrices are not unique, and so the $px and $py returned #by fitwarp2d are not guaranteed to be the "simplest" solution. #They do still work, though: ($x3,$y3) = applywarp2d($px3,$py3,$u,$v); print approx $x3,$x,1e-4; [1 1 1 1 1 1 1 1 1] print approx $y3,$y; [1 1 1 1 1 1 1 1 1] =head2 applywarp2d =for ref Transform a set of points using a 2-D polynomial mapping =for usage ( $x, $y ) = applywarp2d( $px, $py, $u, $v ) Convert a set of points (stored in 1D ndarrays C<$u,$v>) to C<$x,$y> using the 2-D polynomial with coefficients stored in C<$px> and C<$py>. See L for more information on the format of C<$px> and C<$py>. =cut # use SVD to fit data. Assuming no errors. =pod =begin comment Some explanation of the following three subroutines (_svd, _mkbasis, and fitwarp2d): See Wolberg 1990 (full ref elsewhere in this documentation), Chapter 3.6 "Polynomial Transformations". The idea is that, given a set of control points in the input and output images denoted by coordinates (x,y) and (u,v), we want to create a polynomial transformation that relates u to linear combinations of powers of x and y, and another that relates v to powers of x and y. The transformations used here and by Wolberg differ slightly, but the basic idea is something like this. For each u and each v, define a transform: u = (sum over j) (sum over i) a_{ij} x**i * y**j , (eqn 1) v = (sum over j) (sum over i) b_{ij} x**i * y**j . (eqn 2) We can write this in matrix notation. Given that there are M control points, U is a column vector with M rows. A and B are vectors containing the N coefficients (related to the degree of the polynomial fit). W is an MxN matrix of the basis row-vectors (the x**i y**j). The matrix equations we are trying to solve are U = W A , (eqn 3) V = W B . (eqn 4) We need to find the A and B column vectors, those are the coefficients of the polynomial terms in W. W is not square, so it has no inverse. But is has a pseudo-inverse W^+ that is NxM. We are going to use that pseudo-inverse to isolate A and B, like so: W^+ U = W^+ W A = A (eqn 5) W^+ V = W^+ W B = B (eqn 6) We are going to get W^+ by performing a singular value decomposition of W (to use some of the variable names below): W = $svd_u x SIGMA x $svd_v->transpose (eqn 7) W^+ = $svd_v x SIGMA^+ x $svd_u->transpose . (eqn 8) Here SIGMA is a square diagonal matrix that contains the singular values of W that are in the variable $svd_w. SIGMA^+ is the pseudo-inverse of SIGMA, which is calculated by replacing the non-zero singular values with their reciprocals, and then taking the transpose of the matrix (which is a no-op since the matrix is square and diagonal). So the code below does this: _mkbasis computes the matrix W, given control coordinates u and v and the maximum degree of the polynomial (and the terms to use). _svd takes the svd of W, computes the pseudo-inverse of W, and then multiplies that with the U vector (there called $y). The output of _svd is the A or B vector in eqns 5 & 6 above. Rarely is the matrix multiplication explicit, unfortunately, so I have added EXPLANATIONs below. =end comment =cut sub _svd ($$) { my $basis = shift; my $y = shift; # my $thresh = shift; # if we had errors for these points, would normalise the # basis functions, and the output array, by these errors here # perform the SVD my ( $svd_u, $svd_w, $svd_v ) = svd( $basis ); # DAL, 09/2017: the reason for removing ANY singular values, much less #the smallest ones, is not clear. I commented the line below since this #actually removes the LARGEST values in SIGMA^+. # $svd_w *= ( $svd_w >= ($svd_w->max * $thresh ) ); # The line below would instead remove the SMALLEST values in SIGMA^+, but I can see no reason to include it either. # $svd_w *= ( $svd_w <= ($svd_w->min / $thresh ) ); # perform the back substitution # EXPLANATION: same thing as $svd_u->transpose x $y->transpose. my $tmp = $y x $svd_u; #EXPLANATION: the division by (the non-zero elements of) $svd_w (the singular values) is #equivalent to $sigma_plus x $tmp, so $tmp is now SIGMA^+ x $svd_u x $y $tmp /= $svd_w->setvaltobad(0.0); $tmp->inplace->setbadtoval(0.0); #EXPLANATION: $svd_v x SIGMA^+ x $svd_u x $y return sumover( $svd_v * $tmp ); } # sub: _svd() #_mkbasis returns an ndarray in which the k(=j*n+i)_th column is v**j * u**i #k=0 j=0 i=0 #k=1 j=0 i=1 #k=2 j=0 i=2 #k=3 j=1 i=0 # ... #each row corresponds to a control point #and the rows for each of the control points look like this, e.g.: # (1) (u) (u**2) (v) (vu) (v(u**2)) (v**2) ((v**2)u) ((v**2)(u**2)) # and so on for the next control point. sub _mkbasis ($$$$) { my $fit = shift; # dims n n my $npts = shift; # scalar my $u = shift; # dims npts my $v = shift; # dims npts my $ncoeff = sum( $fit ); my $fit_coords = $fit->whichND; # dims uv ncoeff cat($u,$v) # npts uv ->transpose # uv npts ->dummy(1,$ncoeff) # uv ncoeff npts ->ipow($fit_coords) # same ->prodover # ncoeff npts ; } # sub: _mkbasis() sub PDL::fitwarp2d { croak "Usage: (\$px,\$py) = fitwarp2d(x(m);y(m);u(m);v(m);\$nf; { options })" if $#_ < 4 or ( $#_ >= 5 and ref($_[5]) ne "HASH" ); my $x = shift; my $y = shift; my $u = shift; my $v = shift; my $nf = shift; my $opts = PDL::Options->new( { FIT => ones(byte,$nf,$nf) } ); #, THRESH => 1.0e-5 } ); $opts->options( $_[0] ) if $#_ > -1; my $oref = $opts->current(); # safety checks my $npts = $x->nelem; croak "fitwarp2d: x, y, u, and v must be the same size (and 1D)" unless $npts == $y->nelem and $npts == $u->nelem and $npts == $v->nelem and $x->getndims == 1 and $y->getndims == 1 and $u->getndims == 1 and $v->getndims == 1; # my $svd_thresh = $$oref{THRESH}; # croak "fitwarp2d: THRESH option must be >= 0." # if $svd_thresh < 0; my $fit = $$oref{FIT}; my $fit_ndim = $fit->getndims(); croak "fitwarp2d: FIT option must be sent a (\$nf,\$nf[,2]) element ndarray" unless UNIVERSAL::isa($fit,"PDL") and ($fit_ndim == 2 or ($fit_ndim == 3 and $fit->getdim(2) == 2)) and $fit->getdim(0) == $nf and $fit->getdim(1) == $nf; # how many coeffs to fit (first we ensure $fit is either 0 or 1) $fit = convert( $fit != 0, byte ); my ( $fitx, $fity, $ncoeffx, $ncoeffy, $ncoeff ); if ( $fit_ndim == 2 ) { $fitx = $fit; $fity = $fit; $ncoeff = $ncoeffx = $ncoeffy = sum( $fit ); } else { $fitx = $fit->slice(",,(0)"); $fity = $fit->slice(",,(1)"); $ncoeffx = sum($fitx); $ncoeffy = sum($fity); $ncoeff = $ncoeffx > $ncoeffy ? $ncoeffx : $ncoeffy; } croak "fitwarp2d: number of points ($npts) must be >= \$ncoeff ($ncoeff)" unless $npts >= $ncoeff; # create the basis functions for the SVD fitting my ( $basisx, $basisy ); $basisx = _mkbasis( $fitx, $npts, $u, $v ); if ( $fit_ndim == 2 ) { $basisy = $basisx; } else { $basisy = _mkbasis( $fity, $npts, $u, $v ); } my $px = _svd( $basisx, $x ); # $svd_thresh); my $py = _svd( $basisy, $y ); # $svd_thresh); # convert into $nf x $nf element ndarrays, if necessary my $nf2 = $nf * $nf; return ( $px->reshape($nf,$nf), $py->reshape($nf,$nf) ) if $ncoeff == $nf2 and $ncoeffx == $ncoeffy; # re-create the matrix my $xtmp = zeroes( $nf, $nf ); my $ytmp = zeroes( $nf, $nf ); my $kx = 0; my $ky = 0; foreach my $i ( 0 .. ($nf - 1) ) { foreach my $j ( 0 .. ($nf - 1) ) { if ( $fitx->at($i,$j) ) { $xtmp->set($i,$j, $px->at($kx) ); $kx++; } if ( $fity->at($i,$j) ) { $ytmp->set($i,$j, $py->at($ky) ); $ky++; } } } return ( $xtmp, $ytmp ) } # sub: fitwarp2d *fitwarp2d = \&PDL::fitwarp2d; sub PDL::applywarp2d { # checks croak "Usage: (\$x,\$y) = applywarp2d(px(nf,nf);py(nf,nf);u(m);v(m);)" if $#_ != 3; my $px = shift; my $py = shift; my $u = shift; my $v = shift; my $npts = $u->nelem; # safety check croak "applywarp2d: u and v must be the same size (and 1D)" unless $npts == $u->nelem and $npts == $v->nelem and $u->getndims == 1 and $v->getndims == 1; my $nf = $px->getdim(0); my $nf2 = $nf * $nf; # could remove terms with 0 coeff here # (would also have to remove them from px/py for # the matrix multiplication below) # my $mat = _mkbasis( ones(byte,$nf,$nf), $npts, $u, $v ); my $x = reshape( $mat x $px->flat->transpose(), $npts ); my $y = reshape( $mat x $py->flat->transpose(), $npts ); return ( $x, $y ); } # sub: applywarp2d *applywarp2d = \&PDL::applywarp2d; #line 1390 "lib/PDL/Image2D.pm" =head2 warp2d =for sig Signature: (img(m,n); ldouble px(np,np); ldouble py(np,np); [o] warp(m,n); ldouble [t] poly(np); ldouble [t] kernel(ns); char *kernel_type; double noval; IV nsamples => ns) Types: (float double ldouble) =for ref Warp a 2D image given a polynomial describing the I mapping. =for usage $out = warp2d( $img, $px, $py, { options } ); Apply the polynomial transformation encoded in the C<$px> and C<$py> ndarrays to warp the input image C<$img> into the output image C<$out>. The format for the polynomial transformation is described in the documentation for the L routine. At each point C, the closest 16 pixel values are combined with an interpolation kernel to calculate the value at C. The interpolation is therefore done in the image, rather than Fourier, domain. By default, a C kernel is used, but this can be changed using the C option discussed below (the choice of kernel depends on the frequency content of the input image). The routine is based on the C command from the Eclipse data-reduction package - see http://www.eso.org/eclipse/ - and for further details on image resampling see Wolberg, G., "Digital Image Warping", 1990, IEEE Computer Society Press ISBN 0-8186-8944-7). Currently the output image is the same size as the input one, which means data will be lost if the transformation reduces the pixel scale. This will (hopefully) be changed soon. =for example $img = rvals(byte,501,501); imag $img, { JUSTIFY => 1 }; # # use a not-particularly-obvious transformation: # x = -10 + 0.5 * $u - 0.1 * $v # y = -20 + $v - 0.002 * $u * $v # $px = pdl( [ -10, 0.5 ], [ -0.1, 0 ] ); $py = pdl( [ -20, 0 ], [ 1, 0.002 ] ); $wrp = warp2d( $img, $px, $py ); # # see the warped image imag $warp, { JUSTIFY => 1 }; The options are: =for options KERNEL - default value is tanh NOVAL - default value is 0 C is used to specify which interpolation kernel to use (to see what these kernels look like, use the L routine). The options are: =over 4 =item tanh Hyperbolic tangent: the approximation of an ideal box filter by the product of symmetric tanh functions. =item sinc For a correctly sampled signal, the ideal filter in the fourier domain is a rectangle, which produces a C interpolation kernel in the spatial domain: sinc(x) = sin(pi * x) / (pi * x) However, it is not ideal for the C<4x4> pixel region used here. =item sinc2 This is the square of the sinc function. =item lanczos Although defined differently to the C kernel, the result is very similar in the spatial domain. The Lanczos function is defined as L(x) = sinc(x) * sinc(x/2) if abs(x) < 2 = 0 otherwise =item hann This kernel is derived from the following function: H(x) = a + (1-a) * cos(2*pi*x/(N-1)) if abs(x) < 0.5*(N-1) = 0 otherwise with C and N currently equal to 2001. =item hamming This kernel uses the same C as the Hann filter, but with C. =back C gives the value used to indicate that a pixel in the output image does not map onto one in the input image. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut # support routine { my %warp2d = map { ($_,1) } qw( tanh sinc sinc2 lanczos hamming hann ); # note: convert to lower case sub _check_kernel ($$) { my $kernel = lc shift; my $code = shift; barf "Unknown kernel $kernel sent to $code\n" . "\tmust be one of [" . join(',',keys %warp2d) . "]\n" unless exists $warp2d{$kernel}; return $kernel; } } sub PDL::warp2d { my $opts = PDL::Options->new( { KERNEL => "tanh", NOVAL => 0 } ); $opts->options( pop(@_) ) if ref($_[$#_]) eq "HASH"; die "Usage: warp2d( in(m,n), px(np,np); py(np,np); [o] out(m,n), {Options} )" if $#_<2 || $#_>3; my $img = shift; my $px = shift; my $py = shift; my $out = $#_ == -1 ? PDL->null() : shift; # safety checks my $copt = $opts->current(); my $kernel = _check_kernel( $$copt{KERNEL}, "warp2d" ); &PDL::_warp2d_int( $img, $px, $py, $out, $kernel, $$copt{NOVAL}, _get_kernel_size() ); return $out; } *warp2d = \&PDL::warp2d; =head2 warp2d_kernel =for sig Signature: ([o] x(n); [o] k(n); ldouble [t] kernel(n); char *name; PDL_Indx nsize => n) Types: (float double ldouble) =for ref Return the specified kernel, as used by L =for usage ( $x, $k ) = warp2d_kernel( $name ) The valid values for C<$name> are the same as the C option of L. =for example line warp2d_kernel( "hamming" ); =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut sub PDL::warp2d_kernel ($) { my $kernel = _check_kernel( shift, "warp2d_kernel" ); &PDL::_warp2d_kernel_int( my $x=PDL->null, my $k=PDL->null, $kernel, _get_kernel_size() ); return ( $x, $k ); } *warp2d_kernel = \&PDL::warp2d_kernel; #line 37 "lib/PDL/Image2D.pd" =head1 AUTHORS Copyright (C) Karl Glazebrook 1997 with additions by Robin Williams (rjrw@ast.leeds.ac.uk), Tim Jenness (timj@jach.hawaii.edu), and Doug Burke (burke@ifa.hawaii.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut #line 1629 "lib/PDL/Image2D.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/FFT.pm0000644000175000017500000002414014771136050014760 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/FFT.pd! Don't modify! # package PDL::FFT; our @EXPORT_OK = qw(fft ifft fftnd ifftnd fftconvolve realfft realifft kernctr ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::FFT ; #line 12 "lib/PDL/FFT.pd" =head1 NAME PDL::FFT - FFTs for PDL =head1 DESCRIPTION !!!!!!!!!!!!!!!!!!!!!!!!!!WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! As of PDL-2.006_04, the direction of the FFT/IFFT has been reversed to match the usage in the FFTW library and the convention in use generally. !!!!!!!!!!!!!!!!!!!!!!!!!!WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FFTs for PDL. These work for arrays of any dimension, although ones with small prime factors are likely to be the quickest. The forward FFT is unnormalized while the inverse FFT is normalized so that the IFFT of the FFT returns the original values. For historical reasons, these routines work in-place and do not recognize the in-place flag. That should be fixed. =head1 SYNOPSIS use PDL::FFT qw/:Func/; fft($real, $imag); ifft($real, $imag); realfft($real); realifft($real); fftnd($real,$imag); ifftnd($real,$imag); $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); =head1 DATA TYPES The underlying C library upon which this module is based performs FFTs on both single precision and double precision floating point ndarrays. The PP functions are defined to only take those data types. Therefore, if you pass in an ndarray of integer datatype (byte, short, ushort, long) to any of the routines in PDL::FFT, your data will be promoted to a double-precision ndarray. If you pass in a float, the single-precision FFT will be performed. =head1 FREQUENCIES For even-sized input arrays, the frequencies are packed like normal for FFTs (where N is the size of the array and D is the physical step size between elements): 0, 1/ND, 2/ND, ..., (N/2-1)/ND, 1/2D, -(N/2-1)/ND, ..., -1/ND. which can easily be obtained (taking the Nyquist frequency to be positive) using C<< $kx = $real->xlinvals(-($N/2-1)/$N/$D,1/2/$D)->rotate(-($N/2 -1)); >> For odd-sized input arrays the Nyquist frequency is not directly acessible, and the frequencies are 0, 1/ND, 2/ND, ..., (N/2-0.5)/ND, -(N/2-0.5)/ND, ..., -1/ND. which can easily be obtained using C<< $kx = $real->xlinvals(-($N/2-0.5)/$N/$D,($N/2-0.5)/$N/$D)->rotate(-($N-1)/2); >> =head1 ALTERNATIVE FFT PACKAGES Various other modules - such as L and L - contain FFT routines. However, unlike PDL::FFT, these modules are optional, and so may not be installed. =cut #line 104 "lib/PDL/FFT.pm" =head1 FUNCTIONS =cut =head2 fft =for sig Signature: ([io]real(n); [io]imag(n)) Types: (float double ldouble) =for usage fft($real, $imag); # all arguments given $real->fft($imag); # method call =for ref Complex 1-D FFT of the "real" and "imag" arrays [inplace]. A single cfloat/cdouble input ndarray can also be used. =pod Broadcasts over its inputs. =for bad C 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 sub PDL::fft { # Convert the first argument to decimal and check for trouble. my ($re, $im) = @_; if (!$re->type->real) { $im=$re->im; $re=$re->re; } eval { todecimal($re); }; if ($@) { $@ =~ s/ at .*//s; barf("Error in FFT with first argument: $@"); } # Convert the second argument to decimal and check for trouble. eval { todecimal($im); }; if ($@) { $@ =~ s/ at .*//s; my $message = "Error in FFT with second argument: $@"; $message .= '. Did you forget to supply the second (imaginary) ndarray?' if ($message =~ /undefined value/); barf($message); } PDL::_fft_int($re,$im); if (!$_[0]->type->real) { $_[0]= czip($re, $im); } else { $_[0]=$re,$_[1]=$im; } } *fft = \&PDL::fft; =head2 ifft =for sig Signature: ([io]real(n); [io]imag(n)) Types: (float double ldouble) =for usage ifft($real, $imag); # all arguments given $real->ifft($imag); # method call =for ref Complex inverse 1-D FFT of the "real" and "imag" arrays [inplace]. A single cfloat/cdouble input ndarray can also be used. =pod Broadcasts over its inputs. =for bad C 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 sub PDL::ifft { # Convert the first argument to decimal and check for trouble. my ($re, $im) = @_; if (!$re->type->real) { $im=$re->im; $re=$re->re; } eval { todecimal($re); }; if ($@) { $@ =~ s/ at .*//s; barf("Error in FFT with first argument: $@"); } # Convert the second argument to decimal and check for trouble. eval { todecimal($im); }; if ($@) { $@ =~ s/ at .*//s; my $message = "Error in FFT with second argument: $@"; $message .= '. Did you forget to supply the second (imaginary) ndarray?' if ($message =~ /undefined value/); barf($message); } PDL::_ifft_int($re,$im); if (!$_[0]->type->real) { $_[0]= czip($re, $im); } else { $_[0]=$re,$_[1]=$im; } } *ifft = \&PDL::ifft; #line 180 "lib/PDL/FFT.pd" use Carp; use PDL::Core qw/:Func/; use PDL::Basic qw/:Func/; use PDL::Types; use PDL::ImageND qw/kernctr/; # moved to ImageND since FFTW uses it too use PDL::Ops qw/czip/; sub todecimal { my ($arg) = @_; $arg = $arg->double if $arg->type->integer; $_[0] = $arg; 1;} =head2 realfft() =for ref One-dimensional FFT of real function [inplace]. The real part of the transform ends up in the first half of the array and the imaginary part of the transform ends up in the second half of the array. =for usage realfft($real); =cut *realfft = \&PDL::realfft; sub PDL::realfft { barf("Usage: realfft(real(*)") if $#_ != 0; my ($x) = @_; todecimal($x); # FIX: could eliminate $y my ($y) = 0*$x; fft($x,$y); my ($n) = int((($x->dims)[0]-1)/2); my($t); ($t=$x->slice("-$n:-1")) .= $y->slice("1:$n"); undef; } =head2 realifft() =for ref Inverse of one-dimensional realfft routine [inplace]. =for usage realifft($real); =cut *realifft = \&PDL::realifft; sub PDL::realifft { use PDL::Ufunc 'max'; barf("Usage: realifft(xfm(*)") if $#_ != 0; my ($x) = @_; todecimal($x); my ($n) = int((($x->dims)[0]-1)/2); my($t); # FIX: could eliminate $y my ($y) = 0*$x; ($t=$y->slice("1:$n")) .= $x->slice("-$n:-1"); ($t=$x->slice("-$n:-1")) .= $x->slice("$n:1"); ($t=$y->slice("-$n:-1")) .= -$y->slice("$n:1"); ifft($x,$y); # Sanity check -- shouldn't happen carp "Bad inverse transform in realifft" if max(abs($y)) > 1e-6*max(abs($x)); undef; } =head2 fftnd() =for ref N-dimensional FFT over all pdl dims of input (inplace) =for example fftnd($real,$imag); =cut *fftnd = \&PDL::fftnd; sub PDL::fftnd { my ($r,$i) = @_; barf "Must have real and imaginary parts or complex for fftnd" if $r->type->real and @_ != 2; if (!$r->type->real) { $i=$r->im; $r=$r->re; } my ($n) = $r->getndims; barf "Dimensions of real and imag must be the same for fft" if ($n != $i->getndims); $n--; todecimal($r); todecimal($i); # need the copy in case $r and $i point to same memory $i = $i->copy; foreach (0..$n) { fft($r,$i); $r = $r->mv(0,$n) if 0 != $n; $i = $i->mv(0,$n) if 0 != $n; } if (!$_[0]->type->real) { $_[0]= czip($r, $i); } else { $_[0] = $r; $_[1] = $i; } undef; } =head2 ifftnd() =for ref N-dimensional inverse FFT over all pdl dims of input (inplace) =for example ifftnd($real,$imag); =cut *ifftnd = \&PDL::ifftnd; sub PDL::ifftnd { my ($r,$i) = @_; barf "Must have real and imaginary parts or complex for ifftnd" if $r->type->real and @_ != 2; if (!$r->type->real) { $i=$r->im; $r=$r->re; } my ($n) = $r->getndims; barf "Dimensions of real and imag must be the same for ifft" if ($n != $i->getndims); todecimal($r); todecimal($i); # need the copy in case $r and $i point to same memory $i = $i->copy; $n--; foreach (0..$n) { ifft($r,$i); $r = $r->mv(0,$n) if 0 != $n; $i = $i->mv(0,$n) if 0 != $n; } if (!$_[0]->type->real) { $_[0]= czip($r, $i); } else { $_[0] = $r; $_[1] = $i; } undef; } =head2 fftconvolve() =for ref N-dimensional convolution with periodic boundaries (FFT method) =for usage $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); fftconvolve works inplace, and returns an error array in kernel as an accuracy check -- all the values in it should be negligible. See also L, which performs speed-optimized convolution with a variety of boundary conditions. The sizes of the image and the kernel must be the same. L centres a small kernel to emulate the behaviour of the direct convolution routines. The speed cross-over between using straight convolution (L) and these fft routines is for kernel sizes roughly 7x7. =cut *fftconvolve = \&PDL::fftconvolve; sub PDL::fftconvolve { barf "Must have image & kernel for fftconvolve" if $#_ != 1; my ($im, $k) = map $_->r2C, @_; fftnd($im); fftnd($k); my $c = $im * $k; ifftnd($c); $_[0] = $c->re->sever; $_[1] = $c->im->sever; @_; } #line 383 "lib/PDL/FFT.pd" =head1 BUGS Where the source is marked `FIX', could re-implement using phase-shift factors on the transforms and some real-space bookkeeping, to save some temporary space and redundant transforms. =head1 AUTHOR This file copyright (C) 1997, 1998 R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut #line 475 "lib/PDL/FFT.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/Bad.pm0000644000175000017500000005126514771136047015045 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Bad.pd! Don't modify! # package PDL::Bad; our @EXPORT_OK = qw(badflag check_badflag badvalue orig_badvalue nbad nbadover ngood ngoodover setbadat isbad isgood nbadover ngoodover setbadif setvaltobad setnantobad setinftobad setnonfinitetobad setbadtonan setbadtoval badmask copybad locf ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Bad ; #line 20 "lib/PDL/Bad.pd" =head1 NAME PDL::Bad - PDL always processes bad values =head1 DESCRIPTION This module is loaded when you do C, C or C. Implementation details are given in L. =head1 SYNOPSIS use PDL::Bad; print "\nBad value per PDL support in PDL is turned " . $PDL::Bad::PerPdl ? "on" : "off" . ".\n"; =head1 VARIABLES =over 4 =item $PDL::Bad::UseNaN Set to 0 as of PDL 2.040, as no longer available, though NaN can be used as a badvalue for a given PDL object. =item $PDL::Bad::PerPdl Set to 1 as of PDL 2.040 as always available. =item $PDL::Bad::Status Set to 1 as of PDL 2.035 as always available. =back =cut #line 67 "lib/PDL/Bad.pm" =head1 FUNCTIONS =cut #line 63 "lib/PDL/Bad.pd" $PDL::Bad::Status = 1; $PDL::Bad::UseNaN = 0; $PDL::Bad::PerPdl = 1; use strict; use PDL::Types; use PDL::Primitive; ############################################################ ############################################################ #line 79 "lib/PDL/Bad.pd" ############################################################ ############################################################ *badflag = \&PDL::badflag; *badvalue = \&PDL::badvalue; *orig_badvalue = \&PDL::orig_badvalue; ############################################################ ############################################################ =head2 badflag =for ref getter/setter for the bad data flag =for example if ( $x->badflag() ) { print "Data may contain bad values.\n"; } $x->badflag(1); # set bad data flag $x->badflag(0); # unset bad data flag When called as a setter, this modifies the ndarray on which it is called. This always returns a Perl scalar with the final value of the bad flag. A return value of 1 does not guarantee the presence of bad data in an ndarray; all it does is say that we need to I for the presence of such beasties. To actually find out if there are any bad values present in an ndarray, use the L method. =for bad This function works with ndarrays that have bad values. It always returns a Perl scalar, so it never returns bad values. =head2 badvalue =for ref returns (or sets) the value used to indicate a missing (or bad) element for the given ndarray type. You can give it an ndarray, a PDL::Type object, or one of C<$PDL_B>, C<$PDL_S>, etc. =for example $badval = badvalue( float ); $x = ones(ushort,10); print "The bad data value for ushort is: ", $x->badvalue(), "\n"; This can act as a setter (e.g. C<< $x->badvalue(23) >>), including with the value C for floating-point types. Note that this B for floating-point-typed ndarrays. That is, if C<$x> already has bad values, they will not be changed to use the given number and if any elements of C<$x> have that value, they will unceremoniously be marked as bad data. See L, L, and L for ways to actually modify the data in ndarrays It I change data for integer-typed arrays, changing values that had the old bad value to have the new one. It is possible to change the bad value on a per-ndarray basis, so $x = sequence (10); $x->badvalue (3); $x->badflag (1); $y = sequence (10); $y->badvalue (4); $y->badflag (1); will set $x to be C<[0 1 2 BAD 4 5 6 7 8 9]> and $y to be C<[0 1 2 3 BAD 5 6 7 8 9]>. =for bad This method does not care if you call it on an input ndarray that has bad values. It always returns an ndarray with the current or new bad value. =cut sub PDL::badvalue { my ( $self, $val ) = @_; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; if ( $num < $PDL_F && defined($val) && $self->badflag ) { $self->inplace->setbadtoval( $val ); $self->badflag(1); } return PDL::Bad::_badvalue_per_pdl_int($self, $val, $num); } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } PDL::Bad::_badvalue_int( $val, $num ); } =head2 orig_badvalue =for ref returns the original value used to represent bad values for a given type. This routine operates the same as L, except you can not change the values. It also has an I name. =for example $orig_badval = orig_badvalue( float ); $x = ones(ushort,10); print "The original bad data value for ushort is: ", $x->orig_badvalue(), "\n"; =for bad This method does not care if you call it on an input ndarray that has bad values. It always returns an ndarray with the original bad value for the associated type. =cut sub PDL::orig_badvalue { no strict 'refs'; my $self = shift; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } PDL::Bad::_default_badvalue_int($num); } =head2 check_badflag =for ref Clear the badflag of an ndarray if it does not contain any bad values Given an ndarray whose bad flag is set, check whether it actually contains any bad values and, if not, clear the flag. It returns the final state of the badflag. =for example print "State of bad flag == ", $pdl->check_badflag; =for bad This method accepts ndarrays with or without bad values. It returns an ndarray with the final badflag. =cut *check_badflag = \&PDL::check_badflag; sub PDL::check_badflag { my $pdl = shift; $pdl->badflag(0) if $pdl->badflag and $pdl->nbad == 0; return $pdl->badflag; } # sub: check_badflag() #line 268 "lib/PDL/Bad.pm" =head2 isbad =for sig Signature: (a(); int [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = isbad($a); isbad($a, $b); # all arguments given $b = $a->isbad; # method call $a->isbad($b); =for ref Returns a binary mask indicating which values of the input are bad values Returns a 1 if the value is bad, 0 otherwise. Similar to L. =for example $x = pdl(1,2,3); $x->badflag(1); set($x,1,$x->badvalue); $y = isbad($x); print $y, "\n"; [0 1 0] =pod Broadcasts over its inputs. =for bad This method works with input ndarrays that are bad. The output ndarray will never contain bad values, but its bad value flag will be the same as the input ndarray's flag. =cut *isbad = \&PDL::isbad; =head2 isgood =for sig Signature: (a(); int [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = isgood($a); isgood($a, $b); # all arguments given $b = $a->isgood; # method call $a->isgood($b); =for ref Is a value good? Returns a 1 if the value is good, 0 otherwise. Also see L. =for example $x = pdl(1,2,3); $x->badflag(1); set($x,1,$x->badvalue); $y = isgood($x); print $y, "\n"; [1 0 1] =pod Broadcasts over its inputs. =for bad This method works with input ndarrays that are bad. The output ndarray will never contain bad values, but its bad value flag will be the same as the input ndarray's flag. =cut *isgood = \&PDL::isgood; =head2 nbadover =for sig Signature: (a(n); indx [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = nbadover($a); nbadover($a, $b); # all arguments given $b = $a->nbadover; # method call $a->nbadover($b); =for ref Find the number of bad elements along the 1st dimension. This function reduces the dimensionality of an ndarray by one by finding the number of bad elements along the 1st dimension. In this sense it shares much in common with the functions defined in L. In particular, by using L and similar dimension rearranging methods, it is possible to perform this calculation over I dimension. =pod Broadcasts over its inputs. =for bad nbadover processes input values that are bad. The output ndarray will not have any bad values, but the bad flag will be set if the input ndarray had its bad flag set. =cut *nbadover = \&PDL::nbadover; =head2 ngoodover =for sig Signature: (a(n); indx [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = ngoodover($a); ngoodover($a, $b); # all arguments given $b = $a->ngoodover; # method call $a->ngoodover($b); =for ref Find the number of good elements along the 1st dimension. This function reduces the dimensionality of an ndarray by one by finding the number of good elements along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad ngoodover processes input values that are bad. The output ndarray will not have any bad values, but the bad flag will be set if the input ndarray had its bad flag set. =cut *ngoodover = \&PDL::ngoodover; #line 463 "lib/PDL/Bad.pd" *nbad = \&PDL::nbad; sub PDL::nbad { my($x) = @_; my $tmp; $x->flat->nbadover($tmp=PDL->nullcreate($x) ); return $tmp; } #line 463 "lib/PDL/Bad.pd" *ngood = \&PDL::ngood; sub PDL::ngood { my($x) = @_; my $tmp; $x->flat->ngoodover($tmp=PDL->nullcreate($x) ); return $tmp; } #line 475 "lib/PDL/Bad.pd" =head2 nbad =for ref Returns the number of bad values in an ndarray =for bad Accepts good and bad input ndarrays; output is an ndarray and is always good. =head2 ngood =for ref Returns the number of good values in an ndarray =for usage $x = ngood($data); =for bad Accepts good and bad input ndarrays; output is an ndarray and is always good. =head2 setbadat =for ref Set the value to bad at a given position. =for usage setbadat $ndarray, @position C<@position> is a coordinate list, of size equal to the number of dimensions in the ndarray. This is a wrapper around L and is probably mainly useful in test scripts! =for example pdl> $x = sequence 3,4 pdl> $x->setbadat 2,1 pdl> p $x [ [ 0 1 2] [ 3 4 BAD] [ 6 7 8] [ 9 10 11] ] =for bad This method can be called on ndarrays that have bad values. The remainder of the arguments should be Perl scalars indicating the position to set as bad. The output ndarray will have bad values and will have its badflag turned on. =cut *setbadat = \&PDL::setbadat; sub PDL::setbadat { barf 'Usage: setbadat($pdl, $x, $y, ...)' if $#_<1; my $self = shift; PDL::Core::set_c ($self, [@_], $self->badvalue); $self->badflag(1); return $self; } #line 561 "lib/PDL/Bad.pm" =head2 setbadif =for sig Signature: (a(); int mask(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = setbadif($a, $mask); setbadif($a, $mask, $b); # all arguments given $b = $a->setbadif($mask); # method call $a->setbadif($mask, $b); =for ref Set elements bad based on the supplied mask, otherwise copy across the data. =for example pdl> $x = sequence(5,5) pdl> $x = $x->setbadif( $x % 2 ) pdl> p "a badflag: ", $x->badflag, "\n" a badflag: 1 pdl> p "a is\n$x" [ [ 0 BAD 2 BAD 4] [BAD 6 BAD 8 BAD] [ 10 BAD 12 BAD 14] [BAD 16 BAD 18 BAD] [ 20 BAD 22 BAD 24] ] Unfortunately, this routine can I be run inplace, since the current implementation can not handle the same ndarray used as C and C (eg C<< $x->inplace->setbadif($x%2) >> fails). Even more unfortunate: we can't catch this error and tell you. =pod Broadcasts over its inputs. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L to check whether there are any bad values in the output). The input ndarray can have bad values: any bad values in the input ndarrays are copied across to the output ndarray. Also see L and L. =cut *setbadif = \&PDL::setbadif; =head2 setvaltobad =for sig Signature: (a(); [o]b(); double value) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = setvaltobad($a, $value); setvaltobad($a, $b, $value); # all arguments given $b = $a->setvaltobad($value); # method call $a->setvaltobad($b, $value); $a->inplace->setvaltobad($value); # can be used inplace setvaltobad($a->inplace, $value); =for ref Set bad all those elements which equal the supplied value. =for example $x = sequence(10) % 3; $x->inplace->setvaltobad( 0 ); print "$x\n"; [BAD 1 2 BAD 1 2 BAD 1 2 BAD] This is a simpler version of L, but this function can be done inplace. See L if you want to convert NaN to the bad value. =pod Broadcasts over its inputs. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L to check whether there are any bad values in the output). Any bad values in the input ndarrays are copied across to the output ndarray. =cut *setvaltobad = \&PDL::setvaltobad; =head2 setnantobad =for sig Signature: (a(); [o]b()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $b = setnantobad($a); setnantobad($a, $b); # all arguments given $b = $a->setnantobad; # method call $a->setnantobad($b); $a->inplace->setnantobad; # can be used inplace setnantobad($a->inplace); =for ref Sets NaN values (for complex, where either is NaN) in the input ndarray bad (only relevant for floating-point ndarrays). =pod Broadcasts over its inputs. =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not a number (before version 2.040 the test was for "not finite") is also set to bad in the output ndarray. If all values from the input ndarray are good, the output ndarray will B have its bad flag set. =cut *setnantobad = \&PDL::setnantobad; =head2 setinftobad =for sig Signature: (a(); [o]b()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $b = setinftobad($a); setinftobad($a, $b); # all arguments given $b = $a->setinftobad; # method call $a->setinftobad($b); $a->inplace->setinftobad; # can be used inplace setinftobad($a->inplace); =for ref Sets non-finite values (for complex, where either is non-finite) in the input ndarray bad (only relevant for floating-point ndarrays). =pod Broadcasts over its inputs. =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not finite is also set to bad in the output ndarray. If all values from the input ndarray are finite, the output ndarray will B have its bad flag set. =cut *setinftobad = \&PDL::setinftobad; =head2 setnonfinitetobad =for sig Signature: (a(); [o]b()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $b = setnonfinitetobad($a); setnonfinitetobad($a, $b); # all arguments given $b = $a->setnonfinitetobad; # method call $a->setnonfinitetobad($b); $a->inplace->setnonfinitetobad; # can be used inplace setnonfinitetobad($a->inplace); =for ref Sets non-finite values (for complex, where either is non-finite) in the input ndarray bad (only relevant for floating-point ndarrays). =pod Broadcasts over its inputs. =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not finite is also set to bad in the output ndarray. If all values from the input ndarray are finite, the output ndarray will B have its bad flag set. =cut *setnonfinitetobad = \&PDL::setnonfinitetobad; =head2 setbadtonan =for sig Signature: (a(); [o] b()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $b = setbadtonan($a); setbadtonan($a, $b); # all arguments given $b = $a->setbadtonan; # method call $a->setbadtonan($b); $a->inplace->setbadtonan; # can be used inplace setbadtonan($a->inplace); =for ref Sets Bad values to NaN This is only relevant for floating-point ndarrays. The input ndarray can be of any type, but if done inplace, the input must be floating point. =pod Broadcasts over its inputs. =for bad This method processes input ndarrays with bad values. The output ndarrays will not contain bad values (insofar as NaN is not Bad as far as PDL is concerned) and the output ndarray does not have its bad flag set. As an inplace operation, it clears the bad flag. =cut *setbadtonan = \&PDL::setbadtonan; =head2 setbadtoval =for sig Signature: (a(); [o]b(); double newval) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = setbadtoval($a, $newval); setbadtoval($a, $b, $newval); # all arguments given $b = $a->setbadtoval($newval); # method call $a->setbadtoval($b, $newval); $a->inplace->setbadtoval($newval); # can be used inplace setbadtoval($a->inplace, $newval); =for ref Replace any bad values by a (non-bad) value. Also see L. =for example $x->inplace->setbadtoval(23); print "a badflag: ", $x->badflag, "\n"; a badflag: 0 =pod Broadcasts over its inputs. =for bad The output always has its bad flag cleared. If the input ndarray does not have its bad flag set, then values are copied with no replacement. =cut *setbadtoval = \&PDL::setbadtoval; =head2 badmask =for sig Signature: (a(); b(); [o]c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = badmask($a, $b); badmask($a, $b, $c); # all arguments given $c = $a->badmask($b); # method call $a->badmask($b, $c); $a->inplace->badmask($b); # can be used inplace badmask($a->inplace, $b); =for ref Clears all C and C in C<$a> to the corresponding value in C<$b>. =pod Broadcasts over its inputs. =for bad If bad values are present, these are also cleared. =cut *badmask = \&PDL::badmask; =head2 copybad =for sig Signature: (a(); mask(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = copybad($a, $mask); copybad($a, $mask, $b); # all arguments given $b = $a->copybad($mask); # method call $a->copybad($mask, $b); $a->inplace->copybad($mask); # can be used inplace copybad($a->inplace, $mask); =for ref Copies values from one ndarray to another, setting them bad if they are bad in the supplied mask. =for example $x = byte( [0,1,3] ); $mask = byte( [0,0,0] ); $mask->badflag(1); set($mask,1,$mask->badvalue); $x->inplace->copybad( $mask ); p $x; [0 BAD 3] It is equivalent to: $c = $x + $mask * 0 =pod Broadcasts over its inputs. =for bad This handles input ndarrays that are bad. If either C<$x> or C<$mask> have bad values, those values will be marked as bad in the output ndarray and the output ndarray will have its bad value flag set to true. =cut *copybad = \&PDL::copybad; =head2 locf =for sig Signature: (a(n); [o]b(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = locf($a); locf($a, $b); # all arguments given $b = $a->locf; # method call $a->locf($b); =for ref Last Observation Carried Forward - replace every BAD value with the most recent non-BAD value prior to it. Any leading BADs will be set to 0. =pod Broadcasts over its inputs. =for bad C 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 *locf = \&PDL::locf; #line 915 "lib/PDL/Bad.pd" =head1 AUTHOR Doug Burke (djburke@cpan.org), 2000, 2001, 2003, 2006. The per-ndarray bad value support is by Heiko Klein (2006). CPAN documentation fixes by David Mertens (2010, 2013). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut #line 1078 "lib/PDL/Bad.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/ImageND.pm0000644000175000017500000006452214771136052015617 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/ImageND.pd! Don't modify! # package PDL::ImageND; our @EXPORT_OK = qw(kernctr convolve ninterpol rebin circ_mean circ_mean_p convolveND contour_segments contour_polylines path_join path_segs combcoords repulse attract ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::ImageND ; #line 4 "lib/PDL/ImageND.pd" =head1 NAME PDL::ImageND - useful image processing in N dimensions =head1 DESCRIPTION These routines act on PDLs as N-dimensional objects, not as broadcasted sets of 0-D or 1-D objects. The file is sort of a catch-all for broadly functional routines, most of which could legitimately be filed elsewhere (and probably will, one day). ImageND is not a part of the PDL core (v2.4) and hence must be explicitly loaded. =head1 SYNOPSIS use PDL::ImageND; $y = $x->convolveND($kernel,{bound=>'periodic'}); $y = $x->rebin(50,30,10); =cut use strict; use warnings; #line 54 "lib/PDL/ImageND.pm" =head1 FUNCTIONS =cut #line 50 "lib/PDL/ImageND.pd" use Carp; #line 68 "lib/PDL/ImageND.pm" =head2 convolve =for sig Signature: (a(m); b(n); indx adims(p); indx bdims(q); [o]c(m)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref N-dimensional convolution (Deprecated; use convolveND) =for usage $new = convolve $x, $kernel Convolve an array with a kernel, both of which are N-dimensional. This routine does direct convolution (by copying) but uses quasi-periodic boundary conditions: each dim "wraps around" to the next higher row in the next dim. This routine is kept for backwards compatibility with earlier scripts; for most purposes you want L instead: it runs faster and handles a variety of boundary conditions. =pod Broadcasts over its inputs. =for bad C 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 sub PDL::convolve { my($x,$y,$c) = @_; barf("Usage: convolve(a(*), b(*), [o]c(*)") if $#_<1 || $#_>2; $c = PDL->null if $#_<2; PDL::_convolve_int( $x->flat, $y->flat, $x->shape, $y->shape, $c->isnull ? $c : $c->flat, ); $c->setdims([$x->dims]); if($x->is_inplace) { $x .= $c; $x->set_inplace(0); return $x; } return $c; } *convolve = \&PDL::convolve; #line 209 "lib/PDL/ImageND.pd" =head2 ninterpol() =for ref N-dimensional interpolation routine =for sig Signature: ninterpol(point(),data(n),[o]value()) =for usage $value = ninterpol($point, $data); C uses C to find a linearly interpolated value in N dimensions, assuming the data is spread on a uniform grid. To use an arbitrary grid distribution, need to find the grid-space point from the indexing scheme, then call C -- this is far from trivial (and ill-defined in general). See also L, which includes boundary conditions and allows you to switch the method of interpolation, but which runs somewhat slower. =cut *ninterpol = \&PDL::ninterpol; sub PDL::ninterpol { use PDL::Math 'floor'; use PDL::Primitive 'interpol'; print 'Usage: $x = ninterpolate($point(s), $data);' if $#_ != 1; my ($p, $y) = @_; my ($ip) = floor($p); # isolate relevant N-cube $y = $y->slice(join (',',map($_.':'.($_+1),list $ip))); for (list ($p-$ip)) { $y = interpol($_,$y->xvals,$y); } $y; } #line 178 "lib/PDL/ImageND.pm" =head2 rebin =for sig Signature: (a(m); [o]b(n); int ns => n) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref N-dimensional rebinning algorithm =for usage $new = rebin $x, $dim1, $dim2,..;. $new = rebin $x, $template; $new = rebin $x, $template, {Norm => 1}; Rebin an N-dimensional array to newly specified dimensions. Specifying `Norm' keeps the sum constant, otherwise the intensities are kept constant. If more template dimensions are given than for the input pdl, these dimensions are created; if less, the final dimensions are maintained as they were. So if C<$x> is a 10 x 10 pdl, then C is a 15 x 10 pdl, while C is a 15 x 16 x 17 pdl (where the values along the final dimension are all identical). Expansion is performed by sampling; reduction is performed by averaging. If you want different behavior, use L instead. PDL::Transform::map runs slower but is more flexible. =pod Broadcasts over its inputs. =for bad C 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 286 "lib/PDL/ImageND.pd" sub PDL::rebin { my($x) = shift; my($opts) = ref $_[-1] eq "HASH" ? pop : {}; my(@idims) = $x->dims; my(@odims) = ref $_[0] ? $_[0]->dims : @_; my($i,$y); foreach $i (0..$#odims) { if ($i > $#idims) { # Just dummy extra dimensions $x = $x->dummy($i,$odims[$i]); next; # rebin_int can cope with all cases, but code # 1->n and n->1 separately for speed } elsif ($odims[$i] != $idims[$i]) { # If something changes if (!($odims[$i] % $idims[$i])) { # Cells map 1 -> n my ($r) = $odims[$i]/$idims[$i]; $y = ($i==0 ? $x : $x->mv($i,0))->dupN($r); } elsif (!($idims[$i] % $odims[$i])) { # Cells map n -> 1 my ($r) = $idims[$i]/$odims[$i]; $x = $x->mv($i,0) if $i != 0; # -> copy so won\'t corrupt input PDL $y = $x->slice("0:-1:$r")->copy; foreach (1..$r-1) { $y += $x->slice("$_:-1:$r"); } $y /= $r; } else { # Cells map n -> m &PDL::_rebin_int(($i==0 ? $x : $x->mv($i,0)), $y = null, $odims[$i]); } $x = $y->mv(0,$i); } } if (exists $opts->{Norm} and $opts->{Norm}) { my ($norm) = 1; for $i (0..$#odims) { if ($i > $#idims) { $norm /= $odims[$i]; } else { $norm *= $idims[$i]/$odims[$i]; } } return $x * $norm; } else { # Explicit copy so i) can\'t corrupt input PDL through this link # ii) don\'t waste space on invisible elements return $x -> copy; } } #line 276 "lib/PDL/ImageND.pm" *rebin = \&PDL::rebin; #line 359 "lib/PDL/ImageND.pd" =head2 circ_mean_p =for ref Calculates the circular mean of an n-dim image and returns the projection. Optionally takes the center to be used. =for usage $cmean=circ_mean_p($im); $cmean=circ_mean_p($im,{Center => [10,10]}); =cut sub circ_mean_p { my ($x,$opt) = @_; my ($rad,$sum,$norm); if (defined $opt) { $rad = indx PDL::rvals($x,$opt); } else { $rad = indx rvals $x; } my $max1 = $rad->max->sclr+1; $sum = zeroes($max1); PDL::indadd $x->flat, $rad->flat, $sum; # this does the real work $norm = zeroes($max1); PDL::indadd pdl(1), $rad->flat, $norm; # equivalent to get norm $sum /= $norm; return $sum; } =head2 circ_mean =for ref Smooths an image by applying circular mean. Optionally takes the center to be used. =for usage circ_mean($im); circ_mean($im,{Center => [10,10]}); =cut sub circ_mean { my ($x,$opt) = @_; my ($rad,$sum,$norm,$a1); if (defined $opt) { $rad = indx PDL::rvals($x,$opt); } else { $rad = indx rvals $x; } my $max1 = $rad->max->sclr+1; $sum = zeroes($max1); PDL::indadd $x->flat, $rad->flat, $sum; # this does the real work $norm = zeroes($max1); PDL::indadd pdl(1), $rad->flat, $norm; # equivalent to get norm $sum /= $norm; $a1 = $x->flat; $a1 .= $sum->index($rad->flat); return $x; } #line 437 "lib/PDL/ImageND.pd" =head2 kernctr =for ref `centre' a kernel (auxiliary routine to fftconvolve) =for usage $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); kernctr centres a small kernel to emulate the behaviour of the direct convolution routines. =cut *kernctr = \&PDL::kernctr; sub PDL::kernctr { # `centre' the kernel, to match kernel & image sizes and # emulate convolve/conv2d. FIX: implement with phase shifts # in fftconvolve, with option tag barf "Must have image & kernel for kernctr" if $#_ != 1; my ($imag, $kern) = @_; my (@ni) = $imag->dims; my (@nk) = $kern->dims; barf "Kernel and image must have same number of dims" if $#ni != $#nk; my ($newk) = zeroes(double,@ni); my ($k,$n,$y,$d,$i,@stri,@strk,@b); for ($i=0; $i <= $#ni; $i++) { $k = $nk[$i]; $n = $ni[$i]; barf "Kernel must be smaller than image in all dims" if ($n < $k); $d = int(($k-1)/2); $stri[$i][0] = "0:$d,"; $strk[$i][0] = (-$d-1).":-1,"; $stri[$i][1] = $d == 0 ? '' : ($d-$k+1).':-1,'; $strk[$i][1] = $d == 0 ? '' : '0:'.($k-$d-2).','; } # kernel is split between the 2^n corners of the cube my ($nchunk) = 2 << $#ni; CHUNK: for ($i=0; $i < $nchunk; $i++) { my ($stri,$strk); for ($n=0, $y=$i; $n <= $#ni; $n++, $y >>= 1) { next CHUNK if $stri[$n][$y & 1] eq ''; $stri .= $stri[$n][$y & 1]; $strk .= $strk[$n][$y & 1]; } chop ($stri); chop ($strk); (my $t = $newk->slice($stri)) .= $kern->slice($strk); } $newk; } #line 411 "lib/PDL/ImageND.pm" =head2 convolveND =for sig Signature: (k0(); pdl *k; pdl *aa; pdl *a) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref Speed-optimized convolution with selectable boundary conditions =for usage $new = convolveND($x, $kernel, [ {options} ]); Convolve an array with a kernel, both of which are N-dimensional. If the kernel has fewer dimensions than the array, then the extra array dimensions are broadcasted over. There are options that control the boundary conditions and method used. The kernel's origin is taken to be at the kernel's center. If your kernel has a dimension of even order then the origin's coordinates get rounded up to the next higher pixel (e.g. (1,2) for a 3x4 kernel). This mimics the behavior of the earlier L and L routines, so convolveND is a drop-in replacement for them. The kernel may be any size compared to the image, in any dimension. The kernel and the array are not quite interchangeable (as in mathematical convolution): the code is inplace-aware only for the array itself, and the only allowed boundary condition on the kernel is truncation. convolveND is inplace-aware: say C to modify a variable in-place. You don't reduce the working memory that way -- only the final memory. OPTIONS Options are parsed by PDL::Options, so unique abbreviations are accepted. =over 3 =item boundary (default: 'truncate') The boundary condition on the array, which affects any pixel closer to the edge than the half-width of the kernel. The boundary conditions are the same as those accepted by L, because this option is passed directly into L. Useful options are 'truncate' (the default), 'extend', and 'periodic'. You can select different boundary conditions for different axes -- see L for more detail. The (default) truncate option marks all the near-boundary pixels as BAD if you have bad values compiled into your PDL and the array's badflag is set. =item method (default: 'auto') The method to use for the convolution. Acceptable alternatives are 'direct', 'fft', or 'auto'. The direct method is an explicit copy-and-multiply operation; the fft method takes the Fourier transform of the input and output kernels. The two methods give the same answer to within double-precision numerical roundoff. The fft method is much faster for large kernels; the direct method is faster for tiny kernels. The tradeoff occurs when the array has about 400x more pixels than the kernel. The default method is 'auto', which chooses direct or fft convolution based on the size of the input arrays. =back NOTES At the moment there's no way to broadcast over kernels. That could/should be fixed. The broadcasting over input is cheesy and should probably be fixed: currently the kernel just gets dummy dimensions added to it to match the input dims. That does the right thing tersely but probably runs slower than a dedicated broadcastloop. The direct copying code uses PP primarily for the generic typing: it includes its own broadcastloops. =pod Broadcasts over its inputs. =for bad C 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 use PDL::Options; # Perl wrapper conditions the data to make life easier for the PP sub. sub PDL::convolveND { my($a0,$k,$opt0) = @_; my $inplace = $a0->is_inplace; my $x = $a0->new_or_inplace; barf("convolveND: kernel (".join("x",$k->dims).") has more dims than source (".join("x",$x->dims).")\n") if($x->ndims < $k->ndims); # Coerce stuff all into the same type. Try to make sense. # The trivial conversion leaves dataflow intact (nontrivial conversions # don't), so the inplace code is OK. Non-inplace code: let the existing # PDL code choose what type is best. my $type; if($inplace) { $type = $a0->get_datatype; } else { my $z = $x->flat->index(0) + $k->flat->index(0); $type = $z->get_datatype; } $x = $x->convert($type); $k = $k->convert($type); ## Handle options -- $def is a static variable so it only gets set up once. our $def; unless(defined($def)) { $def = PDL::Options->new( { Method=>'a', Boundary=>'t' } ); $def->minmatch(1); $def->casesens(0); } my $opt = $def->options(PDL::Options::ifhref($opt0)); ### # If the kernel has too few dimensions, we broadcast over the other # dims -- this is the same as supplying the kernel with dummy dims of # order 1, so, er, we do that. $k = $k->dummy($x->dims - 1, 1) if($x->ndims > $k->ndims); my $kdims = pdl($k->dims); ### # Decide whether to FFT or directly convolve: if we're in auto mode, # choose based on the relative size of the image and kernel arrays. my $fft = ( ($opt->{Method} =~ m/^a/i) ? ( $x->nelem > 2500 and ($x->nelem) <= ($k->nelem * 500) ) : ( $opt->{Method} !~ m/^[ds]/i ) ); ### # Pad the array to include boundary conditions my $adims = $x->shape; my $koff = ($kdims/2)->ceil - 1; my $aa = $x->range( -$koff, $adims + $kdims, $opt->{Boundary} ) ->sever; if ($fft) { require PDL::FFT; print "convolveND: using FFT method\n" if($PDL::debug); # FFT works best on doubles; do our work there then cast back # at the end. $aa = double($aa); $_ = $aa->zeroes for my ($aai, $kk, $kki); $kk->range( - ($kdims/2)->floor, $kdims, 'p') .= $k; PDL::fftnd($kk, $kki); PDL::fftnd($aa, $aai); { my($ii) = $kk * $aai + $aa * $kki; $aa = $aa * $kk - $kki * $aai; $aai .= $ii; } PDL::ifftnd($aa,$aai); $x .= $aa->range( $koff, $adims); } else { print "convolveND: using direct method\n" if($PDL::debug); ### The first argument is a dummy to set $GENERIC. &PDL::_convolveND_int( $k->flat->index(0), $k, $aa, $x ); } $x; } *convolveND = \&PDL::convolveND; =head2 contour_segments =for sig Signature: (c(); data(m,n); points(d,m,n); [o] segs(d,q=CALC(($SIZE(m)-1)*($SIZE(n)-1)*4)); indx [o] cnt();) Types: (float) =for usage ($segs, $cnt) = contour_segments($c, $data, $points); contour_segments($c, $data, $points, $segs, $cnt); # all arguments given ($segs, $cnt) = $c->contour_segments($data, $points); # method call $c->contour_segments($data, $points, $segs, $cnt); =for ref Finds a contour in given data. Takes 3 ndarrays as input: C<$c> is the contour value (broadcast with this) C<$data> is an [m,n] array of values at each point C<$points> is a list of [d,m,n] points. It should be a grid monotonically increasing with m and n. Returns C<$segs>, and C<$cnt> which is the highest 2nd-dim index in C<$segs> that's defined. The contours are a collection of disconnected line segments rather than a set of closed polygons. The data array represents samples of some field observed on the surface described by points. This uses a variant of the Marching Squares algorithm, though without being data-driven. =pod Broadcasts over its inputs. =for bad C 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 *contour_segments = \&PDL::contour_segments; =head2 contour_polylines =for sig Signature: (c(); data(m,n); points(d,m,n); indx [o] pathendindex(q=CALC(($SIZE(m)-1)*($SIZE(n)-1)*5)); [o] paths(d,q); byte [t] seenmap(m,n)) Types: (float) =for ref Finds polylines describing contours in given data. Takes 3 ndarrays as input: C<$c> is the contour value (broadcast with this) C<$data> is an [m,n] array of values at each point C<$points> is a list of [d,m,n] points. It should be a grid monotonically increasing with m and n. Returns C<$pathendindex>, and C<$paths>. Any C<$pathendindex> entries after the pointers to the ends of polylines are negative. =head3 Algorithm Has two modes: scanning, and line-walking. Scanning is done from the top left, along each row. Each point can be considered as, at C: a|b +-+- c|d|e Every potential boundary above, or to the left of (including the bottom boundaries), C has been cleared (marked with a space above). =head4 Boundary detection This is done by first checking both points' coordinates are within bounds, then checking if the boundary is marked seen, then detecting whether the two cells' values cross the contour threshold. =head4 Scanning If detect boundary between C-C, and also C-C, C-C, or C-C, line-walking starts C-C facing south. If not, mark C-C seen. If detect boundary C-C and C-C, line-walking starts C-C facing west. If detect boundary C-C and also C-C or C-C, line-walking starts C-C facing east. If not, mark C-C seen, and continue scanning. =head4 Line-walking The conditions above guarantee that any line started will have at least two points, since two connected "points" (boundaries between two cells) have been detected. The coordinates of the back end of the starting "point" (boundary with direction) are recorded. At each, a line-point is emitted and that "point" is marked seen. The coordinates emitted are linearly interpolated between the coordinates of the two cells similarly to the Marching Squares algorithm. The next "point" is sought, looking in order right, straight ahead, then left. Each one not detected is marked seen. That order means the walked boundary will always turn as much right (go clockwise) as available, thereby guaranteeing enclosing the area, which deals with saddle points. If a next "point" is found, move to that and repeat. If not, then if the front of the ending "point" (boundary plus direction) is identical to the back of the starting point, a final point is emitted to close the shape. Then the polyline is closed by emitting the current point-counter into C. =for usage use PDL; use PDL::ImageND; use PDL::Graphics::Simple; $SIZE = 500; $vals = rvals($SIZE,$SIZE)->divide($SIZE/12.5)->sin; @cntr_threshes = zeroes(9)->xlinvals($vals->minmax)->list; $win = pgswin(); $xrange = [0,$vals->dim(0)-1]; $yrange = [0,$vals->dim(1)-1]; $win->plot(with=>'image', $vals, {xrange=>$xrange,yrange=>$yrange,j=>1},); for $thresh (@cntr_threshes) { ($pi, $p) = contour_polylines($thresh, $vals, $vals->ndcoords); $pi_max = $pi->max; next if $pi_max < 0; $pi = $pi->where($pi > -1); $p = $p->slice(',0:'.$pi_max); @paths = path_segs($pi, $p->mv(0,-1)); $win->oplot( (map +(with=>'lines', $_->dog), @paths), {xrange=>$xrange,yrange=>$yrange,j=>1}, ); } print "ret> "; <>; =pod Broadcasts over its inputs. =for bad C 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 *contour_polylines = \&PDL::contour_polylines; =head2 path_join =for sig Signature: (e(v=2,n); indx [o] pathendindex(n); indx [o] paths(nout=CALC($SIZE(n)*2)); indx [t] highestoutedge(d); indx [t] outedges(d,d); byte [t] hasinward(d); indx [t] sourceids(d); ; PDL_Indx d => d; int directed) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($pathendindex, $paths) = path_join($e, $d); # using default value of directed=1 ($pathendindex, $paths) = path_join($e, $d, $directed); # overriding default path_join($e, $pathendindex, $paths, $d, $directed); # all arguments given ($pathendindex, $paths) = $e->path_join($d); # method call ($pathendindex, $paths) = $e->path_join($d, $directed); $e->path_join($pathendindex, $paths, $d, $directed); =for ref Links a (by default directed) graph's edges into paths. The outputs are the indices into C ending each path. Past the last path, the indices are set to -1. =pod Broadcasts over its inputs. =for bad C 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 *path_join = \&PDL::path_join; #line 1126 "lib/PDL/ImageND.pd" =head2 path_segs =for ref Divide a path into segments. =for usage @segments = path_segs($pathindices, $paths); Returns a series of slices of the C, such as those created by L, stopping at the first negative index. Currently does not broadcast. =for example use PDL; use PDL::ImageND; use PDL::Graphics::Simple; $SIZE = 500; $vals = rvals($SIZE,$SIZE)->divide($SIZE/12.5)->sin; @cntr_threshes = zeroes(9)->xlinvals($vals->minmax)->list; $win = pgswin(); $xrange = [0,$vals->dim(0)-1]; $yrange = [0,$vals->dim(1)-1]; $win->plot(with=>'image', $vals, {xrange=>$xrange,yrange=>$yrange,j=>1},); for $thresh (@cntr_threshes) { my ($segs, $cnt) = contour_segments($thresh, $vals, $vals->ndcoords); my $segscoords = $segs->slice(',0:'.$cnt->max)->clump(-1)->splitdim(0,4); $linesegs = $segscoords->splitdim(0,2); $uniqcoords = $linesegs->uniqvec; next if $uniqcoords->dim(1) < 2; $indexed = vsearchvec($linesegs, $uniqcoords)->uniqvec; @paths = path_segs(path_join($indexed, $uniqcoords->dim(1), 0)); @paths = map $uniqcoords->dice_axis(1, $_)->mv(0,-1), @paths; $win->oplot( (map +(with=>'lines', $_->dog), @paths), {xrange=>$xrange,yrange=>$yrange,j=>1}, ); } print "ret> "; <>; =cut *path_segs = \&PDL::path_segs; sub PDL::path_segs { my ($pi, $p) = @_; my ($startind, @out) = 0; for ($pi->list) { last if $_ < 0; push @out, $p->slice("$startind:$_"); $startind = $_ + 1; } @out; } #line 909 "lib/PDL/ImageND.pm" =head2 combcoords =for sig Signature: (x(); y(); z(); float [o]coords(tri=3);) Types: (float double) =for usage $coords = combcoords($x, $y, $z); combcoords($x, $y, $z, $coords); # all arguments given $coords = $x->combcoords($y, $z); # method call $x->combcoords($y, $z, $coords); =for ref Combine three coordinates into a single ndarray. Combine x, y and z to a single ndarray the first dimension of which is 3. This routine does dataflow automatically. =pod Broadcasts over its inputs. Creates data-flow by default. =for bad C 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 *combcoords = \&PDL::combcoords; =head2 repulse =for sig Signature: (coords(nc,np); [o]vecs(nc,np); int [t]links(np); double boxsize; int dmult; double a; double b; double c; double d; ) Types: (float double) =for usage $vecs = repulse($coords, $boxsize, $dmult, $a, $b, $c, $d); repulse($coords, $vecs, $boxsize, $dmult, $a, $b, $c, $d); # all arguments given $vecs = $coords->repulse($boxsize, $dmult, $a, $b, $c, $d); # method call $coords->repulse($vecs, $boxsize, $dmult, $a, $b, $c, $d); =for ref Repulsive potential for molecule-like constructs. C uses a hash table of cubes to quickly calculate a repulsive force that vanishes at infinity for many objects. For use by the module L. Checks all neighbouring boxes. The formula is: (r = |dist|+d) a*r^-2 + b*r^-1 + c*r^-0.5 =pod Broadcasts over its inputs. =for bad C 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 *repulse = \&PDL::repulse; =head2 attract =for sig Signature: (coords(nc,np); int from(nl); int to(nl); strength(nl); [o]vecs(nc,np);; double m; double ms; ) Types: (float double) =for usage $vecs = attract($coords, $from, $to, $strength, $m, $ms); attract($coords, $from, $to, $strength, $vecs, $m, $ms); # all arguments given $vecs = $coords->attract($from, $to, $strength, $m, $ms); # method call $coords->attract($from, $to, $strength, $vecs, $m, $ms); =for ref Attractive potential for molecule-like constructs. C is used to calculate an attractive force for many objects, of which some attract each other (in a way like molecular bonds). For use by the module L. For definition of the potential, see the actual function. =pod Broadcasts over its inputs. =for bad C 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 *attract = \&PDL::attract; #line 34 "lib/PDL/ImageND.pd" =head1 AUTHORS Copyright (C) Karl Glazebrook and Craig DeForest, 1997, 2003 All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut #line 1075 "lib/PDL/ImageND.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/Slices.pm0000644000175000017500000016074414771136067015606 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Slices.pd! Don't modify! # package PDL::Slices; our @EXPORT_OK = qw(index index1d index2d indexND indexNDb rangeb rld rle rlevec rldvec rleseq rldseq rleND rldND _clump_int xchg mv using meshgrid lags splitdim rotate broadcastI unbroadcast dice dice_axis slice diagonal ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Slices ; #line 5 "lib/PDL/Slices.pd" =head1 NAME PDL::Slices -- Indexing, slicing, and dicing =head1 SYNOPSIS use PDL; $x = ones(3,3); $y = $x->slice('-1:0,(1)'); $c = $x->dummy(2); =head1 DESCRIPTION This package provides many of the powerful PerlDL core index manipulation routines. These routines mostly allow two-way data flow, so you can modify your data in the most convenient representation. For example, you can make a 1000x1000 unit matrix with $x = zeroes(1000,1000); $x->diagonal(0,1) ++; which is quite efficient. See L and L for more examples. As of 2.090, backward dataflow will be turned off if any input has inward-only dataflow, to avoid creating "loops". See L for more. Slicing is so central to the PDL language that a special compile-time syntax has been introduced to handle it compactly; see L for details. PDL indexing and slicing functions usually include two-way data flow, so that you can separate the actions of reshaping your data structures and modifying the data themselves. Two special methods, L and L, help you control the data flow connection between related variables. $y = $x->slice("1:3"); # Slice maintains a link between $x and $y. $y += 5; # $x is changed! If you want to force a physical copy and no data flow, you can copy or sever the slice expression: $y = $x->slice("1:3")->copy; $y += 5; # $x is not changed. $y = $x->slice("1:3")->sever; $y += 5; # $x is not changed. The difference between C and C is that sever acts on (and returns) its argument, while copy produces a disconnected copy. If you say $y = $x->slice("1:3"); $c = $y->sever; then the variables C<$y> and C<$c> point to the same object but with C<-Ecopy> they would not. =cut use strict; use warnings; use PDL::Core ':Internal'; use Scalar::Util 'blessed'; #line 93 "lib/PDL/Slices.pm" =head1 FUNCTIONS =cut =head2 index =for sig Signature: (a(n); indx ind(); [oca] c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = index($a, $ind); $c = $a->index($ind); # method call $a->index($ind) .= $data; # usable as lvalue =for ref C, C, and C provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines broadcast slightly differently. =over 3 =item * C uses direct broadcasting for 1-D indexing across the 0 dim of C<$source>. It can broadcast over source broadcast dims or index broadcast dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a broadcasting sense. =item * C uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a broadcasting sense. =item * C works like C but uses separate ndarrays for X and Y coordinates. For more general N-dimensional indexing, see the L syntax or L (in particular C, C, and C). =back These functions are two-way, i.e. after $c = $x->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$x>. C provids simple broadcasting: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $x = xvals(10,10)+10*yvals(10,10); $y = $x->index(3); $c = $x->index(9-xvals(10)); puts a single column from C<$x> into C<$y>, and puts a single element from each column of C<$x> into C<$c>. If you want to extract multiple columns from an array in one operation, see L or L. =pod Broadcasts over its inputs. Creates data-flow back and forth by default. =for bad index barfs if any of the index values are bad. =cut *index = \&PDL::index; =head2 index1d =for sig Signature: (a(n); indx ind(m); [oca] c(m)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = index1d($a, $ind); $c = $a->index1d($ind); # method call $a->index1d($ind) .= $data; # usable as lvalue =for ref C, C, and C provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines broadcast slightly differently. =over 3 =item * C uses direct broadcasting for 1-D indexing across the 0 dim of C<$source>. It can broadcast over source broadcast dims or index broadcast dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a broadcasting sense. =item * C uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a broadcasting sense. =item * C works like C but uses separate ndarrays for X and Y coordinates. For more general N-dimensional indexing, see the L syntax or L (in particular C, C, and C). =back These functions are two-way, i.e. after $c = $x->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$x>. C provids simple broadcasting: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $x = xvals(10,10)+10*yvals(10,10); $y = $x->index(3); $c = $x->index(9-xvals(10)); puts a single column from C<$x> into C<$y>, and puts a single element from each column of C<$x> into C<$c>. If you want to extract multiple columns from an array in one operation, see L or L. =pod Broadcasts over its inputs. Creates data-flow back and forth by default. =for bad index1d propagates BAD index elements to the output variable. =cut *index1d = \&PDL::index1d; =head2 index2d =for sig Signature: (a(na,nb); indx inda(); indx indb(); [oca] c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = index2d($a, $inda, $indb); $c = $a->index2d($inda, $indb); # method call $a->index2d($inda, $indb) .= $data; # usable as lvalue =for ref C, C, and C provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines broadcast slightly differently. =over 3 =item * C uses direct broadcasting for 1-D indexing across the 0 dim of C<$source>. It can broadcast over source broadcast dims or index broadcast dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a broadcasting sense. =item * C uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a broadcasting sense. =item * C works like C but uses separate ndarrays for X and Y coordinates. For more general N-dimensional indexing, see the L syntax or L (in particular C, C, and C). =back These functions are two-way, i.e. after $c = $x->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$x>. C provids simple broadcasting: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $x = xvals(10,10)+10*yvals(10,10); $y = $x->index(3); $c = $x->index(9-xvals(10)); puts a single column from C<$x> into C<$y>, and puts a single element from each column of C<$x> into C<$c>. If you want to extract multiple columns from an array in one operation, see L or L. =pod Broadcasts over its inputs. Creates data-flow back and forth by default. =for bad index2d barfs if either of the index values are bad. =cut *index2d = \&PDL::index2d; #line 231 "lib/PDL/Slices.pd" =head2 indexNDb =for ref Backwards-compatibility alias for indexND =head2 indexND =for ref Find selected elements in an N-D ndarray, with optional boundary handling =for example $out = $source->indexND( $index, [$method] ) $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); print $source->indexND( $index ); [ [23 45] [67 89] ] IndexND collapses C<$index> by lookup into C<$source>. The 0th dimension of C<$index> is treated as coordinates in C<$source>, and the return value has the same dimensions as the rest of C<$index>. The returned elements are looked up from C<$source>. Dataflow works -- propagated assignment flows back into C<$source>. IndexND and IndexNDb were originally separate routines but they are both now implemented as a call to L, and have identical syntax to one another. SEE ALSO: L returns N-D indices into a multidimensional PDL, suitable for feeding to this. =cut sub PDL::indexND :lvalue { my($source,$index, $boundary) = @_; return PDL::range($source,$index,undef,$boundary); } *PDL::indexNDb = \&PDL::indexND; sub PDL::range :lvalue { my($source,$ind,$sz,$bound) = @_; # Convert to indx type up front (also handled in rangeb if necessary) my $index = (ref $ind && UNIVERSAL::isa($ind,'PDL') && $ind->type eq 'indx') ? $ind : indx($ind); my $size = defined($sz) ? PDL->pdl($sz) : undef; # Handle empty PDL case: return a properly constructed Empty. if ($index->isempty) { my @sdims = $source->dims; splice @sdims, 0, $index->dim(0) + ($index->dim(0)==0); # added term is to treat Empty[0] like a single empty coordinate unshift @sdims, $size->list if defined $size; my @index_dims = ((0) x ($index->ndims-1)); @index_dims = 0 if !@index_dims; # always at least one 0 return PDL->new_from_specification(@index_dims, @sdims); } $index = $index->dummy(0,1) unless $index->ndims; # Pack boundary string if necessary if (defined $bound) { if (ref $bound eq 'ARRAY') { my ($s,$el); foreach $el (@$bound) { barf "Illegal boundary value '$el' in range" unless $el =~ m/^([0123fFtTeEpPmM])/; $s .= $1; } $bound = $s; } elsif ($bound !~ m/^[0123ftepx]+$/ && $bound =~ m/^([0123ftepx])/i) { $bound = $1; } } no warnings; # shut up about passing undef into rangeb $source->rangeb($index,$size,$bound); } =head2 range =for ref Extract selected chunks from a source ndarray, with boundary conditions =for example $out = $source->range($index,[$size,[$boundary]]) Returns elements or rectangular slices of the original ndarray, indexed by the C<$index> ndarray. C<$source> is an N-dimensional ndarray, and C<$index> is an ndarray whose first dimension has size up to N. Each row of C<$index> is treated as coordinates of a single value or chunk from C<$source>, specifying the location(s) to extract. If you specify a single index location, then range is essentially an expensive slice, with controllable boundary conditions. B C<$index> and C<$size> can be ndarrays or array refs such as you would feed to L and its ilk. If C<$index>'s 0th dimension has size higher than the number of dimensions in C<$source>, then C<$source> is treated as though it had trivial dummy dimensions of size 1, up to the required size to be indexed by C<$index> -- so if your source array is 1-D and your index array is a list of 3-vectors, you get two dummy dimensions of size 1 on the end of your source array. You can extract single elements or N-D rectangular ranges from C<$source>, by setting C<$size>. If C<$size> is undef or zero, then you get a single sample for each row of C<$index>. This behavior is similar to L, which is in fact implemented as a call to L. If C<$size> is positive then you get a range of values from C<$source> at each location, and the output has extra dimensions allocated for them. C<$size> can be a scalar, in which case it applies to all dimensions, or an N-vector, in which case each element is applied independently to the corresponding dimension in C<$source>. See below for details. C<$boundary> is a number, string, or list ref indicating the type of boundary conditions to use when ranges reach the edge of C<$source>. If you specify no boundary conditions the default is to forbid boundary violations on all axes. If you specify exactly one boundary condition, it applies to all axes. If you specify more (as elements of a list ref, or as a packed string, see below), then they apply to dimensions in the order in which they appear, and the last one applies to all subsequent dimensions. (This is less difficult than it sounds; see the examples below). =over 3 =item 0 (synonyms: 'f','forbid') B<(default)> Ranges are not allowed to cross the boundary of the original PDL. Disallowed ranges throw an error. The errors are thrown at evaluation time, not at the time of the range call (this is the same behavior as L). =item 1 (synonyms: 't','truncate') Values outside the original ndarray get BAD if you've got bad value support compiled into your PDL and set the badflag for the source PDL; or 0 if you haven't (you must set the badflag if you want BADs for out of bound values, otherwise you get 0). Reverse dataflow works OK for the portion of the child that is in-bounds. The out-of-bounds part of the child is reset to (BAD|0) during each dataflow operation, but execution continues. =item 2 (synonyms: 'e','x','extend') Values that would be outside the original ndarray point instead to the nearest allowed value within the ndarray. See the CAVEAT below on mappings that are not single valued. =item 3 (synonyms: 'p','periodic') Periodic boundary conditions apply: the numbers in $index are applied, strict-modulo the corresponding dimensions of $source. This is equivalent to duplicating the $source ndarray throughout N-D space. See the CAVEAT below about mappings that are not single valued. =item 4 (synonyms: 'm','mirror') Mirror-reflection periodic boundary conditions apply. See the CAVEAT below about mappings that are not single valued. =back The boundary condition identifiers all begin with unique characters, so you can feed in multiple boundary conditions as either a list ref or a packed string. (The packed string is marginally faster to run). For example, the four expressions [0,1], ['forbid','truncate'], ['f','t'], and 'ft' all specify that violating the boundary in the 0th dimension throws an error, and all other dimensions get truncated. If you feed in a single string, it is interpreted as a packed boundary array if all of its characters are valid boundary specifiers (e.g. 'pet'), but as a single word-style specifier if they are not (e.g. 'forbid'). Where the source PDL is empty, all non-barfing boundary conditions are changed to truncation, since there is no data to reflect, extend, or mirror. B The output broadcasts over both C<$index> and C<$source>. Because implicit broadcasting can happen in a couple of ways, a little thought is needed. The returned dimension list is stacked up like this: (index broadcast dims), (index dims (size)), (source broadcast dims) The first few dims of the output correspond to the extra dims of C<$index> (beyond the 0 dim). They allow you to pick out individual ranges from a large, broadcasted collection. The middle few dims of the output correspond to the size dims specified in C<$size>, and contain the range of values that is extracted at each location in C<$source>. Every nonzero element of C<$size> is copied to the dimension list here, so that if you feed in (for example) C<$size = [2,0,1]> you get an index dim list of C<(2,1)>. The last few dims of the output correspond to extra dims of C<$source> beyond the number of dims indexed by C<$index>. These dims act like ordinary broadcast dims, because adding more dims to C<$source> just tacks extra dims on the end of the output. Each source broadcast dim ranges over the entire corresponding dim of C<$source>. B: Dataflow is bidirectional. B: Here are basic examples of C operation, showing how to get ranges out of a small matrix. The first few examples show extraction and selection of individual chunks. The last example shows how to mark loci in the original matrix (using dataflow). pdl> $src = 10*xvals(10,5)+yvals(10,5) pdl> print $src->range([2,3]) # Cut out a single element 23 pdl> print $src->range([2,3],1) # Cut out a single 1x1 block [ [23] ] pdl> print $src->range([2,3], [2,1]) # Cut a 2x1 chunk [ [23 33] ] pdl> print $src->range([[2,3]],[2,1]) # Trivial list of 1 chunk [ [ [23] [33] ] ] pdl> print $src->range([[2,3],[0,1]], [2,1]) # two 2x1 chunks [ [ [23 1] [33 11] ] ] pdl> # A 2x2 collection of 2x1 chunks pdl> print $src->range([[[1,1],[2,2]],[[2,3],[0,1]]],[2,1]) [ [ [ [11 22] [23 1] ] [ [21 32] [33 11] ] ] ] pdl> $src = xvals(5,3)*10+yvals(5,3) pdl> print $src->range(3,1) # Broadcast over y dimension in $src [ [30] [31] [32] ] pdl> $src = zeroes(5,4); pdl> $src->range(pdl([2,3],[0,1]),pdl(2,1)) .= xvals(2,2,1) + 1 pdl> print $src [ [0 0 0 0 0] [2 2 0 0 0] [0 0 0 0 0] [0 0 1 1 0] ] B: It's quite possible to select multiple ranges that intersect. In that case, modifying the ranges doesn't have a guaranteed result in the original PDL -- the result is an arbitrary choice among the valid values. For some things that's OK; but for others it's not. In particular, this doesn't work: pdl> $photon_list = PDL::RandVar->new->sample(500)->reshape(2,250)*10 pdl> $histogram = zeroes(10,10) pdl> $histogram->range($photon_list,1)++; #not what you wanted The reason is that if two photons land in the same bin, then that bin doesn't get incremented twice. (That may get fixed in a later version...) B: If C<$index> has too many dimensions compared to C<$source>, then $source is treated as though it had dummy dimensions of size 1, up to the required number of dimensions. These virtual dummy dimensions have the usual boundary conditions applied to them. If the 0 dimension of C<$index> is ludicrously large (if its size is more than 5 greater than the number of dims in the source PDL) then range will insist that you specify a size in every dimension, to make sure that you know what you're doing. That catches a common error with range usage: confusing the initial dim (which is usually small) with another index dim (perhaps of size 1000). If the index variable is Empty, then range() always returns the Empty PDL. If the index variable is not Empty, indexing it always yields a boundary violation. All non-barfing conditions are treated as truncation, since there are no actual data to return. B: Because C isn't an affine transformation (it involves lookup into a list of N-D indices), it is somewhat memory-inefficient for long lists of ranges, and keeping dataflow open is much slower than for affine transformations (which don't have to copy data around). Doing operations on small subfields of a large range is inefficient because the engine must flow the entire range back into the original PDL with every atomic perl operation, even if you only touch a single element. One way to speed up such code is to sever your range, so that PDL doesn't have to copy the data with each operation, then copy the elements explicitly at the end of your loop. Here's an example that labels each region in a range sequentially, using many small operations rather than a single xvals assignment: ### How to make a collection of small ops run fast with range... $x = $data->range($index, $sizes, $bound)->sever; $aa = $data->range($index, $sizes, $bound); $x($_ - 1) .= $_ for 1..$x->nelem; # Lots of little ops $aa .= $x; C is a perl front-end to a PP function, C. Calling C is marginally faster but requires that you include all arguments. DEVEL NOTES * index broadcast dimensions are effectively clumped internally. This makes it easier to loop over the index array but a little more brain-bending to tease out the algorithm. =cut #line 733 "lib/PDL/Slices.pm" =head2 rangeb =for sig Signature: (PARENT(); [oca]CHILD(); pdl *ind_pdl; SV *size_sv; SV *boundary_sv) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $CHILD = rangeb($PARENT, $ind_pdl, $size_sv, $boundary_sv); $CHILD = $PARENT->rangeb($ind_pdl, $size_sv, $boundary_sv); # method call $PARENT->rangeb($ind_pdl, $size_sv, $boundary_sv) .= $data; # usable as lvalue =for ref Engine for L =for example Same calling convention as L, but you must supply all parameters. C is marginally faster as it makes a direct PP call, avoiding the perl argument-parsing step. =pod Does not broadcast. Creates data-flow back and forth by default. =for bad C 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 *rangeb = \&PDL::rangeb; =head2 rld =for sig Signature: (indx a(n); b(n); [o]c(m); IV sumover_max => m) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = rld($a, $b, $sumover_max); rld($a, $b, $c, $sumover_max); # all arguments given $c = $a->rld($b, $sumover_max); # method call $a->rld($b, $c, $sumover_max); =for ref Run-length decode a vector Given a vector C<$x> of the numbers of instances of values C<$y>, run-length decode to C<$c>. =pod Broadcasts over its inputs. =for bad C 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 1032 "lib/PDL/Slices.pd" sub PDL::rld { my ($x,$y) = @_; my ($c,$sm) = @_ == 3 ? ($_[2], $_[2]->dim(0)) : (PDL->null, $x->sumover->max->sclr); PDL::_rld_int($x,$y,$c,$sm); $c; } #line 826 "lib/PDL/Slices.pm" *rld = \&PDL::rld; =head2 rle =for sig Signature: (c(n); indx [o]a(m=CALC($SIZE(n))); [o]b(m)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage ($a, $b) = rle($c); rle($c, $a, $b); # all arguments given ($a, $b) = $c->rle; # method call $c->rle($a, $b); =for ref Run-length encode a vector Given vector C<$c>, generate a vector C<$x> with the number of each element, and a vector C<$y> of the unique values. New in PDL 2.017, only the elements up to the first instance of C<0> in C<$x> are returned, which makes the common use case of a 1-dimensional C<$c> simpler. For broadcast operation, C<$x> and C<$y> will be large enough to hold the largest row of C<$y>, and only the elements up to the first instance of C<0> in each row of C<$x> should be considered. =for example $c = floor(4*random(10)); rle($c,$x=null,$y=null); #or ($x,$y) = rle($c); #for $c of shape [10, 4]: $c = floor(4*random(10,4)); ($x,$y) = rle($c); #to see the results of each row one at a time: foreach (0..$c->dim(1)-1){ my ($as,$bs) = ($x(:,($_)),$y(:,($_))); my ($ta,$tb) = where($as,$bs,$as!=0); #only the non-zero elements of $x print $c(:,($_)) . " rle==> " , ($ta,$tb) , "\trld==> " . rld($ta,$tb) . "\n"; } # the inverse of (chance of all 6 3d6 rolls being >= each possible sum) ($nrolls, $ndice, $dmax) = (6, 3, 6); ($x, $x1) = (allaxisvals(($dmax) x $ndice)+1)->sumover->flat->qsort->rle; $y = $x->cumusumover; $yprob1x = $y->slice('-1:0')->double / $y->slice('(-1)'); $z = cat($x1, 1 / $yprob1x**$nrolls)->transpose; =pod Broadcasts over its inputs. =for bad C 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 1062 "lib/PDL/Slices.pd" sub PDL::rle { my $c = shift; my ($x,$y) = @_==2 ? @_ : (null,null); PDL::_rle_int($c,$x,$y); my $max_ind = ($c->ndims<2) ? ($x!=0)->sumover-1 : ($x!=0)->clump(1..$x->ndims-1)->sumover->max->sclr-1; return ($x->slice("0:$max_ind"),$y->slice("0:$max_ind")); } #line 911 "lib/PDL/Slices.pm" *rle = \&PDL::rle; =head2 rlevec =for sig Signature: (c(M,N); indx [o]a(N); [o]b(M,N)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($a, $b) = rlevec($c); rlevec($c, $a, $b); # all arguments given ($a, $b) = $c->rlevec; # method call $c->rlevec($a, $b); =for ref Run-length encode a set of vectors. Higher-order rle(), for use with qsortvec(). Given set of vectors $c, generate a vector $a with the number of occurrences of each element (where an "element" is a vector of length $M occurring in $c), and a set of vectors $b containing the unique values. As for rle(), only the elements up to the first instance of 0 in $a should be considered. Can be used together with clump() to run-length encode "values" of arbitrary dimensions. Can be used together with rotate(), cat(), append(), and qsortvec() to count N-grams over a 1d PDL. See also: L, L, L Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 *rlevec = \&PDL::rlevec; =head2 rldvec =for sig Signature: (indx a(uniqvals); b(M,uniqvals); [o]c(M,decodedvals); IV sumover_max => decodedvals) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = rldvec($a, $b, $sumover_max); rldvec($a, $b, $c, $sumover_max); # all arguments given $c = $a->rldvec($b, $sumover_max); # method call $a->rldvec($b, $c, $sumover_max); =for ref Run-length decode a set of vectors, akin to a higher-order rld(). Given a vector $a() of the number of occurrences of each row, and a set $b() of row-vectors each of length $M, run-length decode to $c(). Can be used together with clump() to run-length decode "values" of arbitrary dimensions. See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 1187 "lib/PDL/Slices.pd" sub PDL::rldvec { my ($a,$b,$c) = @_; ($c,my $sm) = defined($c) ? ($c,$c->dim(1)) : (PDL->null,$a->sumover->max->sclr); PDL::_rldvec_int($a,$b,$c,$sm); return $c; } #line 1023 "lib/PDL/Slices.pm" *rldvec = \&PDL::rldvec; =head2 rleseq =for sig Signature: (c(N); indx [o]a(N); [o]b(N)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($a, $b) = rleseq($c); rleseq($c, $a, $b); # all arguments given ($a, $b) = $c->rleseq; # method call $c->rleseq($a, $b); =for ref Run-length encode a vector of subsequences. Given a vector of $c() of concatenated variable-length, variable-offset subsequences, generate a vector $a containing the length of each subsequence and a vector $b containing the subsequence offsets. As for rle(), only the elements up to the first instance of 0 in $a should be considered. See also L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 *rleseq = \&PDL::rleseq; =head2 rldseq =for sig Signature: (indx a(N); b(N); [o]c(M); IV sumover_max => M) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = rldseq($a, $b, $sumover_max); rldseq($a, $b, $c, $sumover_max); # all arguments given $c = $a->rldseq($b, $sumover_max); # method call $a->rldseq($b, $c, $sumover_max); =for ref Run-length decode a subsequence vector. Given a vector $a() of sequence lengths and a vector $b() of corresponding offsets, decode concatenation of subsequences to $c(), as for: $c = null; $c = $c->append($b($_)+sequence($a->type,$a($_))) foreach (0..($N-1)); See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 1258 "lib/PDL/Slices.pd" sub PDL::rldseq { my ($a,$b,$c) = @_; ($c,my $sm) = defined($c) ? ($c,$c->dim(1)) : (PDL->null,$a->sumover->max->sclr); PDL::_rldseq_int($a,$b,$c,$sm); return $c; } #line 1132 "lib/PDL/Slices.pm" *rldseq = \&PDL::rldseq; #line 1292 "lib/PDL/Slices.pd" =head2 rleND =for sig Signature: (data(@vdims,N); int [o]counts(N); [o]elts(@vdims,N)) =for ref Run-length encode a set of (sorted) n-dimensional values. Generalization of rle() and vv_rlevec(): given set of values $data, generate a vector $counts with the number of occurrences of each element (where an "element" is a matrix of dimensions @vdims occurring as a sequential run over the final dimension in $data), and a set of vectors $elts containing the elements which begin a run. Really just a wrapper for clump() and rlevec(). See also: L, L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =cut *PDL::rleND = \&rleND; sub rleND { my $data = shift; my @vdimsN = $data->dims; ##-- construct output pdls my $counts = $#_ >= 0 ? $_[0] : PDL->null; my $elts = $#_ >= 1 ? $_[1] : zeroes($data->type, @vdimsN); ##-- guts: call rlevec() rlevec($data->clump($#vdimsN), $counts, $elts->clump($#vdimsN)); return ($counts,$elts); } =head2 rldND =for sig Signature: (int counts(N); elts(@vdims,N); [o]data(@vdims,N);) =for ref Run-length decode a set of (sorted) n-dimensional values. Generalization of rld() and rldvec(): given a vector $counts() of the number of occurrences of each @vdims-dimensioned element, and a set $elts() of @vdims-dimensioned elements, run-length decode to $data(). Really just a wrapper for clump() and rldvec(). See also: L, L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =cut *PDL::rldND = \&rldND; sub rldND { my ($counts,$elts) = (shift,shift); my @vdimsN = $elts->dims; ##-- construct output pdl my ($data); if ($#_ >= 0) { $data = $_[0]; } else { my $size = $counts->sumover->max; ##-- get maximum size for Nth-dimension for small encodings my @countdims = $counts->dims; shift(@countdims); $data = zeroes($elts->type, @vdimsN, @countdims); } ##-- guts: call rldvec() rldvec($counts, $elts->clump($#vdimsN), $data->clump($#vdimsN)); return $data; } #line 1219 "lib/PDL/Slices.pm" *_clump_int = \&PDL::_clump_int; =head2 xchg =for sig Signature: (PARENT(); [oca]CHILD(); PDL_Indx n1; PDL_Indx n2) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $CHILD = xchg($PARENT, $n1, $n2); $CHILD = $PARENT->xchg($n1, $n2); # method call $PARENT->xchg($n1, $n2) .= $data; # usable as lvalue =for ref exchange two dimensions Negative dimension indices count from the end. The command =for example $y = $x->xchg(2,3); creates C<$y> to be like C<$x> except that the dimensions 2 and 3 are exchanged with each other i.e. $y->at(5,3,2,8) == $x->at(5,3,8,2) =pod Does not broadcast. Makes L ndarrays. Creates data-flow back and forth by default. =for bad C 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 *xchg = \&PDL::xchg; #line 1448 "lib/PDL/Slices.pd" =head2 reorder =for ref Re-orders the dimensions of a PDL based on the supplied list. Similar to the L method, this method re-orders the dimensions of a PDL. While the L method swaps the position of two dimensions, the reorder method can change the positions of many dimensions at once. =for usage # Completely reverse the dimension order of a 6-Dim array. $reOrderedPDL = $pdl->reorder(5,4,3,2,1,0); The argument to reorder is an array representing where the current dimensions should go in the new array. In the above usage, the argument to reorder C<(5,4,3,2,1,0)> indicates that the old dimensions (C<$pdl>'s dims) should be re-arranged to make the new pdl (C<$reOrderPDL>) according to the following: Old Position New Position ------------ ------------ 5 0 4 1 3 2 2 3 1 4 0 5 You do not need to specify all dimensions, only a complete set starting at position 0. (Extra dimensions are left where they are). This means, for example, that you can reorder() the X and Y dimensions of an image, and not care whether it is an RGB image with a third dimension running across color plane. =for example Example: pdl> $x = sequence(5,3,2); # Create a 3-d Array pdl> p $x [ [ [ 0 1 2 3 4] [ 5 6 7 8 9] [10 11 12 13 14] ] [ [15 16 17 18 19] [20 21 22 23 24] [25 26 27 28 29] ] ] pdl> p $x->reorder(2,1,0); # Reverse the order of the 3-D PDL [ [ [ 0 15] [ 5 20] [10 25] ] [ [ 1 16] [ 6 21] [11 26] ] [ [ 2 17] [ 7 22] [12 27] ] [ [ 3 18] [ 8 23] [13 28] ] [ [ 4 19] [ 9 24] [14 29] ] ] The above is a simple example that could be duplicated by calling C<$x-Exchg(0,2)>, but it demonstrates the basic functionality of reorder. As this is an index function, any modifications to the result PDL will change the parent. =cut sub PDL::reorder :lvalue { my ($pdl,@newDimOrder) = @_; my $arrayMax = $#newDimOrder; #Error Checking: if( $pdl->getndims < scalar(@newDimOrder) ){ my $errString = "PDL::reorder: Number of elements (".scalar(@newDimOrder).") in newDimOrder array exceeds\n"; $errString .= "the number of dims in the supplied PDL (".$pdl->getndims.")"; barf($errString); } # Check to make sure all the dims are within bounds for my $i(0..$#newDimOrder) { my $dim = $newDimOrder[$i]; if($dim < 0 || $dim > $#newDimOrder) { my $errString = "PDL::reorder: Dim index $newDimOrder[$i] out of range in position $i\n(range is 0-$#newDimOrder)"; barf($errString); } } # Checking that they are all present and also not duplicated is done by broadcast() [I think] # a quicker way to do the reorder return $pdl->broadcast(@newDimOrder)->unbroadcast(0); } #line 1401 "lib/PDL/Slices.pm" =head2 mv =for sig Signature: (PARENT(); [oca]CHILD(); PDL_Indx n1; PDL_Indx n2) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $CHILD = mv($PARENT, $n1, $n2); $CHILD = $PARENT->mv($n1, $n2); # method call $PARENT->mv($n1, $n2) .= $data; # usable as lvalue =for ref move a dimension to another position The command =for example $y = $x->mv(4,1); creates C<$y> to be like C<$x> except that the dimension 4 is moved to the place 1, so: $y->at(1,2,3,4,5,6) == $x->at(1,5,2,3,4,6); The other dimensions are moved accordingly. Negative dimension indices count from the end. =pod Does not broadcast. Makes L ndarrays. Creates data-flow back and forth by default. =for bad C 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 *mv = \&PDL::mv; #line 1621 "lib/PDL/Slices.pd" =head2 using =for ref Returns list of columns requested =for usage line $pdl->using(1,2); Plot, as a line, column 1 of C<$pdl> vs. column 2 =for example pdl> $pdl = rcols("file"); pdl> line $pdl->using(1,2); =cut *using = \&PDL::using; sub PDL::using { my ($x,@ind)=@_; @ind = list $ind[0] if (blessed($ind[0]) && $ind[0]->isa('PDL')); foreach (@ind) { $_ = $x->slice("($_)"); } @ind; } =head2 meshgrid =for ref Returns list of given 1-D vectors, but each expanded to match dims using L. =for usage meshgrid($vec1, $vec2, $vec3); =for example print map $_->info, meshgrid(xvals(3), xvals(4), xvals(2)); # PDL: Double D [3,4,2] PDL: Double D [3,4,2] PDL: Double D [3,4,2] =cut *meshgrid = \&PDL::meshgrid; sub PDL::meshgrid { barf "meshgrid: only 1-dimensional inputs" if grep $_->ndims != 1, @_; return @_ if @_ == 1; my @dims = map $_->dims, @_; my @out; for my $ind (0..$#_) { push @out, $_[$ind]->slice(join ',', map $_==$ind ? '' : "*$dims[$_]", 0..$#_); } @out; } #line 1518 "lib/PDL/Slices.pm" =head2 lags =for sig Signature: (PARENT(); [oca]CHILD(); PDL_Indx nthdim;PDL_Indx step;PDL_Indx nlags) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $CHILD = lags($PARENT, $nthdim, $step, $nlags); $CHILD = $PARENT->lags($nthdim, $step, $nlags); # method call =for ref Returns an ndarray of lags to parent. Usage: I.e. if C<$x> contains [0,1,2,3,4,5,6,7] then =for example $y = $x->lags(0,2,2); is a (5,2) matrix [2,3,4,5,6,7] [0,1,2,3,4,5] This order of returned indices is kept because the function is called "lags" i.e. the nth lag is n steps behind the original. C<$step> and C<$nlags> must be positive. C<$nthdim> can be negative and will then be counted from the last dim backwards in the usual way (-1 = last dim). =pod Does not broadcast. Makes L ndarrays. Creates data-flow back and forth by default. =for bad C 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 *lags = \&PDL::lags; =head2 splitdim =for sig Signature: (PARENT(); [oca]CHILD(); PDL_Indx nthdim;PDL_Indx nsp) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $CHILD = splitdim($PARENT, $nthdim, $nsp); $CHILD = $PARENT->splitdim($nthdim, $nsp); # method call =for ref Splits a dimension in the parent ndarray (opposite of L). As of 2.076, throws exception if non-divisible C given, and can give negative C which then counts backwards. =for example After $y = $x->splitdim(2,3); the expression $y->at(6,4,m,n,3,6) == $x->at(6,4,m+3*n) is always true (C has to be less than 3). =pod Does not broadcast. Makes L ndarrays. Creates data-flow back and forth by default. =for bad C 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 *splitdim = \&PDL::splitdim; =head2 rotate =for sig Signature: (x(n); indx shift(); [oca]y(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $y = rotate($x, $shift); $y = $x->rotate($shift); # method call =for ref Shift vector elements along with wrap. =pod Broadcasts over its inputs. Creates data-flow back and forth by default. =for bad C 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 *rotate = \&PDL::rotate; =head2 broadcastI =for sig Signature: (PARENT(); [oca]CHILD(); PDL_Indx id; PDL_Indx whichdims[]) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $CHILD = broadcastI($PARENT, $id, $whichdims); $CHILD = $PARENT->broadcastI($id, $whichdims); # method call $PARENT->broadcastI($id, $whichdims) .= $data; # usable as lvalue =for ref internal Put some dimensions to a broadcastid. =for example $y = $x->broadcastI(0,1,5); # broadcast over dims 1,5 in id 1 =pod Does not broadcast. Makes L ndarrays. Creates data-flow back and forth by default. =for bad C 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 *broadcastI = \&PDL::broadcastI; =head2 unbroadcast =for sig Signature: (PARENT(); [oca]CHILD(); PDL_Indx atind) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $CHILD = unbroadcast($PARENT, $atind); $CHILD = $PARENT->unbroadcast($atind); # method call $PARENT->unbroadcast($atind) .= $data; # usable as lvalue =for ref All broadcasted dimensions are made real again. See [TBD Doc] for details and examples. =pod Does not broadcast. Makes L ndarrays. Creates data-flow back and forth by default. =for bad C 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 *unbroadcast = \&PDL::unbroadcast; #line 1957 "lib/PDL/Slices.pd" =head2 dice =for ref Dice rows/columns/planes out of a PDL using indexes for each dimension. This function can be used to extract irregular subsets along many dimension of a PDL, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! This method is similar in functionality to the L method, but L requires that contiguous ranges or ranges with constant offset be extracted. ( i.e. L requires ranges of the form C<1,2,3,4,5> or C<2,4,6,8,10>). Because of this restriction, L is more memory efficient and slightly faster than dice =for usage $slice = $data->dice([0,2,6],[2,1,6]); # Dicing a 2-D array The arguments to dice are arrays (or 1D PDLs) for each dimension in the PDL. These arrays are used as indexes to which rows/columns/cubes,etc to dice-out (or extract) from the C<$data> PDL. Use C to select all indices along a given dimension (compare also L). As usual (in slicing methods) trailing dimensions can be omitted implying C'es for those. =for example pdl> $x = sequence(10,4) pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9] [10 11 12 13 14 15 16 17 18 19] [20 21 22 23 24 25 26 27 28 29] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $x->dice([1,2],[0,3]) # Select columns 1,2 and rows 0,3 [ [ 1 2] [31 32] ] pdl> p $x->dice(X,[0,3]) [ [ 0 1 2 3 4 5 6 7 8 9] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $x->dice([0,2,5]) [ [ 0 2 5] [10 12 15] [20 22 25] [30 32 35] ] As this is an index function, any modifications to the slice will change the parent (use the C<.=> operator). =cut sub PDL::dice :lvalue { my $self = shift; my @dim_indexes = @_; # array of dimension indexes # Check that the number of dim indexes <= # number of dimensions in the PDL my $no_indexes = scalar(@dim_indexes); my $noDims = $self->getndims; barf("PDL::dice: Number of index arrays ($no_indexes) not equal to the dimensions of the PDL ($noDims") if $no_indexes > $noDims; my $index; my $pdlIndex; my $outputPDL=$self; my $indexNo = 0; # Go thru each index array and dice the input PDL: foreach $index(@dim_indexes){ $outputPDL = $outputPDL->dice_axis($indexNo,$index) unless !ref $index && $index eq 'X'; $indexNo++; } return $outputPDL; } *dice = \&PDL::dice; =head2 dice_axis =for ref Dice rows/columns/planes from a single PDL axis (dimension) using index along a specified axis This function can be used to extract irregular subsets along any dimension, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! =for usage $slice = $data->dice_axis($axis,$index); =for example pdl> $x = sequence(10,4) pdl> $idx = pdl(1,2) pdl> p $x->dice_axis(0,$idx) # Select columns [ [ 1 2] [11 12] [21 22] [31 32] ] pdl> $t = $x->dice_axis(1,$idx) # Select rows pdl> $t.=0 pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9] [ 0 0 0 0 0 0 0 0 0 0] [ 0 0 0 0 0 0 0 0 0 0] [30 31 32 33 34 35 36 37 38 39] ] The trick to using this is that the index selects elements along the dimensions specified, so if you have a 2D image C will select certain C values - i.e. extract columns As this is an index function, any modifications to the slice will change the parent. =cut sub PDL::dice_axis :lvalue { my($self,$axis,$idx) = @_; my $ix = PDL->topdl($idx); barf("dice_axis: index must be <=1D") if $ix->getndims > 1; return $self->mv($axis,0)->index1d($ix)->mv(0,$axis); } *dice_axis = \&PDL::dice_axis; #line 1917 "lib/PDL/Slices.pm" =head2 slice =for sig Signature: (PARENT(); [oca]CHILD(); pdl_slice_args *arglist) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $CHILD = slice($PARENT, $arglist); $CHILD = $PARENT->slice($arglist); # method call =for example $slice = $data->slice([2,3],'x',[2,2,0],"-1:1:-1", "*3"); =for ref Extract rectangular slices of an ndarray, from a string specifier, an array ref specifier, or a combination. C is the main method for extracting regions of PDLs and manipulating their dimensionality. You can call it directly or via the L source prefilter that extends Perl syntax to include array slicing. C can extract regions along each dimension of a source PDL, subsample or reverse those regions, dice each dimension by selecting a list of locations along it, or basic PDL indexing routine. The selected subfield remains connected to the original PDL via dataflow. In most cases this neither allocates more memory nor slows down subsequent operations on either of the two connected PDLs. You pass in a list of arguments. Each term in the list controls the disposition of one axis of the source PDL and/or returned PDL. Each term can be a string-format cut specifier, a list ref that gives the same information without recourse to string manipulation, or a PDL with up to 1 dimension giving indices along that axis that should be selected. If you want to pass in a single string specifier for the entire operation, you can pass in a comma-delimited list as the first argument. C detects this condition and splits the string into a regular argument list. This calling style is fully backwards compatible with C calls from before PDL 2.006. B If a particular argument to C is a string, it is parsed as a selection, an affine slice, or a dummy dimension depending on the form. Leading or trailing whitespace in any part of each specifier is ignored (though it is not ignored within numbers). =over 3 =item C<< '' >>, C<< : >>, or C<< X >> -- keep The empty string, C<:>, or C cause the entire corresponding dimension to be kept unchanged. =item C<< >> -- selection A single number alone causes a single index to be selected from the corresponding dimension. The dimension is kept (and reduced to size 1) in the output. =item C<< () >> -- selection and collapse A single number in parenthesis causes a single index to be selected from the corresponding dimension. The dimension is discarded (completely eliminated) in the output. =item C<< : >> -- select an inclusive range Two numbers separated by a colon selects a range of values from the corresponding axis, e.g. C<< 3:4 >> selects elements 3 and 4 along the corresponding axis, and reduces that axis to size 2 in the output. Both numbers are regularized so that you can address the last element of the axis with an index of C< -1 >. If, after regularization, the two numbers are the same, then exactly one element gets selected (just like the C<< >> case). If, after regulariation, the second number is lower than the first, then the resulting slice counts down rather than up -- e.g. C<-1:0> will return the entire axis, in reversed order. =item C<< :: >> -- select a range with explicit step If you include a third parameter, it is the stride of the extracted range. For example, C<< 0:-1:2 >> will sample every other element across the complete dimension. Specifying a stride of 1 prevents autoreversal -- so to ensure that your slice is *always* forward you can specify, e.g., C<< 2:$n:1 >>. In that case, an "impossible" slice gets an Empty PDL (with 0 elements along the corresponding dimension), so you can generate an Empty PDL with a slice of the form C<< 2:1:1 >>. =item C<< * >> -- insert a dummy dimension Dummy dimensions aren't present in the original source and are "mocked up" to match dimensional slots, by repeating the data in the original PDL some number of times. An asterisk followed by a number produces a dummy dimension in the output, for example C<< *2 >> will generate a dimension of size 2 at the corresponding location in the output dim list. Omitting the number (and using just an asterisk) inserts a dummy dimension of size 1. =back B If you feed in an ARRAY ref as a slice term, then it can have 0-3 elements. The first element is the start of the slice along the corresponding dim; the second is the end; and the third is the stepsize. Different combinations of inputs give the same flexibility as the string syntax. =over 3 =item C<< [] >> - keep dim intact An empty ARRAY ref keeps the entire corresponding dim =item C<< [ 'X' ] >> - keep dim intact =item C<< [ '*',$n ] >> - generate a dummy dim of size $n If $n is missing, you get a dummy dim of size 1. =item C<< [ $dex, 0, 0 ] >> - collapse and discard dim C<$dex> must be a single value. It is used to index the source, and the corresponding dimension is discarded. =item C<< [ $start, $end ] >> - collect inclusive slice In the simple two-number case, you get a slice that runs up or down (as appropriate) to connect $start and $end. =item C<< [ $start, $end, $inc ] >> - collect inclusive slice The three-number case works exactly like the three-number string case above. =back B If you pass in a 0- or 1-D PDL as a slicing argument, the corresponding dimension is "diced" -- you get one position along the corresponding dim, per element of the indexing PDL, e.g. C<< $x->slice( pdl(3,4,9)) >> gives you elements 3, 4, and 9 along the 0 dim of C<< $x >>. Because dicing is not an affine transformation, it is slower than direct slicing even though the syntax is convenient. =for example $x->slice('1:3'); # return the second to fourth elements of $x $x->slice('3:1'); # reverse the above $x->slice('-2:1'); # return last-but-one to second elements of $x $x->slice([1,3]); # Same as above three calls, but using array ref syntax $x->slice([3,1]); $x->slice([-2,1]); =pod Does not broadcast. Makes L ndarrays. Creates data-flow back and forth by default. =for bad C 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 2275 "lib/PDL/Slices.pd" sub PDL::slice :lvalue { my ($source, @others) = @_; for my $i(0..$#others) { my $idx = $others[$i]; if (ref $idx eq 'ARRAY') { my @arr = map UNIVERSAL::isa($_, 'PDL') ? $_->flat->at(0) : $_, @{$others[$i]}; $others[$i] = \@arr; next; } next if !( blessed($idx) && $idx->isa('PDL') ); # Deal with dicing. This is lame and slow compared to the # faster slicing, but works okay. We loop over each argument, # and if it's a PDL we dispatch it in the most straightforward # way. Single-element and zero-element PDLs are trivial and get # converted into slices for faster handling later. barf("slice: dicing parameters must be at most 1D (arg $i)\n") if $idx->ndims > 1; my $nlm = $idx->nelem; if($nlm > 1) { #### More than one element - we have to dice (darn it). $source = $source->mv($i,0)->index1d($idx)->mv(0,$i); $others[$i] = ''; } elsif($nlm) { #### One element - convert to a regular slice. $others[$i] = $idx->flat->at(0); } else { #### Zero elements -- force an extended empty. $others[$i] = "1:0:1"; } } PDL::_slice_int($source,my $o=$source->initialize,\@others); $o; } #line 2141 "lib/PDL/Slices.pm" *slice = \&PDL::slice; =head2 diagonal =for sig Signature: (PARENT(); [oca]CHILD(); PDL_Indx whichdims[]) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for ref Returns the multidimensional diagonal over the specified dimensions. The diagonal is placed at the first (by number) dimension that is diagonalized. The other diagonalized dimensions are removed. So if C<$x> has dimensions C<(5,3,5,4,6,5)> then after =for usage $d = $x->diagonal(dim1, dim2,...) =for example $y = $x->diagonal(0,2,5); the ndarray C<$y> has dimensions C<(5,3,4,6)> and C<$y-Eat(2,1,0,1)> refers to C<$x-Eat(2,1,2,0,1,2)>. NOTE: diagonal doesn't handle broadcastids correctly. XXX FIX pdl> $x = zeroes(3,3,3); pdl> ($y = $x->diagonal(0,1))++; pdl> p $x [ [ [1 0 0] [0 1 0] [0 0 1] ] [ [1 0 0] [0 1 0] [0 0 1] ] [ [1 0 0] [0 1 0] [0 0 1] ] ] =pod Does not broadcast. Makes L ndarrays. Creates data-flow back and forth by default. =for bad C 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 2490 "lib/PDL/Slices.pd" sub PDL::diagonal :lvalue { shift->_diagonal_int(my $o=PDL->null, \@_); $o } #line 2221 "lib/PDL/Slices.pm" *diagonal = \&PDL::diagonal; #line 2540 "lib/PDL/Slices.pd" =head1 BUGS For the moment, you can't slice one of the zero-length dims of an empty ndarray. It is not clear how to implement this in a way that makes sense. Many types of index errors are reported far from the indexing operation that caused them. This is caused by the underlying architecture: slice() sets up a mapping between variables, but that mapping isn't tested for correctness until it is used (potentially much later). =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka. Contributions by Craig DeForest, deforest@boulder.swri.edu. Documentation contributions by David Mertens. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut #line 2256 "lib/PDL/Slices.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/ImageRGB.pm0000644000175000017500000001514014771136052015720 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/ImageRGB.pd! Don't modify! # package PDL::ImageRGB; our @EXPORT_OK = qw(interlrgb rgbtogr bytescl cquant cquant_c ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::ImageRGB ; #line 14 "lib/PDL/ImageRGB.pd" use strict; use warnings; =head1 NAME PDL::ImageRGB -- some utility functions for RGB image data handling =head1 DESCRIPTION Collection of a few commonly used routines involved in handling of RGB, palette and grayscale images. Not much more than a start. Should be a good place to exercise some of the broadcast/map/clump PP stuff. Other stuff that should/could go here: =over 3 =item * color space conversion =item * common image filters =item * image rebinning =back =head1 SYNOPSIS use PDL::ImageRGB; =cut use vars qw( $typecheck $EPS ); use PDL::Core; use PDL::Basic; use PDL::Primitive; use PDL::Types; use Carp; use strict 'vars'; $PDL::ImageRGB::EPS = 1e-7; # there is probably a more portable way =head1 FUNCTIONS =head2 cquant =for ref quantize and reduce colours in 8-bit images =for usage ($out, $lut) = cquant($image [,$ncols]); This function does color reduction for <=8bit displays and accepts 8bit RGB and 8bit palette images. It does this through an interface to the ppm_quant routine from the pbmplus package that implements the median cut routine which intelligently selects the 'best' colors to represent your image on a <= 8bit display (based on the median cut algorithm). Optional args: $ncols sets the maximum nunmber of colours used for the output image (defaults to 256). There are images where a different color reduction scheme gives better results (it seems this is true for images containing large areas with very smoothly changing colours). Returns a list containing the new palette image (type PDL_Byte) and the RGB colormap. =cut # full broadcasting support intended *cquant = \&PDL::cquant; sub PDL::cquant { barf 'Usage: ($out,$olut) = cquant($image[,$ncols])' if $#_<0 || $#_>1; my $image = shift; my $ncols; if ($#_ >= 0 ) { $ncols=shift; } else { $ncols = 256; }; my @Dims = $image->dims; my ($out, $olut) = (null,null); barf "input must be byte (3,x,x)" if (@Dims < 2) || ($Dims[0] != 3) || ($image->get_datatype != $PDL_B); cquant_c($image,$out,$olut,$ncols); return ($out,$olut); } =head2 interlrgb =for ref Make an RGB image from a palette image and its lookup table. =for usage $rgb = $palette_im->interlrgb($lut) Input should be of an integer type and the lookup table (3,x,...). Will perform the lookup for any N-dimensional input pdl (i.e. 0D, 1D, 2D, ...). Uses the index command but will dataflow only if the $lut ndarray has the dataflow_forward flag set (see L). =cut # interlace a palette image, input as 8bit-image, RGB-lut (3,x,..) to # (R,G,B) format for each pixel in the image # should already support broadcasting *interlrgb=\&PDL::interlrgb; sub PDL::interlrgb { my ($pdl,$lut) = @_; my $lut_fflows = $lut->fflows; # for our purposes $lut should be (3,z) where z is the number # of colours in the lut barf "expecting (3,x) input" if ($lut->dims)[0] != 3; # do the conversion as an implicitly broadcasted index lookup my $res = $lut->transpose->index($pdl->dummy(0)); $res->sever if !$lut_fflows; return $res; } =head2 rgbtogr =for ref Converts an RGB image to a grey scale using standard transform =for usage $gr = $rgb->rgbtogr Performs a conversion of an RGB input image (3,x,....) to a greyscale image (x,.....) using standard formula: Grey = 0.301 R + 0.586 G + 0.113 B =cut # convert interlaced rgb image to grayscale # will convert any (3,...) dim pdl, i.e. also single lines, # stacks of RGB images, etc since implicit broadcasting takes care of this # should already support broadcasting *rgbtogr = \&PDL::rgbtogr; sub PDL::rgbtogr { barf "Usage: \$im->rgbtogr" if $#_ < 0; my $im = shift; barf "rgbtogr: expecting RGB (3,...) input" if (($im->dims)[0] != 3); my $type = $im->get_datatype; my $rgb = float([77,150,29])/256; # vector for rgb conversion my $oim = null; # flag PP we want it to allocate inner($im,$rgb,$oim); # do the conversion as a broadcasted inner prod return $oim->convert($type); # convert back to original type } =head2 bytescl =for ref Scales a pdl into a specified data range (default 0-255) =for usage $scale = $im->bytescl([$top]) By default $top=255, otherwise you have to give the desired top value as an argument to C. Normally C doesn't rescale data that fits already in the bounds 0..$top (it only does the type conversion if required). If you want to force it to rescale so that the max of the output is at $top and the min at 0 you give a negative $top value to indicate this. =cut # scale any pdl linearly so that its data fits into the range # 0<=x<=$ncols where $ncols<=255 # returns scaled data with type converted to byte # doesn't rescale but just typecasts if data already fits into range, i.e. # data ist not necessarily stretched to 0..$ncols # needs some changes for full broadcasting support ?? (explicit broadcasting?) *bytescl = \&PDL::bytescl; sub PDL::bytescl { barf 'Usage: bytescl $im[,$top]' if $#_ < 0; my $pdl = shift; my ($top,$force) = (255,0); $top = shift if $#_ > -1; if ($top < 0) { $force=1; $top *= -1; } $top = 255 if $top > 255; print "bytescl: scaling from 0..$top\n" if $PDL::debug; my ($max, $min); $max = max $pdl; $min = min $pdl; return byte $pdl if ($min >= 0 && $max <= $top && !$force); # check for pathological cases if (($max-$min) < $EPS) { print "bytescl: pathological case\n" if $PDL::debug; return byte $pdl if (abs($max) < $EPS) || ($max >= 0 && $max <= $top); return byte ($pdl/$max); } my $type = $pdl->get_datatype > $PDL_F ? $PDL_D : $PDL_F; return byte ($top*($pdl->convert($type)-$min)/($max-$min)+0.5); } ;# Exit with OK status 1; =head1 BUGS This package doesn't yet contain enough useful functions! =head1 AUTHOR Copyright 1997 Christian Soeller All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut #line 257 "lib/PDL/ImageRGB.pm" *cquant_c = \&PDL::cquant_c; # Exit with OK status 1; PDL-2.100/GENERATED/PDL/Compression.pm0000644000175000017500000001366214771136050016651 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Compression.pd! Don't modify! # package PDL::Compression; our @EXPORT_OK = qw(rice_compress rice_expand ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Compression ; #line 9 "lib/PDL/Compression.pd" =head1 NAME PDL::Compression - compression utilities =head1 DESCRIPTION These routines generally accept some data as a PDL and compress it into a smaller PDL. Algorithms typically work on a single dimension and broadcast over other dimensions, producing a broadcasted table of compressed values if more than one dimension is fed in. The Rice algorithm, in particular, is designed to be identical to the RICE_1 algorithm used in internal FITS-file compression (see PDL::IO::FITS). =head1 SYNOPSIS use PDL::Compression ($y,$xsize) = $x->rice_compress(); $c = $y->rice_expand($xsize); =cut use strict; use warnings; #line 54 "lib/PDL/Compression.pm" =head1 FUNCTIONS =cut #line 78 "lib/PDL/Compression.pd" =head1 METHODS =cut #line 70 "lib/PDL/Compression.pm" =head2 rice_compress =for sig Signature: (in(n); [o]out(m=CALC(ceil($SIZE(n) * 1.01))); indx[o]len(); int blocksize) Types: (byte short ushort long) =for usage ($out, $len) = rice_compress($in, $blocksize); rice_compress($in, $out, $len, $blocksize); # all arguments given ($out, $len) = $in->rice_compress($blocksize); # method call $in->rice_compress($out, $len, $blocksize); =for ref Squishes an input PDL along the 0 dimension by Rice compression. In scalar context, you get back only the compressed PDL; in list context, you also get back ancillary information that is required to uncompress the data with rice_uncompress. Multidimensional data are broadcasted over - each row is compressed separately, and the returned PDL is squished to the maximum compressed size of any row. If any of the streams could not be compressed (the algorithm produced longer output), the corresponding length is set to -1 and the row is treated as if it had length 0. Rice compression only works on integer data types -- if you have floating point data you must first quantize them. The underlying algorithm is identical to the Rice compressor used in CFITSIO (and is used by PDL::IO::FITS to load and save compressed FITS images). The optional blocksize indicates how many samples are to be compressed as a unit; it defaults to 32. How it works: Rice compression is a subset of Golomb compression, and works on data sets where variation between adjacent samples is typically small compared to the dynamic range of each sample. In this implementation (originally written by Richard White and contributed to CFITSIO in 1999), the data are divided into blocks of samples (by default 32 samples per block). Each block has a running difference applied, and the difference is bit-folded to make it positive definite. High order bits of the difference stream are discarded, and replaced with a unary representation; low order bits are preserved. Unary representation is very efficient for small numbers, but large jumps could give rise to ludicrously large bins in a plain Golomb code; such large jumps ("high entropy" samples) are simply recorded directly in the output stream. Working on astronomical or solar image data, typical compression ratios of 2-3 are achieved. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut sub PDL::rice_compress { my $in = shift; my $blocksize = shift || 32; ## Reject floating-point inputs if( $in->type != byte && $in->type != short && $in->type != ushort && $in->type != long ) { die("rice_compress: input needs to have type byte, short, ushort, or long, not ".($in->type)."\n"); } PDL::_rice_compress_int( $in, my $out=PDL->null, my $len=PDL->null, $blocksize ); my $l = $len->max->sclr; $out = $out->slice("0:".($l-1))->sever; return wantarray ? ($out, $in->dim(0), $blocksize, $len) : $out; } *rice_compress = \&PDL::rice_compress; =head2 rice_expand =for sig Signature: (in(n); indx len(); [o]out(m); IV dim0 => m; int blocksize) Types: (byte short ushort long) =for usage $out = rice_expand($in, $len, $dim0); # using default value of blocksize=32 $out = rice_expand($in, $len, $dim0, $blocksize); # overriding default rice_expand($in, $len, $out, $dim0, $blocksize); # all arguments given $out = $in->rice_expand($len, $dim0); # method call $out = $in->rice_expand($len, $dim0, $blocksize); $in->rice_expand($len, $out, $dim0, $blocksize); =for ref Unsquishes a PDL that has been squished by rice_compress. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *rice_expand = \&PDL::rice_expand; #line 39 "lib/PDL/Compression.pd" =head1 AUTHORS Copyright (C) 2010 Craig DeForest. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The Rice compression library is derived from the similar library in the CFITSIO 3.24 release, and is licensed under yet more more lenient terms than PDL itself; that notice is present in the file "ricecomp.c". =head1 BUGS =over 3 =item * Currently headers are ignored. =item * Currently there is only one compression algorithm. =back =head1 TODO =over 3 =item * Add object encapsulation =item * Add test suite =back =cut #line 245 "lib/PDL/Compression.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/IO/0000755000175000017500000000000014771136050014311 5ustar osboxesosboxesPDL-2.100/GENERATED/PDL/IO/Pnm.pm0000644000175000017500000002553514771136050015413 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/IO/Pnm.pd! Don't modify! # package PDL::IO::Pnm; our @EXPORT_OK = qw(rpnm wpnm pnminraw pnminascii pnmout ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Pnm ; #line 11 "lib/PDL/IO/Pnm.pd" use strict; use warnings; =head1 NAME PDL::IO::Pnm -- pnm format I/O for PDL =head1 SYNOPSIS use PDL::IO::Pnm; $im = wpnm $pdl, $file, $format[, $raw]; rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm"; =head1 DESCRIPTION pnm I/O for PDL. =cut use PDL::Core qw/howbig convert/; use PDL::Types; use PDL::Basic; # for max/min use PDL::IO::Misc; use Carp; use File::Temp qw( tempfile ); # return the upper limit of data values an integer PDL data type # can hold sub dmax { my $type = shift; my $sz = 8*howbig($type); $sz-- if !PDL::Type->new($type)->unsigned; return ((1 << $sz)-1); } #line 63 "lib/PDL/IO/Pnm.pm" =head1 FUNCTIONS =cut =head2 pnminraw =for sig Signature: (type(); byte+ [o] im(m,n); byte [t] buf(llen); IV ms => m; IV ns => n; int isbin; PerlIO *fp) Types: (byte ushort long) =for usage $im = pnminraw($type, $ms, $ns, $isbin, $fp); pnminraw($type, $im, $ms, $ns, $isbin, $fp); # all arguments given $im = $type->pnminraw($ms, $ns, $isbin, $fp); # method call $type->pnminraw($im, $ms, $ns, $isbin, $fp); =for ref Read in a raw pnm file. read a raw pnm file. The C argument is only there to determine the type of the operation when creating C or trigger the appropriate type conversion (maybe we want a byte+ here so that C follows I the type of C). =pod Broadcasts over its inputs. =for bad C 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 *pnminraw = \&PDL::pnminraw; =head2 pnminascii =for sig Signature: (type(); byte+ [o] im(m,n); IV ms => m; IV ns => n; int format; PerlIO *fp) Types: (byte ushort short long) =for usage $im = pnminascii($type, $ms, $ns, $format, $fp); pnminascii($type, $im, $ms, $ns, $format, $fp); # all arguments given $im = $type->pnminascii($ms, $ns, $format, $fp); # method call $type->pnminascii($im, $ms, $ns, $format, $fp); =for ref Read in an ascii pnm file. =pod Broadcasts over its inputs. =for bad C 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 *pnminascii = \&PDL::pnminascii; =head2 pnmout =for sig Signature: (a(m); int israw; int isbin; PerlIO *fp) Types: (byte ushort short long) =for usage pnmout($a, $israw, $isbin, $fp); # all arguments given $a->pnmout($israw, $isbin, $fp); # method call =for ref Write a line of pnm data. This function is implemented this way so that broadcasting works naturally. =pod Broadcasts over its inputs. Can't use POSIX threads. =for bad C 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 *pnmout = \&PDL::pnmout; #line 49 "lib/PDL/IO/Pnm.pd" =head2 rpnm =for ref Read a pnm (portable bitmap/pixmap, pbm/ppm) file into an ndarray. =for usage Usage: $im = rpnm $file; Reads a file (or open file-handle) in pnm format (ascii or raw) into a pdl (magic numbers P1-P6). Based on the input format it returns pdls with arrays of size (width,height) if binary or grey value data (pbm and pgm) or (3,width,height) if rgb data (ppm). This also means for a palette image that the distinction between an image and its lookup table is lost which can be a problem in cases (but can hardly be avoided when using netpbm/pbmplus). Datatype is dependent on the maximum grey/color-component value (for raw and binary formats always PDL_B). rpnm tries to read chopped files by zero padding the missing data (well it currently doesn't, it barfs; I'll probably fix it when it becomes a problem for me ;). You can also read directly into an existing pdl that has to have the right size(!). This can come in handy when you want to read a sequence of images into a datacube. For details about the formats see appropriate manpages that come with the netpbm/pbmplus packages. =for example $stack = zeroes(byte,3,500,300,4); rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm"; reads an rgb image (that had better be of size (500,300)) into the first plane of a 3D RGB datacube (=4D pdl datacube). You can also do inplace transpose/inversion that way. =cut sub rpnm {PDL->rpnm(@_)} sub PDL::rpnm { barf 'Usage: $im = rpnm($file) or $im = $pdl->rpnm($file)' if !@_ || @_>3; my $pdl = ref($_[1]) && UNIVERSAL::isa($_[1], 'PDL') ? (splice @_, 0, 2)[1] : shift->initialize; my $file = shift; my $fh; if (ref $file) { $fh = $file; } else { open $fh, $file or barf "Can't open pnm file '$file': $!"; } binmode $fh; read($fh,(my $magic),2); barf "Oops, this is not a PNM file" unless $magic =~ /P([1-6])/; my $magicno = $1; print "reading pnm file with magic $magic\n" if $PDL::debug>1; my $israw = $magicno > 3 ? 1 : 0; my $isrgb = ($magicno % 3) == 0; my $ispbm = ($magicno % 3) == 1; my ($params, @dims) = ($ispbm ? 2 : 3, 0, 0, $ispbm ? 1 : 0); # get the header information my $pgot = 0; while (($pgot<$params) && defined(my $line=<$fh>)) { $line =~ s/#.*$//; next if $line =~ /^\s*$/; # just white space while ($line !~ /^\s*$/ && $pgot < $params) { if ($line =~ /\s*(\S+)(.*)$/) { $dims[$pgot++] = $1; $line = $2; } else { barf "no valid header info in pnm";} } } # the file ended prematurely barf "no valid header info in pnm" if $pgot < $params; barf "Dimensions must be > 0" if ($dims[0] <= 0) || ($dims[1] <= 0); my ($type) = grep $dims[2] <= dmax($_), $PDL_B,$PDL_US,$PDL_L; barf "rraw: data from ascii pnm file out of range" if !defined $type; my @Dims = @dims[0,1]; $Dims[0] *= 3 if $isrgb; $pdl = $pdl->zeroes(PDL::Type->new($type),3,@dims[0,1]) if $pdl->isnull and $isrgb; my $npdl = $isrgb ? $pdl->clump(2) : $pdl; if ($israw) { pnminraw (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1], $ispbm, $fh); } else { pnminascii (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1], $magicno, $fh); } print("loaded pnm file, $dims[0]x$dims[1], gmax: $dims[2]", $isrgb ? ", RGB data":"", $israw ? ", raw" : " ASCII"," data\n") if $PDL::debug; # need to byte swap for little endian platforms $pdl->type->bswap->($pdl) if !isbigendian() and $israw; return $pdl; } =head2 wpnm =for ref Write a pnm (portable bitmap/pixmap, pbm/ppm) file into a file or open file-handle. =for usage Usage: $im = wpnm $pdl, $file, $format[, $raw]; Writes data in a pdl into pnm format (ascii or raw) (magic numbers P1-P6). The $format is required (normally produced by B) and routine just checks if data is compatible with that format. All conversions should already have been done. If possible, usage of B is preferred. Currently RAW format is chosen if compliant with range of input data. Explicit control of ASCII/RAW is possible through the optional $raw argument. If RAW is set to zero it will enforce ASCII mode. Enforcing RAW is somewhat meaningless as the routine will always try to write RAW format if the data range allows (but maybe it should reduce to a RAW supported type when RAW == 'RAW'?). For details about the formats consult appropriate manpages that come with the netpbm/pbmplus packages. =cut my %type2base = (PBM => 1, PGM => 2, PPM => 3); *wpnm = \&PDL::wpnm; sub PDL::wpnm { barf ('Usage: wpnm($pdl,$filename,$format[,$raw]) ' . 'or $pdl->wpnm($filename,$format[,$raw])') if $#_ < 2; my ($pdl,$file,$type,$raw) = @_; barf "wpnm: unknown format '$type'" if !exists $type2base{$type}; # need to copy input arg since bswap[24] work inplace # might be better if the bswap calls detected if run in # void context my $swap_inplace = $pdl->is_inplace; # check the data my @Dims = $pdl->dims; barf "wpnm: expecting 3D (3,w,h) input" if ($type =~ /PPM/) && (($#Dims != 2) || ($Dims[0] != 3)); barf "wpnm: expecting 2D (w,h) input" if ($type =~ /P[GB]M/) && ($#Dims != 1); barf "wpnm: user should convert float etc data to appropriate type" if !$pdl->type->integer; my $max = $pdl->max; barf "wpnm: expecting prescaled data (0-65535)" if $pdl->min < 0 or $max > 65535; # check for raw format my $israw = (defined($raw) && !$raw) ? 0 : (($pdl->get_datatype == $PDL_B) || ($pdl->get_datatype == $PDL_US) || ($type eq 'PBM')) ? 3 : 0; my $magic = 'P' . ($type2base{$type} + $israw); my $isrgb = $type eq 'PPM'; my $pref = ($file !~ /^\s*[|>]/) ? ">" : ""; # test for plain file name my ($already_open, $fh) = 0; if (ref $file) { $fh = $file, $already_open = 1; } else { open $fh, $pref . $file or barf "Can't open pnm file: $!"; } binmode $fh; print "writing ". ($israw ? "raw" : "ascii") . "format with magic $magic, max=$max\n" if $PDL::debug; # write header print $fh "$magic\n"; print $fh "$Dims[-2] $Dims[-1]\n"; if ($type ne 'PBM') { # fix maxval for raw output formats my $outmax = 0; if ($max < 256) { $outmax = "255"; } elsif ($max < 65536) { $outmax = "65535"; } else { $outmax = $max; }; print $fh "$outmax\n"; }; # if rgb clump first two dims together my $out = ($isrgb ? $pdl->slice(':,:,-1:0')->clump(2) : $pdl->slice(':,-1:0')); # handle byte swap issues for little endian platforms if (!isbigendian() and $israw) { $out = $out->copy unless $swap_inplace; $out->type->bswap->($out); } pnmout($out,$israw,$type eq "PBM",$fh); # check if our child returned an error (in case of a pipe) barf "wpnm: pbmconverter error: $!" if !$already_open and !close $fh; } ;# Exit with OK status 1; =head1 BUGS C currently relies on the fact that the header is separated from the image data by a newline. This is not required by the p[bgp]m formats (in fact any whitespace is allowed) but most of the pnm writers seem to comply with that. Truncated files are currently treated ungracefully (C just barfs). =head1 AUTHOR Copyright (C) 1996,1997 Christian Soeller All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut ############################## END PM CODE ################################ #line 428 "lib/PDL/IO/Pnm.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/IO/Misc.pm0000644000175000017500000012601414771136050015546 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/IO/Misc.pd! Don't modify! # package PDL::IO::Misc; our @EXPORT_OK = qw(rcols wcols swcols rgrep bswap2 bswap4 bswap8 bswap12 bswap16 bswap24 bswap32 isbigendian rcube rasc ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Misc ; #line 7 "lib/PDL/IO/Misc.pd" use strict; use warnings; =head1 NAME PDL::IO::Misc - misc IO routines for PDL =head1 DESCRIPTION Some basic I/O functionality: tables, byte-swapping =head1 SYNOPSIS use PDL::IO::Misc; =cut #line 45 "lib/PDL/IO/Misc.pm" =head1 FUNCTIONS =cut #line 47 "lib/PDL/IO/Misc.pd" use PDL::Primitive; use PDL::Types; use PDL::Options; use PDL::Bad; use Carp; use Symbol qw/ gensym /; use List::Util; #line 65 "lib/PDL/IO/Misc.pm" =head2 bswap2 =for sig Signature: ([io] x()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage bswap2($x); # all arguments given $x->bswap2; # method call =for ref Swaps pairs of bytes in argument x() =pod Broadcasts over its inputs. =for bad C 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 *bswap2 = \&PDL::bswap2; =head2 bswap4 =for sig Signature: ([io] x()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage bswap4($x); # all arguments given $x->bswap4; # method call =for ref Swaps quads of bytes in argument x() =pod Broadcasts over its inputs. =for bad C 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 *bswap4 = \&PDL::bswap4; =head2 bswap8 =for sig Signature: ([io] x()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage bswap8($x); # all arguments given $x->bswap8; # method call =for ref Swaps octets of bytes in argument x() =pod Broadcasts over its inputs. =for bad C 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 *bswap8 = \&PDL::bswap8; =head2 bswap12 =for sig Signature: ([io] x()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage bswap12($x); # all arguments given $x->bswap12; # method call =for ref Swaps 12s of bytes in argument x() =pod Broadcasts over its inputs. =for bad C 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 *bswap12 = \&PDL::bswap12; =head2 bswap16 =for sig Signature: ([io] x()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage bswap16($x); # all arguments given $x->bswap16; # method call =for ref Swaps 16s of bytes in argument x() =pod Broadcasts over its inputs. =for bad C 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 *bswap16 = \&PDL::bswap16; =head2 bswap24 =for sig Signature: ([io] x()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage bswap24($x); # all arguments given $x->bswap24; # method call =for ref Swaps 24s of bytes in argument x() =pod Broadcasts over its inputs. =for bad C 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 *bswap24 = \&PDL::bswap24; =head2 bswap32 =for sig Signature: ([io] x()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage bswap32($x); # all arguments given $x->bswap32; # method call =for ref Swaps 32s of bytes in argument x() =pod Broadcasts over its inputs. =for bad C 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 *bswap32 = \&PDL::bswap32; #line 91 "lib/PDL/IO/Misc.pd" # Internal routine to extend PDL array by size $n along last dimension # - Would be nice to have a proper extend function rather than hack # - Is a NO-OP when handed a perl ARRAY ref rather than an ndarray arg sub _ext_lastD { # Called by rcols and rgrep my ($x,$n) = @_; if (ref($_[0]) ne 'ARRAY') { my @nold = $x->dims; my @nnew = @nold; $nnew[-1] += $n; # add $n to the last dimension my $y = zeroes($x->type,@nnew); # New pdl my $yy = $y->mv(-1,0)->slice("0:".($nold[-1]-1))->mv(0,-1); $yy .= $x; $_[0] = $y; } 1; } # Implements PDL->at() for either 1D PDL or ARRAY arguments # TODO: Need to add support for multidim ndarrays parallel to rcols sub _at_1D ($$) { # Called by wcols and swcols my $data = $_[0]; my $index = $_[1]; if (ref $data eq 'ARRAY') { return $data->[$index]; } else { return $data->at($index); } } # squeezes "fluffy" perl list values into column data type sub _burp_1D { my $data = $_[0][0]; my $databox = $_[0][1]; my $index = $_[1]; my $start = $index - @{$databox} + 1; if (ref $data eq 'ARRAY') { push @{$data}, @{$databox}; } elsif ( ref($databox->[0]) eq "ARRAY" ) { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) $data->slice(":,$start:$index") .= pdl($data->type, $databox); } else { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) $data->slice("$start:$index") .= pdl($data->type, $databox); } $_[0] = [ $data, [] ]; } # taken outside of rcols() to avoid clutter sub _handle_types ($$$) { my $ncols = shift; my $deftype = shift; my $types = shift; barf "Unknown PDL type given for DEFTYPE.\n" unless ref($deftype) eq "PDL::Type"; my @cols = ref($types) eq "ARRAY" ? @$types : (); if ( $#cols > -1 ) { # truncate if required $#cols = $ncols if $#cols > $ncols; # check input values are sensible for ( 0 .. $#cols ) { barf "Unknown value '$cols[$_]' in TYPES array.\n" unless ref($cols[$_]) eq "PDL::Type"; } } # fill in any missing columns for ( ($#cols+1) .. $ncols ) { push @cols, $deftype; } return @cols; } # sub: _handle_types # Whether an object is an IO handle use Scalar::Util; sub _is_io_handle { my $h = shift; # reftype catches almost every handle, except: *MYHANDLE # fileno catches *MYHANDLE, but doesn't catch handles that aren't files my $reftype = Scalar::Util::reftype($h); return defined(fileno($h)) || (defined($reftype) && $reftype eq 'GLOB'); } =head2 rcols =for ref Read specified ASCII cols from a file into ndarrays and perl arrays (also see L). =for usage Usage: ($x,$y,...) = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, $col1, $col2, ... ) $x = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, [] ) ($x,$y,...) = rcols( *HANDLE|"filename", $col1, $col2, ..., { EXCLUDE => '/^!/' } ) ($x,$y,...) = rcols( *HANDLE|"filename", "/foo/", $col1, $col2, ... ) For each column number specified, a 1D output PDL will be generated. Anonymous arrays of column numbers generate 2D output ndarrays with dim0 for the column data and dim1 equal to the number of columns in the anonymous array(s). An empty anonymous array as column specification will produce a single output data ndarray with dim(1) equal to the number of columns available. There are two calling conventions - the old version, where a pattern can be specified after the filename/handle, and the new version where options are given as as hash reference. This reference can be given as either the second or last argument. The default behaviour is to ignore lines beginning with a # character and lines that only consist of whitespace. Options exist to only read from lines that match, or do not match, supplied patterns, and to set the types of the created ndarrays. Can take file name or *HANDLE, and if no explicit column numbers are specified, all are assumed. For the allowed types, see L. Options (case insensitive): EXCLUDE or IGNORE - ignore lines matching this pattern (default B<'/^#/'>). INCLUDE or KEEP - only use lines which match this pattern (default B<''>). LINES - a string pattern specifying which line numbers to use. Line numbers start at 0 and the syntax is 'a:b:c' to use every c'th matching line between a and b (default B<''>). DEFTYPE - default data type for stored data (if not specified, use the type stored in C<$PDL::IO::Misc::deftype>, which starts off as B). TYPES - reference to an array of data types, one element for each column to be read in. Any missing columns use the DEFTYPE value (default B<[]>). COLSEP - splits on this string/pattern/qr{} between columns of data. Defaults to $PDL::IO::Misc::defcolsep. PERLCOLS - an array of column numbers which are to be read into perl arrays rather than ndarrays. Any columns not specified in the explicit list of columns to read will be returned after the explicit columns. (default B). COLIDS - if defined to an array reference, it will be assigned the column ID values obtained by splitting the first line of the file in the identical fashion to the column data. CHUNKSIZE - the number of input data elements to batch together before appending to each output data ndarray (Default value is 100). If CHUNKSIZE is greater than the number of lines of data to read, the entire file is slurped in, lines split, and perl lists of column data are generated. At the end, effectively pdl(@column_data) produces any result ndarrays. VERBOSE - be verbose about IO processing (default C<$PDL::vebose>) =for example For example: $x = PDL->rcols 'file1'; # file1 has only one column of data $x = PDL->rcols 'file2', []; # file2 can have multiple columns, still 1 ndarray output # (empty array ref spec means all possible data fields) ($x,$y) = rcols 'table.csv', { COLSEP => ',' }; # read CSV data file ($x,$y) = rcols *STDOUT; # default separator for lines like '32 24' # read in lines containing the string foo, where the first # example also ignores lines that begin with a # character. ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/' }; ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/', EXCLUDE => '' }; # ignore the first 27 lines of the file, reading in as ushort's ($x,$y) = rcols 'file3', { LINES => '27:-1', DEFTYPE => ushort }; ($x,$y) = rcols 'file3', { LINES => '27:', TYPES => [ ushort, ushort ] }; # read in the first column as a perl array and the next two as ndarrays # with the perl column returned after the ndarray outputs ($x,$y,$name) = rcols 'file4', 1, 2 , { PERLCOLS => [ 0 ] }; printf "Number of names read in = %d\n", 1 + $#$name; # read in the first column as a perl array and the next two as ndarrays # with PERLCOLS changing the type of the first returned value to perl list ref ($name,$x,$y) = rcols 'file4', 0, 1, 2, { PERLCOLS => [ 0 ] }; # read in the first column as a perl array returned first followed by the # the next two data columns in the file as a single Nx2 ndarray ($name,$xy) = rcols 'file4', 0, [1, 2], { PERLCOLS => [ 0 ] }; NOTES: 1. Quotes are required on patterns or use the qr{} quote regexp syntax. 2. Columns are separated by whitespace by default, use the COLSEP option separator to specify an alternate split pattern or string or specify an alternate default separator by setting C<$PDL::IO::Misc::defcolsep> . 3. Legacy support is present to use C<$PDL::IO::Misc::colsep> to set the column separator but C<$PDL::IO::Misc::colsep> is not defined by default. If you set the variable to a defined value it will get picked up. 4. LINES => '-1:0:3' may not work as you expect, since lines are skipped when read in, then the whole array reversed. 5. For consistency with wcols and rcols 1D usage, column data is loaded into the rows of the pdls (i.e., dim(0) is the elements read per column in the file and dim(1) is the number of columns of data read. =cut use vars qw/ $colsep $defcolsep $deftype /; $defcolsep = ' '; # Default column separator $deftype = double; # Default type for ndarrays my $defchunksize = 100; # Number of perl list items to append to ndarray my $usecolsep; # This is the colsep value that is actually used # NOTE: XXX # need to look at the line-selection code. For instance, if want # lines => '-1:0:3', # read in all lines, reverse, then apply the step # -> fix point 4 above # # perhaps should just simplify the LINES option - ie remove # support for reversed arrays? sub rcols{ PDL->rcols(@_) } sub PDL::rcols { my $class = shift; barf 'Usage ($x,$y,...) = rcols( *HANDLE|"filename", ["/pattern/" or \%options], $col1, $col2, ..., [ \%options] )' if $#_<0; my $is_handle = _is_io_handle $_[0]; my $fh = $is_handle ? $_[0] : gensym; open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle; shift; # set up default options my $opt = PDL::Options->new( { CHUNKSIZE => undef, COLIDS => undef, COLSEP => undef, DEFTYPE => $deftype, EXCLUDE => '/^#/', INCLUDE => undef, LINES => '', PERLCOLS => undef, TYPES => [], VERBOSE=> $PDL::verbose, } ); $opt->synonyms( { IGNORE => 'EXCLUDE', KEEP => 'INCLUDE' } ); # has the user supplied any options if ( defined($_[0]) ) { # ensure the old-style behaviour by setting the exclude pattern to undef if ( $_[0] =~ m|^/.*/$| ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); } elsif ( ref($_[0]) eq "Regexp" ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); } elsif ( ref($_[0]) eq "HASH" ) { $opt->options( shift ); } } # maybe the last element is a hash array as well $opt->options( pop ) if defined($_[-1]) and ref($_[-1]) eq "HASH"; # a reference to a hash array my $options = $opt->current(); # handle legacy colsep variable $usecolsep = (defined $colsep) ? qr{$colsep} : undef; $usecolsep = qr{$options->{COLSEP}} if $options->{COLSEP}; # what are the patterns? foreach my $pattern ( qw( INCLUDE EXCLUDE ) ) { if ( $options->{$pattern} and ref($options->{$pattern}) ne "Regexp" ) { if ( $options->{$pattern} =~ m|^/.*/$| ) { $options->{$pattern} =~ s|^/(.*)/$|$1|; $options->{$pattern} = qr($options->{$pattern}); } else { barf "rcols() - unable to process $pattern value.\n"; } } } # CHUNKSIZE controls memory/time tradeoff of ndarray IO my $chunksize = $options->{CHUNKSIZE} || $defchunksize; my $nextburpindex = -1; # which columns are to be read into ndarrays and which into perl arrays? my @end_perl_cols = (); # unique perl cols to return at end my @perl_cols = (); # perl cols index list from PERLCOLS option @perl_cols = @{ $$options{PERLCOLS} } if $$options{PERLCOLS}; my @is_perl_col; # true if index corresponds to a perl column for (@perl_cols) { $is_perl_col[$_] = 1; }; # print STDERR "rcols: \@is_perl_col is @is_perl_col\n"; my ( @explicit_cols ) = @_; # call specified columns to read # print STDERR "rcols: \@explicit_cols is @explicit_cols\n"; # work out which line numbers are required # - the regexp's are a bit over the top my ( $x, $y, $c ); if ( $$options{LINES} ne '' ) { if ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*$/ ) { $x = $1; $y = $2; } elsif ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*:\s*([+]?\d*)\s*$/ ) { $x = $1; $y = $2; $c = $3; } else { barf "rcols() - unable to parse LINES option.\n"; } } # Since we do not know how many lines there are in advance, things get a bit messy my ( $index_start, $index_end ) = ( 0, -1 ); $index_start = $x if defined($x) and $x ne ''; $index_end = $y if defined($y) and $y ne ''; my $line_step = $c || 1; # $line_rev = 0/1 for normal order/reversed # $line_start/_end refer to the first and last line numbers that we want # (the values of which we may not know until we've read in all the file) my ( $line_start, $line_end, $line_rev ); if ( ($index_start >= 0 and $index_end < 0) ) { # eg 0:-1 $line_rev = 0; $line_start = $index_start; } elsif ( $index_end >= 0 and $index_start < 0 ) { # eg -1:0 $line_rev = 1; $line_start = $index_end; } elsif ( $index_end >= $index_start and $index_start >= 0 ) { # eg 0:10 $line_rev = 0; $line_start = $index_start; $line_end = $index_end; } elsif ( $index_start > $index_end and $index_end >= 0 ) { # eg 10:0 $line_rev = 1; $line_start = $index_end; $line_end = $index_start; } elsif ( $index_start <= $index_end ) { # eg -5:-1 $line_rev = 0; } else { # eg -1:-5 $line_rev = 1; } my @ret; my ($k,$fhline); my $line_num = -1; my $line_ctr = $line_step - 1; # ensure first line is always included my $index = -1; my $pdlsize = 0; my $extend = 10000; my $line_store; # line numbers of saved data RCOLS_IO: { if ($options->{COLIDS}) { print STDERR "rcols: processing COLIDS option\n" if $options->{VERBOSE}; undef $!; if (defined($fhline = <$fh>) ) { # grab first line's fields for column IDs $fhline =~ s/\r?\n$//; # handle DOS on unix files better my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); @{$options->{COLIDS}} = @v; } else { die "rcols: reading COLIDS info, $!" if $!; last RCOLS_IO; } } while( defined($fhline = <$fh>) ) { # chomp $fhline; $fhline =~ s/\r?\n$//; # handle DOS on unix files better $line_num++; # the order of these checks is important, particularly whether we # check for line_ctr before or after the pattern matching # Prior to PDL 2.003 the line checks were done BEFORE the # pattern matching # # need this first check, even with it almost repeated at end of loop, # incase the pattern matching excludes $line_num == $line_end, say last if defined($line_end) and $line_num > $line_end; next if defined($line_start) and $line_num < $line_start; next if $options->{EXCLUDE} and $fhline =~ /$options->{EXCLUDE}/; next if $options->{INCLUDE} and not $fhline =~ /$options->{INCLUDE}/; next unless ++$line_ctr == $line_step; $line_ctr = 0; $index++; my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); # map empty fields '' to undef value @v = map { $_ eq '' ? undef : $_ } @v; # if the first line, set up the output ndarrays using all the columns # if the user doesn't specify anything if ( $index == 0 ) { # Handle implicit multicolumns in command line if ($#explicit_cols < 0) { # implicit single col data @explicit_cols = ( 0 .. $#v ); } if (scalar(@explicit_cols)==1 and ref($explicit_cols[0]) eq "ARRAY") { if ( !scalar(@{$explicit_cols[0]}) ) { # implicit multi-col data @explicit_cols = ( [ 0 .. $#v ] ); } } my $implicit_pdls = 0; my $is_explicit = {}; foreach my $col (@explicit_cols) { if (ref($col) eq "ARRAY") { $implicit_pdls++ if !scalar(@$col); } else { $is_explicit->{$col} = 1; } } if ($implicit_pdls > 1) { die "rcols: only one implicit multicolumn ndarray spec allowed, found $implicit_pdls!\n"; } foreach my $col (@explicit_cols) { if (ref($col) eq "ARRAY" and !scalar(@$col)) { @$col = grep { !$is_explicit->{$_} } ( 0 .. $#v ); } } # remove declared perl columns from pdl data list $k = 0; my @pdl_cols = (); foreach my $col (@explicit_cols) { # strip out declared perl cols so they won't be read into ndarrays if ( ref($col) eq "ARRAY" ) { @$col = grep { !$is_perl_col[$_] } @{$col}; push @pdl_cols, [ @{$col} ]; } elsif (!$is_perl_col[$col]) { push @pdl_cols, $col; } } # strip out perl cols in explicit col list for return at end @end_perl_cols = @perl_cols; foreach my $col (@explicit_cols) { if ( ref($col) ne "ARRAY" and defined($is_perl_col[$col]) ) { @end_perl_cols = grep { $_ != $col } @end_perl_cols; } }; # sort out the types of the ndarrays my @types = _handle_types( $#pdl_cols, $$options{DEFTYPE}, $$options{TYPES} ); if ( $options->{VERBOSE} ) { # dbg aid print "Reading data into ndarrays of type: [ "; foreach my $t ( @types ) { print $t->shortctype() . " "; } print "]\n"; } $k = 0; for (@explicit_cols) { # Using mixed list+ndarray data structure for performance tradeoff # between memory usage (perl list) and speed of IO (PDL operations) if (ref($_) eq "ARRAY") { # use multicolumn ndarray here push @ret, [ $class->zeroes($types[$k++],scalar(@{$_}),1), [] ]; } else { push @ret, ($is_perl_col[$_] ? [ [], [] ] : [ $class->zeroes($types[$k],1), [] ]); $k++ unless $is_perl_col[$_]; } } for (@end_perl_cols) { push @ret, [ [], [] ]; } $line_store = [ $class->zeroes(long,1), [] ]; # only need to store integers } # if necessary, extend PDL in buffered manner $k = 0; if ( $pdlsize < $index ) { for (@ret, $line_store) { _ext_lastD( $_->[0], $extend ); } $pdlsize += $extend; } # - stick perl arrays onto end of $ret $k = 0; for (@explicit_cols, @end_perl_cols) { if (ref($_) eq "ARRAY") { push @{ $ret[$k++]->[1] }, [ @v[ @$_ ] ]; } else { push @{ $ret[$k++]->[1] }, $v[$_]; } } # store the line number push @{$line_store->[1]}, $line_num; # need to burp out list if needed if ( $index >= $nextburpindex ) { for (@ret, $line_store) { _burp_1D($_,$index); } $nextburpindex = $index + $chunksize; } # Thanks to Frank Samuelson for this last if defined($line_end) and $line_num == $line_end; } } close($fh) unless $is_handle; # burp one final time if needed and # clean out additional ARRAY ref level for @ret for (@ret, $line_store) { _burp_1D($_,$index) if defined $_ and scalar @{$_->[1]}; $_ = $_->[0]; } # have we read anything in? if not, return empty ndarrays if ( $index == -1 ) { print "Warning: rcols() did not read in any data.\n" if $options->{VERBOSE}; if ( wantarray ) { foreach ( 0 .. $#explicit_cols ) { if ( $is_perl_col[$_] ) { $ret[$_] = PDL->null; } else { $ret[$_] = []; } } for ( @end_perl_cols ) { push @ret, []; } return ( @ret ); } else { return PDL->null; } } # if the user has asked for lines => 0:-1 or 0:10 or 1:10 or 1:-1, # - ie not reversed and the last line number is known - # then we can skip the following nastiness if ( $line_rev == 0 and $index_start >= 0 and $index_end >= -1 ) { for (@ret) { ## $_ = $_->mv(-1,0)->slice("0:${index}")->mv(0,-1) unless ref($_) eq 'ARRAY'; $_ = $_->mv(-1,0)->slice("0:${index}") unless ref($_) eq 'ARRAY'; # cols are dim(0) }; if ( $options->{VERBOSE} ) { if ( ref($ret[0]) eq 'ARRAY' ) { print "Read in ", scalar( @{ $ret[0] } ), " elements.\n"; } else { print "Read in ", $ret[0]->nelem, " elements.\n"; } } wantarray ? return(@ret) : return $ret[0]; } # Work out which line numbers we want. First we clean up the ndarray # containing the line numbers that have been read in $line_store = $line_store->slice("0:${index}"); # work out the min/max line numbers required if ( $line_rev ) { if ( defined($line_start) and defined($line_end) ) { my $dummy = $line_start; $line_start = $line_end; $line_end = $dummy; } elsif ( defined($line_start) ) { $line_end = $line_start; } else { $line_start = $line_end; } } $line_start = $line_num + 1 + $index_start if $index_start < 0; $line_end = $line_num + 1 + $index_end if $index_end < 0; my $indices; { no warnings 'precedence'; if ( $line_rev ) { $indices = which( $line_store >= $line_end & $line_store <= $line_start )->slice('-1:0'); } else { $indices = which( $line_store >= $line_start & $line_store <= $line_end ); } } # truncate the ndarrays for my $col ( @explicit_cols ) { if ( ref($col) eq "ARRAY" ) { for ( @$col ) { $ret[$_] = $ret[$_]->index($indices); } } else { $ret[$col] = $ret[$col]->index($indices) unless $is_perl_col[$col] }; } # truncate/reverse/etc the perl arrays my @indices_array = list $indices; foreach ( @explicit_cols, @end_perl_cols ) { if ( $is_perl_col[$_] ) { my @temp = @{ $ret[$_] }; $ret[$_] = []; foreach my $i ( @indices_array ) { push @{ $ret[$_] }, $temp[$i] }; } } # print some diagnostics if ( $options->{VERBOSE} ) { my $done = 0; foreach my $col (@explicit_cols) { last if $done; next if $is_perl_col[$col]; print "Read in ", $ret[$col]->nelem, " elements.\n"; $done = 1; } foreach my $col (@explicit_cols, @end_perl_cols) { last if $done; print "Read in ", $ret[$col]->nelem, " elements.\n"; $done = 1; } } # fix 2D pdls to match what wcols generates foreach my $col (@ret) { next if ref($col) eq "ARRAY"; $col = $col->transpose if $col->ndims == 2; } wantarray ? return(@ret) : return $ret[0]; } =head2 wcols =for ref Write ASCII columns into file from 1D or 2D ndarrays and/or 1D listrefs efficiently. Can take file name or *HANDLE, and if no file/filehandle is given defaults to STDOUT. Options (case insensitive): HEADER - prints this string before the data. If the string is not terminated by a newline, one is added. (default B<''>). COLSEP - prints this string between columns of data. Defaults to $PDL::IO::Misc::defcolsep. FORMAT - A printf-style format string that is cycled through column output for user controlled formatting. =for usage Usage: wcols $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; # or wcols $format_string, $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; where the $dataN args are either 1D ndarrays, 1D perl array refs, or 2D ndarrays (as might be returned from rcols() with the [] column syntax and/or using the PERLCOLS option). dim(0) of all ndarrays written must be the same size. The printf-style $format_string, if given, overrides any FORMAT key settings in the option hash. e.g., =for example $x = random(4); $y = ones(4); wcols $x, $y+2, 'foo.dat'; wcols $x, $y+2, *STDERR; wcols $x, $y+2, '|wc'; $x = sequence(3); $y = zeros(3); $c = random(3); wcols $x,$y,$c; # Orthogonal version of 'print $x,$y,$c' :-) wcols "%10.3f", $x,$y; # Formatted wcols "%10.3f %10.5g", $x,$y; # Individual column formatting $x = sequence(3); $y = zeros(3); $units = [ 'm/sec', 'kg', 'MPH' ]; wcols $x,$y, { HEADER => "# x y" }; wcols $x,$y, { Header => "# x y", Colsep => ', ' }; # case insensitive option names! wcols " %4.1f %4.1f %s",$x,$y,$units, { header => "# Day Time Units" }; $a52 = sequence(5,2); $y = ones(5); $c = [ 1, 2, 4 ]; wcols $a52; # now can write out 2D pdls (2 columns data in output) wcols $y, $a52, $c # ...and mix and match with 1D listrefs as well NOTES: 1. Columns are separated by whitespace by default, use C<$PDL::IO::Misc::defcolsep> to modify the default value or the COLSEP option 2. Support for the C<$PDL::IO::Misc::colsep> global value of PDL-2.4.6 and earlier is maintained but the initial value of the global is undef until you set it. The value will be then be picked up and used as if defcolsep were specified. 3. Dim 0 corresponds to the column data dimension for both rcols and wcols. This makes wcols the reverse operation of rcols. =cut *wcols = \&PDL::wcols; sub PDL::wcols { barf 'Usage: wcols($optional_format_string, 1_or_2D_pdls, *HANDLE|"filename", [\%options])' if @_<1; # handle legacy colsep variable $usecolsep = (defined $colsep) ? $colsep : $defcolsep; # if last argument is a reference to a hash, parse the options my ($format_string, $step, $fh); my $header; if ( ref( $_[-1] ) eq "HASH" ) { my $opt = pop; foreach my $key ( sort keys %$opt ) { if ( $key =~ /^H/i ) { $header = $opt->{$key}; } # option: HEADER elsif ( $key =~ /^COLSEP/i ) { $usecolsep = $opt->{$key}; } # option: COLSEP elsif ( $key =~ /^FORMAT/i ) { $format_string = $opt->{$key}; } # option: FORMAT else { print "Warning: wcols does not understand option <$key>.\n"; } } } if (ref(\$_[0]) eq "SCALAR" || $format_string) { $format_string = shift if (ref(\$_[0]) eq "SCALAR"); # 1st arg not ndarray, explicit format string overrides option hash FORMAT $step = $format_string; $step =~ s/(%%|[^%])//g; # use step to count number of format items $step = length ($step); } my $file = $_[-1]; my $file_opened; my $is_handle = !UNIVERSAL::isa($file,'PDL') && !UNIVERSAL::isa($file,'ARRAY') && _is_io_handle $file; if ($is_handle) { # file handle passed directly $fh = $file; pop; } else{ if (ref(\$file) eq "SCALAR") { # Must be a file name $fh = gensym; if (!$is_handle) { $file = ">$file" unless $file =~ /^\|/ or $file =~ /^\>/; open $fh, $file or barf "File $file can not be opened for writing\n"; } pop; $file_opened = 1; } else{ # Not a filehandle or filename, assume something else # (probably ndarray) and send to STDOUT $fh = *STDOUT; } } my @p = @_; my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->dim(0); my @dogp = (); # need to break 2D pdls into a their 1D pdl components for (@p) { if ( ref $_ eq 'ARRAY' ) { barf "wcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n; push @dogp, $_; } else { barf "wcols: 1D args must have same number of elements\n" if $_->dim(0) != $n or $_->getndims > 2; if ( $_->getndims == 2 ) { push @dogp, $_->dog; } else { push @dogp, $_; } } } if ( defined $header ) { $header .= "\n" unless $header =~ m/\n$/; print $fh $header; } my $i; my $pcnt = scalar @dogp; for ($i=0; $i<$n; $i++) { if ($format_string) { my @d; my $pdone = 0; for (@dogp) { push @d,_at_1D($_,$i); $pdone++; if (@d == $step) { printf $fh $format_string,@d; printf $fh $usecolsep unless $pdone==$pcnt; $#d = -1; } } if (@d && !$i) { my $str; if ($#dogp>0) { $str = ($#dogp+1).' columns don\'t'; } else { $str = '1 column doesn\'t'; } $str .= " fit in $step column format ". '(even repeated) -- discarding surplus'; carp $str; # printf $fh $format_string,@d; # printf $fh $usecolsep; } } else { my $pdone = 0; for (@dogp) { $pdone++; print $fh _at_1D($_,$i) . ( ($pdone==$pcnt) ? '' : $usecolsep ); } } print $fh "\n"; } close($fh) if $file_opened; return 1; } =head2 swcols =for ref generate string list from C format specifier and a list of ndarrays C takes an (optional) format specifier of the printf sort and a list of 1D ndarrays as input. It returns a perl array (or array reference if called in scalar context) where each element of the array is the string generated by printing the corresponding element of the ndarray(s) using the format specified. If no format is specified it uses the default print format. =for usage Usage: @str = swcols format, pdl1,pdl2,pdl3,...; or $str = swcols format, pdl1,pdl2,pdl3,...; =cut *swcols = \&PDL::swcols; sub PDL::swcols{ my ($format_string,$step); my @outlist; if (ref(\$_[0]) eq "SCALAR") { $step = $format_string = shift; # 1st arg not ndarray $step =~ s/(%%|[^%])//g; # use step to count number of format items $step = length ($step); } my @p = @_; my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->nelem; for (@p) { if ( ref $_ eq 'ARRAY' ) { barf "swcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n; } else { barf "swcols: 1D args must have same number of elements\n" if $_->nelem != $n or $_->getndims!=1; } } my $i; for ($i=0; $i<$n; $i++) { if ($format_string) { my @d; for (@p) { push @d,_at_1D($_,$i); if (@d == $step) { push @outlist,sprintf $format_string,@d; $#d = -1; } } if (@d && !$i) { my $str; if ($#p>0) { $str = ($#p+1).' columns don\'t'; } else { $str = '1 column doesn\'t'; } $str .= " fit in $step column format ". '(even repeated) -- discarding surplus'; carp $str; # printf $fh $format_string,@d; # printf $fh $usecolsep; } } else { for (@p) { push @outlist,sprintf _at_1D($_,$i),$usecolsep; } } } wantarray ? return @outlist: return \@outlist; } =head2 rgrep =for ref Read columns into ndarrays using full regexp pattern matching. Options: UNDEFINED: This option determines what will be done for undefined values. For instance when reading a comma-separated file of the type C<1,2,,4> where the C<,,> indicates a missing value. The default value is to assign C<$PDL::undefval> to undefined values, but if C is set this is used instead. This would normally be set to a number, but if it is set to C and PDL is compiled with Badvalue support (see L) then undefined values are set to the appropriate badvalue and the column is marked as bad. DEFTYPE: Sets the default type of the columns - see the documentation for L TYPES: A reference to a Perl array with types for each column - see the documentation for L BUFFERSIZE: The number of lines to extend the ndarray by. It might speed up the reading a little bit by setting this to the number of lines in the file, but in general L is a better choice Usage =for usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename") e.g. =for example ($x,$y) = rgrep {/Foo (.*) Bar (.*) Mumble/} $file; i.e. the vectors C<$x> and C<$y> get the progressive values of C<$1>, C<$2> etc. =cut sub rgrep (&@) { barf 'Usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename", [{OPTIONS}])' if $#_ > 2; my (@ret,@v,$nret); my ($m,$n)=(-1,0); # Count/PDL size my $pattern = shift; my $is_handle = _is_io_handle $_[0]; my $fh = $is_handle ? $_[0] : gensym; open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle; if (ref($pattern) ne "CODE") { die "Got a ".ref($pattern)." for rgrep?!"; } # set up default options my $opt = PDL::Options->new( { DEFTYPE => $deftype, TYPES => [], UNDEFINED => $PDL::undefval, BUFFERSIZE => 10000 } ); # Check if the user specified options my $u_opt = $_[1] || {}; $opt->options( $u_opt); my $options = $opt->current(); # If UNDEFINED is set to .*bad.* then undefined are set to # bad - unless we have a Perl that is not compiled with Bad support my $undef_is_bad = ($$options{UNDEFINED} =~ /bad/i); barf "Unknown PDL type given for DEFTYPE.\n" unless ref($$options{DEFTYPE}) eq "PDL::Type"; while(<$fh>) { next unless @v = &$pattern; $m++; # Count got if ($m==0) { $nret = $#v; # Last index of values to return # Handle various columns as in rcols - added 18/04/05 my @types = _handle_types( $nret, $$options{DEFTYPE}, $$options{TYPES} ); for (0..$nret) { # Modified 18/04/05 to use specified precision. $ret[$_] = [ PDL->zeroes($types[$_], 1), [] ]; } } else { # perhaps should only carp once... carp "Non-rectangular rgrep" if $nret != $#v; } if ($n<$m) { for (0..$nret) { _ext_lastD( $ret[$_]->[0], $$options{BUFFERSIZE} ); # Extend PDL in buffered manner } $n += $$options{BUFFERSIZE}; } for(0..$nret) { # Set values - '1*' is to ensure numeric # We now (JB - 18/04/05) also check for defined values or not # Ideally this should include Badvalue support.. if ($v[$_] eq '') { # Missing value - let us treat this specially if ($undef_is_bad) { set $ret[$_]->[0], $m, $$options{DEFTYPE}->badvalue(); # And set bad flag on $ref[$_]! $ret[$_]->[0]->badflag(1); } else { set $ret[$_]->[0], $m, $$options{UNDEFINED}; } } else { set $ret[$_]->[0], $m, 1*$v[$_]; } } } close($fh) unless $is_handle; for (@ret) { $_ = $_->[0]->slice("0:$m")->copy; }; # Truncate wantarray ? return(@ret) : return $ret[0]; } =head2 isbigendian =for ref Determine endianness of machine - returns 0 or 1 accordingly =cut #line 1141 "lib/PDL/IO/Misc.pd" sub PDL::isbigendian { return 0; }; *isbigendian = \&PDL::isbigendian; #line 1147 "lib/PDL/IO/Misc.pd" =head2 rcube =for ref Read list of files directly into a large data cube (for efficiency) =for usage $cube = rcube \&reader_function, @files; =for example $cube = rcube \&rfits, glob("*.fits"); This IO function allows direct reading of files into a large data cube, Obviously one could use cat() but this is more memory efficient. The reading function (e.g. rfits, readfraw) (passed as a reference) and files are the arguments. The cube is created as the same X,Y dims and datatype as the first image specified. The Z dim is simply the number of images. =cut sub rcube { my $reader = shift; barf "Usage: blah" unless ref($reader) eq "CODE"; my $k=0; my ($im,$cube,$nx,$ny); my $nz = scalar(@_); for my $file (@_) { print "Slice ($k) - reading file $file...\n" if $PDL::verbose; $im = &$reader($file); ($nx, $ny) = dims $im; if ($k == 0) { print "Creating $nx x $ny x $nz cube...\n" if $PDL::verbose; $cube = $im->zeroes($im->type,$nx,$ny,$nz); } else { barf "Dimensions do not match for file $file!\n" if $im->getdim(0) != $nx or $im->getdim(1) != $ny ; } $cube->slice(":,:,($k)") .= $im; $k++; } return $cube; } #line 1433 "lib/PDL/IO/Misc.pm" =head2 rasc =for sig Signature: ([o] nums(n); int [o] ierr(n); PerlIO *fp; IV num => n) Types: (float double) =for ref Simple function to slurp in ASCII numbers quite quickly, although error handling is marginal (to nonexistent). =for usage $pdl->rasc("filename"|FILEHANDLE [,$noElements]); Where: filename is the name of the ASCII file to read or open file handle $noElements is the optional number of elements in the file to read. (If not present, all of the file will be read to fill up $pdl). $pdl can be of type float or double (for more precision). =for example # (test.num is an ascii file with 20 numbers. One number per line.) $in = PDL->null; $num = 20; $in->rasc('test.num',20); $imm = zeroes(float,20,2); $imm->rasc('test.num'); =pod Broadcasts over its inputs. =for bad C 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 sub rasc {PDL->rasc(@_)} sub PDL::rasc { my ($pdl, $file, $num) = @_; $num = -1 unless defined $num; my $is_openhandle = defined fileno $file; my $fi; if ($is_openhandle) { $fi = $file; } else { barf 'usage: rasc $pdl, "filename"|FILEHANDLE, [$num_to_read]' if !defined $file || ref $file; open $fi, "<", $file or barf "Can't open $file"; } $pdl->_rasc_int(my $ierr=null,$fi,$num); close $fi unless $is_openhandle; return all $ierr > 0; } #line 27 "lib/PDL/IO/Misc.pd" =head1 AUTHOR Copyright (C) Karl Glazebrook 1997, Craig DeForest 2001, 2003, and Chris Marshall 2010. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut #line 1521 "lib/PDL/IO/Misc.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/Primitive.pm0000644000175000017500000040224514771136065016325 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Primitive.pd! Don't modify! # package PDL::Primitive; our @EXPORT_OK = qw(inner outer matmult innerwt inner2 inner2d inner2t crossp norm indadd conv1d in uniq uniqind uniqvec hclip lclip clip wtstat statsover stats histogram whistogram histogram2d whistogram2d fibonacci append axisvalues cmpvec eqvec enumvec enumvecg vsearchvec unionvec intersectvec setdiffvec union_sorted intersect_sorted setdiff_sorted vcos srandom random randsym grandom vsearch vsearch_sample vsearch_insert_leftmost vsearch_insert_rightmost vsearch_match vsearch_bin_inclusive vsearch_bin_exclusive interpolate interpol interpND one2nd which which_both whichover approx_artol where where_both whereND whereND_both whichND whichND_both setops intersect pchip_chim pchip_chic pchip_chsp pchip_chfd pchip_chfe pchip_chia pchip_chid pchip_chbs pchip_bvalu ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Primitive ; { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload 'x' => $overload_sub = sub { Carp::confess("PDL::matmult: overloaded 'x' given undef") if grep !defined, @_[0,1]; return PDL::matmult(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], 'x')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 36 "lib/PDL/Primitive.pm" } #line 12 "lib/PDL/Primitive.pd" use strict; use warnings; use PDL::Slices; use Carp; =head1 NAME PDL::Primitive - primitive operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP and able to use the new indexing tricks. See L for how to use indices creatively. For explanation of the signature format, see L. =head1 SYNOPSIS # Pulls in PDL::Primitive, among other modules. use PDL; # Only pull in PDL::Primitive: use PDL::Primitive; =cut #line 73 "lib/PDL/Primitive.pm" =head1 FUNCTIONS =cut =head2 inner =for sig Signature: (a(n); b(n); [o]c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = inner($a, $b); inner($a, $b, $c); # all arguments given $c = $a->inner($b); # method call $a->inner($b, $c); =for ref Inner product over one dimension c = sum_i a_i * b_i See also L, L. =pod Broadcasts over its inputs. =for bad If C contains only bad data, C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *inner = \&PDL::inner; =head2 outer =for sig Signature: (a(n); b(m); [o]c(n,m)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = outer($a, $b); outer($a, $b, $c); # all arguments given $c = $a->outer($b); # method call $a->outer($b, $c); =for ref outer product over one dimension Naturally, it is possible to achieve the effects of outer product simply by broadcasting over the "C<*>" operator but this function is provided for convenience. =pod Broadcasts over its inputs. =for bad C 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 *outer = \&PDL::outer; #line 98 "lib/PDL/Primitive.pd" =head2 x =for sig Signature: (a(i,z), b(x,i),[o]c(x,z)) =for ref Matrix multiplication PDL overloads the C operator (normally the repeat operator) for matrix multiplication. The number of columns (size of the 0 dimension) in the left-hand argument must normally equal the number of rows (size of the 1 dimension) in the right-hand argument. Row vectors are represented as (N x 1) two-dimensional PDLs, or you may be sloppy and use a one-dimensional PDL. Column vectors are represented as (1 x N) two-dimensional PDLs. Broadcasting occurs in the usual way, but as both the 0 and 1 dimension (if present) are included in the operation, you must be sure that you don't try to broadcast over either of those dims. Of note, due to how Perl v5.14.0 and above implement operator overloading of the C operator, the use of parentheses for the left operand creates a list context, that is pdl> ( $x * $y ) x $z ERROR: Argument "..." isn't numeric in repeat (x) ... treats C<$z> as a numeric count for the list repeat operation and does not call the scalar form of the overloaded operator. To use the operator in this case, use a scalar context: pdl> scalar( $x * $y ) x $z or by calling L directly: pdl> ( $x * $y )->matmult( $z ) EXAMPLES Here are some simple ways to define vectors and matrices: pdl> $r = pdl(1,2); # A row vector pdl> $c = pdl([[3],[4]]); # A column vector pdl> $c = pdl(3,4)->(*1); # A column vector, using NiceSlice pdl> $m = pdl([[1,2],[3,4]]); # A 2x2 matrix Now that we have a few objects prepared, here is how to matrix-multiply them: pdl> print $r x $m # row x matrix = row [ [ 7 10] ] pdl> print $m x $r # matrix x row = ERROR PDL: Dim mismatch in matmult of [2x2] x [2x1]: 2 != 1 pdl> print $m x $c # matrix x column = column [ [ 5] [11] ] pdl> print $m x 2 # Trivial case: scalar mult. [ [2 4] [6 8] ] pdl> print $r x $c # row x column = scalar [ [11] ] pdl> print $c x $r # column x row = matrix [ [3 6] [4 8] ] INTERNALS The mechanics of the multiplication are carried out by the L method. =cut #line 264 "lib/PDL/Primitive.pm" =head2 matmult =for sig Signature: (a(t,h); b(w,t); [o]c(w,h)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = x $a, $b; # overloads the Perl 'x' operator $c = matmult($a, $b); matmult($a, $b, $c); # all arguments given $c = $a->matmult($b); # method call $a->matmult($b, $c); =for ref Matrix multiplication Notionally, matrix multiplication $x x $y is equivalent to the broadcasting expression $x->dummy(1)->inner($y->xchg(0,1)->dummy(2),$c); but for large matrices that breaks CPU cache and is slow. Instead, matmult calculates its result in 32x32x32 tiles, to keep the memory footprint within cache as long as possible on most modern CPUs. For usage, see L, a description of the overloaded 'x' operator =pod Broadcasts over its inputs. =for bad C 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 197 "lib/PDL/Primitive.pd" sub PDL::matmult { my ($x,$y,$c) = @_; $y = PDL->topdl($y); $c = PDL->null if !UNIVERSAL::isa($c, 'PDL'); while($x->getndims < 2) {$x = $x->dummy(-1)} while($y->getndims < 2) {$y = $y->dummy(-1)} return ($c .= $x * $y) if( ($x->dim(0)==1 && $x->dim(1)==1) || ($y->dim(0)==1 && $y->dim(1)==1) ); barf sprintf 'Dim mismatch in matmult of [%1$dx%2$d] x [%3$dx%4$d]: %1$d != %4$d',$x->dim(0),$x->dim(1),$y->dim(0),$y->dim(1) if $y->dim(1) != $x->dim(0); PDL::_matmult_int($x,$y,$c); $c; } #line 327 "lib/PDL/Primitive.pm" *matmult = \&PDL::matmult; =head2 innerwt =for sig Signature: (a(n); b(n); c(n); [o]d()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $d = innerwt($a, $b, $c); innerwt($a, $b, $c, $d); # all arguments given $d = $a->innerwt($b, $c); # method call $a->innerwt($b, $c, $d); =for ref Weighted (i.e. triple) inner product d = sum_i a(i) b(i) c(i) =pod Broadcasts over its inputs. =for bad C 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 *innerwt = \&PDL::innerwt; =head2 inner2 =for sig Signature: (a(n); b(n,m); c(m); [o]d()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $d = inner2($a, $b, $c); inner2($a, $b, $c, $d); # all arguments given $d = $a->inner2($b, $c); # method call $a->inner2($b, $c, $d); =for ref Inner product of two vectors and a matrix d = sum_ij a(i) b(i,j) c(j) Note that you should probably not broadcast over C and C since that would be very wasteful. Instead, you should use a temporary for C. =pod Broadcasts over its inputs. =for bad C 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 *inner2 = \&PDL::inner2; =head2 inner2d =for sig Signature: (a(n,m); b(n,m); [o]c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = inner2d($a, $b); inner2d($a, $b, $c); # all arguments given $c = $a->inner2d($b); # method call $a->inner2d($b, $c); =for ref Inner product over 2 dimensions. Equivalent to $c = inner($x->clump(2), $y->clump(2)) =pod Broadcasts over its inputs. =for bad C 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 *inner2d = \&PDL::inner2d; =head2 inner2t =for sig Signature: (a(j,n); b(n,m); c(m,k); [t]tmp(n,k); [o]d(j,k)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $d = inner2t($a, $b, $c); inner2t($a, $b, $c, $d); # all arguments given $d = $a->inner2t($b, $c); # method call $a->inner2t($b, $c, $d); =for ref Efficient Triple matrix product C Efficiency comes from by using the temporary C. This operation only scales as C whereas broadcasting using L would scale as C. The reason for having this routine is that you do not need to have the same broadcast-dimensions for C as for the other arguments, which in case of large numbers of matrices makes this much more memory-efficient. It is hoped that things like this could be taken care of as a kind of closure at some point. =pod Broadcasts over its inputs. =for bad C 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 *inner2t = \&PDL::inner2t; =head2 crossp =for sig Signature: (a(tri=3); b(tri); [o] c(tri)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = crossp($a, $b); crossp($a, $b, $c); # all arguments given $c = $a->crossp($b); # method call $a->crossp($b, $c); =for ref Cross product of two 3D vectors After =for example $c = crossp $x, $y the inner product C<$c*$x> and C<$c*$y> will be zero, i.e. C<$c> is orthogonal to C<$x> and C<$y> =pod Broadcasts over its inputs. =for bad C 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 *crossp = \&PDL::crossp; =head2 norm =for sig Signature: (vec(n); [o] norm(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $norm = norm($vec); norm($vec, $norm); # all arguments given $norm = $vec->norm; # method call $vec->norm($norm); Normalises a vector to unit Euclidean length See also L, L. =pod Broadcasts over its inputs. =for bad C 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 *norm = \&PDL::norm; =head2 indadd =for sig Signature: (input(n); indx ind(n); [io] sum(m)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage indadd($input, $ind, $sum); # all arguments given $input->indadd($ind, $sum); # method call =for ref Broadcasting index add: add C to the C element of C, i.e: sum(ind) += input =for example Simple example: $x = 2; $ind = 3; $sum = zeroes(10); indadd($x,$ind, $sum); print $sum #Result: ( 2 added to element 3 of $sum) # [0 0 0 2 0 0 0 0 0 0] Broadcasting example: $x = pdl( 1,2,3); $ind = pdl( 1,4,6); $sum = zeroes(10); indadd($x,$ind, $sum); print $sum."\n"; #Result: ( 1, 2, and 3 added to elements 1,4,6 $sum) # [0 1 0 0 2 0 3 0 0 0] =pod Broadcasts over its inputs. =for bad The routine barfs on bad indices, and bad inputs set target outputs bad. =cut *indadd = \&PDL::indadd; =head2 conv1d =for sig Signature: (a(m); kern(p); [o]b(m); int reflect) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = conv1d($a, $kern, $reflect); conv1d($a, $kern, $b, $reflect); # all arguments given $b = $a->conv1d($kern, $reflect); # method call $a->conv1d($kern, $b, $reflect); =for ref 1D convolution along first dimension The m-th element of the discrete convolution of an input ndarray C<$a> of size C<$M>, and a kernel ndarray C<$kern> of size C<$P>, is calculated as n = ($P-1)/2 ==== \ ($a conv1d $kern)[m] = > $a_ext[m - n] * $kern[n] / ==== n = -($P-1)/2 where C<$a_ext> is either the periodic (or reflected) extension of C<$a> so it is equal to C<$a> on C< 0..$M-1 > and equal to the corresponding periodic/reflected image of C<$a> outside that range. =for example $con = conv1d sequence(10), pdl(-1,0,1); $con = conv1d sequence(10), pdl(-1,0,1), {Boundary => 'reflect'}; By default, periodic boundary conditions are assumed (i.e. wrap around). Alternatively, you can request reflective boundary conditions using the C option: {Boundary => 'reflect'} # case in 'reflect' doesn't matter The convolution is performed along the first dimension. To apply it across another dimension use the slicing routines, e.g. $y = $x->mv(2,0)->conv1d($kernel)->mv(0,2); # along third dim This function is useful for broadcasted filtering of 1D signals. Compare also L, L, L =for bad WARNING: C processes bad values in its inputs as the numeric value of C<< $pdl->badvalue >> so it is not recommended for processing pdls with bad values in them unless special care is taken. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 568 "lib/PDL/Primitive.pd" sub PDL::conv1d { my $opt = pop @_ if ref($_[-1]) eq 'HASH'; die 'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )' if @_<2 || @_>3; my($x,$kern) = @_; my $c = @_ == 3 ? $_[2] : PDL->null; PDL::_conv1d_int($x,$kern,$c, !(defined $opt && exists $$opt{Boundary}) ? 0 : lc $$opt{Boundary} eq "reflect"); return $c; } #line 760 "lib/PDL/Primitive.pm" *conv1d = \&PDL::conv1d; =head2 in =for sig Signature: (a(); b(n); [o] c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = in($a, $b); in($a, $b, $c); # all arguments given $c = $a->in($b); # method call $a->in($b, $c); =for ref test if a is in the set of values b =for example $goodmsk = $labels->in($goodlabels); print pdl(3,1,4,6,2)->in(pdl(2,3,3)); [1 0 0 0 1] C is akin to the I of set theory. In principle, PDL broadcasting could be used to achieve its functionality by using a construct like $msk = ($labels->dummy(0) == $goodlabels)->orover; However, C doesn't create a (potentially large) intermediate and is generally faster. =pod Broadcasts over its inputs. =for bad C 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 *in = \&PDL::in; #line 636 "lib/PDL/Primitive.pd" =head2 uniq =for ref return all unique elements of an ndarray The unique elements are returned in ascending order. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniq [-1 0 2 4 6] # 0 is returned 2nd (sorted order) PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniq [-1 2 4 6 nan] # NaN value is returned at end Note: The returned pdl is 1D; any structure of the input ndarray is lost. C values are never compare equal to any other values, even themselves. As a result, they are always unique. C returns the NaN values at the end of the result ndarray. This follows the Matlab usage. See L if you need the indices of the unique elements rather than the values. =for bad Bad values are not considered unique by uniq and are ignored. $x=sequence(10); $x=$x->setbadif($x%3); print $x->uniq; [0 3 6 9] =cut *uniq = \&PDL::uniq; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniq { my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) return $arr->flat if($arr->nelem == 1); # singleton list is unique my $aflat = $arr->flat; my $srt = $aflat->where($aflat==$aflat)->qsort; # no NaNs or BADs for qsort 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 ( $uniq->nelem > 0 ? $uniq : $srt->nelem == 0 ? $srt : PDL::pdl( ref($srt), [$srt->index(0)] ) )->append($nans); } #line 695 "lib/PDL/Primitive.pd" =head2 uniqind =for ref Return the indices of all unique elements of an ndarray The order is in the order of the values to be consistent with uniq. C values never compare equal with any other value and so are always unique. This follows the Matlab usage. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniqind [5 4 1 3 6] # the 0 at index 4 is returned 2nd, but... PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniqind [5 1 3 6 4] # ...the NaN at index 4 is returned at end Note: The returned pdl is 1D; any structure of the input ndarray is lost. See L if you want the unique values instead of the indices. =for bad Bad values are not considered unique by uniqind and are ignored. =cut *uniqind = \&PDL::uniqind; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniqind { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) # Different from uniq we sort and store the result in an intermediary my $aflat = $arr->flat; my $nanind = which($aflat!=$aflat); # NaN indexes my $good = PDL->sequence(indx, $aflat->dims)->where($aflat==$aflat); # good indexes my $i_srt = $aflat->where($aflat==$aflat)->qsorti; # no BAD or NaN values for qsorti my $srt = $aflat->where($aflat==$aflat)->index($i_srt); my $uniqind; if ($srt->nelem > 0) { $uniqind = which($srt != $srt->rotate(-1)); $uniqind = $i_srt->slice('0') if $uniqind->isempty; } else { $uniqind = which($srt); } # Now map back to the original space my $ansind = $nanind; if ( $uniqind->nelem > 0 ) { $ansind = ($good->index($i_srt->index($uniqind)))->append($ansind); } else { $ansind = $uniqind->append($ansind); } return $ansind; } #line 761 "lib/PDL/Primitive.pd" =head2 uniqvec =for ref Return all unique vectors out of a collection NOTE: If any vectors in the input ndarray have NaN values they are returned at the end of the non-NaN ones. This is because, by definition, NaN values never compare equal with any other value. NOTE: The current implementation does not sort the vectors containing NaN values. The unique vectors are returned in lexicographically sorted ascending order. The 0th dimension of the input PDL is treated as a dimensional index within each vector, and the 1st and any higher dimensions are taken to run across vectors. The return value is always 2D; any structure of the input PDL (beyond using the 0th dimension for vector index) is lost. See also L for a unique list of scalars; and L for sorting a list of vectors lexicographcally. =for bad If a vector contains all bad values, it is ignored as in L. If some of the values are good, it is treated as a normal vector. For example, [1 2 BAD] and [BAD 2 3] could be returned, but [BAD BAD BAD] could not. Vectors containing BAD values will be returned after any non-NaN and non-BAD containing vectors, followed by the NaN vectors. =cut sub PDL::uniqvec { my($pdl) = shift; return $pdl if ( $pdl->nelem == 0 || $pdl->ndims < 2 ); return $pdl if ( $pdl->slice("(0)")->nelem < 2 ); # slice isn't cheap but uniqvec isn't either my $pdl2d = $pdl->clump(1..$pdl->ndims-1); my $ngood = $pdl2d->ngoodover; $pdl2d = $pdl2d->mv(0,-1)->dice($ngood->which)->mv(-1,0); # remove all-BAD vectors my $numnan = ($pdl2d!=$pdl2d)->sumover; # works since no all-BADs to confuse my $presrt = $pdl2d->mv(0,-1)->dice($numnan->not->which)->mv(0,-1); # remove vectors with any NaN values my $nanvec = $pdl2d->mv(0,-1)->dice($numnan->which)->mv(0,-1); # the vectors with any NaN values my $srt = $presrt->qsortvec->mv(0,-1); # BADs are sorted by qsortvec my $srtdice = $srt; my $somebad = null; if ($srt->badflag) { $srtdice = $srt->dice($srt->mv(0,-1)->nbadover->not->which); $somebad = $srt->dice($srt->mv(0,-1)->nbadover->which); } my $uniq = $srtdice->nelem > 0 ? ($srtdice != $srtdice->rotate(-1))->mv(0,-1)->orover->which : $srtdice->orover->which; my $ans = $uniq->nelem > 0 ? $srtdice->dice($uniq) : ($srtdice->nelem > 0) ? $srtdice->slice("0,:") : $srtdice; return $ans->append($somebad)->append($nanvec->mv(0,-1))->mv(0,-1); } #line 1013 "lib/PDL/Primitive.pm" =head2 hclip =for sig Signature: (a(); b(); [o] c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = hclip($a, $b); hclip($a, $b, $c); # all arguments given $c = $a->hclip($b); # method call $a->hclip($b, $c); =for ref clip (threshold) C<$a> by C<$b> (C<$b> is upper bound) =pod Broadcasts over its inputs. =for bad C 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 856 "lib/PDL/Primitive.pd" sub PDL::hclip { my ($x,$y) = @_; my $c; if ($x->is_inplace) { $x->set_inplace(0); $c = $x; } elsif (@_ > 2) {$c=$_[2]} else {$c=PDL->nullcreate($x)} PDL::_hclip_int($x,$y,$c); return $c; } #line 1060 "lib/PDL/Primitive.pm" *hclip = \&PDL::hclip; =head2 lclip =for sig Signature: (a(); b(); [o] c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = lclip($a, $b); lclip($a, $b, $c); # all arguments given $c = $a->lclip($b); # method call $a->lclip($b, $c); =for ref clip (threshold) C<$a> by C<$b> (C<$b> is lower bound) =pod Broadcasts over its inputs. =for bad C 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 856 "lib/PDL/Primitive.pd" sub PDL::lclip { my ($x,$y) = @_; my $c; if ($x->is_inplace) { $x->set_inplace(0); $c = $x; } elsif (@_ > 2) {$c=$_[2]} else {$c=PDL->nullcreate($x)} PDL::_lclip_int($x,$y,$c); return $c; } #line 1113 "lib/PDL/Primitive.pm" *lclip = \&PDL::lclip; =head2 clip =for sig Signature: (a(); l(); h(); [o] c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref Clip (threshold) an ndarray by (optional) upper or lower bounds. =for usage $y = $x->clip(0,3); $c = $x->clip(undef, $x); =pod Broadcasts over its inputs. =for bad C 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 892 "lib/PDL/Primitive.pd" *clip = \&PDL::clip; sub PDL::clip { my($x, $l, $h) = @_; my $d; unless(defined($l) || defined($h)) { # Deal with pathological case if($x->is_inplace) { $x->set_inplace(0); return $x; } else { return $x->copy; } } if($x->is_inplace) { $x->set_inplace(0); $d = $x } elsif (@_ > 3) { $d=$_[3] } else { $d = PDL->nullcreate($x); } if(defined($l) && defined($h)) { PDL::_clip_int($x,$l,$h,$d); } elsif( defined($l) ) { PDL::_lclip_int($x,$l,$d); } elsif( defined($h) ) { PDL::_hclip_int($x,$h,$d); } else { die "This can't happen (clip contingency) - file a bug"; } return $d; } #line 1188 "lib/PDL/Primitive.pm" *clip = \&PDL::clip; =head2 wtstat =for sig Signature: (a(n); wt(n); avg(); [o]b(); int deg) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = wtstat($a, $wt, $avg, $deg); wtstat($a, $wt, $avg, $b, $deg); # all arguments given $b = $a->wtstat($wt, $avg, $deg); # method call $a->wtstat($wt, $avg, $b, $deg); =for ref Weighted statistical moment of given degree This calculates a weighted statistic over the vector C. The formula is b() = (sum_i wt_i * (a_i ** degree - avg)) / (sum_i wt_i) =pod Broadcasts over its inputs. =for bad Bad values are ignored in any calculation; C<$b> will only have its bad flag set if the output contains any bad data. =cut *wtstat = \&PDL::wtstat; =head2 statsover =for sig Signature: (a(n); w(n); float+ [o]avg(); float+ [o]prms(); int+ [o]min(); int+ [o]max(); float+ [o]adev(); float+ [o]rms()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref Calculate useful statistics over a dimension of an ndarray =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = statsover($ndarray, $weights); This utility function calculates various useful quantities of an ndarray. These are: =over 3 =item * the mean: MEAN = sum (x)/ N with C being the number of elements in x =item * the population RMS deviation from the mean: PRMS = sqrt( sum( (x-mean(x))^2 )/(N-1) ) The population deviation is the best-estimate of the deviation of the population from which a sample is drawn. =item * the median The median is the 50th percentile data value. Median is found by L, so WEIGHTING IS IGNORED FOR THE MEDIAN CALCULATION. =item * the minimum =item * the maximum =item * the average absolute deviation: AADEV = sum( abs(x-mean(x)) )/N =item * RMS deviation from the mean: RMS = sqrt(sum( (x-mean(x))^2 )/N) (also known as the root-mean-square deviation, or the square root of the variance) =back This operator is a projection operator so the calculation will take place over the final dimension. Thus if the input is N-dimensional each returned value will be N-1 dimensional, to calculate the statistics for the entire ndarray either use C directly on the ndarray or call C. =pod Broadcasts over its inputs. =for bad Bad values are simply ignored in the calculation, effectively reducing the sample size. If all data are bad then the output data are marked bad. =cut #line 1018 "lib/PDL/Primitive.pd" sub PDL::statsover { barf('Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($data,[$weights])') if @_>2; my ($data, $weights) = @_; $weights //= $data->ones(); my $median = $data->medover; my $mean = PDL->nullcreate($data); my $rms = PDL->nullcreate($data); my $min = PDL->nullcreate($data); my $max = PDL->nullcreate($data); my $adev = PDL->nullcreate($data); my $prms = PDL->nullcreate($data); PDL::_statsover_int($data, $weights, $mean, $prms, $min, $max, $adev, $rms); wantarray ? ($mean, $prms, $median, $min, $max, $adev, $rms) : $mean; } #line 1334 "lib/PDL/Primitive.pm" *statsover = \&PDL::statsover; #line 1095 "lib/PDL/Primitive.pd" =head2 stats =for ref Calculates useful statistics on an ndarray =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = stats($ndarray,[$weights]); This utility calculates all the most useful quantities in one call. It works the same way as L, except that the quantities are calculated considering the entire input PDL as a single sample, rather than as a collection of rows. See L for definitions of the returned quantities. =for bad Bad values are handled; if all input values are bad, then all of the output values are flagged bad. =cut *stats = \&PDL::stats; sub PDL::stats { barf('Usage: ($mean,[$rms]) = stats($data,[$weights])') if @_>2; my ($data,$weights) = @_; # Ensure that $weights is properly broadcasted over; this could be # done rather more efficiently... if(defined $weights) { $weights = pdl($weights) unless UNIVERSAL::isa($weights,'PDL'); if( ($weights->ndims != $data->ndims) or (pdl($weights->dims) != pdl($data->dims))->or ) { $weights = $weights + zeroes($data) } $weights = $weights->flat; } return PDL::statsover($data->flat,$weights); } #line 1386 "lib/PDL/Primitive.pm" =head2 histogram =for sig Signature: (in(n); int+[o] hist(m); double step; double min; IV msize => m) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for ref Calculates a histogram for given stepsize and minimum. =for usage $h = histogram($data, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing ndarray. histogram($data, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the number of values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different broadcastloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. For a higher-level interface, see L. =for example pdl> p histogram(pdl(1,1,2),1,0,3) [0 2 1] =pod Broadcasts over its inputs. =for bad C 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 *histogram = \&PDL::histogram; =head2 whistogram =for sig Signature: (in(n); float+ wt(n);float+[o] hist(m); double step; double min; IV msize => m) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for ref Calculates a histogram from weighted data for given stepsize and minimum. =for usage $h = whistogram($data, $weights, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing ndarray. whistogram($data, $weights, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different broadcastloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. =for example pdl> p whistogram(pdl(1,1,2), pdl(0.1,0.1,0.5), 1, 0, 4) [0 0.2 0.5 0] =pod Broadcasts over its inputs. =for bad C 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 *whistogram = \&PDL::whistogram; =head2 histogram2d =for sig Signature: (ina(n); inb(n); int+[o] hist(ma,mb); double stepa; double mina; IV masize => ma; double stepb; double minb; IV mbsize => mb;) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for ref Calculates a 2d histogram. =for usage $h = histogram2d($datax, $datay, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing ndarray. histogram2d($datax, $datay, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the number of values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p histogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),1,0,3,1,0,3) [ [0 0 0] [0 2 2] [0 1 0] ] =pod Broadcasts over its inputs. =for bad C 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 *histogram2d = \&PDL::histogram2d; =head2 whistogram2d =for sig Signature: (ina(n); inb(n); float+ wt(n);float+[o] hist(ma,mb); double stepa; double mina; IV masize => ma; double stepb; double minb; IV mbsize => mb;) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for ref Calculates a 2d histogram from weighted data. =for usage $h = whistogram2d($datax, $datay, $weights, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing ndarray. whistogram2d($datax, $datay, $weights, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p whistogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),pdl(0.1,0.2,0.3,0.4,0.5),1,0,3,1,0,3) [ [ 0 0 0] [ 0 0.5 0.9] [ 0 0.1 0] ] =pod Broadcasts over its inputs. =for bad C 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 *whistogram2d = \&PDL::whistogram2d; =head2 fibonacci =for sig Signature: (i(n); [o]x(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $x = fibonacci($i); fibonacci($i, $x); # all arguments given $x = $i->fibonacci; # method call $i->fibonacci($x); $i->inplace->fibonacci; # can be used inplace fibonacci($i->inplace); =for ref Constructor - a vector with Fibonacci's sequence =pod Broadcasts over its inputs. =for bad C 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 1363 "lib/PDL/Primitive.pd" sub fibonacci { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->fibonacci : PDL->fibonacci(@_) } sub PDL::fibonacci{ my $x = &PDL::Core::_construct; my $is_inplace = $x->is_inplace; my ($in, $out) = $x->flat; $out = $is_inplace ? $in->inplace : PDL->null; PDL::_fibonacci_int($in, $out); $out; } #line 1667 "lib/PDL/Primitive.pm" =head2 append =for sig Signature: (a(n); b(m); [o] c(mn=CALC($SIZE(n)+$SIZE(m)))) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = append($a, $b); append($a, $b, $c); # all arguments given $c = $a->append($b); # method call $a->append($b, $c); =for ref append two ndarrays by concatenating along their first dimensions =for example $x = ones(2,4,7); $y = sequence 5; $c = $x->append($y); # size of $c is now (7,4,7) (a jumbo-ndarray ;) C appends two ndarrays along their first dimensions. The rest of the dimensions must be compatible in the broadcasting sense. The resulting size of the first dimension is the sum of the sizes of the first dimensions of the two argument ndarrays - i.e. C. Similar functions include L (below), which can append more than two ndarrays along an arbitrary dimension, and L, which can append more than two ndarrays that all have the same sized dimensions. =pod Broadcasts over its inputs. =for bad C 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 1389 "lib/PDL/Primitive.pd" sub PDL::append { my ($i1, $i2, $o) = map PDL->topdl($_), @_; $_ = empty() for grep $_->isnull, $i1, $i2; my $nempty = grep $_->isempty, $i1, $i2; if ($nempty == 2) { my @dims = $i1->dims; $dims[0] += $i2->dim(0); return PDL->zeroes($i1->type, @dims); } $o //= PDL->null; $o .= $i1->isempty ? $i2 : $i1, return $o if $nempty == 1; PDL::_append_int($i1, $i2->convert($i1->type), $o); $o; } #line 1737 "lib/PDL/Primitive.pm" *append = \&PDL::append; #line 1433 "lib/PDL/Primitive.pd" =head2 glue =for usage $c = $x->glue(,$y,...) =for ref Glue two or more PDLs together along an arbitrary dimension (N-D L). Sticks $x, $y, and all following arguments together along the specified dimension. All other dimensions must be compatible in the broadcasting sense. Glue is permissive, in the sense that every PDL is treated as having an infinite number of trivial dimensions of order 1 -- so C<< $x->glue(3,$y) >> works, even if $x and $y are only one dimensional. If one of the PDLs has no elements, it is ignored. Likewise, if one of them is actually the undefined value, it is treated as if it had no elements. If the first parameter is a defined perl scalar rather than a pdl, then it is taken as a dimension along which to glue everything else, so you can say C<$cube = PDL::glue(3,@image_list);> if you like. C is implemented in pdl, using a combination of L and L. It should probably be updated (one day) to a pure PP function. Similar functions include L (above), which appends only two ndarrays along their first dimension, and L, which can append more than two ndarrays that all have the same sized dimensions. =cut sub PDL::glue{ my($x) = shift; my($dim) = shift; ($dim, $x) = ($x, $dim) if defined $x && !ref $x; confess 'dimension must be Perl scalar' if ref $dim; if(!defined $x || $x->nelem==0) { return $x unless(@_); return shift() if(@_<=1); $x=shift; return PDL::glue($x,$dim,@_); } if($dim - $x->dim(0) > 100) { print STDERR "warning:: PDL::glue allocating >100 dimensions!\n"; } while($dim >= $x->ndims) { $x = $x->dummy(-1,1); } $x = $x->xchg(0,$dim) if 0 != $dim; while(scalar(@_)){ my $y = shift; next unless(defined $y && $y->nelem); while($dim >= $y->ndims) { $y = $y->dummy(-1,1); } $y = $y->xchg(0,$dim) if 0 != $dim; $x = $x->append($y); } 0 == $dim ? $x : $x->xchg(0,$dim); } #line 1819 "lib/PDL/Primitive.pm" *axisvalues = \&PDL::axisvalues; =head2 cmpvec =for sig Signature: (a(n); b(n); sbyte [o]c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = cmpvec($a, $b); cmpvec($a, $b, $c); # all arguments given $c = $a->cmpvec($b); # method call $a->cmpvec($b, $c); =for ref Compare two vectors lexicographically. Returns -1 if a is less, 1 if greater, 0 if equal. =pod Broadcasts over its inputs. =for bad The output is bad if any input values up to the point of inequality are bad - any after are ignored. =cut *cmpvec = \&PDL::cmpvec; =head2 eqvec =for sig Signature: (a(n); b(n); sbyte [o]c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = eqvec($a, $b); eqvec($a, $b, $c); # all arguments given $c = $a->eqvec($b); # method call $a->eqvec($b, $c); =for ref Compare two vectors, returning 1 if equal, 0 if not equal. =pod Broadcasts over its inputs. =for bad The output is bad if any input values are bad. =cut *eqvec = \&PDL::eqvec; =head2 enumvec =for sig Signature: (v(M,N); indx [o]k(N)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $k = enumvec($v); enumvec($v, $k); # all arguments given $k = $v->enumvec; # method call $v->enumvec($k); =for ref Enumerate a list of vectors with locally unique keys. Given a sorted list of vectors $v, generate a vector $k containing locally unique keys for the elements of $v (where an "element" is a vector of length $M occurring in $v). Note that the keys returned in $k are only unique over a run of a single vector in $v, so that each unique vector in $v has at least one 0 (zero) index in $k associated with it. If you need global keys, see enumvecg(). Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 *enumvec = \&PDL::enumvec; =head2 enumvecg =for sig Signature: (v(M,N); indx [o]k(N)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $k = enumvecg($v); enumvecg($v, $k); # all arguments given $k = $v->enumvecg; # method call $v->enumvecg($k); =for ref Enumerate a list of vectors with globally unique keys. Given a sorted list of vectors $v, generate a vector $k containing globally unique keys for the elements of $v (where an "element" is a vector of length $M occurring in $v). Basically does the same thing as: $k = $v->vsearchvec($v->uniqvec); ... but somewhat more efficiently. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 *enumvecg = \&PDL::enumvecg; =head2 vsearchvec =for sig Signature: (find(M); which(M,N); indx [o]found()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $found = vsearchvec($find, $which); vsearchvec($find, $which, $found); # all arguments given $found = $find->vsearchvec($which); # method call $find->vsearchvec($which, $found); =for ref Routine for searching N-dimensional values - akin to vsearch() for vectors. =for example $found = vsearchvec($find, $which); $nearest = $which->dice_axis(1,$found); Returns for each row-vector in C<$find> the index along dimension N of the least row vector of C<$which> greater or equal to it. C<$which> should be sorted in increasing order. If the value of C<$find> is larger than any member of C<$which>, the index to the last element of C<$which> is returned. See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 *vsearchvec = \&PDL::vsearchvec; =head2 unionvec =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC=CALC($SIZE(NA) + $SIZE(NB))); indx [o]nc()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($c, $nc) = unionvec($a, $b); unionvec($a, $b, $c, $nc); # all arguments given ($c, $nc) = $a->unionvec($b); # method call $a->unionvec($b, $c, $nc); =for ref Union of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the union. In scalar context, slices $c() to the actual number of elements in the union and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 1708 "lib/PDL/Primitive.pd" sub PDL::unionvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($nc)); $nc = PDL->null if (!defined($nc)); PDL::_unionvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice(",0:".($nc->max-1)); } #line 2115 "lib/PDL/Primitive.pm" *unionvec = \&PDL::unionvec; =head2 intersectvec =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC=CALC(PDLMIN($SIZE(NA),$SIZE(NB)))); indx [o]nc()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($c, $nc) = intersectvec($a, $b); intersectvec($a, $b, $c, $nc); # all arguments given ($c, $nc) = $a->intersectvec($b); # method call $a->intersectvec($b, $c, $nc); =for ref Intersection of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the intersection. In scalar context, slices $c() to the actual number of elements in the intersection and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 1767 "lib/PDL/Primitive.pd" sub PDL::intersectvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_intersectvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice(",0:".($nc_max-1)) : $c->reshape($c->dim(0), 0, ($c->dims)[2..($c->ndims-1)])); } #line 2177 "lib/PDL/Primitive.pm" *intersectvec = \&PDL::intersectvec; =head2 setdiffvec =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC=CALC($SIZE(NA))); indx [o]nc()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($c, $nc) = setdiffvec($a, $b); setdiffvec($a, $b, $c, $nc); # all arguments given ($c, $nc) = $a->setdiffvec($b); # method call $a->setdiffvec($b, $c, $nc); =for ref Set-difference ($a() \ $b()) of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the computed vector set. In scalar context, slices $c() to the actual number of elements in the output vector set and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 1822 "lib/PDL/Primitive.pd" sub PDL::setdiffvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_setdiffvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice(",0:".($nc_max-1)) : $c->reshape($c->dim(0), 0, ($c->dims)[2..($c->ndims-1)])); } #line 2240 "lib/PDL/Primitive.pm" *setdiffvec = \&PDL::setdiffvec; =head2 union_sorted =for sig Signature: (a(NA); b(NB); [o]c(NC=CALC($SIZE(NA) + $SIZE(NB))); indx [o]nc()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($c, $nc) = union_sorted($a, $b); union_sorted($a, $b, $c, $nc); # all arguments given ($c, $nc) = $a->union_sorted($b); # method call $a->union_sorted($b, $c, $nc); =for ref Union of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicates. On return, $nc() holds the actual number of values in the union. In scalar context, reshapes $c() to the actual number of elements in the union and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 1888 "lib/PDL/Primitive.pd" sub PDL::union_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_union_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice("0:".($nc->max-1)); } #line 2298 "lib/PDL/Primitive.pm" *union_sorted = \&PDL::union_sorted; =head2 intersect_sorted =for sig Signature: (a(NA); b(NB); [o]c(NC=CALC(PDLMIN($SIZE(NA),$SIZE(NB)))); indx [o]nc()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($c, $nc) = intersect_sorted($a, $b); intersect_sorted($a, $b, $c, $nc); # all arguments given ($c, $nc) = $a->intersect_sorted($b); # method call $a->intersect_sorted($b, $c, $nc); =for ref Intersection of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicates. On return, $nc() holds the actual number of values in the intersection. In scalar context, reshapes $c() to the actual number of elements in the intersection and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 1947 "lib/PDL/Primitive.pd" sub PDL::intersect_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_intersect_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice("0:".($nc_max-1)) : $c->reshape(0, ($c->dims)[1..($c->ndims-1)])); } #line 2359 "lib/PDL/Primitive.pm" *intersect_sorted = \&PDL::intersect_sorted; =head2 setdiff_sorted =for sig Signature: (a(NA); b(NB); [o]c(NC=CALC($SIZE(NA))); indx [o]nc()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($c, $nc) = setdiff_sorted($a, $b); setdiff_sorted($a, $b, $c, $nc); # all arguments given ($c, $nc) = $a->setdiff_sorted($b); # method call $a->setdiff_sorted($b, $c, $nc); =for ref Set-difference ($a() \ $b()) of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicate values. On return, $nc() holds the actual number of values in the computed vector set. In scalar context, reshapes $c() to the actual number of elements in the difference set and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad C 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 2003 "lib/PDL/Primitive.pd" sub PDL::setdiff_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_setdiff_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice("0:".($nc_max-1)) : $c->reshape(0, ($c->dims)[1..($c->ndims-1)])); } #line 2421 "lib/PDL/Primitive.pm" *setdiff_sorted = \&PDL::setdiff_sorted; =head2 vcos =for sig Signature: (a(M,N);b(M);float+ [o]vcos(N)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $vcos = vcos($a, $b); vcos($a, $b, $vcos); # all arguments given $vcos = $a->vcos($b); # method call $a->vcos($b, $vcos); Computes the vector cosine similarity of a dense vector $b() with respect to each row $a(*,i) of a dense PDL $a(). This is basically the same thing as: inner($a, $b) / $a->magnover * $b->magnover ... but should be much faster to compute, and avoids allocating potentially large temporaries for the vector magnitudes. 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(). You can use PDL broadcasting to batch-compute distances for multiple $b() vectors simultaneously: $bx = random($M, $NB); ##-- get $NB random vectors of size $N $vcos = vcos($a,$bx); ##-- $vcos(i,j) ~ sim($a(,i),$b(,j)) Contributed by Bryan Jurish Emoocow@cpan.orgE. =pod Broadcasts over its inputs. =for bad vcos() will set the bad status flag on the output $vcos() if it is set on either of the inputs $a() or $b(), but BAD values will otherwise be ignored for computing the cosine similarity. =cut *vcos = \&PDL::vcos; =head2 srandom =for sig Signature: (a()) Types: (longlong) =for ref Seed random-number generator with a 64-bit int. Will generate seed data for a number of threads equal to the return-value of L. As of 2.062, the generator changed from Perl's generator to xoshiro256++ (see L). Before PDL 2.090, this was called C, but was renamed to avoid clashing with Perl's built-in. =for usage srandom(); # uses current time srandom(5); # fixed number e.g. for testing =pod Does not broadcast. Can't use POSIX threads. =for bad C 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 2179 "lib/PDL/Primitive.pd" *srandom = \&PDL::srandom; sub PDL::srandom { PDL::_srandom_int($_[0] // PDL::Core::seed()) } #line 2527 "lib/PDL/Primitive.pm" *srandom = \&PDL::srandom; =head2 random =for sig Signature: ([o] a()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref Constructor which returns ndarray of random numbers, real data-types only. =for usage $x = random([type], $nx, $ny, $nz,...); $x = random $y; etc (see L). This is the uniform distribution between 0 and 1 (assumedly excluding 1 itself). The arguments are the same as C (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. As of 2.062, the generator changed from Perl's generator to xoshiro256++ (see L). =pod Broadcasts over its inputs. =for bad C 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 2219 "lib/PDL/Primitive.pd" sub random { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->random : PDL->random(@_) } sub PDL::random { splice @_, 1, 0, double() if !ref($_[0]) and @_<=1; my $x = &PDL::Core::_construct; PDL::_random_int($x); return $x; } #line 2588 "lib/PDL/Primitive.pm" =head2 randsym =for sig Signature: ([o] a()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref Constructor which returns ndarray of random numbers, real data-types only. =for usage $x = randsym([type], $nx, $ny, $nz,...); $x = randsym $y; etc (see L). This is the uniform distribution between 0 and 1 (excluding both 0 and 1, cf L). The arguments are the same as C (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. =pod Broadcasts over its inputs. =for bad C 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 2263 "lib/PDL/Primitive.pd" sub randsym { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->randsym : PDL->randsym(@_) } sub PDL::randsym { splice @_, 1, 0, double() if !ref($_[0]) and @_<=1; my $x = &PDL::Core::_construct; PDL::_randsym_int($x); return $x; } #line 2274 "lib/PDL/Primitive.pd" =head2 grandom =for ref Constructor which returns ndarray of Gaussian random numbers =for usage $x = grandom([type], $nx, $ny, $nz,...); $x = grandom $y; etc (see L). This is generated using the math library routine C. Mean = 0, Stddev = 1 You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. =cut sub grandom { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->grandom : PDL->grandom(@_) } sub PDL::grandom { my $x = &PDL::Core::_construct; use PDL::Math 'ndtri'; $x .= ndtri(randsym($x)); return $x; } #line 2313 "lib/PDL/Primitive.pd" =head2 vsearch =for sig Signature: ( vals(); xs(n); [o] indx(); [\%options] ) =for ref Efficiently search for values in a sorted ndarray, returning indices. =for usage $idx = vsearch( $vals, $x, [\%options] ); vsearch( $vals, $x, $idx, [\%options ] ); B performs a binary search in the ordered ndarray C<$x>, for the values from C<$vals> ndarray, returning indices into C<$x>. What is a "match", and the meaning of the returned indices, are determined by the options. The C option indicates which method of searching to use, and may be one of: =over =item C invoke L|/vsearch_sample>, returning indices appropriate for sampling within a distribution. =item C invoke L|/vsearch_insert_leftmost>, returning the left-most possible insertion point which still leaves the ndarray sorted. =item C invoke L|/vsearch_insert_rightmost>, returning the right-most possible insertion point which still leaves the ndarray sorted. =item C invoke L|/vsearch_match>, returning the index of a matching element, else -(insertion point + 1) =item C invoke L|/vsearch_bin_inclusive>, returning an index appropriate for binning on a grid where the left bin edges are I of the bin. See below for further explanation of the bin. =item C invoke L|/vsearch_bin_exclusive>, returning an index appropriate for binning on a grid where the left bin edges are I of the bin. See below for further explanation of the bin. =back The default value of C is C. =for example use PDL; my @modes = qw( sample insert_leftmost insert_rightmost match bin_inclusive bin_exclusive ); # Generate a sequence of 3 zeros, 3 ones, ..., 3 fours. my $x = zeroes(3,5)->yvals->flat; for my $mode ( @modes ) { # if the value is in $x my $contained = 2; my $idx_contained = vsearch( $contained, $x, { mode => $mode } ); my $x_contained = $x->copy; $x_contained->slice( $idx_contained ) .= 9; # if the value is not in $x my $not_contained = 1.5; my $idx_not_contained = vsearch( $not_contained, $x, { mode => $mode } ); my $x_not_contained = $x->copy; $x_not_contained->slice( $idx_not_contained ) .= 9; print sprintf("%-23s%30s\n", '$x', $x); print sprintf("%-23s%30s\n", "$mode ($contained)", $x_contained); print sprintf("%-23s%30s\n\n", "$mode ($not_contained)", $x_not_contained); } # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # sample (2) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # sample (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # insert_leftmost (2) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # insert_leftmost (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # insert_rightmost (2) [0 0 0 1 1 1 2 2 2 9 3 3 4 4 4] # insert_rightmost (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # match (2) [0 0 0 1 1 1 2 9 2 3 3 3 4 4 4] # match (1.5) [0 0 0 1 1 1 2 2 9 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # bin_inclusive (2) [0 0 0 1 1 1 2 2 9 3 3 3 4 4 4] # bin_inclusive (1.5) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # bin_exclusive (2) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] # bin_exclusive (1.5) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] Also see L|/vsearch_sample>, L|/vsearch_insert_leftmost>, L|/vsearch_insert_rightmost>, L|/vsearch_match>, L|/vsearch_bin_inclusive>, and L|/vsearch_bin_exclusive> =cut sub vsearch { my $opt = 'HASH' eq ref $_[-1] ? pop : { mode => 'sample' }; croak( "unknown options to vsearch\n" ) if ( ! defined $opt->{mode} && keys %$opt ) || keys %$opt > 1; my $mode = $opt->{mode}; goto $mode eq 'sample' ? \&vsearch_sample : $mode eq 'insert_leftmost' ? \&vsearch_insert_leftmost : $mode eq 'insert_rightmost' ? \&vsearch_insert_rightmost : $mode eq 'match' ? \&vsearch_match : $mode eq 'bin_inclusive' ? \&vsearch_bin_inclusive : $mode eq 'bin_exclusive' ? \&vsearch_bin_exclusive : croak( "unknown vsearch mode: $mode\n" ); } *PDL::vsearch = \&vsearch; #line 2819 "lib/PDL/Primitive.pm" =head2 vsearch_sample =for sig Signature: (vals(); x(n); indx [o]idx()) Types: (float double ldouble) =for ref Search for values in a sorted array, return index appropriate for sampling from a distribution =for usage $idx = vsearch_sample($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. B returns an index I for each value I of C<$vals> appropriate for sampling C<$vals> I has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem -1 =item * if C<$x> is sorted in decreasing order V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem - 1 =back If all elements of C<$x> are equal, I<< I = $x->nelem - 1 >>. If C<$x> contains duplicated elements, I is the index of the leftmost (by position in array) duplicate if I matches. =for example This function is useful e.g. when you have a list of probabilities for events and want to generate indices to events: $x = pdl(.01,.86,.93,1); # Barnsley IFS probabilities cumulatively $y = random 20; $c = vsearch_sample($y, $x); # Now, $c will have the appropriate distr. It is possible to use the L function to obtain cumulative probabilities from absolute probabilities. =pod Broadcasts over its inputs. =for bad bad values in vals() result in bad values in idx() =cut *vsearch_sample = \&PDL::vsearch_sample; =head2 vsearch_insert_leftmost =for sig Signature: (vals(); x(n); indx [o]idx()) Types: (float double ldouble) =for ref Determine the insertion point for values in a sorted array, inserting before duplicates. =for usage $idx = vsearch_insert_leftmost($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. B returns an index I for each value I of C<$vals> equal to the leftmost position (by index in array) within C<$x> that I may be inserted and still maintain the order in C<$x>. Insertion at index I involves shifting elements I and higher of C<$x> to the right by one and setting the now empty element at index I to I. I has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem =item * if C<$x> is sorted in decreasing order V > x[0] : I = -1 x[0] >= V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem -1 =back If all elements of C<$x> are equal, i = 0 If C<$x> contains duplicated elements, I is the index of the leftmost (by index in array) duplicate if I matches. =pod Broadcasts over its inputs. =for bad bad values in vals() result in bad values in idx() =cut *vsearch_insert_leftmost = \&PDL::vsearch_insert_leftmost; =head2 vsearch_insert_rightmost =for sig Signature: (vals(); x(n); indx [o]idx()) Types: (float double ldouble) =for ref Determine the insertion point for values in a sorted array, inserting after duplicates. =for usage $idx = vsearch_insert_rightmost($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. B returns an index I for each value I of C<$vals> equal to the rightmost position (by index in array) within C<$x> that I may be inserted and still maintain the order in C<$x>. Insertion at index I involves shifting elements I and higher of C<$x> to the right by one and setting the now empty element at index I to I. I has the following properties: =over =item * if C<$x> is sorted in increasing order V < x[0] : I = 0 x[0] <= V < x[-1] : I s.t. x[I-1] <= V < x[I] x[-1] <= V : I = $x->nelem =item * if C<$x> is sorted in decreasing order V >= x[0] : I = -1 x[0] > V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] > V : I = $x->nelem -1 =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the leftmost (by index in array) duplicate if I matches. =pod Broadcasts over its inputs. =for bad bad values in vals() result in bad values in idx() =cut *vsearch_insert_rightmost = \&PDL::vsearch_insert_rightmost; =head2 vsearch_match =for sig Signature: (vals(); x(n); indx [o]idx()) Types: (float double ldouble) =for ref Match values against a sorted array. =for usage $idx = vsearch_match($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. B returns an index I for each value I of C<$vals>. If I matches an element in C<$x>, I is the index of that element, otherwise it is I<-( insertion_point + 1 )>, where I is an index in C<$x> where I may be inserted while maintaining the order in C<$x>. If C<$x> has duplicated values, I may refer to any of them. =pod Broadcasts over its inputs. =for bad bad values in vals() result in bad values in idx() =cut *vsearch_match = \&PDL::vsearch_match; =head2 vsearch_bin_inclusive =for sig Signature: (vals(); x(n); indx [o]idx()) Types: (float double ldouble) =for ref Determine the index for values in a sorted array of bins, lower bound inclusive. =for usage $idx = vsearch_bin_inclusive($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is inclusive to the bin, its outer bound is exclusive to it. B returns an index I for each value I of C<$vals> I has the following properties: =over =item * if C<$x> is sorted in increasing order V < x[0] : I = -1 x[0] <= V < x[-1] : I s.t. x[I] <= V < x[I+1] x[-1] <= V : I = $x->nelem - 1 =item * if C<$x> is sorted in decreasing order V >= x[0] : I = 0 x[0] > V >= x[-1] : I s.t. x[I+1] > V >= x[I] x[-1] > V : I = $x->nelem =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the righmost (by index in array) duplicate if I matches. =pod Broadcasts over its inputs. =for bad bad values in vals() result in bad values in idx() =cut *vsearch_bin_inclusive = \&PDL::vsearch_bin_inclusive; =head2 vsearch_bin_exclusive =for sig Signature: (vals(); x(n); indx [o]idx()) Types: (float double ldouble) =for ref Determine the index for values in a sorted array of bins, lower bound exclusive. =for usage $idx = vsearch_bin_exclusive($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is exclusive to the bin, its upper bound is inclusive to it. B returns an index I for each value I of C<$vals>. I has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = -1 x[0] < V <= x[-1] : I s.t. x[I] < V <= x[I+1] x[-1] < V : I = $x->nelem - 1 =item * if C<$x> is sorted in decreasing order V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I-1] >= V > x[I] x[-1] >= V : I = $x->nelem =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the righmost (by index in array) duplicate if I matches. =pod Broadcasts over its inputs. =for bad bad values in vals() result in bad values in idx() =cut *vsearch_bin_exclusive = \&PDL::vsearch_bin_exclusive; =head2 interpolate =for sig Signature: (!complex xi(); !complex x(n); y(n); [o] yi(); int [o] err()) Types: (float ldouble cfloat cdouble cldouble double) =for usage ($yi, $err) = interpolate($xi, $x, $y); interpolate($xi, $x, $y, $yi, $err); # all arguments given ($yi, $err) = $xi->interpolate($x, $y); # method call $xi->interpolate($x, $y, $yi, $err); =for ref routine for 1D linear interpolation Given a set of points C<($x,$y)>, use linear interpolation to find the values C<$yi> at a set of points C<$xi>. C uses a binary search to find the suspects, er..., interpolation indices and therefore abscissas (ie C<$x>) have to be I ordered (increasing or decreasing). For interpolation at lots of closely spaced abscissas an approach that uses the last index found as a start for the next search can be faster (compare Numerical Recipes C routine). Feel free to implement that on top of the binary search if you like. For out of bounds values it just does a linear extrapolation and sets the corresponding element of C<$err> to 1, which is otherwise 0. See also L, which uses the same routine, differing only in the handling of extrapolation - an error message is printed rather than returning an error ndarray. Note that C can use complex values for C<$y> and C<$yi> but C<$x> and C<$xi> must be real. =pod Broadcasts over its inputs. =for bad needs major (?) work to handles bad values =cut *interpolate = \&PDL::interpolate; #line 2987 "lib/PDL/Primitive.pd" =head2 interpol =for sig Signature: (xi(); x(n); y(n); [o] yi()) =for ref routine for 1D linear interpolation =for usage $yi = interpol($xi, $x, $y) C uses the same search method as L, hence C<$x> must be I ordered (either increasing or decreasing). The difference occurs in the handling of out-of-bounds values; here an error message is printed. =cut # kept in for backwards compatibility sub interpol ($$$;$) { my $xi = shift; my $x = shift; my $y = shift; my $yi = @_ == 1 ? $_[0] : PDL->null; interpolate( $xi, $x, $y, $yi, my $err = PDL->null ); print "some values had to be extrapolated\n" if any $err; return $yi if @_ == 0; } # sub: interpol() *PDL::interpol = \&interpol; #line 3025 "lib/PDL/Primitive.pd" =head2 interpND =for ref Interpolate values from an N-D ndarray, with switchable method =for example $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2.2,3.5],[4.1,5.0]],[[6.0,7.4],[8,9]]); print $source->interpND( $index ); InterpND acts like L, collapsing C<$index> by lookup into C<$source>; but it does interpolation rather than direct sampling. The interpolation method and boundary condition are switchable via an options hash. By default, linear or sample interpolation is used, with constant value outside the boundaries of the source pdl. No dataflow occurs, because in general the output is computed rather than indexed. All the interpolation methods treat the pixels as value-centered, so the C method will return C<< $a->(0) >> for coordinate values on the set [-0.5,0.5], and all methods will return C<< $a->(1) >> for a coordinate value of exactly 1. Recognized options: =over 3 =item method Values can be: =over 3 =item * 0, s, sample, Sample (default for integer source types) The nearest value is taken. Pixels are regarded as centered on their respective integer coordinates (no offset from the linear case). =item * 1, l, linear, Linear (default for floating point source types) The values are N-linearly interpolated from an N-dimensional cube of size 2. =item * 3, c, cube, cubic, Cubic The values are interpolated using a local cubic fit to the data. The fit is constrained to match the original data and its derivative at the data points. The second derivative of the fit is not continuous at the data points. Multidimensional datasets are interpolated by the successive-collapse method. (Note that the constraint on the first derivative causes a small amount of ringing around sudden features such as step functions). =item * f, fft, fourier, Fourier The source is Fourier transformed, and the interpolated values are explicitly calculated from the coefficients. The boundary condition option is ignored -- periodic boundaries are imposed. If you pass in the option "fft", and it is a list (ARRAY) ref, then it is a stash for the magnitude and phase of the source FFT. If the list has two elements then they are taken as already computed; otherwise they are calculated and put in the stash. =back =item b, bound, boundary, Boundary This option is passed unmodified into L, which is used as the indexing engine for the interpolation. Some current allowed values are 'extend', 'periodic', 'truncate', and 'mirror' (default is 'truncate'). =item bad contains the fill value used for 'truncate' boundary. (default 0) =item fft An array ref whose associated list is used to stash the FFT of the source data, for the FFT method. =back =cut *interpND = *PDL::interpND; sub PDL::interpND { my $source = shift; my $index = shift; my $options = shift; barf 'Usage: interpND($source,$index[,{%options}])' if(defined $options and ref $options ne 'HASH'); my $opt = defined $options ? $options : {}; my $method = $opt->{m} || $opt->{meth} || $opt->{method} || $opt->{Method}; $method //= $source->type->integer ? 'sample' : 'linear'; my $boundary = $opt->{b} || $opt->{boundary} || $opt->{Boundary} || $opt->{bound} || $opt->{Bound} || 'extend'; my $bad = $opt->{bad} || $opt->{Bad} || 0.0; return $source->range(PDL::Math::floor($index+0.5),0,$boundary) if $method =~ m/^s(am(p(le)?)?)?/i; if (($method eq 1) || $method =~ m/^l(in(ear)?)?/i) { ## key: (ith = index broadcast; cth = cube broadcast; sth = source broadcast) my $d = $index->dim(0); my $di = $index->ndims - 1; # Grab a 2-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor,2,$boundary); # (ith, cth, sth) # Reorder to put the cube dimensions in front and convert to a list $samp = $samp->reorder( $di .. $di+$d-1, 0 .. $di-1, $di+$d .. $samp->ndims-1) # (cth, ith, sth) ->clump($d); # (clst, ith, sth) # Enumerate the corners of an n-cube and convert to a list # (the 'x' is the normal perl repeat operator) my $crnr = PDL::Basic::ndcoords( (2) x $index->dim(0) ) # (index,cth) ->mv(0,-1)->clump($index->dim(0))->mv(-1,0); # (index, clst) # a & b are the weighting coefficients. my($x,$y); $index->where( 0 * $index ) .= -10; # Change NaN to invalid { my $bb = PDL::Math::floor($index); $x = ($index - $bb) -> dummy(1,$crnr->dim(1)); # index, clst, ith $y = ($bb + 1 - $index) -> dummy(1,$crnr->dim(1)); # index, clst, ith } # Use 1/0 corners to select which multiplier happens, multiply # 'em all together to get sample weights, and sum to get the answer. my $out0 = ( ($x * ($crnr==1) + $y * ($crnr==0)) #index, clst, ith -> prodover #clst, ith ); my $out = ($out0 * $samp)->sumover; # ith, sth # Work around BAD-not-being-contagious bug in PDL <= 2.6 bad handling code --CED 3-April-2013 if ($source->badflag) { my $baddies = $samp->isbad->orover; $out = $out->setbadif($baddies); } $out = $out->convert($source->type->enum) if $out->type != $source->type; return $out; } elsif(($method eq 3) || $method =~ m/^c(u(b(e|ic)?)?)?/i) { my ($d,@di) = $index->dims; my $di = $index->ndims - 1; # Grab a 4-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor - 1,4,$boundary) #ith, cth, sth ->reorder( $di .. $di+$d-1, 0..$di-1, $di+$d .. $source->ndims-1 ); # (cth, ith, sth) # Make a cube of the subpixel offsets, and expand its dims to # a 4-on-a-side N-1 cube, to match the slices of $samp (used below). my $y = $index - $index->floor; for my $i(1..$d-1) { $y = $y->dummy($i,4); } # Collapse by interpolation, one dimension at a time... for my $i(0..$d-1) { my $a0 = $samp->slice("(1)"); # Just-under-sample my $a1 = $samp->slice("(2)"); # Just-over-sample my $a1a0 = $a1 - $a0; my $gradient = 0.5 * ($samp->slice("2:3")-$samp->slice("0:1")); my $s0 = $gradient->slice("(0)"); # Just-under-gradient my $s1 = $gradient->slice("(1)"); # Just-over-gradient my $bb = $y->slice("($i)"); # Collapse the sample... $samp = ( $a0 + $bb * ( $s0 + $bb * ( (3 * $a1a0 - 2*$s0 - $s1) + $bb * ( $s1 + $s0 - 2*$a1a0 ) ) ) ); # "Collapse" the subpixel offset... $y = $y->slice(":,($i)"); } $samp = $samp->convert($source->type->enum) if $samp->type != $source->type; return $samp; } elsif($method =~ m/^f(ft|ourier)?/i) { require PDL::FFT; my $fftref = $opt->{fft}; $fftref = [] unless(ref $fftref eq 'ARRAY'); if(@$fftref != 2) { my $x = $source->copy; my $y = zeroes($source); PDL::FFT::fftnd($x,$y); $fftref->[0] = sqrt($x*$x+$y*$y) / $x->nelem; $fftref->[1] = - atan2($y,$x); } my $i; my $c = PDL::Basic::ndcoords($source); # (dim, source-dims) for $i(1..$index->ndims-1) { $c = $c->dummy($i,$index->dim($i)) } my $id = $index->ndims-1; my $phase = (($c * $index * 3.14159 * 2 / pdl($source->dims)) ->sumover) # (index-dims, source-dims) ->reorder($id..$id+$source->ndims-1,0..$id-1); # (src, index) my $phref = $fftref->[1]->copy; # (source-dims) my $mag = $fftref->[0]->copy; # (source-dims) for $i(1..$index->ndims-1) { $phref = $phref->dummy(-1,$index->dim($i)); $mag = $mag->dummy(-1,$index->dim($i)); } my $out = cos($phase + $phref ) * $mag; $out = $out->clump($source->ndims)->sumover; $out = $out->convert($source->type->enum) if $out->type != $source->type; return $out; } else { barf("interpND: unknown method '$method'; valid ones are 'linear' and 'sample'.\n"); } } #line 3272 "lib/PDL/Primitive.pd" =head2 one2nd =for ref Converts a one dimensional index ndarray to a set of ND coordinates =for usage @coords=one2nd($x, $indices) returns an array of ndarrays containing the ND indexes corresponding to the one dimensional list indices. The indices are assumed to correspond to array C<$x> clumped using C. This routine is used in the old vector form of L, but is useful on its own occasionally. Returned ndarrays have the L datatype. C<$indices> can have values larger than C<< $x->nelem >> but negative values in C<$indices> will not give the answer you expect. =for example pdl> $x=pdl [[[1,2],[-1,1]], [[0,-3],[3,2]]]; $c=$x->clump(-1) pdl> $maxind=maximum_ind($c); p $maxind; 6 pdl> print one2nd($x, maximum_ind($c)) 0 1 1 pdl> p $x->at(0,1,1) 3 =cut *one2nd = \&PDL::one2nd; sub PDL::one2nd { barf "Usage: one2nd \$array, \$indices\n" if @_ != 2; my ($x, $ind)=@_; my @dimension=$x->dims; $ind = indx($ind); my(@index); my $count=0; foreach (@dimension) { $index[$count++]=$ind % $_; $ind /= $_; } return @index; } #line 3648 "lib/PDL/Primitive.pm" =head2 which =for sig Signature: (mask(n); indx [o] inds(n); indx [o]lastout()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for ref Returns indices of non-zero values from a 1-D PDL =for usage $i = which($mask); returns a pdl with indices for all those elements that are nonzero in the mask. Note that the returned indices will be 1D. If you feed in a multidimensional mask, it will be flattened before the indices are calculated. See also L for multidimensional masks. If you want to index into the original mask or a similar ndarray with output from C, remember to flatten it before calling index: $data = random 5, 5; $idx = which $data > 0.5; # $idx is now 1D $bigsum = $data->flat->index($idx)->sum; # flatten before indexing Compare also L for similar functionality. SEE ALSO: L returns separately the indices of both nonzero and zero values in the mask. L returns separately slices of both nonzero and zero values in the mask. L returns associated values from a data PDL, rather than indices into the mask PDL. L returns N-D indices into a multidimensional PDL. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> $indx = which($x>6); p $indx [7 8 9] =pod Broadcasts over its inputs. =for bad C 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 3405 "lib/PDL/Primitive.pd" sub which { my ($this,$out) = @_; $this = $this->flat; $out //= $this->nullcreate; PDL::_which_int($this,$out,my $lastout = $this->nullcreate); my $lastoutmax = $lastout->max->sclr; $lastoutmax ? $out->slice('0:'.($lastoutmax-1))->sever : empty(indx); } *PDL::which = \&which; #line 3725 "lib/PDL/Primitive.pm" *which = \&PDL::which; =head2 which_both =for sig Signature: (mask(n); indx [o] inds(n); indx [o]notinds(n); indx [o]lastout(); indx [o]lastoutn()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for ref Returns indices of nonzero and zero values in a mask PDL =for usage ($i, $c_i) = which_both($mask); This works just as L, but the complement of C<$i> will be in C<$c_i>. =for example pdl> p $x = sequence(10) [0 1 2 3 4 5 6 7 8 9] pdl> ($big, $small) = which_both($x >= 5); p "$big\n$small" [5 6 7 8 9] [0 1 2 3 4] See also L for the n-dimensional version. =pod Broadcasts over its inputs. =for bad C 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 3422 "lib/PDL/Primitive.pd" sub which_both { my ($this,$outi,$outni) = @_; $this = $this->flat; $outi //= $this->nullcreate; $outni //= $this->nullcreate; PDL::_which_both_int($this,$outi,$outni,my $lastout = $this->nullcreate,my $lastoutn = $this->nullcreate); my $lastoutmax = $lastout->max->sclr; $outi = $lastoutmax ? $outi->slice('0:'.($lastoutmax-1))->sever : empty(indx); return $outi if !wantarray; my $lastoutnmax = $lastoutn->max->sclr; ($outi, $lastoutnmax ? $outni->slice('0:'.($lastoutnmax-1))->sever : empty(indx)); } *PDL::which_both = \&which_both; #line 3791 "lib/PDL/Primitive.pm" *which_both = \&PDL::which_both; =head2 whichover =for sig Signature: (a(n); [o]o(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $o = whichover($a); whichover($a, $o); # all arguments given $o = $a->whichover; # method call $a->whichover($o); $a->inplace->whichover; # can be used inplace whichover($a->inplace); =for ref Collects the coordinates of non-zero, non-bad values in each 1D mask in ndarray at the start of the output, and fills the rest with -1. By using L etc. it is possible to use I dimension. =for example my $a = pdl q[3 4 2 3 2 3 1]; my $b = $a->uniq; my $c = +($a->dummy(0) == $b)->transpose; print $c, $c->whichover; # [ # [0 0 0 0 0 0 1] # [0 0 1 0 1 0 0] # [1 0 0 1 0 1 0] # [0 1 0 0 0 0 0] # ] # [ # [ 6 -1 -1 -1 -1 -1 -1] # [ 2 4 -1 -1 -1 -1 -1] # [ 0 3 5 -1 -1 -1 -1] # [ 1 -1 -1 -1 -1 -1 -1] # ] =pod Broadcasts over its inputs. =for bad C 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 *whichover = \&PDL::whichover; =head2 approx_artol =for sig Signature: (got(); expected(); sbyte [o] result(); double atol; double rtol) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $result = approx_artol($got, $expected); # using defaults of atol=1e-06, rtol=0 $result = approx_artol($got, $expected, $atol); $result = approx_artol($got, $expected, $atol, $rtol); approx_artol($got, $expected, $atol, $rtol, $result); # all arguments given $result = $got->approx_artol($expected); # method call $result = $got->approx_artol($expected, $atol); $result = $got->approx_artol($expected, $atol, $rtol); $got->approx_artol($expected, $atol, $rtol, $result); =for ref Returns C mask whether C<< abs($got()-$expected())> <= >> either absolute or relative (C * C<$expected()>) tolerances. Relative tolerance defaults to zero, and absolute tolerance defaults to C<1e-6>, for compatibility with L. Works with complex numbers, and to avoid expensive Cing uses the squares of the input quantities and differences. Bear this in mind for numbers outside the range (for C) of about C<1e-154..1e154>. Handles Cs by showing them approximately equal (i.e. true in the output) if both values are C, and not otherwise. Adapted from code by Edward Baudrez, test changed from C<< < >> to C<< <= >>. =pod Broadcasts over its inputs. =for bad Handles bad values similarly to Cs, above. This includes if only one of the two input ndarrays has their badflag true. =cut *approx_artol = \&PDL::approx_artol; #line 3554 "lib/PDL/Primitive.pd" =head2 where =for ref Use a mask to select values from one or more data PDLs C accepts one or more data ndarrays and a mask ndarray. It returns a list of output ndarrays, corresponding to the input data ndarrays. Each output ndarray is a 1-dimensional list of values in its corresponding data ndarray. The values are drawn from locations where the mask is nonzero. The output PDLs are still connected to the original data PDLs, for the purpose of dataflow. C combines the functionality of L and L into a single operation. BUGS: While C works OK for most N-dimensional cases, it does not broadcast properly over (for example) the (N+1)th dimension in data that is compared to an N-dimensional mask. Use C for that. =for example $i = $x->where($x+5 > 0); # $i contains those elements of $x # where mask ($x+5 > 0) is 1 $i .= -5; # Set those elements (of $x) to -5. Together, these # commands clamp $x to a maximum of -5. It is also possible to use the same mask for several ndarrays with the same call: ($i,$j,$k) = where($x,$y,$z, $x+5>0); Note: C<$i> is always 1-D, even if C<$x> is E1-D. WARNING: The first argument (the values) and the second argument (the mask) currently have to have the exact same dimensions (or horrible things happen). You *cannot* broadcast over a smaller mask, for example. =cut sub PDL::where :lvalue { barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if @_ == 1; my $mask = pop->flat->which; @_ == 1 ? $_[0]->flat->index($mask) : map $_->flat->index($mask), @_; } *where = \&PDL::where; #line 3610 "lib/PDL/Primitive.pd" =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, 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->flat; map $arr_flat->index1d($_), PDL::which_both($mask); } *where_both = \&PDL::where_both; #line 3648 "lib/PDL/Primitive.pd" =head2 whereND =for ref C with support for ND masks and broadcasting C accepts one or more data ndarrays and a mask ndarray. It returns a list of output ndarrays, corresponding to the input data ndarrays. The values are drawn from locations where the mask is nonzero. C differs from C in that the mask dimensionality is preserved which allows for proper broadcasting of the selection operation over higher dimensions. As with C the output PDLs are still connected to the original data PDLs, for the purpose of dataflow. =for usage $sdata = whereND $data, $mask ($s1, $s2, ..., $sn) = whereND $d1, $d2, ..., $dn, $mask where $data is M dimensional $mask is N < M dimensional dims($data) 1..N == dims($mask) 1..N with broadcasting over N+1 to M dimensions =for example $data = sequence(4,3,2); # example data array $mask4 = (random(4)>0.5); # example 1-D mask array, has $n4 true values $mask43 = (random(4,3)>0.5); # example 2-D mask array, has $n43 true values $sdat4 = whereND $data, $mask4; # $sdat4 is a [$n4,3,2] pdl $sdat43 = whereND $data, $mask43; # $sdat43 is a [$n43,2] pdl Just as with C, you can use the returned value in an assignment. That means that both of these examples are valid: # Used to create a new slice stored in $sdat4: $sdat4 = $data->whereND($mask4); $sdat4 .= 0; # Used in lvalue context: $data->whereND($mask4) .= 0; SEE ALSO: L returns N-D indices into a multidimensional PDL, from a mask. =cut sub PDL::whereND :lvalue { barf "Usage: whereND( \$pdl1, ..., \$pdlN, \$mask )\n" if @_ == 1; my $mask = pop @_; # $mask has 0==false, 1==true my @to_return; my $n = PDL::sum($mask); my $maskndims = $mask->ndims; foreach my $arr (@_) { # count the number of dims in $mask and $arr # $mask = a b c d e f..... my @idims = dims($arr); splice @idims, 0, $maskndims; # pop off the number of dims in $mask if (!$n or $arr->isempty) { push @to_return, PDL->zeroes($arr->type, $n, @idims); next; } my $sub_i = $mask * ones($arr); my $where_sub_i = PDL::where($arr, $sub_i); my $ndim = 0; foreach my $id ($n, @idims[0..($#idims-1)]) { $where_sub_i = $where_sub_i->splitdim($ndim++,$id) if $n>0; } push @to_return, $where_sub_i; } return (@to_return == 1) ? $to_return[0] : @to_return; } *whereND = \&PDL::whereND; =head2 whereND_both =for ref C with support for ND masks and broadcasting This works like L, but data-flowing slices rather than index-sets are returned. C differs from C in that the mask dimensionality is preserved which allows for proper broadcasting of the selection operation over higher dimensions. As with C the output PDLs are still connected to the original data PDLs, for the purpose of dataflow. =for usage ($match_vals, $non_match_vals) = whereND_both($pdl, $mask); =cut sub PDL::whereND_both :lvalue { barf "Usage: whereND_both(\$pdl, \$mask)\n" if @_ != 2; my ($arr, $mask) = @_; # $mask has 0==false, 1==true map $arr->indexND($_), PDL::whichND_both($mask); } *whereND_both = \&PDL::whereND_both; #line 3762 "lib/PDL/Primitive.pd" =head2 whichND =for ref Return the coordinates of non-zero values in a mask. =for usage WhichND returns the N-dimensional coordinates of each nonzero value in a mask PDL with any number of dimensions. The returned values arrive as an array-of-vectors suitable for use in L or L. $coords = whichND($mask); returns a PDL containing the coordinates of the elements that are non-zero in C<$mask>, suitable for use in L. The 0th dimension contains the full coordinate listing of each point; the 1st dimension lists all the points. For example, if $mask has rank 4 and 100 matching elements, then $coords has dimension 4x100. If no such elements exist, then whichND returns a structured empty PDL: an Nx0 PDL that contains no values (but matches, broadcasting-wise, with the vectors that would be produced if such elements existed). DEPRECATED BEHAVIOR IN LIST CONTEXT: whichND once delivered different values in list context than in scalar context, for historical reasons. In list context, it returned the coordinates transposed, as a collection of 1-PDLs (one per dimension) in a list. This usage is deprecated in PDL 2.4.10, and will cause a warning to be issued every time it is encountered. To avoid the warning, you can set the global variable "$PDL::whichND" to 's' to get scalar behavior in all contexts, or to 'l' to get list behavior in list context. In later versions of PDL, the deprecated behavior will disappear. Deprecated list context whichND expressions can be replaced with: @list = $x->whichND->mv(0,-1)->dog; SEE ALSO: L finds coordinates of nonzero values in a 1-D mask. L extracts values from a data PDL that are associated with nonzero values in a mask PDL. L can be fed the coordinates to return the values. =for example pdl> $s=sequence(10,10,3,4) pdl> ($x, $y, $z, $w)=whichND($s == 203); p $x, $y, $z, $w [3] [0] [2] [0] pdl> print $s->at(list(cat($x,$y,$z,$w))) 203 =cut sub _one2nd { my ($mask, $ind) = @_; my $ndims = my @mdims = $mask->dims; # In the empty case, explicitly return the correct type of structured empty return PDL->new_from_specification(indx, $ndims, 0) if !$ind->nelem; my $mult = ones(indx, $ndims); $mult->index($_+1) .= $mult->index($_) * $mdims[$_] for 0..$#mdims-1; for my $i (0..$#mdims) { my $s = $ind->index($i); $s /= $mult->index($i); $s %= $mdims[$i]; } $ind; } *whichND = \&PDL::whichND; sub PDL::whichND { my $mask = PDL->topdl(shift); # List context: generate a perl list by dimension if(wantarray) { if(!defined($PDL::whichND)) { printf STDERR "whichND: WARNING - list context deprecated. Set \$PDL::whichND. Details in pod."; } elsif($PDL::whichND =~ m/l/i) { # old list context enabled by setting $PDL::whichND to 'l' return $mask->one2nd($mask->flat->which); } # if $PDL::whichND does not contain 'l' or 'L', fall through to scalar context } # Scalar context: generate an N-D index ndarray my $ndims = $mask->getndims; return PDL->new_from_specification(indx,$ndims,0) if !$mask->nelem; return $mask ? pdl(indx,0) : PDL->new_from_specification(indx,0) if !$ndims; _one2nd($mask, $mask->flat->which->dummy(0,$ndims)->sever); } =head2 whichND_both =for ref Return the coordinates of non-zero values in a mask. =for usage Like L, but returns the N-dimensional coordinates (like L) of the nonzero, zero values in the mask PDL. The returned values arrive as an array-of-vectors suitable for use in L or L. Added in 2.099. ($nonzero_coords, $zero_coords) = whichND_both($mask); SEE ALSO: L finds coordinates of nonzero values in a 1-D mask. L extracts values from a data PDL that are associated with nonzero values in a mask PDL. L can be fed the coordinates to return the values. =for example pdl> $s=sequence(10,10,3,4) pdl> ($x, $y, $z, $w)=whichND($s == 203); p $x, $y, $z, $w [3] [0] [2] [0] pdl> print $s->at(list(cat($x,$y,$z,$w))) 203 =cut *whichND_both = \&PDL::whichND_both; sub PDL::whichND_both { my $mask = PDL->topdl(shift); return ((PDL->new_from_specification(indx,$mask->ndims,0))x2) if !$mask->nelem; my $ndims = $mask->getndims; if (!$ndims) { my ($t, $f) = (pdl(indx,0), PDL->new_from_specification(indx,0)); return $mask ? ($t,$f) : ($f,$t); } map _one2nd($mask, $_->dummy(0,$ndims)->sever), $mask->flat->which_both; } #line 3913 "lib/PDL/Primitive.pd" =head2 setops =for ref Implements simple set operations like union and intersection =for usage Usage: $set = setops($x, , $y); The operator can be C, C or C. This is then applied to C<$x> viewed as a set and C<$y> viewed as a set. Set theory says that a set may not have two or more identical elements, but setops takes care of this for you, so C<$x=pdl(1,1,2)> is OK. The functioning is as follows: =over =item C The resulting vector will contain the elements that are either in C<$x> I in C<$y> or both. This is the union in set operation terms =item C The resulting vector will contain the elements that are either in C<$x> or C<$y>, but not in both. This is Union($x, $y) - Intersection($x, $y) in set operation terms. =item C The resulting vector will contain the intersection of C<$x> and C<$y>, so the elements that are in both C<$x> and C<$y>. Note that for convenience this operation is also aliased to L. =back It should be emphasized that these routines are used when one or both of the sets C<$x>, C<$y> are hard to calculate or that you get from a separate subroutine. Finally IDL users might be familiar with Craig Markwardt's C routine which has inspired this routine although it was written independently However the present routine has a few less options (but see the examples) =for example You will very often use these functions on an index vector, so that is what we will show here. We will in fact something slightly silly. First we will find all squares that are also cubes below 10000. Create a sequence vector: pdl> $x = sequence(10000) Find all odd and even elements: pdl> ($even, $odd) = which_both( ($x % 2) == 0) Find all squares pdl> $squares= which(ceil(sqrt($x)) == floor(sqrt($x))) Find all cubes (being careful with roundoff error!) pdl> $cubes= which(ceil($x**(1.0/3.0)) == floor($x**(1.0/3.0)+1e-6)) Then find all squares that are cubes: pdl> $both = setops($squares, 'AND', $cubes) And print these (assumes that C is loaded!) pdl> p $x($both) [0 1 64 729 4096] Then find all numbers that are either cubes or squares, but not both: pdl> $cube_xor_square = setops($squares, 'XOR', $cubes) pdl> p $cube_xor_square->nelem() 112 So there are a total of 112 of these! Finally find all odd squares: pdl> $odd_squares = setops($squares, 'AND', $odd) Another common occurrence is to want to get all objects that are in C<$x> and in the complement of C<$y>. But it is almost always best to create the complement explicitly since the universe that both are taken from is not known. Thus use L if possible to keep track of complements. If this is impossible the best approach is to make a temporary: This creates an index vector the size of the universe of the sets and set all elements in C<$y> to 0 pdl> $tmp = ones($n_universe); $tmp($y) .= 0; This then finds the complement of C<$y> pdl> $C_b = which($tmp == 1); and this does the final selection: pdl> $set = setops($x, 'AND', $C_b) =cut *setops = \&PDL::setops; sub PDL::setops { my ($x, $op, $y)=@_; # Check that $x and $y are 1D. if ($x->ndims() > 1 || $y->ndims() > 1) { warn 'setops: $x and $y must be 1D - flattening them!'."\n"; $x = $x->flat; $y = $y->flat; } #Make sure there are no duplicate elements. $x=$x->uniq; $y=$y->uniq; my $result; if ($op eq 'OR') { # Easy... $result = uniq(append($x, $y)); } elsif ($op eq 'XOR') { # Make ordered list of set union. my $union = append($x, $y)->qsort; # Index lists. my $s1=zeroes(byte, $union->nelem()); my $s2=zeroes(byte, $union->nelem()); # Find indices which are duplicated - these are to be excluded # # We do this by comparing x with x shifted each way. my $i1 = which($union != rotate($union, 1)); my $i2 = which($union != rotate($union, -1)); # # We then mark/mask these in the s1 and s2 arrays to indicate which ones # are not equal to their neighbours. # my $ts; ($ts = $s1->index($i1)) .= byte(1) if $i1->nelem() > 0; ($ts = $s2->index($i2)) .= byte(1) if $i2->nelem() > 0; my $inds=which($s1 == $s2); if ($inds->nelem() > 0) { return $union->index($inds); } else { return $inds; } } elsif ($op eq 'AND') { # The intersection of the arrays. return $x if $x->isempty; return $y if $y->isempty; # Make ordered list of set union. my $union = append($x, $y)->qsort; return $union->where($union == rotate($union, -1))->uniq; } else { print "The operation $op is not known!"; return -1; } } #line 4096 "lib/PDL/Primitive.pd" =head2 intersect =for ref Calculate the intersection of two ndarrays =for usage Usage: $set = intersect($x, $y); This routine is merely a simple interface to L. See that for more information =for example Find all numbers less that 100 that are of the form 2*y and 3*x pdl> $x=sequence(100) pdl> $factor2 = which( ($x % 2) == 0) pdl> $factor3 = which( ($x % 3) == 0) pdl> $ii=intersect($factor2, $factor3) pdl> p $x($ii) [0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96] =cut *intersect = \&PDL::intersect; sub PDL::intersect { setops($_[0], 'AND', $_[1]) } #line 4482 "lib/PDL/Primitive.pm" =head2 pchip_chim =for sig Signature: (x(n); f(n); [o]d(n); indx [o]ierr()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($d, $ierr) = pchip_chim($x, $f); pchip_chim($x, $f, $d, $ierr); # all arguments given ($d, $ierr) = $x->pchip_chim($f); # method call $x->pchip_chim($f, $d, $ierr); =for ref Calculate the derivatives of (x,f(x)) using cubic Hermite interpolation. Calculate the derivatives needed to determine a monotone piecewise cubic Hermite interpolant to the given set of points (C<$x,$f>, where C<$x> is strictly increasing). The resulting set of points - C<$x,$f,$d>, referred to as the cubic Hermite representation - can then be used in other functions, such as L, L, and L. The boundary conditions are compatible with monotonicity, and if the data are only piecewise monotonic, the interpolant will have an extremum at the switch points; for more control over these issues use L. References: 1. F. N. Fritsch and J. Butland, A method for constructing local monotone piecewise cubic interpolants, SIAM Journal on Scientific and Statistical Computing 5, 2 (June 1984), pp. 300-304. F. N. Fritsch and R. E. Carlson, Monotone piecewise cubic interpolation, SIAM Journal on Numerical Analysis 17, 2 (April 1980), pp. 238-246. =pod =head3 Parameters =over =item x ordinate data =item f array of dependent variable values to be interpolated. F(I) is value corresponding to X(I). C is designed for monotonic data, but it will work for any F-array. It will force extrema at points where monotonicity switches direction. If some other treatment of switch points is desired, DPCHIC should be used instead. =item d array of derivative values at the data points. If the data are monotonic, these values will determine a monotone cubic Hermite function. =item ierr Error status: =over =item * 0 if successful. =item * E 0 if there were C switches in the direction of monotonicity (data still valid). =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =back (The D-array has not been changed in any of these cases.) NOTE: The above errors are checked in the order listed, and following arguments have B been validated. =back Broadcasts over its inputs. =for bad C 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 *pchip_chim = \&PDL::pchip_chim; =head2 pchip_chic =for sig Signature: (sbyte ic(two=2); vc(two=2); mflag(); x(n); f(n); [o]d(n); indx [o]ierr(); [t]h(nless1=CALC($SIZE(n)-1)); [t]slope(nless1);) Types: (float double ldouble) =for usage ($d, $ierr) = pchip_chic($ic, $vc, $mflag, $x, $f); pchip_chic($ic, $vc, $mflag, $x, $f, $d, $ierr); # all arguments given ($d, $ierr) = $ic->pchip_chic($vc, $mflag, $x, $f); # method call $ic->pchip_chic($vc, $mflag, $x, $f, $d, $ierr); =for ref Set derivatives needed to determine a piecewise monotone piecewise cubic Hermite interpolant to given data. User control is available over boundary conditions and/or treatment of points where monotonicity switches direction. Calculate the derivatives needed to determine a piecewise monotone piecewise cubic interpolant to the data given in (C<$x,$f>, where C<$x> is strictly increasing). Control over the boundary conditions is given by the C<$ic> and C<$vc> ndarrays, and the value of C<$mflag> determines the treatment of points where monotonicity switches direction. A simpler, more restricted, interface is available using L. The resulting piecewise cubic Hermite function may be evaluated by L or L. References: 1. F. N. Fritsch, Piecewise Cubic Hermite Interpolation Package, Report UCRL-87285, Lawrence Livermore National Laboratory, July 1982. [Poster presented at the SIAM 30th Anniversary Meeting, 19-23 July 1982.] 2. F. N. Fritsch and J. Butland, A method for constructing local monotone piecewise cubic interpolants, SIAM Journal on Scientific and Statistical Computing 5, 2 (June 1984), pp. 300-304. 3. F. N. Fritsch and R. E. Carlson, Monotone piecewise cubic interpolation, SIAM Journal on Numerical Analysis 17, 2 (April 1980), pp. 238-246. =pod =head3 Parameters =over =item ic The first and second elements of C<$ic> determine the boundary conditions at the start and end of the data respectively. If the value is 0, then the default condition, as used by L, is adopted. If greater than zero, no adjustment for monotonicity is made, otherwise if less than zero the derivative will be adjusted. The allowed magnitudes for C are: =over =item * 1 if first derivative at C is given in C. =item * 2 if second derivative at C is given in C. =item * 3 to use the 3-point difference formula for C. (Reverts to the default b.c. if C 3>) =item * 4 to use the 4-point difference formula for C. (Reverts to the default b.c. if C 4>) =item * 5 to set C so that the second derivative is continuous at C. (Reverts to the default b.c. if C 4>) This option is somewhat analogous to the "not a knot" boundary condition provided by DPCHSP. =back The values for C are the same as above, except that the first-derivative value is stored in C for cases 1 and 2. The values of C<$vc> need only be set if options 1 or 2 are chosen for C<$ic>. NOTES: =over =item * Only in case C<$ic(n)> E 0 is it guaranteed that the interpolant will be monotonic in the first interval. If the returned value of D(start_or_end) lies between zero and 3*SLOPE(start_or_end), the interpolant will be monotonic. This is B checked if C<$ic(n)> E 0. =item * If C<$ic(n)> E 0 and D(0) had to be changed to achieve monotonicity, a warning error is returned. =back Set C<$mflag = 0> if interpolant is required to be monotonic in each interval, regardless of monotonicity of data. This causes C<$d> to be set to 0 at all switch points. NOTES: =over =item * This will cause D to be set to zero at all switch points, thus forcing extrema there. =item * The result of using this option with the default boundary conditions will be identical to using DPCHIM, but will generally cost more compute time. This option is provided only to facilitate comparison of different switch and/or boundary conditions. =back =item vc See ic for details =item mflag Set to non-zero to use a formula based on the 3-point difference formula at switch points. If C<$mflag E 0>, then the interpolant at switch points is forced to not deviate from the data by more than C<$mflag*dfloc>, where C is the maximum of the change of C<$f> on this interval and its two immediate neighbours. If C<$mflag E 0>, no such control is to be imposed. =item x array of independent variable values. The elements of X must be strictly increasing: X(I-1) .LT. X(I), I = 2(1)N. (Error return if not.) =item f array of dependent variable values to be interpolated. F(I) is value corresponding to X(I). =item d array of derivative values at the data points. These values will determine a monotone cubic Hermite function on each subinterval on which the data are monotonic, except possibly adjacent to switches in monotonicity. The value corresponding to X(I) is stored in D(I). No other entries in D are changed. =item ierr Error status: =over =item * 0 if successful. =item * 1 if C 0> and C had to be adjusted for monotonicity. =item * 2 if C 0> and C had to be adjusted for monotonicity. =item * 3 if both 1 and 2 are true. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 5>. =item * -5 if C 5>. =item * -6 if both -4 and -5 are true. =item * -7 if C 2*(n-1)>. =back (The D-array has not been changed in any of these cases.) NOTE: The above errors are checked in the order listed, and following arguments have B been validated. =back Broadcasts over its inputs. =for bad C 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 *pchip_chic = \&PDL::pchip_chic; =head2 pchip_chsp =for sig Signature: (sbyte ic(two=2); vc(two=2); x(n); f(n); [o]d(n); indx [o]ierr(); [t]dx(n); [t]dy_dx(n); ) Types: (float double ldouble) =for usage ($d, $ierr) = pchip_chsp($ic, $vc, $x, $f); pchip_chsp($ic, $vc, $x, $f, $d, $ierr); # all arguments given ($d, $ierr) = $ic->pchip_chsp($vc, $x, $f); # method call $ic->pchip_chsp($vc, $x, $f, $d, $ierr); =for ref Calculate the derivatives of (x,f(x)) using cubic spline interpolation. Computes the Hermite representation of the cubic spline interpolant to the data given in (C<$x,$f>), with the specified boundary conditions. Control over the boundary conditions is given by the C<$ic> and C<$vc> ndarrays. The resulting values - C<$x,$f,$d> - can be used in all the functions which expect a cubic Hermite function, including L. References: Carl de Boor, A Practical Guide to Splines, Springer-Verlag, New York, 1978, pp. 53-59. =pod =head3 Parameters =over =item ic The first and second elements determine the boundary conditions at the start and end of the data respectively. The allowed values for C are: =over =item * 0 to set C so that the third derivative is continuous at C. =item * 1 if first derivative at C is given in C). =item * 2 if second derivative at C) is given in C. =item * 3 to use the 3-point difference formula for C. (Reverts to the default b.c. if C 3>.) =item * 4 to use the 4-point difference formula for C. (Reverts to the default b.c. if C 4>.) =back The values for C are the same as above, except that the first-derivative value is stored in C for cases 1 and 2. The values of C<$vc> need only be set if options 1 or 2 are chosen for C<$ic>. NOTES: For the "natural" boundary condition, use IC(n)=2 and VC(n)=0. =item vc See ic for details =item ierr Error status: =over =item * 0 if successful. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 0> or C 4>. =item * -5 if C 0> or C 4>. =item * -6 if both of the above are true. =item * -7 if C 2*n>. NOTE: The above errors are checked in the order listed, and following arguments have B been validated. (The D-array has not been changed in any of these cases.) =item * -8 in case of trouble solving the linear system for the interior derivative values. (The D-array may have been changed in this case. Do B use it!) =back =back Broadcasts over its inputs. =for bad C 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 *pchip_chsp = \&PDL::pchip_chsp; =head2 pchip_chfd =for sig Signature: (x(n); f(n); d(n); xe(ne); [o] fe(ne); [o] de(ne); indx [o] ierr(); int [o] skip()) Types: (float double ldouble) =for usage ($fe, $de, $ierr, $skip) = pchip_chfd($x, $f, $d, $xe); pchip_chfd($x, $f, $d, $xe, $fe, $de, $ierr, $skip); # all arguments given ($fe, $de, $ierr, $skip) = $x->pchip_chfd($f, $d, $xe); # method call $x->pchip_chfd($f, $d, $xe, $fe, $de, $ierr, $skip); =for ref Evaluate a piecewise cubic Hermite function and its first derivative at an array of points. May be used by itself for Hermite interpolation, or as an evaluator for DPCHIM or DPCHIC. Given a piecewise cubic Hermite function - such as from L - evaluate the function (C<$fe>) and derivative (C<$de>) at a set of points (C<$xe>). If function values alone are required, use L. =pod =head3 Parameters =over =item xe array of points at which the functions are to be evaluated. NOTES: =over =item 1 The evaluation will be most efficient if the elements of XE are increasing relative to X; that is, XE(J) .GE. X(I) implies XE(K) .GE. X(I), all K.GE.J . =item 2 If any of the XE are outside the interval [X(1),X(N)], values are extrapolated from the nearest extreme cubic, and a warning error is returned. =back =item fe array of values of the cubic Hermite function defined by N, X, F, D at the points XE. =item de array of values of the first derivative of the same function at the points XE. =item ierr Error status: =over =item * 0 if successful. =item * E0 if extrapolation was performed at C points (data still valid). =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 1>. =item * -5 if an error has occurred in a lower-level routine, which should never happen. =back =item skip Set to 1 to skip checks on the input data. This will save time in case these checks have already been performed (say, in L or L). Will be set to TRUE on normal return. =back Broadcasts over its inputs. =for bad C 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 *pchip_chfd = \&PDL::pchip_chfd; =head2 pchip_chfe =for sig Signature: (x(n); f(n); d(n); xe(ne); [o] fe(ne); indx [o] ierr(); int [o] skip()) Types: (float double ldouble) =for usage ($fe, $ierr, $skip) = pchip_chfe($x, $f, $d, $xe); pchip_chfe($x, $f, $d, $xe, $fe, $ierr, $skip); # all arguments given ($fe, $ierr, $skip) = $x->pchip_chfe($f, $d, $xe); # method call $x->pchip_chfe($f, $d, $xe, $fe, $ierr, $skip); =for ref Evaluate a piecewise cubic Hermite function at an array of points. May be used by itself for Hermite interpolation, or as an evaluator for L or L. Given a piecewise cubic Hermite function - such as from L - evaluate the function (C<$fe>) at a set of points (C<$xe>). If derivative values are also required, use L. =pod =head3 Parameters =over =item x array of independent variable values. The elements of X must be strictly increasing: X(I-1) .LT. X(I), I = 2(1)N. (Error return if not.) =item f array of function values. F(I) is the value corresponding to X(I). =item d array of derivative values. D(I) is the value corresponding to X(I). =item xe array of points at which the function is to be evaluated. NOTES: =over =item 1 The evaluation will be most efficient if the elements of XE are increasing relative to X; that is, XE(J) .GE. X(I) implies XE(K) .GE. X(I), all K.GE.J . =item 2 If any of the XE are outside the interval [X(1),X(N)], values are extrapolated from the nearest extreme cubic, and a warning error is returned. =back =item fe array of values of the cubic Hermite function defined by N, X, F, D at the points XE. =item ierr Error status returned by C<$>: =over =item * 0 if successful. =item * E0 if extrapolation was performed at C points (data still valid). =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 1>. =back (The FE-array has not been changed in any of these cases.) NOTE: The above errors are checked in the order listed, and following arguments have B been validated. =item skip Set to 1 to skip checks on the input data. This will save time in case these checks have already been performed (say, in L or L). Will be set to TRUE on normal return. =back Broadcasts over its inputs. =for bad C 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 *pchip_chfe = \&PDL::pchip_chfe; =head2 pchip_chia =for sig Signature: (x(n); f(n); d(n); la(); lb(); [o]ans(); indx [o]ierr(); int [o]skip()) Types: (float double ldouble) =for usage ($ans, $ierr, $skip) = pchip_chia($x, $f, $d, $la, $lb); pchip_chia($x, $f, $d, $la, $lb, $ans, $ierr, $skip); # all arguments given ($ans, $ierr, $skip) = $x->pchip_chia($f, $d, $la, $lb); # method call $x->pchip_chia($f, $d, $la, $lb, $ans, $ierr, $skip); =for ref Integrate (x,f(x)) over arbitrary limits. Evaluate the definite integral of a piecewise cubic Hermite function over an arbitrary interval, given by C<[$la,$lb]>. =pod =head3 Parameters =over =item x array of independent variable values. The elements of X must be strictly increasing (error return if not): X(I-1) .LT. X(I), I = 2(1)N. =item f array of function values. F(I) is the value corresponding to X(I). =item d should contain the derivative values, computed by L. See L if the integration limits are data points. =item la The values of C<$la> and C<$lb> do not have to lie within C<$x>, although the resulting integral value will be highly suspect if they are not. =item lb See la =item ierr Error status: =over =item * 0 if successful. =item * 1 if C<$la> lies outside C<$x>. =item * 2 if C<$lb> lies outside C<$x>. =item * 3 if both 1 and 2 are true. (Note that this means that either [A,B] contains data interval or the intervals do not intersect at all.) =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if an error has occurred in a lower-level routine, which should never happen. =back =item skip Set to 1 to skip checks on the input data. This will save time in case these checks have already been performed (say, in L or L). Will be set to TRUE on return with IERR E= 0. =back Broadcasts over its inputs. =for bad C 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 *pchip_chia = \&PDL::pchip_chia; =head2 pchip_chid =for sig Signature: (x(n); f(n); d(n); indx ia(); indx ib(); [o]ans(); indx [o]ierr(); int [o]skip()) Types: (float double ldouble) =for usage ($ans, $ierr, $skip) = pchip_chid($x, $f, $d, $ia, $ib); pchip_chid($x, $f, $d, $ia, $ib, $ans, $ierr, $skip); # all arguments given ($ans, $ierr, $skip) = $x->pchip_chid($f, $d, $ia, $ib); # method call $x->pchip_chid($f, $d, $ia, $ib, $ans, $ierr, $skip); =for ref Evaluate the definite integral of a piecewise cubic Hermite function over an interval whose endpoints are data points. Evaluate the definite integral of a a piecewise cubic Hermite function between C and C. See L for integration between arbitrary limits. =pod =head3 Parameters =over =item x array of independent variable values. The elements of X must be strictly increasing: X(I-1) .LT. X(I), I = 2(1)N. (Error return if not.) It is a fatal error to pass in data with C E 2. =item f array of function values. F(I) is the value corresponding to X(I). =item d should contain the derivative values, computed by L. =item ia IA,IB -- (input) indices in X-array for the limits of integration. both must be in the range [0,N-1] (this is different from the Fortran version) - error return if not. No restrictions on their relative values. =item ib See ia for details =item ierr Error status - this will be set, but an exception will also be thrown: =over =item * 0 if successful. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C<$ia> or C<$ib> is out of range. =back (VALUE will be zero in any of these cases.) NOTE: The above errors are checked in the order listed, and following arguments have B been validated. =item skip Set to 1 to skip checks on the input data. This will save time in case these checks have already been performed (say, in L or L). Will be set to TRUE on return with IERR of 0 or -4. =back Broadcasts over its inputs. =for bad C 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 *pchip_chid = \&PDL::pchip_chid; =head2 pchip_chbs =for sig Signature: (x(n); f(n); d(n); sbyte knotyp(); [o]t(nknots=CALC(2*$SIZE(n)+4)); [o]bcoef(ndim=CALC(2*$SIZE(n))); indx [o]ierr()) Types: (float double ldouble) =for usage ($t, $bcoef, $ierr) = pchip_chbs($x, $f, $d, $knotyp); pchip_chbs($x, $f, $d, $knotyp, $t, $bcoef, $ierr); # all arguments given ($t, $bcoef, $ierr) = $x->pchip_chbs($f, $d, $knotyp); # method call $x->pchip_chbs($f, $d, $knotyp, $t, $bcoef, $ierr); =for ref Piecewise Cubic Hermite function to B-Spline converter. Computes the B-spline representation of the PCH function determined by N,X,F,D. The output is the B-representation for the function: NKNOTS, T, BCOEF, NDIM, KORD. L, L, or L can be used to determine an interpolating PCH function from a set of data. The B-spline routine L can be used to evaluate the resulting B-spline representation of the data (i.e. C, C, C, C, and C). Caution: Since it is assumed that the input PCH function has been computed by one of the other routines in the package PCHIP, input arguments N, X are B checked for validity. Restrictions/assumptions: =over =item C<1> N.GE.2 . (not checked) =item C<2> X(i).LT.X(i+1), i=1,...,N . (not checked) =item C<4> KNOTYP.LE.2 . (error return if not) =item C<6> T(2*k+1) = T(2*k) = X(k), k=1,...,N . (not checked) * Indicates this applies only if KNOTYP.LT.0 . =back References: F. N. Fritsch, "Representations for parametric cubic splines," Computer Aided Geometric Design 6 (1989), pp.79-82. =pod =head3 Parameters =over =item f the array of dependent variable values. C is the value corresponding to C. =item d the array of derivative values at the data points. C is the value corresponding to C. =item knotyp flag which controls the knot sequence. The knot sequence C is normally computed from C<$x> by putting a double knot at each C and setting the end knot pairs according to the value of C (where C): =over =item * 0 - Quadruple knots at the first and last points. =item * 1 - Replicate lengths of extreme subintervals: C and C =item * 2 - Periodic placement of boundary knots: C and C =item * E0 - Assume the C and C were set in a previous call. This option is provided for improved efficiency when used in a parametric setting. =back =item t the array of C<2*n+4> knots for the B-representation and may be changed by the routine. If C= 0>, C will be changed so that the interior double knots are equal to the x-values and the boundary knots set as indicated above, otherwise it is assumed that C was set by a previous call (no check is made to verify that the data forms a legitimate knot sequence). =item bcoef the array of 2*N B-spline coefficients. =item ierr Error status: =over =item * 0 if successful. =item * -4 if C 2>. (recoverable) =item * -5 if C 0> and C. (recoverable) =back =back Broadcasts over its inputs. =for bad C 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 *pchip_chbs = \&PDL::pchip_chbs; =head2 pchip_bvalu =for sig Signature: (t(nplusk); a(n); indx ideriv(); x(); [o]ans(); indx [o] inbv(); [t] work(k3=CALC(3*($SIZE(nplusk)-$SIZE(n))));) Types: (float double ldouble) =for usage ($ans, $inbv) = pchip_bvalu($t, $a, $ideriv, $x); pchip_bvalu($t, $a, $ideriv, $x, $ans, $inbv); # all arguments given ($ans, $inbv) = $t->pchip_bvalu($a, $ideriv, $x); # method call $t->pchip_bvalu($a, $ideriv, $x, $ans, $inbv); =for ref Evaluate the B-representation of a B-spline at X for the function value or any of its derivatives. Evaluates the B-representation C<(T,A,N,K)> of a B-spline at C for the function value on C or any of its derivatives on C. Right limiting values (right derivatives) are returned except at the right end point C where left limiting values are computed. The spline is defined on C. BVALU returns a fatal error message when C is outside of this interval. To compute left derivatives or left limiting values at a knot C, replace C by C and set C, C. References: Carl de Boor, Package for calculating with B-splines, SIAM Journal on Numerical Analysis 14, 3 (June 1977), pp. 441-472. =pod =head3 Parameters =over =item t knot vector of length N+K =item a B-spline coefficient vector of length N, the number of B-spline coefficients; N = sum of knot multiplicities-K =item ideriv order of the derivative, 0 .LE. IDERIV .LE. K-1 IDERIV=0 returns the B-spline value =item x T(K) .LE. X .LE. T(N+1) =item ans value of the IDERIV-th derivative at X =item inbv contains information for efficient processing after the initial call and INBV must not be changed by the user. Distinct splines require distinct INBV parameters. =back Broadcasts over its inputs. =for bad C 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 *pchip_bvalu = \&PDL::pchip_bvalu; #line 6328 "lib/PDL/Primitive.pd" =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Craig DeForest (deforest@boulder.swri.edu) and Jarle Brinchmann (jarle@astro.up.pt) All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. Updated for CPAN viewing compatibility by David Mertens. =cut #line 5775 "lib/PDL/Primitive.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/Ufunc.pm0000644000175000017500000014225314771136071015432 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Ufunc.pd! Don't modify! # package PDL::Ufunc; our @EXPORT_OK = qw(prodover dprodover cumuprodover dcumuprodover sumover dsumover cumusumover dcumusumover andover bandover borover bxorover firstnonzeroover orover xorover zcover numdiff diffcentred partial diff2 intover average avgover caverage cavgover daverage davgover minimum minover minimum_ind minover_ind minimum_n_ind minover_n_ind maximum maxover maximum_ind maxover_ind maximum_n_ind maxover_n_ind minmaximum minmaxover avg sum prod davg dsum dprod zcheck and band or bor xorall bxor min max median mode oddmedian any all minmax medover oddmedover modeover pctover oddpctover pct oddpct qsort qsorti qsortvec qsortveci magnover ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Ufunc ; #line 8 "lib/PDL/Ufunc.pd" use strict; use warnings; =encoding utf8 =head1 NAME PDL::Ufunc - primitive ufunc operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP based on functionality of what are sometimes called I (for example NumPY and Mathematica talk about these). It collects all the functions generally used to C or C along a dimension. These all do their job across the first dimension but by using the slicing functions you can do it on any dimension. The L module provides an alternative interface to many of the functions in this module. =head1 SYNOPSIS use PDL::Ufunc; =cut use PDL::Slices; use Carp; #line 59 "lib/PDL/Ufunc.pm" =head1 FUNCTIONS =cut =head2 prodover =for sig Signature: (a(n); int+ [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = prodover($a); prodover($a, $b); # all arguments given $b = $a->prodover; # method call $a->prodover($b); =for ref Project via product to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the product along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad C 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 *prodover = \&PDL::prodover; =head2 dprodover =for sig Signature: (a(n); double [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = dprodover($a); dprodover($a, $b); # all arguments given $b = $a->dprodover; # method call $a->dprodover($b); =for ref Project via product to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the product along the 1st dimension. By using L etc. it is possible to use I dimension. Unlike L, the calculations are performed in double precision. =pod Broadcasts over its inputs. =for bad C 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 *dprodover = \&PDL::dprodover; =head2 cumuprodover =for sig Signature: (a(n); int+ [o]b(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = cumuprodover($a); cumuprodover($a, $b); # all arguments given $b = $a->cumuprodover; # method call $a->cumuprodover($b); =for ref Cumulative product This function calculates the cumulative product along the 1st dimension. By using L etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative product is the first element of the parameter. =pod Broadcasts over its inputs. =for bad C 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 *cumuprodover = \&PDL::cumuprodover; =head2 dcumuprodover =for sig Signature: (a(n); double [o]b(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = dcumuprodover($a); dcumuprodover($a, $b); # all arguments given $b = $a->dcumuprodover; # method call $a->dcumuprodover($b); =for ref Cumulative product This function calculates the cumulative product along the 1st dimension. By using L etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative product is the first element of the parameter. Unlike L, the calculations are performed in double precision. =pod Broadcasts over its inputs. =for bad C 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 *dcumuprodover = \&PDL::dcumuprodover; =head2 sumover =for sig Signature: (a(n); int+ [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = sumover($a); sumover($a, $b); # all arguments given $b = $a->sumover; # method call $a->sumover($b); =for ref Project via sum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the sum along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad C 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 *sumover = \&PDL::sumover; =head2 dsumover =for sig Signature: (a(n); double [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = dsumover($a); dsumover($a, $b); # all arguments given $b = $a->dsumover; # method call $a->dsumover($b); =for ref Project via sum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the sum along the 1st dimension. By using L etc. it is possible to use I dimension. Unlike L, the calculations are performed in double precision. =pod Broadcasts over its inputs. =for bad C 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 *dsumover = \&PDL::dsumover; =head2 cumusumover =for sig Signature: (a(n); int+ [o]b(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = cumusumover($a); cumusumover($a, $b); # all arguments given $b = $a->cumusumover; # method call $a->cumusumover($b); =for ref Cumulative sum This function calculates the cumulative sum along the 1st dimension. By using L etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative sum is the first element of the parameter. =pod Broadcasts over its inputs. =for bad C 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 *cumusumover = \&PDL::cumusumover; =head2 dcumusumover =for sig Signature: (a(n); double [o]b(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = dcumusumover($a); dcumusumover($a, $b); # all arguments given $b = $a->dcumusumover; # method call $a->dcumusumover($b); =for ref Cumulative sum This function calculates the cumulative sum along the 1st dimension. By using L etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative sum is the first element of the parameter. Unlike L, the calculations are performed in double precision. =pod Broadcasts over its inputs. =for bad C 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 *dcumusumover = \&PDL::dcumusumover; =head2 andover =for sig Signature: (a(n); [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = andover($a); andover($a, $b); # all arguments given $b = $a->andover; # method call $a->andover($b); =for ref Project via logical and to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the logical and along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *andover = \&PDL::andover; =head2 bandover =for sig Signature: (a(n); [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $b = bandover($a); bandover($a, $b); # all arguments given $b = $a->bandover; # method call $a->bandover($b); =for ref Project via bitwise and to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the bitwise and along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *bandover = \&PDL::bandover; =head2 borover =for sig Signature: (a(n); [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $b = borover($a); borover($a, $b); # all arguments given $b = $a->borover; # method call $a->borover($b); =for ref Project via bitwise or to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the bitwise or along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *borover = \&PDL::borover; =head2 bxorover =for sig Signature: (a(n); [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $b = bxorover($a); bxorover($a, $b); # all arguments given $b = $a->bxorover; # method call $a->bxorover($b); =for ref Project via bitwise xor to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the bitwise xor along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *bxorover = \&PDL::bxorover; =head2 firstnonzeroover =for sig Signature: (a(n); [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = firstnonzeroover($a); firstnonzeroover($a, $b); # all arguments given $b = $a->firstnonzeroover; # method call $a->firstnonzeroover($b); =for ref Project via first non-zero value to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the first non-zero value along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *firstnonzeroover = \&PDL::firstnonzeroover; =head2 orover =for sig Signature: (a(n); [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = orover($a); orover($a, $b); # all arguments given $b = $a->orover; # method call $a->orover($b); =for ref Project via logical or to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the logical or along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *orover = \&PDL::orover; =head2 xorover =for sig Signature: (a(n); [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = xorover($a); xorover($a, $b); # all arguments given $b = $a->xorover; # method call $a->xorover($b); =for ref Project via logical xor to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the logical xor along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *xorover = \&PDL::xorover; =head2 zcover =for sig Signature: (a(n); [o] b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = zcover($a); zcover($a, $b); # all arguments given $b = $a->zcover; # method call $a->zcover($b); =for ref Project via == 0 to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the == 0 along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut *zcover = \&PDL::zcover; =head2 numdiff =for sig Signature: (x(t); [o]dx(t)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $dx = numdiff($x); numdiff($x, $dx); # all arguments given $dx = $x->numdiff; # method call $x->numdiff($dx); $x->inplace->numdiff; # can be used inplace numdiff($x->inplace); =for ref Numerical differencing. DX(t) = X(t) - X(t-1), DX(0) = X(0). Combined with C, can be used for backward differencing. Unlike L, output vector is same length. Originally by Maggie J. Xiong. Compare to L, which acts as the converse of this. See also L, L, L, L. =pod Broadcasts over its inputs. =for bad C 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 *numdiff = \&PDL::numdiff; =head2 diffcentred =for sig Signature: (a(n); [o]o(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $o = diffcentred($a); diffcentred($a, $o); # all arguments given $o = $a->diffcentred; # method call $a->diffcentred($o); =for ref Calculates centred differences along a vector's 0th dimension. Always periodic on boundaries; currently to change this, you must pad your data, and/or trim afterwards. This is so that when using with L, the size of data stays the same and therefore compatible if differentiated along different dimensions, e.g. calculating "curl". By using L etc. it is possible to use I dimension. See also L, L, L, L. =pod Broadcasts over its inputs. =for bad A bad value at C means the affected output values at C,C (if in boounds) are set bad. =cut *diffcentred = \&PDL::diffcentred; #line 248 "lib/PDL/Ufunc.pd" =head2 partial =for ref Take a numerical partial derivative along a given dimension, either forward, backward, or centred. See also L, L, L, L, and L, which are currently used to implement this. Can be used to implement divergence and curl calculations (adapted from Luis Mochán's work at https://sourceforge.net/p/pdl/mailman/message/58843767/): use v5.36; use PDL; sub curl ($f) { my ($f0, $f1, $f2) = $f->using(0..2); my $o = {dir=>'c'}; pdl( $f2->partial(1,$o) - $f1->partial(2,$o), $f0->partial(2,$o) - $f2->partial(0,$o), $f1->partial(0,$o) - $f0->partial(1,$o), )->mv(-1,0); } sub div ($f) { my ($f0, $f1, $f2) = $f->using(0..2); my $o = {dir=>'c'}; $f0->partial(0,$o) + $f1->partial(1,$o) + $f2->partial(2,$o); } sub trim3d ($f) { $f->slice(':,1:-2,1:-2,1:-2') } # adjust if change "dir" my $z=zeroes(5,5,5); my $v=pdl(-$z->yvals, $z->xvals, $z->zvals)->mv(-1,0); say trim3d(curl($v)); say div($v); =for usage $pdl->partial(2); # along dim 2, centred $pdl->partial(2, {d=>'c'}); # along dim 2, centred $pdl->partial(2, {d=>'f'}); # along dim 2, forward $pdl->partial(2, {d=>'b'}); # along dim 2, backward $pdl->partial(2, {d=>'p'}); # along dim 2, piecewise cubic Hermite $pdl->partial(2, {d=>'s'}); # along dim 2, cubic spline =cut my %dirtype2func = ( f => \&numdiff, b => sub { $_[0]->slice('-1:0')->numdiff }, c => \&diffcentred, p => sub {(PDL::Primitive::pchip_chim($_[0]->xvals, $_[0]))[0]}, s => sub {(PDL::Primitive::pchip_chsp([0,0], [0,0], $_[0]->xvals, $_[0]))[0]}, ); *partial = \&PDL::partial; sub PDL::partial { my ($f, $dim, $opts) = @_; $opts ||= {}; my $difftype = $opts->{dir} || $opts->{d} || 'c'; my $func = $dirtype2func{$difftype} || barf "partial: unknown 'dir' option '$difftype', only know (@{[sort keys %dirtype2func]})"; $f = $f->mv($dim, 0) if $dim; my $ret = $f->$func; $dim ? $ret->mv(0, $dim) : $ret; } #line 996 "lib/PDL/Ufunc.pm" =head2 diff2 =for sig Signature: (a(n); [o]o(nminus1=CALC($SIZE(n) - 1))) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $o = diff2($a); diff2($a, $o); # all arguments given $o = $a->diff2; # method call $a->diff2($o); =for ref Numerically forward differentiates a vector along 0th dimension. By using L etc. it is possible to use I dimension. Unlike L, output vector is one shorter. Combined with C, can be used for backward differencing. See also L, L, L, L. =for example print pdl(q[3 4 2 3 2 3 1])->diff2; # [1 -2 1 -1 1 -2] =pod Broadcasts over its inputs. =for bad On bad value, output value is set bad. On next good value, output value is difference between that and last good value. =cut *diff2 = \&PDL::diff2; =head2 intover =for sig Signature: (a(n); float+ [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = intover($a); intover($a, $b); # all arguments given $b = $a->intover; # method call $a->intover($b); =for ref Project via integral to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the integral along the 1st dimension. By using L etc. it is possible to use I dimension. Notes: C uses a point spacing of one (i.e., delta-h==1). You will need to scale the result to correct for the true point delta. For C 3>, these are all C (like Simpson's rule), but are integrals between the end points assuming the pdl gives values just at these centres: for such `functions', sumover is correct to C, but is the natural (and correct) choice for binned data, of course. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *intover = \&PDL::intover; =head2 average =for sig Signature: (a(n); int+ [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = average($a); average($a, $b); # all arguments given $b = $a->average; # method call $a->average($b); =for ref Project via average to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the average along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad C 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 *average = \&PDL::average; #line 415 "lib/PDL/Ufunc.pd" =head2 avgover =for ref Synonym for L. =cut *PDL::avgover = *avgover = \&PDL::average; #line 1162 "lib/PDL/Ufunc.pm" =head2 caverage =for sig Signature: (a(n); cdouble [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = caverage($a); caverage($a, $b); # all arguments given $b = $a->caverage; # method call $a->caverage($b); =for ref Project via average to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the average along the 1st dimension. By using L etc. it is possible to use I dimension. Unlike L, the calculation is performed in complex double precision. =pod Broadcasts over its inputs. =for bad C 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 *caverage = \&PDL::caverage; #line 415 "lib/PDL/Ufunc.pd" =head2 cavgover =for ref Synonym for L. =cut *PDL::cavgover = *cavgover = \&PDL::caverage; #line 1224 "lib/PDL/Ufunc.pm" =head2 daverage =for sig Signature: (a(n); double [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = daverage($a); daverage($a, $b); # all arguments given $b = $a->daverage; # method call $a->daverage($b); =for ref Project via average to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the average along the 1st dimension. By using L etc. it is possible to use I dimension. Unlike L, the calculation is performed in double precision. =pod Broadcasts over its inputs. =for bad C 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 *daverage = \&PDL::daverage; #line 415 "lib/PDL/Ufunc.pd" =head2 davgover =for ref Synonym for L. =cut *PDL::davgover = *davgover = \&PDL::daverage; #line 1286 "lib/PDL/Ufunc.pm" =head2 minimum =for sig Signature: (a(n); [o]c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = minimum($a); minimum($a, $c); # all arguments given $c = $a->minimum; # method call $a->minimum($c); =for ref Project via minimum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the minimum along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad Output is set bad if no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut *minimum = \&PDL::minimum; #line 415 "lib/PDL/Ufunc.pd" =head2 minover =for ref Synonym for L. =cut *PDL::minover = *minover = \&PDL::minimum; #line 1349 "lib/PDL/Ufunc.pm" =head2 minimum_ind =for sig Signature: (a(n); indx [o] c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = minimum_ind($a); minimum_ind($a, $c); # all arguments given $c = $a->minimum_ind; # method call $a->minimum_ind($c); =for ref Like minimum but returns the first matching index rather than the value =pod Broadcasts over its inputs. =for bad Output is set bad if no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut *minimum_ind = \&PDL::minimum_ind; #line 415 "lib/PDL/Ufunc.pd" =head2 minover_ind =for ref Synonym for L. =cut *PDL::minover_ind = *minover_ind = \&PDL::minimum_ind; #line 1406 "lib/PDL/Ufunc.pm" =head2 minimum_n_ind =for sig Signature: (a(n); indx [o]c(m); PDL_Indx m_size => m) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref Returns the index of first C minimum elements. As of 2.077, you can specify how many by either passing in an ndarray of the given size (DEPRECATED - will be converted to indx if needed and the input arg will be set to that), or just the size, or a null and the size. =for usage minimum_n_ind($pdl, $out = zeroes(5)); # DEPRECATED $out = minimum_n_ind($pdl, 5); minimum_n_ind($pdl, $out = null, 5); =pod Broadcasts over its inputs. =for bad Output bad flag is cleared for the output ndarray if sufficient non-bad elements found, else remaining slots in C<$c()> are set bad. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut #line 515 "lib/PDL/Ufunc.pd" sub PDL::minimum_n_ind { my ($a, $c, $m_size) = @_; $m_size //= ref($c) ? $c->dim(0) : $c; # back-compat with pre-2.077 my $set_out = 1; $set_out = 0, $c = null if !ref $c; $c = $c->indx if !$c->isnull; PDL::_minimum_n_ind_int($a, $c, $m_size); $set_out ? $_[1] = $c : $c; } #line 1459 "lib/PDL/Ufunc.pm" *minimum_n_ind = \&PDL::minimum_n_ind; #line 415 "lib/PDL/Ufunc.pd" =head2 minover_n_ind =for ref Synonym for L. =cut *PDL::minover_n_ind = *minover_n_ind = \&PDL::minimum_n_ind; #line 1478 "lib/PDL/Ufunc.pm" =head2 maximum =for sig Signature: (a(n); [o]c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = maximum($a); maximum($a, $c); # all arguments given $c = $a->maximum; # method call $a->maximum($c); =for ref Project via maximum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the maximum along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad Output is set bad if no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut *maximum = \&PDL::maximum; #line 415 "lib/PDL/Ufunc.pd" =head2 maxover =for ref Synonym for L. =cut *PDL::maxover = *maxover = \&PDL::maximum; #line 1541 "lib/PDL/Ufunc.pm" =head2 maximum_ind =for sig Signature: (a(n); indx [o] c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = maximum_ind($a); maximum_ind($a, $c); # all arguments given $c = $a->maximum_ind; # method call $a->maximum_ind($c); =for ref Like maximum but returns the first matching index rather than the value =pod Broadcasts over its inputs. =for bad Output is set bad if no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut *maximum_ind = \&PDL::maximum_ind; #line 415 "lib/PDL/Ufunc.pd" =head2 maxover_ind =for ref Synonym for L. =cut *PDL::maxover_ind = *maxover_ind = \&PDL::maximum_ind; #line 1598 "lib/PDL/Ufunc.pm" =head2 maximum_n_ind =for sig Signature: (a(n); indx [o]c(m); PDL_Indx m_size => m) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for ref Returns the index of first C maximum elements. As of 2.077, you can specify how many by either passing in an ndarray of the given size (DEPRECATED - will be converted to indx if needed and the input arg will be set to that), or just the size, or a null and the size. =for usage maximum_n_ind($pdl, $out = zeroes(5)); # DEPRECATED $out = maximum_n_ind($pdl, 5); maximum_n_ind($pdl, $out = null, 5); =pod Broadcasts over its inputs. =for bad Output bad flag is cleared for the output ndarray if sufficient non-bad elements found, else remaining slots in C<$c()> are set bad. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut #line 515 "lib/PDL/Ufunc.pd" sub PDL::maximum_n_ind { my ($a, $c, $m_size) = @_; $m_size //= ref($c) ? $c->dim(0) : $c; # back-compat with pre-2.077 my $set_out = 1; $set_out = 0, $c = null if !ref $c; $c = $c->indx if !$c->isnull; PDL::_maximum_n_ind_int($a, $c, $m_size); $set_out ? $_[1] = $c : $c; } #line 1651 "lib/PDL/Ufunc.pm" *maximum_n_ind = \&PDL::maximum_n_ind; #line 415 "lib/PDL/Ufunc.pd" =head2 maxover_n_ind =for ref Synonym for L. =cut *PDL::maxover_n_ind = *maxover_n_ind = \&PDL::maximum_n_ind; #line 1670 "lib/PDL/Ufunc.pm" =head2 minmaximum =for sig Signature: (a(n); [o]cmin(); [o] cmax(); indx [o]cmin_ind(); indx [o]cmax_ind()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($cmin, $cmax, $cmin_ind, $cmax_ind) = minmaximum($a); minmaximum($a, $cmin, $cmax, $cmin_ind, $cmax_ind); # all arguments given ($cmin, $cmax, $cmin_ind, $cmax_ind) = $a->minmaximum; # method call $a->minmaximum($cmin, $cmax, $cmin_ind, $cmax_ind); =for ref Find minimum and maximum and their indices for a given ndarray; =for example pdl> $x=pdl [[-2,3,4],[1,0,3]] pdl> ($min, $max, $min_ind, $max_ind)=minmaximum($x) pdl> p $min, $max, $min_ind, $max_ind [-2 0] [4 3] [0 1] [2 2] See also L, which clumps the ndarray together. =pod Broadcasts over its inputs. =for bad If C contains only bad data, then the output ndarrays will be set bad, along with their bad flag. Otherwise they will have their bad flags cleared, since they will not contain any bad values. =cut *minmaximum = \&PDL::minmaximum; #line 415 "lib/PDL/Ufunc.pd" =head2 minmaxover =for ref Synonym for L. =cut *PDL::minmaxover = *minmaxover = \&PDL::minmaximum; #line 648 "lib/PDL/Ufunc.pd" =head2 avg =for ref Return the average of all elements in an ndarray. See the documentation for L for more information. =for usage $x = avg($data); =for bad This routine handles bad values. =cut *avg = \&PDL::avg; sub PDL::avg { $_[0]->flat->average } #line 648 "lib/PDL/Ufunc.pd" =head2 sum =for ref Return the sum of all elements in an ndarray. See the documentation for L for more information. =for usage $x = sum($data); =for bad This routine handles bad values. =cut *sum = \&PDL::sum; sub PDL::sum { $_[0]->flat->sumover } #line 648 "lib/PDL/Ufunc.pd" =head2 prod =for ref Return the product of all elements in an ndarray. See the documentation for L for more information. =for usage $x = prod($data); =for bad This routine handles bad values. =cut *prod = \&PDL::prod; sub PDL::prod { $_[0]->flat->prodover } #line 648 "lib/PDL/Ufunc.pd" =head2 davg =for ref Return the average (in double precision) of all elements in an ndarray. See the documentation for L for more information. =for usage $x = davg($data); =for bad This routine handles bad values. =cut *davg = \&PDL::davg; sub PDL::davg { $_[0]->flat->daverage } #line 648 "lib/PDL/Ufunc.pd" =head2 dsum =for ref Return the sum (in double precision) of all elements in an ndarray. See the documentation for L for more information. =for usage $x = dsum($data); =for bad This routine handles bad values. =cut *dsum = \&PDL::dsum; sub PDL::dsum { $_[0]->flat->dsumover } #line 648 "lib/PDL/Ufunc.pd" =head2 dprod =for ref Return the product (in double precision) of all elements in an ndarray. See the documentation for L for more information. =for usage $x = dprod($data); =for bad This routine handles bad values. =cut *dprod = \&PDL::dprod; sub PDL::dprod { $_[0]->flat->dprodover } #line 648 "lib/PDL/Ufunc.pd" =head2 zcheck =for ref Return the check for zero of all elements in an ndarray. See the documentation for L for more information. =for usage $x = zcheck($data); =for bad This routine handles bad values. =cut *zcheck = \&PDL::zcheck; sub PDL::zcheck { $_[0]->flat->zcover } #line 648 "lib/PDL/Ufunc.pd" =head2 and =for ref Return the logical and of all elements in an ndarray. See the documentation for L for more information. =for usage $x = and($data); =for bad This routine handles bad values. =cut *and = \&PDL::and; sub PDL::and { $_[0]->flat->andover } #line 648 "lib/PDL/Ufunc.pd" =head2 band =for ref Return the bitwise and of all elements in an ndarray. See the documentation for L for more information. =for usage $x = band($data); =for bad This routine handles bad values. =cut *band = \&PDL::band; sub PDL::band { $_[0]->flat->bandover } #line 648 "lib/PDL/Ufunc.pd" =head2 or =for ref Return the logical or of all elements in an ndarray. See the documentation for L for more information. =for usage $x = or($data); =for bad This routine handles bad values. =cut *or = \&PDL::or; sub PDL::or { $_[0]->flat->orover } #line 648 "lib/PDL/Ufunc.pd" =head2 bor =for ref Return the bitwise or of all elements in an ndarray. See the documentation for L for more information. =for usage $x = bor($data); =for bad This routine handles bad values. =cut *bor = \&PDL::bor; sub PDL::bor { $_[0]->flat->borover } #line 648 "lib/PDL/Ufunc.pd" =head2 xorall =for ref Return the logical xor of all elements in an ndarray. See the documentation for L for more information. =for usage $x = xorall($data); =for bad This routine handles bad values. =cut *xorall = \&PDL::xorall; sub PDL::xorall { $_[0]->flat->xorover } #line 648 "lib/PDL/Ufunc.pd" =head2 bxor =for ref Return the bitwise xor of all elements in an ndarray. See the documentation for L for more information. =for usage $x = bxor($data); =for bad This routine handles bad values. =cut *bxor = \&PDL::bxor; sub PDL::bxor { $_[0]->flat->bxorover } #line 648 "lib/PDL/Ufunc.pd" =head2 min =for ref Return the minimum of all elements in an ndarray. See the documentation for L for more information. =for usage $x = min($data); =for bad This routine handles bad values. =cut *min = \&PDL::min; sub PDL::min { $_[0]->flat->minimum } #line 648 "lib/PDL/Ufunc.pd" =head2 max =for ref Return the maximum of all elements in an ndarray. See the documentation for L for more information. =for usage $x = max($data); =for bad This routine handles bad values. =cut *max = \&PDL::max; sub PDL::max { $_[0]->flat->maximum } #line 648 "lib/PDL/Ufunc.pd" =head2 median =for ref Return the median of all elements in an ndarray. See the documentation for L for more information. =for usage $x = median($data); =for bad This routine handles bad values. =cut *median = \&PDL::median; sub PDL::median { $_[0]->flat->medover } #line 648 "lib/PDL/Ufunc.pd" =head2 mode =for ref Return the mode of all elements in an ndarray. See the documentation for L for more information. =for usage $x = mode($data); =for bad This routine handles bad values. =cut *mode = \&PDL::mode; sub PDL::mode { $_[0]->flat->modeover } #line 648 "lib/PDL/Ufunc.pd" =head2 oddmedian =for ref Return the oddmedian of all elements in an ndarray. See the documentation for L for more information. =for usage $x = oddmedian($data); =for bad This routine handles bad values. =cut *oddmedian = \&PDL::oddmedian; sub PDL::oddmedian { $_[0]->flat->oddmedover } #line 674 "lib/PDL/Ufunc.pd" =head2 any =for ref Return true if any element in ndarray set Useful in conditional expressions: =for example if (any $x>15) { print "some values are greater than 15\n" } =for bad See L for comments on what happens when all elements in the check are bad. =cut *any = \∨ *PDL::any = \&PDL::or; =head2 all =for ref Return true if all elements in ndarray set Useful in conditional expressions: =for example if (all $x>15) { print "all values are greater than 15\n" } =for bad See L for comments on what happens when all elements in the check are bad. =cut *all = \∧ *PDL::all = \&PDL::and; =head2 minmax =for ref Returns a list with minimum and maximum values of an ndarray. =for usage ($mn, $mx) = minmax($pdl); This routine does I broadcast over the dimensions of C<$pdl>; it returns the minimum and maximum values of the whole ndarray. See L if this is not what is required. The two values are returned as Perl scalars, and therefore ignore whether the values are bad. =for example pdl> $x = pdl [1,-2,3,5,0] pdl> ($min, $max) = minmax($x); pdl> p "$min $max\n"; -2 5 =cut *minmax = \&PDL::minmax; sub PDL::minmax { map $_->sclr, ($_[0]->flat->minmaximum)[0,1] } #line 2222 "lib/PDL/Ufunc.pm" =head2 medover =for sig Signature: (a(n); [o]b(); [t]tmp(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = medover($a); medover($a, $b); # all arguments given $b = $a->medover; # method call $a->medover($b); =for ref Project via median to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the median along the 1st dimension. By using L etc. it is possible to use I dimension. =pod Broadcasts over its inputs. =for bad C 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 *medover = \&PDL::medover; =head2 oddmedover =for sig Signature: (a(n); [o]b(); [t]tmp(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = oddmedover($a); oddmedover($a, $b); # all arguments given $b = $a->oddmedover; # method call $a->oddmedover($b); =for ref Project via oddmedian to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the oddmedian along the 1st dimension. By using L etc. it is possible to use I dimension. The median is sometimes not a good choice as if the array has an even number of elements it lies half-way between the two middle values - thus it does not always correspond to a data value. The lower-odd median is just the lower of these two values and so it ALWAYS sits on an actual data value which is useful in some circumstances. =pod Broadcasts over its inputs. =for bad C 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 *oddmedover = \&PDL::oddmedover; =head2 modeover =for sig Signature: (data(n); [o]out(); [t]sorted(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $out = modeover($data); modeover($data, $out); # all arguments given $out = $data->modeover; # method call $data->modeover($out); =for ref Project via mode to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the mode along the 1st dimension. By using L etc. it is possible to use I dimension. The mode is the single element most frequently found in a discrete data set. It I makes sense for integer data types, since floating-point types are demoted to integer before the mode is calculated. C treats BAD the same as any other value: if BAD is the most common element, the returned value is also BAD. =pod Broadcasts over its inputs. =for bad C 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 *modeover = \&PDL::modeover; =head2 pctover =for sig Signature: (a(n); p(); [o]b(); [t]tmp(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = pctover($a, $p); pctover($a, $p, $b); # all arguments given $b = $a->pctover($p); # method call $a->pctover($p, $b); =for ref Project via specified percentile to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the specified percentile along the 1st dimension. By using L etc. it is possible to use I dimension. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. Values outside the allowed range are clipped to 0.0 or 1.0 respectively. The algorithm implemented here is based on the interpolation variant described at L as used by Microsoft Excel and recommended by NIST. =pod Broadcasts over its inputs. =for bad C 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 *pctover = \&PDL::pctover; =head2 oddpctover =for sig Signature: (a(n); p(); [o]b(); [t]tmp(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = oddpctover($a, $p); oddpctover($a, $p, $b); # all arguments given $b = $a->oddpctover($p); # method call $a->oddpctover($p, $b); =for ref Project via specified percentile to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the specified percentile along the 1st dimension. By using L etc. it is possible to use I dimension. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. The algorithm implemented is from the textbook version described first at L. =pod Broadcasts over its inputs. =for bad C 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 *oddpctover = \&PDL::oddpctover; #line 1022 "lib/PDL/Ufunc.pd" =head2 pct =for ref Return the specified percentile of all elements in an ndarray. The specified percentile (p) must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. =for usage $x = pct($data, $pct); =cut *pct = \&PDL::pct; sub PDL::pct { my($x, $p) = @_; $x->flat->pctover($p, my $tmp=PDL->nullcreate($x)); $tmp; } #line 1022 "lib/PDL/Ufunc.pd" =head2 oddpct =for ref Return the specified percentile of all elements in an ndarray. The specified percentile (p) must be between 0.0 and 1.0. When the specified percentile falls between data points, the nearest data value is the result. =for usage $x = oddpct($data, $pct); =cut *oddpct = \&PDL::oddpct; sub PDL::oddpct { my($x, $p) = @_; $x->flat->oddpctover($p, my $tmp=PDL->nullcreate($x)); $tmp; } #line 2530 "lib/PDL/Ufunc.pm" =head2 qsort =for sig Signature: (!complex a(n); !complex [o]b(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = qsort($a); qsort($a, $b); # all arguments given $b = $a->qsort; # method call $a->qsort($b); $a->inplace->qsort; # can be used inplace qsort($a->inplace); =for ref Quicksort a vector into ascending order. =pod Broadcasts over its inputs. =for bad Bad values are moved to the end of the array: pdl> p $y [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p qsort($y) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] =cut *qsort = \&PDL::qsort; =head2 qsorti =for sig Signature: (!complex a(n); indx [o]indx(n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $indx = qsorti($a); qsorti($a, $indx); # all arguments given $indx = $a->qsorti; # method call $a->qsorti($indx); =for ref Quicksort a vector and return index of elements in ascending order. =for example $ix = qsorti $x; print $x->index($ix); # Sorted list =pod Broadcasts over its inputs. =for bad Bad elements are moved to the end of the array: pdl> p $y [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p $y->index( qsorti($y) ) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] =cut *qsorti = \&PDL::qsorti; =head2 qsortvec =for sig Signature: (!complex a(n,m); !complex [o]b(n,m)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = qsortvec($a); qsortvec($a, $b); # all arguments given $b = $a->qsortvec; # method call $a->qsortvec($b); $a->inplace->qsortvec; # can be used inplace qsortvec($a->inplace); =for ref Sort a list of vectors lexicographically. The 0th dimension of the source ndarray is dimension in the vector; the 1st dimension is list order. Higher dimensions are broadcasted over. =for example print qsortvec pdl([[1,2],[0,500],[2,3],[4,2],[3,4],[3,5]]); [ [ 0 500] [ 1 2] [ 2 3] [ 3 4] [ 3 5] [ 4 2] ] =pod Broadcasts over its inputs. =for bad Vectors with bad components are moved to the end of the array: pdl> p $p = pdl("[0 0] [-100 0] [BAD 0] [100 0]")->qsortvec [ [-100 0] [ 0 0] [ 100 0] [ BAD 0] ] =cut *qsortvec = \&PDL::qsortvec; =head2 qsortveci =for sig Signature: (!complex a(n,m); indx [o]indx(m)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $indx = qsortveci($a); qsortveci($a, $indx); # all arguments given $indx = $a->qsortveci; # method call $a->qsortveci($indx); =for ref Sort a list of vectors lexicographically, returning the indices of the sorted vectors rather than the sorted list itself. As with C, the input PDL should be an NxM array containing M separate N-dimensional vectors. The return value is an integer M-PDL containing the M-indices of original array rows, in sorted order. As with C, the zeroth element of the vectors runs slowest in the sorted list. Additional dimensions are broadcasted over: each plane is sorted separately, so qsortveci may be thought of as a collapse operator of sorts (groan). =pod Broadcasts over its inputs. =for bad Vectors with bad components are moved to the end of the array as for L. =cut *qsortveci = \&PDL::qsortveci; =head2 magnover =for sig Signature: (a(n); float+ [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = magnover($a); magnover($a, $b); # all arguments given $b = $a->magnover; # method call $a->magnover($b); =for ref Project via Euclidean (aka Pythagorean) distance to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the Euclidean (aka Pythagorean) distance along the 1st dimension. By using L etc. it is possible to use I dimension. Minimum C precision output. See also L, L. =pod Broadcasts over its inputs. =for bad C 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 *magnover = \&PDL::magnover; #line 1266 "lib/PDL/Ufunc.pd" =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz) and Karl Glazebrook (kgb@aaoepp.aao.gov.au). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut #line 2808 "lib/PDL/Ufunc.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/Ops.pm0000644000175000017500000012760714771136062015121 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Ops.pd! Don't modify! # package PDL::Ops; our @EXPORT_OK = qw(log10 assgn carg conj czip ipow abs2 r2C i2C ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Ops ; { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '+' => $overload_sub = sub { Carp::confess("PDL::plus: overloaded '+' given undef") if grep !defined, @_[0,1]; return PDL::plus(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '+')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '+=' => sub { Carp::confess("PDL::plus: overloaded '+=' given undef") if grep !defined, @_[0,1]; PDL::plus($_[0]->inplace, $_[1]); $_[0] }; #line 44 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '*' => $overload_sub = sub { Carp::confess("PDL::mult: overloaded '*' given undef") if grep !defined, @_[0,1]; return PDL::mult(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '*')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '*=' => sub { Carp::confess("PDL::mult: overloaded '*=' given undef") if grep !defined, @_[0,1]; PDL::mult($_[0]->inplace, $_[1]); $_[0] }; #line 70 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '-' => $overload_sub = sub { Carp::confess("PDL::minus: overloaded '-' given undef") if grep !defined, @_[0,1]; return PDL::minus(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '-')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '-=' => sub { Carp::confess("PDL::minus: overloaded '-=' given undef") if grep !defined, @_[0,1]; PDL::minus($_[0]->inplace, $_[1]); $_[0] }; #line 96 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '/' => $overload_sub = sub { Carp::confess("PDL::divide: overloaded '/' given undef") if grep !defined, @_[0,1]; return PDL::divide(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '/')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '/=' => sub { Carp::confess("PDL::divide: overloaded '/=' given undef") if grep !defined, @_[0,1]; PDL::divide($_[0]->inplace, $_[1]); $_[0] }; #line 122 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '>' => $overload_sub = sub { Carp::confess("PDL::gt: overloaded '>' given undef") if grep !defined, @_[0,1]; return PDL::gt(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 140 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '<' => $overload_sub = sub { Carp::confess("PDL::lt: overloaded '<' given undef") if grep !defined, @_[0,1]; return PDL::lt(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 158 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '<=' => $overload_sub = sub { Carp::confess("PDL::le: overloaded '<=' given undef") if grep !defined, @_[0,1]; return PDL::le(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<=')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 176 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '>=' => $overload_sub = sub { Carp::confess("PDL::ge: overloaded '>=' given undef") if grep !defined, @_[0,1]; return PDL::ge(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>=')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 194 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '==' => $overload_sub = sub { Carp::confess("PDL::eq: overloaded '==' given undef") if grep !defined, @_[0,1]; return PDL::eq(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '==')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 212 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '!=' => $overload_sub = sub { Carp::confess("PDL::ne: overloaded '!=' given undef") if grep !defined, @_[0,1]; return PDL::ne(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '!=')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 230 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '<<' => $overload_sub = sub { Carp::confess("PDL::shiftleft: overloaded '<<' given undef") if grep !defined, @_[0,1]; return PDL::shiftleft(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<<')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '<<=' => sub { Carp::confess("PDL::shiftleft: overloaded '<<=' given undef") if grep !defined, @_[0,1]; PDL::shiftleft($_[0]->inplace, $_[1]); $_[0] }; #line 256 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '>>' => $overload_sub = sub { Carp::confess("PDL::shiftright: overloaded '>>' given undef") if grep !defined, @_[0,1]; return PDL::shiftright(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>>')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '>>=' => sub { Carp::confess("PDL::shiftright: overloaded '>>=' given undef") if grep !defined, @_[0,1]; PDL::shiftright($_[0]->inplace, $_[1]); $_[0] }; #line 282 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '|' => $overload_sub = sub { Carp::confess("PDL::or2: overloaded '|' given undef") if grep !defined, @_[0,1]; return PDL::or2($_[2]?@_[1,0]:@_[0,1]) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '|')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '|=' => sub { Carp::confess("PDL::or2: overloaded '|=' given undef") if grep !defined, @_[0,1]; PDL::or2($_[0]->inplace, $_[1]); $_[0] }; #line 308 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '&' => $overload_sub = sub { Carp::confess("PDL::and2: overloaded '&' given undef") if grep !defined, @_[0,1]; return PDL::and2($_[2]?@_[1,0]:@_[0,1]) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '&')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '&=' => sub { Carp::confess("PDL::and2: overloaded '&=' given undef") if grep !defined, @_[0,1]; PDL::and2($_[0]->inplace, $_[1]); $_[0] }; #line 334 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '^' => $overload_sub = sub { Carp::confess("PDL::xor: overloaded '^' given undef") if grep !defined, @_[0,1]; return PDL::xor($_[2]?@_[1,0]:@_[0,1]) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '^')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '^=' => sub { Carp::confess("PDL::xor: overloaded '^=' given undef") if grep !defined, @_[0,1]; PDL::xor($_[0]->inplace, $_[1]); $_[0] }; #line 360 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '**' => $overload_sub = sub { Carp::confess("PDL::power: overloaded '**' given undef") if grep !defined, @_[0,1]; return PDL::power(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '**')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '**=' => sub { Carp::confess("PDL::power: overloaded '**=' given undef") if grep !defined, @_[0,1]; PDL::power($_[0]->inplace, $_[1]); $_[0] }; #line 386 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload 'atan2' => $overload_sub = sub { Carp::confess("PDL::atan2: overloaded 'atan2' given undef") if grep !defined, @_[0,1]; return PDL::atan2(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], 'atan2')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 404 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '%' => $overload_sub = sub { Carp::confess("PDL::modulo: overloaded '%' given undef") if grep !defined, @_[0,1]; return PDL::modulo(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '%')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 1455 "lib/PDL/PP.pm" # in1, in2, out, swap if true use overload '%=' => sub { Carp::confess("PDL::modulo: overloaded '%=' given undef") if grep !defined, @_[0,1]; PDL::modulo($_[0]->inplace, $_[1]); $_[0] }; #line 430 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1440 "lib/PDL/PP.pm" { my ($foo, $overload_sub); use overload '<=>' => $overload_sub = sub { Carp::confess("PDL::spaceship: overloaded '<=>' given undef") if grep !defined, @_[0,1]; return PDL::spaceship(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<=>')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } #line 448 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1432 "lib/PDL/PP.pm" use overload '~' => sub { Carp::confess("PDL::bitnot: overloaded '~' given undef") if grep !defined, $_[0]; PDL::bitnot($_[0]); }; #line 459 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1432 "lib/PDL/PP.pm" use overload 'sqrt' => sub { Carp::confess("PDL::sqrt: overloaded 'sqrt' given undef") if grep !defined, $_[0]; PDL::sqrt($_[0]); }; #line 470 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1432 "lib/PDL/PP.pm" use overload 'sin' => sub { Carp::confess("PDL::sin: overloaded 'sin' given undef") if grep !defined, $_[0]; PDL::sin($_[0]); }; #line 481 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1432 "lib/PDL/PP.pm" use overload 'cos' => sub { Carp::confess("PDL::cos: overloaded 'cos' given undef") if grep !defined, $_[0]; PDL::cos($_[0]); }; #line 492 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1432 "lib/PDL/PP.pm" use overload '!' => sub { Carp::confess("PDL::not: overloaded '!' given undef") if grep !defined, $_[0]; PDL::not($_[0]); }; #line 503 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1432 "lib/PDL/PP.pm" use overload 'exp' => sub { Carp::confess("PDL::exp: overloaded 'exp' given undef") if grep !defined, $_[0]; PDL::exp($_[0]); }; #line 514 "lib/PDL/Ops.pm" } { package # hide from MetaCPAN PDL; #line 1432 "lib/PDL/PP.pm" use overload 'log' => sub { Carp::confess("PDL::log: overloaded 'log' given undef") if grep !defined, $_[0]; PDL::log($_[0]); }; #line 525 "lib/PDL/Ops.pm" } #line 20 "lib/PDL/Ops.pd" use strict; use warnings; =head1 NAME PDL::Ops - Fundamental mathematical operators =head1 DESCRIPTION This module provides the functions used by PDL to overload the basic mathematical operators (C<+ - / *> etc.) and functions (C etc.) It also includes the function C, which should be a perl function so that we can overload it! Matrix multiplication (the operator C) is handled by the module L. =head1 SYNOPSIS none =cut #line 560 "lib/PDL/Ops.pm" =head1 FUNCTIONS =cut =head2 plus =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = $a + $b; # overloads the Perl '+' operator $a += $b; $c = PDL::plus($a, $b); # using default value of swap=0 $c = PDL::plus($a, $b, $swap); # overriding default PDL::plus($a, $b, $c, $swap); # all arguments given $c = $a->plus($b); # method call $c = $a->plus($b, $swap); $a->plus($b, $c, $swap); $a->inplace->plus($b, $swap); # can be used inplace PDL::plus($a->inplace, $b, $swap); =for ref add two ndarrays =pod Broadcasts over its inputs. =for bad C 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 *plus = \&PDL::plus; =head2 mult =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = $a * $b; # overloads the Perl '*' operator $a *= $b; $c = PDL::mult($a, $b); # using default value of swap=0 $c = PDL::mult($a, $b, $swap); # overriding default PDL::mult($a, $b, $c, $swap); # all arguments given $c = $a->mult($b); # method call $c = $a->mult($b, $swap); $a->mult($b, $c, $swap); $a->inplace->mult($b, $swap); # can be used inplace PDL::mult($a->inplace, $b, $swap); =for ref multiply two ndarrays =pod Broadcasts over its inputs. =for bad C 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 *mult = \&PDL::mult; =head2 minus =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = $a - $b; # overloads the Perl '-' operator $a -= $b; $c = PDL::minus($a, $b); # using default value of swap=0 $c = PDL::minus($a, $b, $swap); # overriding default PDL::minus($a, $b, $c, $swap); # all arguments given $c = $a->minus($b); # method call $c = $a->minus($b, $swap); $a->minus($b, $c, $swap); $a->inplace->minus($b, $swap); # can be used inplace PDL::minus($a->inplace, $b, $swap); =for ref subtract two ndarrays =pod Broadcasts over its inputs. =for bad C 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 *minus = \&PDL::minus; =head2 divide =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = $a / $b; # overloads the Perl '/' operator $a /= $b; $c = PDL::divide($a, $b); # using default value of swap=0 $c = PDL::divide($a, $b, $swap); # overriding default PDL::divide($a, $b, $c, $swap); # all arguments given $c = $a->divide($b); # method call $c = $a->divide($b, $swap); $a->divide($b, $c, $swap); $a->inplace->divide($b, $swap); # can be used inplace PDL::divide($a->inplace, $b, $swap); =for ref divide two ndarrays =pod Broadcasts over its inputs. =for bad C 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 *divide = \&PDL::divide; =head2 gt =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = $a > $b; # overloads the Perl '>' operator $c = PDL::gt($a, $b); # using default value of swap=0 $c = PDL::gt($a, $b, $swap); # overriding default PDL::gt($a, $b, $c, $swap); # all arguments given $c = $a->gt($b); # method call $c = $a->gt($b, $swap); $a->gt($b, $c, $swap); $a->inplace->gt($b, $swap); # can be used inplace PDL::gt($a->inplace, $b, $swap); =for ref the binary E (greater than) operation =pod Broadcasts over its inputs. =for bad C 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 *gt = \&PDL::gt; =head2 lt =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = $a < $b; # overloads the Perl '<' operator $c = PDL::lt($a, $b); # using default value of swap=0 $c = PDL::lt($a, $b, $swap); # overriding default PDL::lt($a, $b, $c, $swap); # all arguments given $c = $a->lt($b); # method call $c = $a->lt($b, $swap); $a->lt($b, $c, $swap); $a->inplace->lt($b, $swap); # can be used inplace PDL::lt($a->inplace, $b, $swap); =for ref the binary E (less than) operation =pod Broadcasts over its inputs. =for bad C 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 *lt = \&PDL::lt; =head2 le =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = $a <= $b; # overloads the Perl '<=' operator $c = PDL::le($a, $b); # using default value of swap=0 $c = PDL::le($a, $b, $swap); # overriding default PDL::le($a, $b, $c, $swap); # all arguments given $c = $a->le($b); # method call $c = $a->le($b, $swap); $a->le($b, $c, $swap); $a->inplace->le($b, $swap); # can be used inplace PDL::le($a->inplace, $b, $swap); =for ref the binary E= (less equal) operation =pod Broadcasts over its inputs. =for bad C 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 *le = \&PDL::le; =head2 ge =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = $a >= $b; # overloads the Perl '>=' operator $c = PDL::ge($a, $b); # using default value of swap=0 $c = PDL::ge($a, $b, $swap); # overriding default PDL::ge($a, $b, $c, $swap); # all arguments given $c = $a->ge($b); # method call $c = $a->ge($b, $swap); $a->ge($b, $c, $swap); $a->inplace->ge($b, $swap); # can be used inplace PDL::ge($a->inplace, $b, $swap); =for ref the binary E= (greater equal) operation =pod Broadcasts over its inputs. =for bad C 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 *ge = \&PDL::ge; =head2 eq =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = $a == $b; # overloads the Perl '==' operator $c = PDL::eq($a, $b); # using default value of swap=0 $c = PDL::eq($a, $b, $swap); # overriding default PDL::eq($a, $b, $c, $swap); # all arguments given $c = $a->eq($b); # method call $c = $a->eq($b, $swap); $a->eq($b, $c, $swap); $a->inplace->eq($b, $swap); # can be used inplace PDL::eq($a->inplace, $b, $swap); =for ref binary I operation (C<==>) =pod Broadcasts over its inputs. =for bad C 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 *eq = \&PDL::eq; =head2 ne =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $c = $a != $b; # overloads the Perl '!=' operator $c = PDL::ne($a, $b); # using default value of swap=0 $c = PDL::ne($a, $b, $swap); # overriding default PDL::ne($a, $b, $c, $swap); # all arguments given $c = $a->ne($b); # method call $c = $a->ne($b, $swap); $a->ne($b, $c, $swap); $a->inplace->ne($b, $swap); # can be used inplace PDL::ne($a->inplace, $b, $swap); =for ref binary I operation (C) =pod Broadcasts over its inputs. =for bad C 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 *ne = \&PDL::ne; =head2 shiftleft =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $c = $a << $b; # overloads the Perl '<<' operator $a <<= $b; $c = PDL::shiftleft($a, $b); # using default value of swap=0 $c = PDL::shiftleft($a, $b, $swap); # overriding default PDL::shiftleft($a, $b, $c, $swap); # all arguments given $c = $a->shiftleft($b); # method call $c = $a->shiftleft($b, $swap); $a->shiftleft($b, $c, $swap); $a->inplace->shiftleft($b, $swap); # can be used inplace PDL::shiftleft($a->inplace, $b, $swap); =for ref bitwise leftshift C<$a> by C<$b> =pod Broadcasts over its inputs. =for bad C 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 *shiftleft = \&PDL::shiftleft; =head2 shiftright =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $c = $a >> $b; # overloads the Perl '>>' operator $a >>= $b; $c = PDL::shiftright($a, $b); # using default value of swap=0 $c = PDL::shiftright($a, $b, $swap); # overriding default PDL::shiftright($a, $b, $c, $swap); # all arguments given $c = $a->shiftright($b); # method call $c = $a->shiftright($b, $swap); $a->shiftright($b, $c, $swap); $a->inplace->shiftright($b, $swap); # can be used inplace PDL::shiftright($a->inplace, $b, $swap); =for ref bitwise rightshift C<$a> by C<$b> =pod Broadcasts over its inputs. =for bad C 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 *shiftright = \&PDL::shiftright; =head2 or2 =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $c = $a | $b; # overloads the Perl '|' operator $a |= $b; $c = PDL::or2($a, $b); # using default value of swap=0 $c = PDL::or2($a, $b, $swap); # overriding default PDL::or2($a, $b, $c, $swap); # all arguments given $c = $a->or2($b); # method call $c = $a->or2($b, $swap); $a->or2($b, $c, $swap); $a->inplace->or2($b, $swap); # can be used inplace PDL::or2($a->inplace, $b, $swap); =for ref bitwise I of two ndarrays =pod Broadcasts over its inputs. =for bad C 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 *or2 = \&PDL::or2; =head2 and2 =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $c = $a & $b; # overloads the Perl '&' operator $a &= $b; $c = PDL::and2($a, $b); # using default value of swap=0 $c = PDL::and2($a, $b, $swap); # overriding default PDL::and2($a, $b, $c, $swap); # all arguments given $c = $a->and2($b); # method call $c = $a->and2($b, $swap); $a->and2($b, $c, $swap); $a->inplace->and2($b, $swap); # can be used inplace PDL::and2($a->inplace, $b, $swap); =for ref bitwise I of two ndarrays =pod Broadcasts over its inputs. =for bad C 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 *and2 = \&PDL::and2; =head2 xor =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $c = $a ^ $b; # overloads the Perl '^' operator $a ^= $b; $c = PDL::xor($a, $b); # using default value of swap=0 $c = PDL::xor($a, $b, $swap); # overriding default PDL::xor($a, $b, $c, $swap); # all arguments given $c = $a->xor($b); # method call $c = $a->xor($b, $swap); $a->xor($b, $c, $swap); $a->inplace->xor($b, $swap); # can be used inplace PDL::xor($a->inplace, $b, $swap); =for ref bitwise I of two ndarrays =pod Broadcasts over its inputs. =for bad C 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 *xor = \&PDL::xor; #line 306 "lib/PDL/Ops.pd" =head2 xor2 =for ref Synonym for L. =cut *PDL::xor2 = *xor2 = \&PDL::xor; #line 1261 "lib/PDL/Ops.pm" =head2 power =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (cfloat cdouble cldouble float ldouble double) =for usage $c = $a ** $b; # overloads the Perl '**' operator $a **= $b; $c = PDL::power($a, $b); # using default value of swap=0 $c = PDL::power($a, $b, $swap); # overriding default PDL::power($a, $b, $c, $swap); # all arguments given $c = $a->power($b); # method call $c = $a->power($b, $swap); $a->power($b, $c, $swap); $a->inplace->power($b, $swap); # can be used inplace PDL::power($a->inplace, $b, $swap); =for ref raise ndarray C<$a> to the power C<$b> =pod Broadcasts over its inputs. =for bad C 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 *power = \&PDL::power; =head2 atan2 =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (float ldouble double) =for usage $c = atan2 $a, $b; # overloads the Perl 'atan2' operator $c = PDL::atan2($a, $b); # using default value of swap=0 $c = PDL::atan2($a, $b, $swap); # overriding default PDL::atan2($a, $b, $c, $swap); # all arguments given $c = $a->atan2($b); # method call $c = $a->atan2($b, $swap); $a->atan2($b, $c, $swap); $a->inplace->atan2($b, $swap); # can be used inplace PDL::atan2($a->inplace, $b, $swap); =for ref elementwise C of two ndarrays =pod Broadcasts over its inputs. =for bad C 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 *atan2 = \&PDL::atan2; =head2 modulo =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = $a % $b; # overloads the Perl '%' operator $a %= $b; $c = PDL::modulo($a, $b); # using default value of swap=0 $c = PDL::modulo($a, $b, $swap); # overriding default PDL::modulo($a, $b, $c, $swap); # all arguments given $c = $a->modulo($b); # method call $c = $a->modulo($b, $swap); $a->modulo($b, $c, $swap); $a->inplace->modulo($b, $swap); # can be used inplace PDL::modulo($a->inplace, $b, $swap); =for ref elementwise C operation =pod Broadcasts over its inputs. =for bad C 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 *modulo = \&PDL::modulo; =head2 spaceship =for sig Signature: (a(); b(); [o]c(); int $swap) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = $a <=> $b; # overloads the Perl '<=>' operator $c = PDL::spaceship($a, $b); # using default value of swap=0 $c = PDL::spaceship($a, $b, $swap); # overriding default PDL::spaceship($a, $b, $c, $swap); # all arguments given $c = $a->spaceship($b); # method call $c = $a->spaceship($b, $swap); $a->spaceship($b, $c, $swap); $a->inplace->spaceship($b, $swap); # can be used inplace PDL::spaceship($a->inplace, $b, $swap); =for ref elementwise "<=>" operation =pod Broadcasts over its inputs. =for bad C 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 *spaceship = \&PDL::spaceship; =head2 bitnot =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong) =for usage $b = ~$a; # overloads the Perl '~' operator $b = PDL::bitnot($a); PDL::bitnot($a, $b); # all arguments given $b = $a->bitnot; # method call $a->bitnot($b); $a->inplace->bitnot; # can be used inplace PDL::bitnot($a->inplace); =for ref unary bitwise negation =pod Broadcasts over its inputs. =for bad C 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 *bitnot = \&PDL::bitnot; =head2 sqrt =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = sqrt $a; # overloads the Perl 'sqrt' operator $b = PDL::sqrt($a); PDL::sqrt($a, $b); # all arguments given $b = $a->sqrt; # method call $a->sqrt($b); $a->inplace->sqrt; # can be used inplace PDL::sqrt($a->inplace); =for ref elementwise square root =pod Broadcasts over its inputs. =for bad C 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 *sqrt = \&PDL::sqrt; =head2 sin =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = sin $a; # overloads the Perl 'sin' operator $b = PDL::sin($a); PDL::sin($a, $b); # all arguments given $b = $a->sin; # method call $a->sin($b); $a->inplace->sin; # can be used inplace PDL::sin($a->inplace); =for ref the sin function =pod Broadcasts over its inputs. =for bad C 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 *sin = \&PDL::sin; =head2 cos =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = cos $a; # overloads the Perl 'cos' operator $b = PDL::cos($a); PDL::cos($a, $b); # all arguments given $b = $a->cos; # method call $a->cos($b); $a->inplace->cos; # can be used inplace PDL::cos($a->inplace); =for ref the cos function =pod Broadcasts over its inputs. =for bad C 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 *cos = \&PDL::cos; =head2 not =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = !$a; # overloads the Perl '!' operator $b = PDL::not($a); PDL::not($a, $b); # all arguments given $b = $a->not; # method call $a->not($b); $a->inplace->not; # can be used inplace PDL::not($a->inplace); =for ref the elementwise I operation =pod Broadcasts over its inputs. =for bad C 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 *not = \&PDL::not; =head2 exp =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float ldouble double) =for usage $b = exp $a; # overloads the Perl 'exp' operator $b = PDL::exp($a); PDL::exp($a, $b); # all arguments given $b = $a->exp; # method call $a->exp($b); $a->inplace->exp; # can be used inplace PDL::exp($a->inplace); =for ref the exponential function =pod Broadcasts over its inputs. =for bad C 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 *exp = \&PDL::exp; =head2 log =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float ldouble double) =for usage $b = log $a; # overloads the Perl 'log' operator $b = PDL::log($a); PDL::log($a, $b); # all arguments given $b = $a->log; # method call $a->log($b); $a->inplace->log; # can be used inplace PDL::log($a->inplace); =for ref the natural logarithm =pod Broadcasts over its inputs. =for bad C 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 *log = \&PDL::log; =head2 re =for sig Signature: (complexv(); real [o]b()) Types: (cfloat cdouble cldouble) =for usage $b = PDL::re($complexv); PDL::re($complexv, $b); # all arguments given $b = $complexv->re; # method call $complexv->re($b); =for ref Returns the real part of a complex number. Flows data back & forth. =pod Broadcasts over its inputs. Creates data-flow back and forth by default. =for bad C 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 *re = \&PDL::re; =head2 im =for sig Signature: (complexv(); real [o]b()) Types: (cfloat cdouble cldouble) =for usage $b = PDL::im($complexv); PDL::im($complexv, $b); # all arguments given $b = $complexv->im; # method call $complexv->im($b); =for ref Returns the imaginary part of a complex number. Flows data back & forth. =pod Broadcasts over its inputs. Creates data-flow back and forth by default. =for bad C 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 *im = \&PDL::im; =head2 _cabs =for sig Signature: (complexv(); real [o]b()) Types: (cfloat cdouble cldouble) =for usage $b = PDL::_cabs($complexv); PDL::_cabs($complexv, $b); # all arguments given $b = $complexv->_cabs; # method call $complexv->_cabs($b); =for ref Returns the absolute (length) of a complex number. =pod Broadcasts over its inputs. =for bad C<_cabs> 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 =head2 log10 =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = log10($a); log10($a, $b); # all arguments given $b = $a->log10; # method call $a->log10($b); $a->inplace->log10; # can be used inplace log10($a->inplace); =for ref the base 10 logarithm =pod Broadcasts over its inputs. =for bad C 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 sub PDL::log10 { my ($x, $y) = @_; return log($x) / log(10) if !UNIVERSAL::isa($x,"PDL"); barf "inplace but output given" if $x->is_inplace and defined $y; if ($x->is_inplace) { $x->set_inplace(0); $y = $x; } elsif (!defined $y) { $y = $x->initialize; } &PDL::_log10_int( $x, $y ); $y; }; *log10 = \&PDL::log10; =head2 assgn =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = assgn($a); assgn($a, $b); # all arguments given $b = $a->assgn; # method call $a->assgn($b); =for ref Plain numerical assignment. This is used to implement the ".=" operator =pod Broadcasts over its inputs. =for bad C 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 *assgn = \&PDL::assgn; =head2 carg =for sig Signature: (!real complexv(); real [o]b()) Types: (cfloat cdouble cldouble) =for usage $b = carg($complexv); carg($complexv, $b); # all arguments given $b = $complexv->carg; # method call $complexv->carg($b); =for ref Returns the polar angle of a complex number. =pod Broadcasts over its inputs. =for bad C 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 *carg = \&PDL::carg; =head2 conj =for sig Signature: (complexv(); [o]b()) Types: (cfloat cdouble cldouble) =for usage $b = conj($complexv); conj($complexv, $b); # all arguments given $b = $complexv->conj; # method call $complexv->conj($b); $complexv->inplace->conj; # can be used inplace conj($complexv->inplace); =for ref complex conjugate. =pod Broadcasts over its inputs. =for bad C 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 *conj = \&PDL::conj; =head2 czip =for sig Signature: (!complex r(); !complex i(); complex [o]c()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = czip($r, $i); czip($r, $i, $c); # all arguments given $c = $r->czip($i); # method call $r->czip($i, $c); convert real, imaginary to native complex, (sort of) like LISP zip function. Will add the C ndarray to "i" times the C ndarray. Only takes real ndarrays as input. =pod Broadcasts over its inputs. =for bad C 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 *czip = \&PDL::czip; =head2 ipow =for sig Signature: (a(); longlong b(); [o] ans()) Types: (ulonglong longlong float ldouble cfloat cdouble cldouble double) =for usage $ans = ipow($a, $b); ipow($a, $b, $ans); # all arguments given $ans = $a->ipow($b); # method call $a->ipow($b, $ans); $a->inplace->ipow($b); # can be used inplace ipow($a->inplace, $b); =for ref raise ndarray C<$a> to integer power C<$b> Algorithm from L =pod Broadcasts over its inputs. =for bad C 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 *ipow = \&PDL::ipow; #line 468 "lib/PDL/Ops.pd" =head2 abs =for ref Returns the absolute value of a number. =cut sub PDL::abs { $_[0]->type->real ? goto &PDL::_rabs : goto &PDL::_cabs } #line 2132 "lib/PDL/Ops.pm" =head2 abs2 =for sig Signature: (a(); real [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = abs2($a); abs2($a, $b); # all arguments given $b = $a->abs2; # method call $a->abs2($b); =for ref Returns the square of the absolute value of a number. =pod Broadcasts over its inputs. =for bad C 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 *abs2 = \&PDL::abs2; =head2 r2C =for sig Signature: (r(); complex [o]c()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $c = r2C($r); r2C($r, $c); # all arguments given $c = $r->r2C; # method call $r->r2C($c); =for ref convert real to native complex, with an imaginary part of zero =pod Broadcasts over its inputs. =for bad C 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 sub PDL::r2C ($) { return $_[0] if UNIVERSAL::isa($_[0], 'PDL') and !$_[0]->type->real; my $r = $_[1] // PDL->nullcreate($_[0]); PDL::_r2C_int($_[0], $r); $r; } *r2C = \&PDL::r2C; =head2 i2C =for sig Signature: (i(); complex [o]c()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $c = i2C($i); i2C($i, $c); # all arguments given $c = $i->i2C; # method call $i->i2C($c); =for ref convert imaginary to native complex, with a real part of zero =pod Broadcasts over its inputs. =for bad C 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 sub PDL::i2C ($) { return $_[0] if UNIVERSAL::isa($_[0], 'PDL') and !$_[0]->type->real; my $r = $_[1] // PDL->nullcreate($_[0]); PDL::_i2C_int($_[0], $r); $r; } *i2C = \&PDL::i2C; #line 525 "lib/PDL/Ops.pd" # This is to used warn if an operand is non-numeric or non-PDL. sub warn_non_numeric_op_wrapper { require Scalar::Util; my ($cb, $op_name) = @_; return sub { my ($op1, $op2) = @_; warn "'$op2' is not numeric nor a PDL in operator $op_name" unless Scalar::Util::looks_like_number($op2) || ( Scalar::Util::blessed($op2) && $op2->isa('PDL') ); $cb->(@_); } } { package # hide from MetaCPAN PDL; use overload "eq" => PDL::Ops::warn_non_numeric_op_wrapper(\&PDL::eq, 'eq'), ".=" => sub { my @args = !$_[2] ? @_[1,0] : @_[0,1]; PDL::Ops::assgn(@args); return $args[1]; }, 'abs' => sub { PDL::abs($_[0]) }, '++' => sub { $_[0] += ($PDL::Core::pdl_ones[$_[0]->get_datatype]//barf "Couldn't find 'one' for type ", $_[0]->get_datatype) }, '--' => sub { $_[0] -= ($PDL::Core::pdl_ones[$_[0]->get_datatype]//barf "Couldn't find 'one' for type ", $_[0]->get_datatype) }, ; } #line 49 "lib/PDL/Ops.pd" =head1 AUTHOR Tuomas J. Lukka (lukka@fas.harvard.edu), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Doug Hunt (dhunt@ucar.edu), Christian Soeller (c.soeller@auckland.ac.nz), Doug Burke (burke@ifa.hawaii.edu), and Craig DeForest (deforest@boulder.swri.edu). =cut #line 2312 "lib/PDL/Ops.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/MatrixOps.pm0000644000175000017500000012062714771136056016304 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/MatrixOps.pd! Don't modify! # package PDL::MatrixOps; our @EXPORT_OK = qw(identity stretcher inv det determinant eigens_sym eigens svd lu_decomp lu_decomp2 lu_backsub simq squaretotri tritosquare tricpy mstack augment ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::MatrixOps ; #line 14 "lib/PDL/MatrixOps.pd" =encoding utf8 use strict; use warnings; =head1 NAME PDL::MatrixOps -- Some Useful Matrix Operations =head1 SYNOPSIS $inv = $x->inv; $det = $x->det; ($lu,$perm,$par) = $x->lu_decomp; $y = lu_backsub($lu,$perm,$z); # solve $x x $y = $z =head1 DESCRIPTION PDL::MatrixOps is PDL's built-in matrix manipulation code. It contains utilities for many common matrix operations: inversion, determinant finding, eigenvalue/vector finding, singular value decomposition, etc. PDL::MatrixOps routines are written in a mixture of Perl and C, so that they are reliably present even when there is no external library available (e.g. L or any of the PDL::GSL family of modules). Matrix manipulation, particularly with large matrices, is a challenging field and no one algorithm is suitable in all cases. The utilities here use general-purpose algorithms that work acceptably for many cases but might not scale well to very large or pathological (near-singular) matrices. Except as noted, the matrices are PDLs whose 0th dimension ranges over column and whose 1st dimension ranges over row. The matrices appear correctly when printed. These routines should work OK with L objects as well as with normal PDLs. =head1 TIPS ON MATRIX OPERATIONS Like most computer languages, PDL addresses matrices in (column,row) order in most cases; this corresponds to (X,Y) coordinates in the matrix itself, counting rightwards and downwards from the upper left corner. This means that if you print a PDL that contains a matrix, the matrix appears correctly on the screen, but if you index a matrix element, you use the indices in the reverse order that you would in a math textbook. If you prefer your matrices indexed in (row, column) order, you can try using the L object, which includes an implicit exchange of the first two dimensions but should be compatible with most of these matrix operations. TIMTOWDTI.) Matrices, row vectors, and column vectors can be multiplied with the 'x' operator (which is, of course, broadcastable): $m3 = $m1 x $m2; $col_vec2 = $m1 x $col_vec1; $row_vec2 = $row_vec1 x $m1; $scalar = $row_vec x $col_vec; Because of the (column,row) addressing order, 1-D PDLs are treated as _row_ vectors; if you want a _column_ vector you must add a dummy dimension: $rowvec = pdl(1,2); # row vector $colvec = $rowvec->slice('*1'); # 1x2 column vector $matrix = pdl([[3,4],[6,2]]); # 2x2 matrix $rowvec2 = $rowvec x $matrix; # right-multiplication by matrix $colvec = $matrix x $colvec; # left-multiplication by matrix $m2 = $matrix x $rowvec; # Throws an error Implicit broadcasting works correctly with most matrix operations, but you must be extra careful that you understand the dimensionality. In particular, matrix multiplication and other matrix ops need nx1 PDLs as row vectors and 1xn PDLs as column vectors. In most cases you must explicitly include the trailing 'x1' dimension in order to get the expected results when you broadcast over multiple row vectors. When broadcasting over matrices, it's very easy to get confused about which dimension goes where. It is useful to include comments with every expression, explaining what you think each dimension means: $x = xvals(360)*3.14159/180; # (angle) $rot = cat(cat(cos($x),sin($x)), # rotmat: (col,row,angle) cat(-sin($x),cos($x))); =head1 ACKNOWLEDGEMENTS MatrixOps includes algorithms and pre-existing code from several origins. In particular, C is the work of Stephen Moshier, C uses an SVD subroutine written by Bryant Marks, and C uses a subset of the Small Scientific Library by Kenneth Geisshirt. They are free software, distributable under same terms as PDL itself. =head1 NOTES This is intended as a general-purpose linear algebra package for small-to-mid sized matrices. The algorithms may not scale well to large matrices (hundreds by hundreds) or to near singular matrices. If there is something you want that is not here, please add and document it! =cut use Carp; use strict; #line 137 "lib/PDL/MatrixOps.pm" =head1 FUNCTIONS =cut #line 131 "lib/PDL/MatrixOps.pd" =head2 identity =for sig Signature: (n; [o]a(n,n)) =for ref Return an identity matrix of the specified size. If you hand in a scalar, its value is the size of the identity matrix; if you hand in a dimensioned PDL, the 0th dimension is the first two dimensions of the matrix, with higher dimensions preserved. =cut sub identity { my $n = shift; my $out = !(my $was_pdl = UNIVERSAL::isa($n,'PDL')) ? zeroes($n,$n) : $n->getndims == 0 ? zeroes($n->type, $n->at(0),$n->at(0)) : undef; if (!defined $out) { my @dims = $n->dims; $out = zeroes($n->type, @dims[0, 0, 2..$#dims]); } $out->diagonal(0,1)++; $was_pdl ? bless $out, ref($n) : $out; } #line 164 "lib/PDL/MatrixOps.pd" =head2 stretcher =for sig Signature: (a(n); [o]b(n,n)) =for usage $mat = stretcher($eigenvalues); =for ref Return a diagonal matrix with the specified diagonal elements. Preserves higher dimensions. As of 2.096, it will also have the same datatype. =cut sub stretcher { my $in = shift; my $out = zeroes($in->type, $in->dim(0), $in->dims); $out->diagonal(0,1) += $in; $out; } #line 196 "lib/PDL/MatrixOps.pd" =head2 inv =for sig Signature: (a(m,m); sv opt ) =for usage $a1 = inv($a, {$opt}); =for ref Invert a square matrix. You feed in an NxN matrix in $a, and get back its inverse (if it exists). The code is inplace-aware, so you can get back the inverse in $a itself if you want -- though temporary storage is used either way. You can cache the LU decomposition in an output option variable. C uses C by default; that is a numerically stable (pivoting) LU decomposition method. OPTIONS: =over 3 =item * s Boolean value indicating whether to complain if the matrix is singular. If this is false, singular matrices cause inverse to barf. If it is true, then singular matrices cause inverse to return undef. =item * lu (I/O) This value contains a list ref with the LU decomposition, permutation, and parity values for C<$a>. If you do not mention the key, or if the value is undef, then inverse calls C. If the key exists with an undef value, then the output of C is stashed here (unless the matrix is singular). If the value exists, then it is assumed to hold the LU decomposition. =item * det (Output) If this key exists, then the determinant of C<$a> get stored here, whether or not the matrix is singular. =back =cut *PDL::inv = \&inv; sub inv { my $x = shift; my $opt = shift; $opt = {} unless defined($opt); barf "inverse needs a square PDL as a matrix\n" unless(UNIVERSAL::isa($x,'PDL') && $x->dims >= 2 && $x->dim(0) == $x->dim(1) ); my ($lu,$perm,$par); if(exists($opt->{lu}) && ref $opt->{lu} eq 'ARRAY' && ref $opt->{lu}->[0] eq 'PDL') { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($x); @{$opt->{lu}} = ($lu,$perm,$par) if(ref $opt->{lu} eq 'ARRAY'); } my $det = (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : pdl(0); $opt->{det} = $det if exists($opt->{det}); unless($det->nelem > 1 || $det) { return undef if $opt->{s}; barf("PDL::inv: got a singular matrix or LU decomposition\n"); } my $out = lu_backsub($lu,$perm,$par,identity($x))->transpose->sever; return $out unless($x->is_inplace); $x .= $out; $x; } #line 296 "lib/PDL/MatrixOps.pd" =head2 det =for sig Signature: (a(m,m); sv opt) =for usage $det = det($a,{opt}); =for ref Determinant of a square matrix using LU decomposition (for large matrices) You feed in a square matrix, you get back the determinant. Some options exist that allow you to cache the LU decomposition of the matrix (note that the LU decomposition is invalid if the determinant is zero!). The LU decomposition is cacheable, in case you want to re-use it. This method of determinant finding is more rapid than recursive-descent on large matrices, and if you reuse the LU decomposition it's essentially free. OPTIONS: =over 3 =item * lu (I/O) Provides a cache for the LU decomposition of the matrix. If you provide the key but leave the value undefined, then the LU decomposition goes in here; if you put an LU decomposition here, it will be used and the matrix will not be decomposed again. =back =cut *PDL::det = \&det; sub det { my ($x, $opt) = @_; $opt = {} unless defined($opt); my($lu,$perm,$par); if(exists ($opt->{lu}) and (ref $opt->{lu} eq 'ARRAY')) { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($x); $opt->{lu} = [$lu,$perm,$par] if(exists($opt->{lu})); } defined $lu ? $lu->diagonal(0,1)->prodover * $par : PDL->zeroes(sbyte,1); } #line 355 "lib/PDL/MatrixOps.pd" =head2 determinant =for sig Signature: (a(m,m)) =for usage $det = determinant($x); =for ref Determinant of a square matrix, using recursive descent (broadcastable). This is the traditional, robust recursive determinant method taught in most linear algebra courses. It scales like C (and hence is pitifully slow for large matrices) but is very robust because no division is involved (hence no division-by-zero errors for singular matrices). It's also broadcastable, so you can find the determinants of a large collection of matrices all at once if you want. Matrices up to 3x3 are handled by direct multiplication; larger matrices are handled by recursive descent to the 3x3 case. The LU-decomposition method L is faster in isolation for single matrices larger than about 4x4, and is much faster if you end up reusing the LU decomposition of C<$a> (NOTE: check performance and broadcasting benchmarks with new code). =cut *PDL::determinant = \&determinant; sub determinant { my($x) = shift; my($n); return undef unless( UNIVERSAL::isa($x,'PDL') && $x->getndims >= 2 && ($n = $x->dim(0)) == $x->dim(1) ); return $x->clump(2) if($n==1); if($n==2) { my($y) = $x->clump(2); return $y->index(0)*$y->index(3) - $y->index(1)*$y->index(2); } if($n==3) { my($y) = $x->clump(2); my $y3 = $y->index(3); my $y4 = $y->index(4); my $y5 = $y->index(5); my $y6 = $y->index(6); my $y7 = $y->index(7); my $y8 = $y->index(8); return ( $y->index(0) * ( $y4 * $y8 - $y5 * $y7 ) + $y->index(1) * ( $y5 * $y6 - $y3 * $y8 ) + $y->index(2) * ( $y3 * $y7 - $y4 * $y6 ) ); } my($i); my($sum) = zeroes($x->slice('(0),(0)')); # Do middle submatrices for $i(1..$n-2) { my $el = $x->slice("($i),(0)"); next if( ($el==0)->all ); # Optimize away unnecessary recursion $sum += $el * (1-2*($i%2)) * determinant($x->slice("0:".($i-1).",1:-1")-> append($x->slice(($i+1).":-1,1:-1"))); } # Do beginning and end submatrices $sum += $x->slice("(0),(0)") * determinant($x->slice('1:-1,1:-1')); $sum -= $x->slice("(-1),(0)") * determinant($x->slice('0:-2,1:-1')) * (1 - 2*($n % 2)); return $sum; } #line 436 "lib/PDL/MatrixOps.pm" =head2 eigens_sym =for sig Signature: ([phys]a(m); [o,phys]ev(n,n); [o,phys]e(n)) Types: (double) =for ref Eigenvalues and -vectors of a symmetric square matrix. If passed an asymmetric matrix, the routine will warn and symmetrize it, by taking the average value. That is, it will solve for 0.5*($a+$a->transpose). It's broadcastable, so if C<$a> is 3x3x100, it's treated as 100 separate 3x3 matrices, and both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context it hands back only the eigenvalues. Ultimately, it should switch to a faster algorithm in this case (as discarding the eigenvectors is wasteful). The algorithm used is due to J. von Neumann, which was a rediscovery of L . The eigenvectors are returned in COLUMNS of the returned PDL. That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens_sym $x; # Make eigenvector matrix $vector = $ev->slice($n); # Select nth eigenvector as a column-vector $vector = $ev->slice("($n)"); # Select nth eigenvector as a row-vector As of 2.096, the eigenvalues are returned in ascending order. To compare with L: use PDL::LinearAlgebra; ($val, $rvec) = msymeigen($A = pdl([3,4], [4,-3]),1,1); print $val->slice(1) * $rvec->slice(1); #[ # [ -4.472136] # [ -2.236068] #] print $A x $rvec->slice(1); #[ # [ -4.472136] # [ -2.236068] #] ($rvec, $val) = eigens_sym($A); # note return values other way round # otherwise the same =for usage ($ev, $e) = eigens_sym($x); # e-vects & e-values $e = eigens_sym($x); # just eigenvalues =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut sub PDL::eigens_sym { my ($x) = @_; my @d = $x->dims; barf "Need real square matrix for eigens_sym" if @d < 2 or $d[0] != $d[1]; my ($sym) = 0.5*($x + $x->transpose); my ($err) = PDL::max(abs($sym)); barf "Need symmetric component non-zero for eigens_sym" if $err == 0; $err = PDL::max(abs($x-$sym))/$err; warn "Using symmetrized version of the matrix in eigens_sym" if $err > 1e-5 && $PDL::debug; PDL::_eigens_sym_int($sym->squaretotri, my $ev=PDL->null, my $e=PDL->null); return ($ev->transpose, $e) if wantarray; $e; #just eigenvalues } *eigens_sym = \&PDL::eigens_sym; =head2 eigens =for sig Signature: ([phys]a(n,n); complex [o,phys]ev(n,n); complex [o,phys]e(n)) Types: (double) =for ref Complex eigenvalues and -vectors of a real square matrix. (See also L<"eigens_sym"|/eigens_sym>, for eigenvalues and -vectors of a real, symmetric, square matrix). The eigens function will attempt to compute the eigenvalues and eigenvectors of a square matrix with real components. If the matrix is symmetric, the same underlying code as L<"eigens_sym"|/eigens_sym> is used. If asymmetric, the eigenvalues and eigenvectors are computed with algorithms from the sslib library. These are a slightly modified version of EISPACK's C code. Not all square matrices are diagonalizable. If you feed in a non-diagonalizable matrix, then the algorithm may fail, in which case an exception will be thrown. C is broadcastable, so you can solve 100 eigenproblems by feeding in a 3x3x100 array. Both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context C hands back only the eigenvalues. This is somewhat wasteful, as it calculates the eigenvectors anyway. The eigenvectors are returned in COLUMNS of the returned PDL (ie the the 0 dimension). That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens $x; # Make eigenvector matrix $vector = $ev->slice($n); # Select nth eigenvector as a column-vector $vector = $ev->slice("($n)"); # Select nth eigenvector as a row-vector To compare with L: use PDL::LinearAlgebra; ($val, $lvec, $rvec) = meigen($A = pdl([4,-1], [2,1]),1,1); print $val->slice(1) * $rvec->slice(1); #[ # [0.894427190999916] # [ 1.78885438199983] #] print $A x $rvec->slice(1); #[ # [0.894427190999916] # [ 1.78885438199983] #] ($rvec, $val) = eigens($A); # note return values other way round # otherwise the same =for usage ($ev, $e) = eigens($x); # e'vects & e'vals $e = eigens($x); # just eigenvalues =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut sub PDL::eigens { my ($x) = @_; my @d = $x->dims; barf "Need real square matrix for eigens" if @d < 2 or $d[0] != $d[1]; my $deviation = PDL::max(abs($x - $x->transpose))/PDL::max(abs($x)); if ( $deviation <= 1e-5 ) { PDL::_eigens_sym_int($x->squaretotri, my $ev=PDL->null, my $e=PDL->null); return $ev->transpose, $e if wantarray; return $e; #just eigenvalues } else { PDL::_eigens_int($x, my $ev=PDL->null, my $e=PDL->null); return $ev, $e if wantarray; return $e; #just eigenvalues } } *eigens = \&PDL::eigens; =head2 svd =for sig Signature: (a(n,m); [t]w(wsize=CALC($SIZE(n) * ($SIZE(m) + $SIZE(n)))); [o]u(n,m); [o,phys]z(n); [o]v(n,n)) Types: (double) =for usage ($u, $z, $v) = svd($a); svd($a, $u, $z, $v); # all arguments given ($u, $z, $v) = $a->svd; # method call $a->svd($u, $z, $v); =for ref Singular value decomposition of a matrix. C is broadcastable. Given an m x n matrix C<$a> that has m rows and n columns (m >= n), C computes matrices C<$u> and C<$v>, and a vector of the singular values C<$s>. Like most implementations, C computes what is commonly referred to as the "thin SVD" of C<$a>, such that C<$u> is m x n, C<$v> is n x n, and there are <=n singular values. As long as m >= n, the original matrix can be reconstructed as follows: ($u,$s,$v) = svd($x); $ess = zeroes($x->dim(0),$x->dim(0)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$x->dim(0)-1); #generic diagonal $a_copy = $u x $ess x $v->transpose; If m==n, C<$u> and C<$v> can be thought of as rotation matrices that convert from the original matrix's singular coordinates to final coordinates, and from original coordinates to singular coordinates, respectively, and $ess is a diagonal scaling matrix. If n>m, C will barf. This can be avoided by passing in the transpose of C<$a>, and reconstructing the original matrix like so: ($u,$s,$v) = svd($x->transpose); $ess = zeroes($x->dim(1),$x->dim(1)); $ess->slice($_,$_).=$s->slice($_) foreach (0..$x->dim(1)-1); #generic diagonal $x_copy = $v x $ess x $u->transpose; EXAMPLE The computing literature has loads of examples of how to use SVD. Here's a trivial example (used in L) of how to make a matrix less, er, singular, without changing the orientation of the ellipsoid of transformation: { my($r1,$s,$r2) = svd $x; $s++; # fatten all singular values $r2 *= $s; # implicit broadcasting for cheap mult. $x .= $r2 x $r1; # a gets r2 x ess x r1 } =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *svd = \&PDL::svd; #line 690 "lib/PDL/MatrixOps.pd" =head2 lu_decomp =for sig Signature: (a(m,m); [o]lu(m,m); [o]perm(m); [o]parity) =for ref LU decompose a matrix, with row permutation =for usage ($lu, $perm, $parity) = lu_decomp($x); $lu = lu_decomp($x, $perm, $par); # $perm and $par are outputs! lu_decomp($x->inplace,$perm,$par); # Everything in place. =for description C returns an LU decomposition of a square matrix, using Crout's method with partial pivoting. It's ported from I. The partial pivoting keeps it numerically stable but means a little more overhead from broadcasting. C decomposes the input matrix into matrices L and U such that LU = A, L is a subdiagonal matrix, and U is a superdiagonal matrix. By convention, the diagonal of L is all 1's. The single output matrix contains all the variable elements of both the L and U matrices, stacked together. Because the method uses pivoting (rearranging the lower part of the matrix for better numerical stability), you have to permute input vectors before applying the L and U matrices. The permutation is returned either in the second argument or, in list context, as the second element of the list. You need the permutation for the output to make any sense, so be sure to get it one way or the other. LU decomposition is the answer to a lot of matrix questions, including inversion and determinant-finding, and C is used by L. If you pass in C<$perm> and C<$parity>, they either must be predeclared PDLs of the correct size ($perm is an n-vector, C<$parity> is a scalar) or scalars. If the matrix is singular, then the LU decomposition might not be defined; in those cases, C silently returns undef. Some singular matrices LU-decompose just fine, and those are handled OK but give a zero determinant (and hence can't be inverted). C uses pivoting, which rearranges the values in the matrix for more numerical stability. This makes it really good for large and even near-singular matrices. There is a non-pivoting version C available which is from 5 to 60 percent faster for typical problems at the expense of failing to compute a result in some cases. Now that the C is broadcasted, it is the recommended LU decomposition routine. It no longer falls back to C. C is ported from I to PDL. It should probably be implemented in C. =cut *PDL::lu_decomp = \&lu_decomp; sub lu_decomp { my($in) = shift; my($permute) = shift; my($parity) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $permute) { barf('lu_decomp: permutation vector must match the matrix') if(!UNIVERSAL::isa($permute,'PDL') || $permute->ndims != 1 || $permute->dim(0) != $out->dim(0)); $permute .= PDL->xvals($in->dim(0)); } else { $permute = $in->slice("(0)")->xvals; } if(defined $parity) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($parity,'PDL') || $parity->dim(0) != 1); $parity .= 1.0; } else { $parity = $in->slice('(0),(0)')->ones; } my($scales) = $in->copy->abs->maximum; # elementwise by rows if(($scales==0)->sum) { return undef; } # Some holding tanks my($tmprow) = $out->slice('(0)')->zeroes; $tmprow = $tmprow->double if $tmprow->type < double; my($tmpval) = $tmprow->slice('(0)')->sever; my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->slice("($col),0:$klim") * $out->slice("0:$klim,($row)") )->sumover; } } # Figure a_ij, with pivoting if($col < $n1) { # Find the maximum value in the rest of the row my $sl = $out->slice("($col),$col:$n1"); my $wh = $sl->abs->maximum_ind; my $big = $sl->index($wh)->sever; # Permute if necessary to make the diagonal the maximum # if($wh != 0) { # Permute rows to place maximum element on diagonal. my $whc = $wh+$col; my $sl1 = $out->mv(1,0)->index($whc->slice("*$n")); my $sl2 = $out->slice(":,($col)"); $tmprow .= $sl1; $sl1 .= $sl2; $sl2 .= $tmprow; $sl1 = $permute->index($whc); $sl2 = $permute->index($col); $tmpval .= $sl1; $sl1 .= $sl2; $sl2 .= $tmpval; $parity->where($wh>0) *= -1.0; } # LAPACK cgetrf does not try fix singularity so nor do we, even though NR does my $notbig = $big->where(abs($big) < $TINY); return if !$notbig->isempty; # Divide by the diagonal element (which is now the largest element) my $tout; ($tout = $out->slice("($col),".($col+1).":$n1")) /= $big->slice('*1'); } # end of pivoting part } # end of column loop wantarray ? ($out,$permute,$parity) : $out; } #line 867 "lib/PDL/MatrixOps.pd" =head2 lu_decomp2 =for sig Signature: (a(m,m); [o]lu(m,m)) =for ref LU decompose a matrix, with no row permutation =for usage ($lu, $perm, $parity) = lu_decomp2($x); $lu = lu_decomp2($x,$perm,$parity); # or $lu = lu_decomp2($x); # $perm and $parity are optional lu_decomp($x->inplace,$perm,$parity); # or lu_decomp($x->inplace); # $perm and $parity are optional =for description C works just like L, but it does B pivoting at all. For compatibility with L, it will give you a permutation list and a parity scalar if you ask for them -- but they are always trivial. Because C does not pivot, it is numerically B -- that means it is less precise than L, particularly for large or near-singular matrices. There are also specific types of non-singular matrices that confuse it (e.g. ([0,-1,0],[1,0,0],[0,0,1]), which is a 90 degree rotation matrix but which confuses C). On the other hand, if you want to invert rapidly a few hundred thousand small matrices and don't mind missing one or two, it could be the ticket. It can be up to 60% faster at the expense of possible failure of the decomposition for some of the input matrices. The output is a single matrix that contains the LU decomposition of C<$a>; you can even do it in-place, thereby destroying C<$a>, if you want. See L for more information about LU decomposition. C is ported from I into PDL. =cut *PDL::lu_decomp2 = \&lu_decomp2; sub lu_decomp2 { my($in) = shift; my($perm) = shift; my($par) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp2 requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $perm) { barf('lu_decomp2: permutation vector must match the matrix') if(!UNIVERSAL::isa($perm,'PDL') || $perm->ndims != 1 || $perm->dim(0) != $out->dim(0)); $perm .= PDL->xvals($in->dim(0)); } else { $perm = PDL->xvals($in->dim(0)); } if(defined $par) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($par,'PDL') || $par->nelem != 1); $par .= 1.0; } else { $par = pdl(1.0); } my $diagonal = $out->diagonal(0,1); my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->slice("($col),0:$klim") * $out->slice("0:$klim,($row)") )->sumover; } } # Figure a_ij, with no pivoting if($col < $n1) { # Divide the rest of the column by the diagonal element $out->slice("($col),".($col+1).":$n1") /= $diagonal->index($col)->dummy(0,$n1-$col); } } # end of column loop wantarray ? ($out,$perm,$par) : $out; } #line 988 "lib/PDL/MatrixOps.pd" =head2 lu_backsub =for sig Signature: (lu(m,m); perm(m); b(m)) =for ref Solve A x = B for matrix A, by back substitution into A's LU decomposition. =for usage ($lu,$perm,$par) = lu_decomp($A); $x = lu_backsub($lu,$perm,$par,$A); # or $x = lu_backsub($lu,$perm,$B); # $par is not required for lu_backsub lu_backsub($lu,$perm,$B->inplace); # modify $B in-place $x = lu_backsub(lu_decomp($A),$B); # (ignores parity value from lu_decomp) # starting from square matrix A and columns matrix B, with mathematically # correct dimensions $A = identity(4) + ones(4, 4); $A->slice('2,0') .= 0; # break symmetry to see if need transpose $B = sequence(2, 4); # all these functions take B as rows, interpret as though notional columns # mathematically confusing but can't change as back-compat and also # familiar to Fortran users, so just transpose inputs and outputs # using lu_backsub ($lu,$perm,$par) = lu_decomp($A); $x = lu_backsub($lu,$perm,$par, $B->transpose)->transpose; # using simq # remove all active dims @A_dims = $A->dims; @B_dims = $B->transpose->dims; splice @A_dims, 0, 2; splice @B_dims, 0, 1; @broadcast = PDL::Core::dims_filled(\@A_dims, \@B_dims); # simq modifies A, so need 1 copy per broadcast else non-first run has wrong A ($x) = simq($A->dupN(1,1,map +($A_dims[$_]//1)==1?$broadcast[$_]:1, 0..$#broadcast)->copy, $B->transpose, 0); $x = $x->inplace->transpose; # or with PDL::LinearAlgebra wrappers of LAPACK $x = msolve($A, $B); # or with LAPACK use PDL::LinearAlgebra::Real; getrf($lu=$A->copy, $ipiv=null, $info=null); getrs($lu, 1, $x=$B->transpose->copy, $ipiv, $info=null); # again, need transpose $x=$x->inplace->transpose; # or with GSL use PDL::GSL::LINALG; LU_decomp(my $lu=$A->copy, my $p=null, my $signum=null); # $B and $x, first dim is because GSL treats as vector, higher dims broadcast # so we transpose in and back out LU_solve($lu, $p, $B->transpose, my $x=null); $x=$x->inplace->transpose; # proof of the pudding is in the eating: print $A x $x; =for description Given the LU decomposition of a square matrix (from L), C does back substitution into the matrix to solve C for given vector C. It is separated from the C method so that you can call the cheap C multiple times and not have to do the expensive LU decomposition more than once. C acts on single vectors and broadcasts in the usual way, which means that it treats C<$y> as the I of the input. If you want to process a matrix, you must hand in the I of the matrix, and then transpose the output when you get it back. that is because pdls are indexed by (col,row), and matrices are (row,column) by convention, so a 1-D pdl corresponds to a row vector, not a column vector. If C<$lu> is dense and you have more than a few points to solve for, it is probably cheaper to find C with L, and just multiply C.) in fact, L works by calling C with the identity matrix. C is ported from section 2.3 of I. It is written in PDL but should probably be implemented in C. =cut *PDL::lu_backsub = \&lu_backsub; sub lu_backsub { my ($lu, $perm, $y, $par); print STDERR "lu_backsub: entering debug version...\n" if $PDL::debug; if(@_==3) { ($lu, $perm, $y) = @_; } elsif(@_==4) { ($lu, $perm, $par, $y) = @_; } barf("lu_backsub: LU decomposition is undef -- probably from a singular matrix.\n") unless defined($lu); barf("Usage: \$x = lu_backsub(\$lu,\$perm,\$y); all must be PDLs\n") unless(UNIVERSAL::isa($lu,'PDL') && UNIVERSAL::isa($perm,'PDL') && UNIVERSAL::isa($y,'PDL')); my $n = $y->dim(0); my $n1 = $n; $n1--; # Make sure broadcasting dimensions are compatible. # There are two possible sources of broadcast dims: # # (1) over multiple LU (i.e., $lu,$perm) instances # (2) over multiple B (i.e., $y) column instances # # The full dimensions of the function call looks like # # lu_backsub( lu(m,m,X), perm(m,X), b(m,Y) ) # # where X is the list of extra LU dims and Y is # the list of extra B dims. We have several possible # cases: # # (1) Check that m dims are compatible my $ludims = pdl($lu->dims); my $permdims = pdl($perm->dims); my $bdims = pdl($y->dims); print STDERR "lu_backsub: called with args: \$lu$ludims, \$perm$permdims, \$y$bdims\n" if $PDL::debug; my $m = $ludims->slice("(0)"); # this is the sig dimension unless ( ($ludims->slice(0) == $m) and ($ludims->slice(1) == $m) and ($permdims->slice(0) == $m) and ($bdims->slice(0) == $m)) { barf "lu_backsub: mismatched sig dimensions"; } my $lunumthr = $ludims->dim(0)-2; my $permnumthr = $permdims->dim(0)-1; my $bnumthr = $bdims->dim(0)-1; unless ( ($lunumthr == $permnumthr) and ($ludims->slice("1:-1") == $permdims)->all ) { barf "lu_backsub: \$lu and \$perm broadcast dims not equal! \n"; } # (2) If X == Y then default broadcasting is ok if ( ($bnumthr==$permnumthr) and ($bdims==$permdims)->all) { print STDERR "lu_backsub: have explicit broadcast dims, goto BROADCAST_OK\n" if $PDL::debug; goto BROADCAST_OK; } # (3) If X == (x,Y) then add x dummy to lu,perm # (4) If ndims(X) > ndims(Y) then must have #3 # (5) If ndims(X) < ndims(Y) then foreach # non-trivial leading dim in X (x0,x1,..) # insert dummy (x0,x1) into lu and perm # This means that broadcasting occurs over all # leading non-trivial (not length 1) dims of # B unless all the broadcast dims are explicitly # matched to the LU dims. BROADCAST_OK: # Permute the vector and make a copy if necessary. my $out = $y->dummy(1,$y->dim(0))->index($perm->dummy(1)); $out = $out->sever if !$y->is_inplace; print STDERR "lu_backsub: starting with \$out" . pdl($out->dims) . "\n" if $PDL::debug; # Make sure broadcasting over lu happens OK... if($out->ndims < $lu->ndims-1) { print STDERR "lu_backsub: adjusting dims for \$out" . pdl($out->dims) . "\n" if $PDL::debug; do { $out = $out->dummy(-1,$lu->dim($out->ndims+1)); } while($out->ndims < $lu->ndims-1); } ## Do forward substitution into L my $row; my $r1; for $row(1..$n1) { $r1 = $row-1; $out->index($row) -= ($lu->slice("0:$r1,$row") * $out->slice("0:$r1") )->sumover; } ## Do backward substitution into U, and normalize by the diagonal my $ludiag = $lu->diagonal(0,1); $out->index($n1) /= $ludiag->index($n1)->dummy(0); # TODO: check broadcasting for ($row=$n1; $row>0; $row--) { $r1 = $row-1; $out->index($r1) -= ($lu->slice("$row:$n1,$r1") * # TODO: check broadcast dims $out->slice("$row:$n1") )->sumover; $out->index($r1) /= $ludiag->index($r1)->dummy(0); # TODO: check broadcast dims } if ($y->is_inplace) { $y->setdims([$out->dims]) if !PDL::all($y->shape == $out->shape); # assgn needs same shape $y .= $out; } $out; } #line 1216 "lib/PDL/MatrixOps.pm" =head2 simq =for sig Signature: ([io,phys]a(n,n); [phys]b(n); [o,phys]x(n); int [o,phys]ips(n); int flag) Types: (double) =for ref Solution of simultaneous linear equations, C. B. =for usage # remove all active dims @A_dims = $A->dims; @B_dims = $B->transpose->dims; splice @A_dims, 0, 2; splice @B_dims, 0, 1; @broadcast = PDL::Core::dims_filled(\@A_dims, \@B_dims); # simq modifies A, so need 1 copy per broadcast else non-first run has wrong A ($x) = simq($A->dupN(1,1,map +($A_dims[$_]//1)==1?$broadcast[$_]:1, 0..$#broadcast)->copy, $B->transpose, 0); $x = $x->inplace->transpose; C<$a> is an C matrix (i.e., a vector of length C), stored row-wise: that is, C, where C. While this is the transpose of the normal column-wise storage, this corresponds to normal PDL usage. The contents of matrix a may be altered (but may be required for subsequent calls with flag = -1). C<$y>, C<$x>, C<$ips> are vectors of length C. Set C to solve. Set C to do a new back substitution for different C<$y> vector using the same a matrix previously reduced when C (the C<$ips> vector generated in the previous solution is also required). For this function to work well with broadcasting, it will need the LU decomposition part split out, so that for solving C only C would be written to. See also L, which does the same thing with a slightly less opaque interface. =pod Broadcasts over its inputs. =for bad C ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *simq = \&PDL::simq; =head2 squaretotri =for sig Signature: (a(n,n); [o]b(m=CALC(($SIZE(n) * ($SIZE(n)+1))/2))) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = squaretotri($a); squaretotri($a, $b); # all arguments given $b = $a->squaretotri; # method call $a->squaretotri($b); =for ref Convert a lower-triangular square matrix to triangular vector storage. Ignores upper half of input. =pod Broadcasts over its inputs. =for bad C 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 *squaretotri = \&PDL::squaretotri; =head2 tritosquare =for sig Signature: (a(m); [o]b(n,n)) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $b = tritosquare($a); tritosquare($a, $b); # all arguments given $b = $a->tritosquare; # method call $a->tritosquare($b); =for ref Convert a triangular vector to lower-triangular square matrix storage. Does not touch upper half of output. =pod Broadcasts over its inputs. =for bad C 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 *tritosquare = \&PDL::tritosquare; =head2 tricpy =for sig Signature: (A(m,n);[o] C(m,n); int uplo) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $C = tricpy($A); # using default of uplo=0 $C = tricpy($A, $uplo); tricpy($A, $uplo, $C); # all arguments given $C = $A->tricpy; # method call $C = $A->tricpy($uplo); $A->tricpy($uplo, $C); =for ref Copy triangular part to another matrix. If uplo == 0 copy upper triangular part. Originally by Grégory Vanuxem. =pod Broadcasts over its inputs. =for bad C 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 *tricpy = \&PDL::tricpy; =head2 mstack =for sig Signature: (x(n,m);y(n,p);[o]out(n,q=CALC($SIZE(m)+$SIZE(p)))) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $out = mstack($x, $y); mstack($x, $y, $out); # all arguments given $out = $x->mstack($y); # method call $x->mstack($y, $out); =for ref Combine two 2D ndarrays into a single ndarray, along the second ("vertical") dim. This routine does backward and forward dataflow automatically. Originally by Grégory Vanuxem. =pod Broadcasts over its inputs. Creates data-flow back and forth by default. =for bad C 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 *mstack = \&PDL::mstack; =head2 augment =for sig Signature: (x(n); y(p);[o]out(q=CALC($SIZE(n)+$SIZE(p)))) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble cfloat cdouble cldouble) =for usage $out = augment($x, $y); augment($x, $y, $out); # all arguments given $out = $x->augment($y); # method call $x->augment($y, $out); =for ref Combine two ndarrays into a single ndarray along the 0-th ("horizontal") dim. This routine does backward and forward dataflow automatically. Originally by Grégory Vanuxem. =pod Broadcasts over its inputs. Creates data-flow back and forth by default. =for bad C 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 *augment = \&PDL::augment; #line 1371 "lib/PDL/MatrixOps.pd" =head1 AUTHOR Copyright (C) 2002 Craig DeForest (deforest@boulder.swri.edu), R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au). There is no warranty. You are allowed to redistribute and/or modify this work under the same conditions as PDL itself. If this file is separated from the PDL distribution, then the PDL copyright notice should be included in this file. =cut #line 1513 "lib/PDL/MatrixOps.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/Math.pm0000644000175000017500000006136714771136056015254 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Math.pd! Don't modify! # package PDL::Math; our @EXPORT_OK = qw(acos asin atan cosh sinh tan tanh ceil floor rint pow acosh asinh atanh erf erfc bessj0 bessj1 bessy0 bessy1 bessjn bessyn lgamma isfinite erfi ndtri polyroots polyfromroots polyval csqrt clog cacos casin cacosh catanh csqrt_up ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Math ; #line 44 "lib/PDL/Math.pd" use strict; use warnings; =head1 NAME PDL::Math - extended mathematical operations and special functions =head1 SYNOPSIS use PDL::Math; use PDL::Graphics::TriD; imag3d [SURF2D,bessj0(rvals(zeroes(50,50))/2)]; =head1 DESCRIPTION This module extends PDL with more advanced mathematical functions than provided by standard Perl. All the functions have one input pdl, and one output, unless otherwise stated. Many of the functions are linked from the system maths library or the Cephes maths library (determined when PDL is compiled); a few are implemented entirely in PDL. =cut ### Kludge for backwards compatibility with older scripts ### This should be deleted at some point later than 21-Nov-2003. BEGIN {use PDL::MatrixOps;} #line 60 "lib/PDL/Math.pm" =head1 FUNCTIONS =cut =head2 acos =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float double ldouble) =for usage $b = acos($a); acos($a, $b); # all arguments given $b = $a->acos; # method call $a->acos($b); $a->inplace->acos; # can be used inplace acos($a->inplace); The usual trigonometric function. =pod Broadcasts over its inputs. =for bad C 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 *acos = \&PDL::acos; =head2 asin =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float double ldouble) =for usage $b = asin($a); asin($a, $b); # all arguments given $b = $a->asin; # method call $a->asin($b); $a->inplace->asin; # can be used inplace asin($a->inplace); The usual trigonometric function. =pod Broadcasts over its inputs. =for bad C 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 *asin = \&PDL::asin; =head2 atan =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float double ldouble) =for usage $b = atan($a); atan($a, $b); # all arguments given $b = $a->atan; # method call $a->atan($b); $a->inplace->atan; # can be used inplace atan($a->inplace); The usual trigonometric function. =pod Broadcasts over its inputs. =for bad C 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 *atan = \&PDL::atan; =head2 cosh =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float double ldouble) =for usage $b = cosh($a); cosh($a, $b); # all arguments given $b = $a->cosh; # method call $a->cosh($b); $a->inplace->cosh; # can be used inplace cosh($a->inplace); The standard hyperbolic function. =pod Broadcasts over its inputs. =for bad C 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 *cosh = \&PDL::cosh; =head2 sinh =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float double ldouble) =for usage $b = sinh($a); sinh($a, $b); # all arguments given $b = $a->sinh; # method call $a->sinh($b); $a->inplace->sinh; # can be used inplace sinh($a->inplace); The standard hyperbolic function. =pod Broadcasts over its inputs. =for bad C 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 *sinh = \&PDL::sinh; =head2 tan =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float double ldouble) =for usage $b = tan($a); tan($a, $b); # all arguments given $b = $a->tan; # method call $a->tan($b); $a->inplace->tan; # can be used inplace tan($a->inplace); The usual trigonometric function. =pod Broadcasts over its inputs. =for bad C 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 *tan = \&PDL::tan; =head2 tanh =for sig Signature: (a(); [o]b()) Types: (cfloat cdouble cldouble float double ldouble) =for usage $b = tanh($a); tanh($a, $b); # all arguments given $b = $a->tanh; # method call $a->tanh($b); $a->inplace->tanh; # can be used inplace tanh($a->inplace); The standard hyperbolic function. =pod Broadcasts over its inputs. =for bad C 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 *tanh = \&PDL::tanh; =head2 ceil =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = ceil($a); ceil($a, $b); # all arguments given $b = $a->ceil; # method call $a->ceil($b); $a->inplace->ceil; # can be used inplace ceil($a->inplace); =for ref Round to integer values in floating-point format. =pod Broadcasts over its inputs. =for bad C 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 *ceil = \&PDL::ceil; =head2 floor =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = floor($a); floor($a, $b); # all arguments given $b = $a->floor; # method call $a->floor($b); $a->inplace->floor; # can be used inplace floor($a->inplace); =for ref Round to integer values in floating-point format. =pod Broadcasts over its inputs. =for bad C 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 *floor = \&PDL::floor; =head2 rint =for sig Signature: (a(); [o]b()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $b = rint($a); rint($a, $b); # all arguments given $b = $a->rint; # method call $a->rint($b); $a->inplace->rint; # can be used inplace rint($a->inplace); =for ref Round to integer values in floating-point format. This is the C99 function; previous to 2.096, the doc referred to a bespoke function that did banker's rounding, but this was not used as a system version will have been detected and used. If you are looking to round half-integers up (regardless of sign), try C. If you want to round half-integers away from zero, try C<< ceil(abs($x)+0.5)*($x<=>0) >>. =pod Broadcasts over its inputs. =for bad C 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 *rint = \&PDL::rint; =head2 pow =for sig Signature: (a(); b(); [o]c()) Types: (cfloat cdouble cldouble sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $c = pow($a, $b); pow($a, $b, $c); # all arguments given $c = $a->pow($b); # method call $a->pow($b, $c); $a->inplace->pow($b); # can be used inplace pow($a->inplace, $b); =for ref Synonym for `**'. =pod Broadcasts over its inputs. =for bad C 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 *pow = \&PDL::pow; =head2 acosh =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = acosh($a); acosh($a, $b); # all arguments given $b = $a->acosh; # method call $a->acosh($b); $a->inplace->acosh; # can be used inplace acosh($a->inplace); The standard hyperbolic function. =pod Broadcasts over its inputs. =for bad C 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 *acosh = \&PDL::acosh; =head2 asinh =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = asinh($a); asinh($a, $b); # all arguments given $b = $a->asinh; # method call $a->asinh($b); $a->inplace->asinh; # can be used inplace asinh($a->inplace); The standard hyperbolic function. =pod Broadcasts over its inputs. =for bad C 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 *asinh = \&PDL::asinh; =head2 atanh =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = atanh($a); atanh($a, $b); # all arguments given $b = $a->atanh; # method call $a->atanh($b); $a->inplace->atanh; # can be used inplace atanh($a->inplace); The standard hyperbolic function. =pod Broadcasts over its inputs. =for bad C 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 *atanh = \&PDL::atanh; =head2 erf =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = erf($a); erf($a, $b); # all arguments given $b = $a->erf; # method call $a->erf($b); $a->inplace->erf; # can be used inplace erf($a->inplace); =for ref The error function. =pod Broadcasts over its inputs. =for bad C 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 *erf = \&PDL::erf; =head2 erfc =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = erfc($a); erfc($a, $b); # all arguments given $b = $a->erfc; # method call $a->erfc($b); $a->inplace->erfc; # can be used inplace erfc($a->inplace); =for ref The complement of the error function. =pod Broadcasts over its inputs. =for bad C 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 *erfc = \&PDL::erfc; =head2 bessj0 =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = bessj0($a); bessj0($a, $b); # all arguments given $b = $a->bessj0; # method call $a->bessj0($b); $a->inplace->bessj0; # can be used inplace bessj0($a->inplace); =for ref The regular Bessel function of the first kind, J_n =pod Broadcasts over its inputs. =for bad C 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 *bessj0 = \&PDL::bessj0; =head2 bessj1 =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = bessj1($a); bessj1($a, $b); # all arguments given $b = $a->bessj1; # method call $a->bessj1($b); $a->inplace->bessj1; # can be used inplace bessj1($a->inplace); =for ref The regular Bessel function of the first kind, J_n =pod Broadcasts over its inputs. =for bad C 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 *bessj1 = \&PDL::bessj1; =head2 bessy0 =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = bessy0($a); bessy0($a, $b); # all arguments given $b = $a->bessy0; # method call $a->bessy0($b); $a->inplace->bessy0; # can be used inplace bessy0($a->inplace); =for ref The regular Bessel function of the second kind, Y_n. =pod Broadcasts over its inputs. =for bad C 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 *bessy0 = \&PDL::bessy0; =head2 bessy1 =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = bessy1($a); bessy1($a, $b); # all arguments given $b = $a->bessy1; # method call $a->bessy1($b); $a->inplace->bessy1; # can be used inplace bessy1($a->inplace); =for ref The regular Bessel function of the second kind, Y_n. =pod Broadcasts over its inputs. =for bad C 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 *bessy1 = \&PDL::bessy1; =head2 bessjn =for sig Signature: (a(); int n(); [o]b()) Types: (float double ldouble) =for usage $b = bessjn($a, $n); bessjn($a, $n, $b); # all arguments given $b = $a->bessjn($n); # method call $a->bessjn($n, $b); $a->inplace->bessjn($n); # can be used inplace bessjn($a->inplace, $n); =for ref The regular Bessel function of the first kind, J_n . This takes a second int argument which gives the order of the function required. =pod Broadcasts over its inputs. =for bad C 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 *bessjn = \&PDL::bessjn; =head2 bessyn =for sig Signature: (a(); int n(); [o]b()) Types: (float double ldouble) =for usage $b = bessyn($a, $n); bessyn($a, $n, $b); # all arguments given $b = $a->bessyn($n); # method call $a->bessyn($n, $b); $a->inplace->bessyn($n); # can be used inplace bessyn($a->inplace, $n); =for ref The regular Bessel function of the first kind, Y_n . This takes a second int argument which gives the order of the function required. =pod Broadcasts over its inputs. =for bad C 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 *bessyn = \&PDL::bessyn; =head2 lgamma =for sig Signature: (a(); [o]b(); int[o]s()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage ($b, $s) = lgamma($a); lgamma($a, $b, $s); # all arguments given ($b, $s) = $a->lgamma; # method call $a->lgamma($b, $s); =for ref log gamma function This returns 2 ndarrays -- the first set gives the log(gamma) values, while the second set, of integer values, gives the sign of the gamma function. This is useful for determining factorials, amongst other things. =pod Broadcasts over its inputs. =for bad C 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 *lgamma = \&PDL::lgamma; =head2 isfinite =for sig Signature: (a(); int [o]mask()) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =for usage $mask = isfinite($a); isfinite($a, $mask); # all arguments given $mask = $a->isfinite; # method call $a->isfinite($mask); =for ref Sets C<$mask> true if C<$a> is not a C or C (either positive or negative). =pod Broadcasts over its inputs. =for bad Bad values are treated as C or C. =cut *isfinite = \&PDL::isfinite; =head2 erfi =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = erfi($a); erfi($a, $b); # all arguments given $b = $a->erfi; # method call $a->erfi($b); $a->inplace->erfi; # can be used inplace erfi($a->inplace); =for ref erfi =pod Broadcasts over its inputs. =for bad C 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 *erfi = \&PDL::erfi; =head2 ndtri =for sig Signature: (a(); [o]b()) Types: (float double ldouble) =for usage $b = ndtri($a); ndtri($a, $b); # all arguments given $b = $a->ndtri; # method call $a->ndtri($b); $a->inplace->ndtri; # can be used inplace ndtri($a->inplace); =for ref ndtri =pod Broadcasts over its inputs. =for bad C 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 *ndtri = \&PDL::ndtri; =head2 polyroots =for sig Signature: (cr(n); ci(n); [o]rr(m=CALC($SIZE(n)-1)); [o]ri(m)) Types: (double) =for ref Complex roots of a complex polynomial, given coefficients in order of decreasing powers. Only works for degree >= 1. Uses the Jenkins-Traub algorithm (see L). As of 2.086, works with native-complex data. =for usage $roots = polyroots($coeffs); # native complex polyroots($coeffs, $roots=null); # native complex ($rr, $ri) = polyroots($cr, $ci); polyroots($cr, $ci, $rr, $ri); =pod Broadcasts over its inputs. =for bad C 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 357 "lib/PDL/Math.pd" sub PDL::polyroots { my @args = map PDL->topdl($_), @_; my $natcplx = !$args[0]->type->real; barf "need array context if give real data and no outputs" if !$natcplx and @_ < 3 and !(wantarray//1); splice @args, 0, 1, map $args[0]->$_, qw(re im) if $natcplx; my @ins = splice @args, 0, 2; my $explicit_out = my @outs = @args; if ($natcplx) { $_ //= PDL->null for $outs[0]; } else { $_ //= PDL->null for @outs[0,1]; } my @args_out = $natcplx ? (map PDL->null, 1..2) : @outs; # opposite from polyfromroots PDL::_polyroots_int(@ins, @args_out); return @args_out if !$natcplx; $outs[0] .= PDL::czip(@args_out[0,1]); } #line 1194 "lib/PDL/Math.pm" *polyroots = \&PDL::polyroots; =head2 polyfromroots =for sig Signature: (r(m); [o]c(n=CALC($SIZE(m)+1))) Types: (cdouble) =for ref Calculates the complex coefficients of a polynomial from its complex roots, in order of decreasing powers. Added in 2.086, works with native-complex data. Algorithm is from Octave poly.m, O(n^2), per L; using an FFT would allow O(n*log(n)^2). =for usage $coeffs = polyfromroots($roots); # native complex ($cr, $ci) = polyfromroots($rr, $ri); =pod Broadcasts over its inputs. =for bad C 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 406 "lib/PDL/Math.pd" sub PDL::polyfromroots { my @args = map PDL->topdl($_), @_; my $natcplx = !$args[0]->type->real; barf "need array context" if !$natcplx and !(wantarray//1); if (!$natcplx) { splice @args, 0, 2, $args[0]->czip($args[1]); # r } my @ins = splice @args, 0, 1; my $explicit_out = my @outs = @args; if ($natcplx) { $_ //= PDL->null for $outs[0]; } else { $_ //= PDL->null for @outs[0,1]; } my @args_out = $natcplx ? @outs : PDL->null; PDL::_polyfromroots_int(@ins, @args_out); if (!$natcplx) { $outs[0] .= $args_out[0]->re; $outs[1] .= $args_out[0]->im; } $natcplx ? $outs[0] : @outs; } #line 1263 "lib/PDL/Math.pm" *polyfromroots = \&PDL::polyfromroots; =head2 polyval =for sig Signature: (c(n); x(); [o]y()) Types: (cdouble) =for ref Complex value of a complex polynomial at given point, given coefficients in order of decreasing powers. Uses Horner recurrence. Added in 2.086, works with native-complex data. =for usage $y = polyval($coeffs, $x); # native complex ($yr, $yi) = polyval($cr, $ci, $xr, $xi); =pod Broadcasts over its inputs. =for bad C 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 "lib/PDL/Math.pd" sub PDL::polyval { my @args = map PDL->topdl($_), @_; my $natcplx = !$args[0]->type->real; barf "need array context" if !$natcplx and !(wantarray//1); if (!$natcplx) { splice @args, 0, 2, $args[0]->czip($args[1]); # c splice @args, 1, 2, $args[1]->czip($args[2]); # x } my @ins = splice @args, 0, 2; my $explicit_out = my @outs = @args; if ($natcplx) { $_ //= PDL->null for $outs[0]; } else { $_ //= PDL->null for @outs[0,1]; } my @args_out = $natcplx ? @outs : PDL->null; PDL::_polyval_int(@ins, @args_out); if (!$natcplx) { $outs[0] .= $args_out[0]->re; $outs[1] .= $args_out[0]->im; } $natcplx ? $outs[0] : @outs; } #line 1329 "lib/PDL/Math.pm" *polyval = \&PDL::polyval; =head2 csqrt =for sig Signature: (i(); complex [o] o()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $o = csqrt($i); csqrt($i, $o); # all arguments given $o = $i->csqrt; # method call $i->csqrt($o); =for ref Takes real or complex data, returns the complex C. Added in 2.099. =pod Broadcasts over its inputs. =for bad C 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 *csqrt = \&PDL::csqrt; =head2 clog =for sig Signature: (i(); complex [o] o()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $o = clog($i); clog($i, $o); # all arguments given $o = $i->clog; # method call $i->clog($o); =for ref Takes real or complex data, returns the complex C. Added in 2.099. =pod Broadcasts over its inputs. =for bad C 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 *clog = \&PDL::clog; =head2 cacos =for sig Signature: (i(); complex [o] o()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $o = cacos($i); cacos($i, $o); # all arguments given $o = $i->cacos; # method call $i->cacos($o); =for ref Takes real or complex data, returns the complex C. Added in 2.099. =pod Broadcasts over its inputs. =for bad C 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 *cacos = \&PDL::cacos; =head2 casin =for sig Signature: (i(); complex [o] o()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $o = casin($i); casin($i, $o); # all arguments given $o = $i->casin; # method call $i->casin($o); =for ref Takes real or complex data, returns the complex C. Added in 2.099. =pod Broadcasts over its inputs. =for bad C 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 *casin = \&PDL::casin; =head2 cacosh =for sig Signature: (i(); complex [o] o()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $o = cacosh($i); cacosh($i, $o); # all arguments given $o = $i->cacosh; # method call $i->cacosh($o); =for ref Takes real or complex data, returns the complex C. Added in 2.099. =pod Broadcasts over its inputs. =for bad C 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 *cacosh = \&PDL::cacosh; =head2 catanh =for sig Signature: (i(); complex [o] o()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $o = catanh($i); catanh($i, $o); # all arguments given $o = $i->catanh; # method call $i->catanh($o); =for ref Takes real or complex data, returns the complex C. Added in 2.099. =pod Broadcasts over its inputs. =for bad C 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 *catanh = \&PDL::catanh; =head2 csqrt_up =for sig Signature: (i(); complex [o] o()) Types: (float ldouble cfloat cdouble cldouble double) =for usage $o = csqrt_up($i); csqrt_up($i, $o); # all arguments given $o = $i->csqrt_up; # method call $i->csqrt_up($o); Take the complex square root of a number choosing that whose imaginary part is not negative, i.e., it is a square root with a branch cut 'infinitesimally' below the positive real axis. =pod Broadcasts over its inputs. =for bad C 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 *csqrt_up = \&PDL::csqrt_up; #line 529 "lib/PDL/Math.pd" =head1 AUTHOR Copyright (C) R.J.R. Williams 1997 (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au) and Tuomas J. Lukka (Tuomas.Lukka@helsinki.fi). Portions (C) Craig DeForest 2002 (deforest@boulder.swri.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the PDL copyright notice should be included in the file. =cut #line 1639 "lib/PDL/Math.pm" # Exit with OK status 1; PDL-2.100/GENERATED/PDL/Transform.pm0000644000175000017500000031020614771136067016325 0ustar osboxesosboxes# # GENERATED WITH PDL::PP from lib/PDL/Transform.pd! Don't modify! # package PDL::Transform; our @EXPORT_OK = qw(apply invert map map unmap t_inverse t_compose t_wrap t_identity t_lookup t_linear t_scale t_offset t_rot t_fits t_code t_cylindrical t_radial t_quadratic t_cubic t_quadratic t_spherical t_projective ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Transform ; #line 2 "lib/PDL/Transform.pd" =head1 NAME PDL::Transform - Coordinate transforms, image warping, and N-D functions =head1 SYNOPSIS use PDL::Transform; my $t = PDL::Transform::->new() $out = $t->apply($in) # Apply transform to some N-vectors (Transform method) $out = $in->apply($t) # Apply transform to some N-vectors (PDL method) $im1 = $t->map($im); # Transform image coordinates (Transform method) $im1 = $im->map($t); # Transform image coordinates (PDL method) $t2 = $t->compose($t1); # compose two transforms $t2 = $t x $t1; # compose two transforms (by analogy to matrix mult.) $t3 = $t2->inverse(); # invert a transform $t3 = !$t2; # invert a transform (by analogy to logical "not") =head1 DESCRIPTION PDL::Transform is a convenient way to represent coordinate transformations and resample images. It embodies functions mapping R^N -> R^M, both with and without inverses. Provision exists for parametrizing functions, and for composing them. You can use this part of the Transform object to keep track of arbitrary functions mapping R^N -> R^M with or without inverses. The simplest way to use a Transform object is to transform vector data between coordinate systems. The L method accepts a PDL whose 0th dimension is coordinate index (all other dimensions are broadcasted over) and transforms the vectors into the new coordinate system. Transform also includes image resampling, via the L method. You define a coordinate transform using a Transform object, then use it to remap an image PDL. The output is a remapped, resampled image. You can define and compose several transformations, then apply them all at once to an image. The image is interpolated only once, when all the composed transformations are applied. In keeping with standard practice, but somewhat counterintuitively, the L engine uses the inverse transform to map coordinates FROM the destination dataspace (or image plane) TO the source dataspace; hence PDL::Transform keeps track of both the forward and inverse transform. For terseness and convenience, most of the constructors are exported into the current package with the name C<< t_ >>, so the following (for example) are synonyms: $t = PDL::Transform::Radial->new; # Long way $t = t_radial(); # Short way Several math operators are overloaded, so that you can compose and invert functions with expression syntax instead of method syntax (see below). =head1 EXAMPLE Coordinate transformations and mappings are a little counterintuitive at first. Here are some examples of transforms in action: use PDL::Transform; use PDL::Graphics::Simple; $x = rfits('m51.fits'); # Substitute path if necessary! $ts = t_linear(Scale=>3); # Scaling transform $w = pgswin(xs); $w->plot(with=>'image', $x); ## Grow m51 by a factor of 3; origin is at lower left. $y = $ts->map($x,{pix=>1}); # pix option uses direct pixel coord system $w->plot(with=>'image', $y); ## Shrink m51 by a factor of 3; origin still at lower left. $c = $ts->unmap($x, {pix=>1}); $w->plot(with=>'image', $c); ## Grow m51 by a factor of 3; origin is at scientific origin. $d = $ts->map($x,$x->hdr); # FITS hdr template prevents autoscaling $w->plot(with=>'image', $d); ## Shrink m51 by a factor of 3; origin is still at sci. origin. $e = $ts->unmap($x,$x->hdr); $w->plot(with=>'image', $e); ## A no-op: shrink m51 by a factor of 3, then autoscale back to size $f = $ts->map($x); # No template causes autoscaling of output =head1 OPERATOR OVERLOADS =over 3 =item '!' The bang is a unary inversion operator. It binds exactly as tightly as the normal bang operator. =item 'x' By analogy to matrix multiplication, 'x' is the compose operator, so these two expressions are equivalent: $f->inverse()->compose($g)->compose($f) # long way !$f x $g x $f # short way Both of those expressions are equivalent to the mathematical expression f^-1 o g o f, or f^-1(g(f(x))). =item '**' By analogy to numeric powers, you can apply an operator a positive integer number of times with the ** operator: $f->compose($f)->compose($f) # long way $f**3 # short way =back =head1 INTERNALS Transforms are perl hashes. Here's a list of the meaning of each key: =over 3 =item func Ref to a subroutine that evaluates the transformed coordinates. It's called with the input coordinate, and the "params" hash. This springboarding is done via explicit ref rather than by subclassing, for convenience both in coding new transforms (just add the appropriate sub to the module) and in adding custom transforms at run-time. Note that, if possible, new Cs should support L operation to save memory when the data are flagged inplace. But C should always return its result even when flagged to compute in-place. C should treat the 0th dimension of its input as a dimensional index (running 0..N-1 for R^N operation) and broadcast over all other input dimensions. =item inv Ref to an inverse method that reverses the transformation. It must accept the same "params" hash that the forward method accepts. This key can be left undefined in cases where there is no inverse. =item idim, odim Number of useful dimensions for indexing on the input and output sides (ie the order of the 0th dimension of the coordinates to be fed in or that come out). If this is set to 0, then as many are allocated as needed. =item name A shorthand name for the transformation (convenient for debugging). You should plan on using UNIVERAL::isa to identify classes of transformation, e.g. all linear transformations should be subclasses of PDL::Transform::Linear. That makes it easier to add smarts to, e.g., the compose() method. =item itype An array containing the name of the quantity that is expected from the input ndarray for the transform, for each dimension. This field is advisory, and can be left blank if there's no obvious quantity associated with the transform. This is analogous to the CTYPEn field used in FITS headers. =item oname Same as itype, but reporting what quantity is delivered for each dimension. =item iunit The units expected on input, if a specific unit (e.g. degrees) is expected. This field is advisory, and can be left blank if there's no obvious unit associated with the transform. =item ounit Same as iunit, but reporting what quantity is delivered for each dimension. =item params Hash ref containing relevant parameters or anything else the func needs to work right. =item is_inverse Bit indicating whether the transform has been inverted. That is useful for some stringifications (see the PDL::Transform::Linear stringifier), and may be useful for other things. =back Transforms should be inplace-aware where possible, to prevent excessive memory usage. If you define a new type of transform, consider generating a new stringify method for it. Just define the sub "stringify" in the subclass package. It should call SUPER::stringify to generate the first line (though the PDL::Transform::Composition bends this rule by tweaking the top-level line), then output (indented) additional lines as necessary to fully describe the transformation. =head1 NOTES Transforms have a mechanism for labeling the units and type of each coordinate, but it is just advisory. A routine to identify and, if necessary, modify units by scaling would be a good idea. Currently, it just assumes that the coordinates are correct for (e.g.) FITS scientific-to-pixel transformations. Composition works OK but should probably be done in a more sophisticated way so that, for example, linear transformations are combined at the matrix level instead of just strung together pixel-to-pixel. =head1 MODULE INTERFACE There are both operators and constructors. The constructors are all exported, all begin with "t_", and all return objects that are subclasses of PDL::Transform. The L, L, L, and L methods are also exported to the C package: they are both Transform methods and PDL methods. =cut use strict; use warnings; #line 266 "lib/PDL/Transform.pm" =head1 FUNCTIONS =cut #line 315 "lib/PDL/Transform.pd" =head2 apply =for sig Signature: (data(); PDL::Transform t) =for usage $out = $data->apply($t); $out = $t->apply($data); =for ref Apply a transformation to some input coordinates. In the example, C<$t> is a PDL::Transform and C<$data> is a PDL to be interpreted as a collection of N-vectors (with index in the 0th dimension). The output is a similar but transformed PDL. For convenience, this is both a PDL method and a Transform method. =cut use Carp; *PDL::apply = \&apply; sub apply { my ($me, $from) = UNIVERSAL::isa($_[0],'PDL') ? @_[1,0] : @_; croak "apply requires both a PDL and a PDL::Transform.\n" unless UNIVERSAL::isa($me,'PDL::Transform') && UNIVERSAL::isa($from,'PDL'); croak "Applying a PDL::Transform with no func! Oops.\n" unless(defined($me->{func}) and ref($me->{func}) eq 'CODE'); my $result = $me->{func}->($from,$me->{params}); $result->is_inplace(0); # clear inplace flag, just in case. if (defined $from->gethdr && $from->hdr->{NAXIS}) { my $nd = $me->{odim} || $me->{idim} || 2; for my $d (1..$nd) { $result->hdr->{"CTYPE$d"} = ( (!defined($me->{otype}) ? "" : ref($me->{otype}) ne 'ARRAY' ? $me->{otype} : $me->{otype}[$d-1]) || $from->hdr->{"CTYPE$d"} || ""); $result->hdr->{"CUNIT$d"} = ( (!defined($me->{ounit}) ? "" : ref($me->{ounit}) ne 'ARRAY' ? $me->{ounit} : $me->{ounit}[$d-1]) || $from->hdr->{"CUNIT$d"} || $from->hdr->{"CTYPE$d"} || ""); } } return $result; } #line 373 "lib/PDL/Transform.pd" =head2 invert =for sig Signature: (data(); PDL::Transform t) =for usage $out = $t->invert($data); $out = $data->invert($t); =for ref Apply an inverse transformation to some input coordinates. In the example, C<$t> is a PDL::Transform and C<$data> is an ndarray to be interpreted as a collection of N-vectors (with index in the 0th dimension). The output is a similar ndarray. For convenience this is both a PDL method and a PDL::Transform method. =cut *PDL::invert = \&invert; sub invert { my ($me, $from) = UNIVERSAL::isa($_[0],'PDL') ? @_[1,0] : @_; croak "invert requires a PDL and a PDL::Transform (did you want 'inverse' instead?)\n" unless UNIVERSAL::isa($me,'PDL::Transform') && UNIVERSAL::isa($from,'PDL'); croak "Inverting a PDL::Transform with no inverse! Oops.\n" unless(defined($me->{inv}) and ref($me->{inv}) eq 'CODE'); my $result = $me->{inv}->($from, $me->{params}); $result->is_inplace(0); # make sure inplace flag is clear. return $result; } #line 368 "lib/PDL/Transform.pm" =head2 map =for sig Signature: (k0(); pdl *in; pdl *out; pdl *map; SV *boundary; SV *method; long big; double blur; double sv_min; char flux; SV *bv) Types: (sbyte byte short ushort long ulong indx ulonglong longlong float double ldouble) =head2 match =for usage $y = $x->match($c); # Match $c's header and size $y = $x->match([100,200]); # Rescale to 100x200 pixels $y = $x->match([100,200],{rect=>1}); # Rescale and remove rotation/skew. =for ref Resample a scientific image to the same coordinate system as another. The example above is syntactic sugar for $y = $x->map(t_identity, $c, ...); it resamples the input PDL with the identity transformation in scientific coordinates, and matches the pixel coordinate system to $c's FITS header. There is one difference between match and map: match makes the C option to C default to 0, not 1. This only affects matching where autoscaling is required (i.e. the array ref example above). By default, that example simply scales $x to the new size and maintains any rotation or skew in its scientific-to-pixel coordinate transform. =head2 map =for usage $y = $x->map($xform,[