File Coverage

blib/lib/PDLA/IO/Misc.pm
Criterion Covered Total %
statement 345 537 64.2
branch 157 318 49.3
condition 48 103 46.6
subroutine 27 32 84.3
pod 5 11 45.4
total 582 1001 58.1


line stmt bran cond sub pod time code
1              
2             #
3             # GENERATED WITH PDLA::PP! Don't modify!
4             #
5             package PDLA::IO::Misc;
6              
7             @EXPORT_OK = qw( rcols wcols swcols rgrep rdsa PDLA::PP bswap2 PDLA::PP bswap4 PDLA::PP bswap8 isbigendian rasc rcube PDLA::PP _rasc );
8             %EXPORT_TAGS = (Func=>[@EXPORT_OK]);
9              
10 18     18   754 use PDLA::Core;
  18         40  
  18         129  
11 18     18   132 use PDLA::Exporter;
  18         42  
  18         113  
12 18     18   114 use DynaLoader;
  18         40  
  18         1285  
13              
14              
15              
16            
17             @ISA = ( 'PDLA::Exporter','DynaLoader' );
18             push @PDLA::Core::PP, __PACKAGE__;
19             bootstrap PDLA::IO::Misc ;
20              
21              
22              
23              
24              
25             =head1 NAME
26              
27             PDLA::IO::Misc - misc IO routines for PDLA
28              
29             =head1 DESCRIPTION
30              
31             Some basic I/O functionality: FITS, tables, byte-swapping
32              
33             =head1 SYNOPSIS
34              
35             use PDLA::IO::Misc;
36              
37             =cut
38              
39              
40              
41              
42              
43              
44              
45             =head1 FUNCTIONS
46              
47              
48              
49             =cut
50              
51              
52              
53              
54              
55 18     18   130 use PDLA::Primitive;
  18         36  
  18         138  
56 18     18   143 use PDLA::Types;
  18         41  
  18         2267  
57 18     18   131 use PDLA::Options;
  18         60  
  18         1192  
58 18     18   188 use PDLA::Bad;
  18         52  
  18         114  
59 18     18   136 use Carp;
  18         46  
  18         1120  
60 18     18   118 use Symbol qw/ gensym /;
  18         46  
  18         1058  
61 18     18   119 use List::Util;
  18         36  
  18         987  
62 18     18   129 use strict;
  18         43  
  18         11718  
63              
64              
65              
66              
67              
68             =head2 bswap2
69              
70             =for sig
71              
72             Signature: (x(); )
73              
74             =for ref
75              
76             Swaps pairs of bytes in argument x()
77              
78             =for bad
79              
80             bswap2 does not process bad values.
81             It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles.
82              
83              
84             =cut
85              
86              
87              
88              
89              
90              
91             *bswap2 = \&PDLA::bswap2;
92              
93              
94              
95              
96              
97             =head2 bswap4
98              
99             =for sig
100              
101             Signature: (x(); )
102              
103             =for ref
104              
105             Swaps quads of bytes in argument x()
106              
107             =for bad
108              
109             bswap4 does not process bad values.
110             It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles.
111              
112              
113             =cut
114              
115              
116              
117              
118              
119              
120             *bswap4 = \&PDLA::bswap4;
121              
122              
123              
124              
125              
126             =head2 bswap8
127              
128             =for sig
129              
130             Signature: (x(); )
131              
132             =for ref
133              
134             Swaps octets of bytes in argument x()
135              
136             =for bad
137              
138             bswap8 does not process bad values.
139             It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles.
140              
141              
142             =cut
143              
144              
145              
146              
147              
148              
149             *bswap8 = \&PDLA::bswap8;
150              
151              
152              
153              
154              
155              
156             # Internal routine to extend PDLA array by size $n along last dimension
157             # - Would be nice to have a proper extend function rather than hack
158             # - Is a NO-OP when handed a perl ARRAY ref rather than a piddle arg
159             sub _ext_lastD { # Called by rcols and rgrep
160 28     28   57 my ($x,$n) = @_;
161 28 50       68 if (ref($_[0]) ne 'ARRAY') {
162 28         86 my @nold = $x->dims;
163 28         52 my @nnew = @nold;
164 28         46 $nnew[-1] += $n; # add $n to the last dimension
165 28         72 my $y = zeroes($x->type,@nnew); # New pdl
166 28         292 my $yy = $y->mv(-1,0)->slice("0:".($nold[-1]-1))->mv(0,-1);
167 28         151 $yy .= $x;
168 28         169 $_[0] = $y;
169             }
170 28         105 1;
171             }
172              
173             # Implements PDLA->at() for either 1D PDLA or ARRAY arguments
174             # TODO: Need to add support for multidim piddles parallel to rcols
175             sub _at_1D ($$) { # Called by wcols and swcols
176 32     32   40 my $data = $_[0];
177 32         40 my $index = $_[1];
178            
179 32 50       55 if (ref $data eq 'ARRAY') {
180 0         0 return $data->[$index];
181             } else {
182 32         69 return $data->at($index);
183             }
184             }
185              
186             # squeezes "fluffy" perl list values into column data type
187             sub _burp_1D {
188 55     55   90 my $data = $_[0]->[0];
189 55         73 my $databox = $_[0]->[1];
190 55         78 my $index = $_[1];
191              
192 55         70 my $start = $index - @{$databox} + 1;
  55         104  
193              
194 55         82 my $tmp; # work around for perl -d "feature"
195 55 50       159 if (ref $data eq 'ARRAY') {
    100          
196 0         0 push @{$data}, @{$databox};
  0         0  
  0         0  
197             } elsif ( ref($databox->[0]) eq "ARRAY" ) {
198             # could add POSIX::strtol for hex and octal support but
199             # can't break float conversions (how?)
200 2         14 ($tmp = $data->slice(":,$start:$index")) .= pdl($databox);
201             } else {
202             # could add POSIX::strtol for hex and octal support but
203             # can't break float conversions (how?)
204 53         202 ($tmp = $data->slice("$start:$index")) .= pdl($databox);
205             }
206 55         378 $_[0] = [ $data, [] ];
207             }
208              
209             # taken outside of rcols() to avoid clutter
210             sub _handle_types ($$$) {
211 11     11   24 my $ncols = shift;
212 11         17 my $deftype = shift;
213 11         14 my $types = shift;
214              
215 11 50       29 barf "Unknown PDLA type given for DEFTYPE.\n"
216             unless ref($deftype) eq "PDLA::Type";
217              
218 11 50       31 my @cols = ref($types) eq "ARRAY" ? @$types : ();
219            
220 11 100       26 if ( $#cols > -1 ) {
221             # truncate if required
222 1 50       5 $#cols = $ncols if $#cols > $ncols;
223            
224             # check input values are sensible
225 1         4 for ( 0 .. $#cols ) {
226 1 50       5 barf "Unknown value '$cols[$_]' in TYPES array.\n"
227             unless ref($cols[$_]) eq "PDLA::Type";
228             }
229             }
230              
231             # fill in any missing columns
232 11         29 for ( ($#cols+1) .. $ncols ) { push @cols, $deftype; }
  20         38  
233              
234 11         27 return @cols;
235             } # sub: _handle_types
236              
237              
238             # Whether an object is an IO handle
239 18     18   157 use Scalar::Util;
  18         52  
  18         7016  
240             sub _is_io_handle {
241 16     16   31 my $h = shift;
242             # reftype catches almost every handle, except: *MYHANDLE
243             # fileno catches *MYHANDLE, but doesn't catch handles that aren't files
244 16         45 my $reftype = Scalar::Util::reftype($h);
245 16   66     113 return defined(fileno($h)) || (defined($reftype) && $reftype eq 'GLOB');
246             }
247              
248              
249             =head2 rcols
250              
251             =for ref
252              
253             Read specified ASCII cols from a file into piddles and perl
254             arrays (also see L).
255              
256             =for usage
257              
258             Usage:
259             ($x,$y,...) = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, $col1, $col2, ... )
260             $x = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, [] )
261             ($x,$y,...) = rcols( *HANDLE|"filename", $col1, $col2, ..., { EXCLUDE => '/^!/' } )
262             ($x,$y,...) = rcols( *HANDLE|"filename", "/foo/", $col1, $col2, ... )
263              
264             For each column number specified, a 1D output PDLA will be
265             generated. Anonymous arrays of column numbers generate
266             2D output piddles with dim0 for the column data and dim1
267             equal to the number of columns in the anonymous array(s).
268              
269             An empty anonymous array as column specification will
270             produce a single output data piddle with dim(1) equal
271             to the number of columns available.
272              
273             There are two calling conventions - the old version, where a
274             pattern can be specified after the filename/handle, and the
275             new version where options are given as as hash reference.
276             This reference can be given as either the second or last
277             argument.
278              
279             The default behaviour is to ignore lines beginning with
280             a # character and lines that only consist of whitespace.
281             Options exist to only read from lines that match, or do
282             not match, supplied patterns, and to set the types of the
283             created piddles.
284              
285             Can take file name or *HANDLE, and if no explicit column
286             numbers are specified, all are assumed. For the allowed types,
287             see L.
288              
289             Options (case insensitive):
290              
291             EXCLUDE or IGNORE
292             - ignore lines matching this pattern (default B<'/^#/'>).
293            
294             INCLUDE or KEEP
295             - only use lines which match this pattern (default B<''>).
296            
297             LINES
298             - a string pattern specifying which line numbers to use.
299             Line numbers start at 0 and the syntax is 'a:b:c' to use
300             every c'th matching line between a and b (default B<''>).
301            
302             DEFTYPE
303             - default data type for stored data (if not specified, use the type
304             stored in C<$PDLA::IO::Misc::deftype>, which starts off as B).
305            
306             TYPES
307             - reference to an array of data types, one element for each column
308             to be read in. Any missing columns use the DEFTYPE value (default B<[]>).
309            
310             COLSEP
311             - splits on this string/pattern/qr{} between columns of data. Defaults to
312             $PDLA::IO::Misc::defcolsep.
313            
314             PERLCOLS
315             - an array of column numbers which are to be read into perl arrays
316             rather than piddles. Any columns not specified in the explicit list
317             of columns to read will be returned after the explicit columns.
318             (default B).
319              
320             COLIDS
321             - if defined to an array reference, it will be assigned the column
322             ID values obtained by splitting the first line of the file in the
323             identical fashion to the column data.
324              
325             CHUNKSIZE
326             - the number of input data elements to batch together before appending
327             to each output data piddle (Default value is 100). If CHUNKSIZE is
328             greater than the number of lines of data to read, the entire file is
329             slurped in, lines split, and perl lists of column data are generated.
330             At the end, effectively pdl(@column_data) produces any result piddles.
331              
332             VERBOSE
333             - be verbose about IO processing (default C<$PDLA::vebose>)
334              
335             =for example
336              
337             For example:
338              
339             $x = PDLA->rcols 'file1'; # file1 has only one column of data
340             $x = PDLA->rcols 'file2', []; # file2 can have multiple columns, still 1 piddle output
341             # (empty array ref spec means all possible data fields)
342              
343             ($x,$y) = rcols 'table.csv', { COLSEP => ',' }; # read CSV data file
344             ($x,$y) = rcols *STDOUT; # default separator for lines like '32 24'
345              
346             # read in lines containing the string foo, where the first
347             # example also ignores lines that begin with a # character.
348             ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/' };
349             ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/', EXCLUDE => '' };
350              
351             # ignore the first 27 lines of the file, reading in as ushort's
352             ($x,$y) = rcols 'file3', { LINES => '27:-1', DEFTYPE => ushort };
353             ($x,$y) = rcols 'file3', { LINES => '27:', TYPES => [ ushort, ushort ] };
354              
355             # read in the first column as a perl array and the next two as piddles
356             # with the perl column returned after the piddle outputs
357             ($x,$y,$name) = rcols 'file4', 1, 2 , { PERLCOLS => [ 0 ] };
358             printf "Number of names read in = %d\n", 1 + $#$name;
359              
360             # read in the first column as a perl array and the next two as piddles
361             # with PERLCOLS changing the type of the first returned value to perl list ref
362             ($name,$x,$y) = rcols 'file4', 0, 1, 2, { PERLCOLS => [ 0 ] };
363              
364             # read in the first column as a perl array returned first followed by the
365             # the next two data columns in the file as a single Nx2 piddle
366             ($name,$xy) = rcols 'file4', 0, [1, 2], { PERLCOLS => [ 0 ] };
367              
368              
369             NOTES:
370              
371             1. Quotes are required on patterns or use the qr{} quote regexp syntax.
372            
373             2. Columns are separated by whitespace by default, use the COLSEP option
374             separator to specify an alternate split pattern or string or specify an
375             alternate default separator by setting C<$PDLA::IO::Misc::defcolsep> .
376            
377             3. Legacy support is present to use C<$PDLA::IO::Misc::colsep> to set the
378             column separator but C<$PDLA::IO::Misc::colsep> is not defined by default.
379             If you set the variable to a defined value it will get picked up.
380            
381             4. LINES => '-1:0:3' may not work as you expect, since lines are skipped
382             when read in, then the whole array reversed.
383              
384             5. For consistency with wcols and rcols 1D usage, column data is loaded
385             into the rows of the pdls (i.e., dim(0) is the elements read per column
386             in the file and dim(1) is the number of columns of data read.
387              
388             =cut
389              
390 18     18   141 use vars qw/ $colsep $defcolsep $deftype /;
  18         78  
  18         38186  
391              
392             $defcolsep = ' '; # Default column separator
393             $deftype = double; # Default type for piddles
394              
395             my $defchunksize = 100; # Number of perl list items to append to piddle
396             my $usecolsep; # This is the colsep value that is actually used
397              
398             # NOTE: XXX
399             # need to look at the line-selection code. For instance, if want
400             # lines => '-1:0:3',
401             # read in all lines, reverse, then apply the step
402             # -> fix point 4 above
403             #
404             # perhaps should just simplify the LINES option - ie remove
405             # support for reversed arrays?
406              
407 11     11 1 12777 sub rcols{ PDLA->rcols(@_) }
408              
409             sub PDLA::rcols {
410 11     11 0 22 my $class = shift;
411 11 50       45 barf 'Usage ($x,$y,...) = rcols( *HANDLE|"filename", ["/pattern/" or \%options], $col1, $col2, ..., [ \%options] )'
412             if $#_<0;
413              
414 11         26 my $is_handle = _is_io_handle $_[0];
415 11 100       48 my $fh = $is_handle ? $_[0] : gensym;
416 11 100 50     429 open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle;
417 11         36 shift;
418              
419             # set up default options
420 11         128 my $opt = new PDLA::Options( {
421             CHUNKSIZE => undef,
422             COLIDS => undef,
423             COLSEP => undef,
424             DEFTYPE => $deftype,
425             EXCLUDE => '/^#/',
426             INCLUDE => undef,
427             LINES => '',
428             PERLCOLS => undef,
429             TYPES => [],
430             VERBOSE=> $PDLA::verbose,
431             } );
432 11         57 $opt->synonyms( { IGNORE => 'EXCLUDE', KEEP => 'INCLUDE' } );
433              
434             # has the user supplied any options
435 11 100       34 if ( defined($_[0]) ) {
436             # ensure the old-style behaviour by setting the exclude pattern to undef
437 9 100       49 if ( $_[0] =~ m|^/.*/$| ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); }
  1 50       6  
    100          
438 0         0 elsif ( ref($_[0]) eq "Regexp" ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); }
439 2         7 elsif ( ref($_[0]) eq "HASH" ) { $opt->options( shift ); }
440             }
441              
442             # maybe the last element is a hash array as well
443 11 100 100     51 $opt->options( pop ) if defined($_[-1]) and ref($_[-1]) eq "HASH";
444              
445             # a reference to a hash array
446 11         27 my $options = $opt->current();
447              
448             # handle legacy colsep variable
449 11 50       28 $usecolsep = (defined $colsep) ? qr{$colsep} : undef;
450 11 100       38 $usecolsep = qr{$options->{COLSEP}} if $options->{COLSEP};
451              
452             # what are the patterns?
453 11         22 foreach my $pattern ( qw( INCLUDE EXCLUDE ) ) {
454 22 100 66     75 if ( $options->{$pattern} and ref($options->{$pattern}) ne "Regexp" ) {
455 12 50       65 if ( $options->{$pattern} =~ m|^/.*/$| ) {
456 12         62 $options->{$pattern} =~ s|^/(.*)/$|$1|;
457 12         110 $options->{$pattern} = qr($options->{$pattern});
458             } else {
459 0         0 barf "rcols() - unable to process $pattern value.\n";
460             }
461             }
462             }
463              
464             # CHUNKSIZE controls memory/time tradeoff of piddle IO
465 11   33     42 my $chunksize = $options->{CHUNKSIZE} || $defchunksize;
466 11         19 my $nextburpindex = -1;
467              
468             # which columns are to be read into piddles and which into perl arrays?
469 11         15 my @end_perl_cols = (); # unique perl cols to return at end
470              
471 11         16 my @perl_cols = (); # perl cols index list from PERLCOLS option
472 11 50       22 @perl_cols = @{ $$options{PERLCOLS} } if $$options{PERLCOLS};
  0         0  
473              
474 11         18 my @is_perl_col; # true if index corresponds to a perl column
475 11         24 for (@perl_cols) { $is_perl_col[$_] = 1; };
  0         0  
476             # print STDERR "rcols: \@is_perl_col is @is_perl_col\n";
477              
478 11         28 my ( @explicit_cols ) = @_; # call specified columns to read
479             # print STDERR "rcols: \@explicit_cols is @explicit_cols\n";
480              
481             # work out which line numbers are required
482             # - the regexp's are a bit over the top
483 11         15 my ( $x, $y, $c );
484 11 100       28 if ( $$options{LINES} ne '' ) {
485 1 50       8 if ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*$/ ) {
    0          
486 1         4 $x = $1; $y = $2;
  1         2  
487             } elsif ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*:\s*([+]?\d*)\s*$/ ) {
488 0         0 $x = $1; $y = $2; $c = $3;
  0         0  
  0         0  
489             } else {
490 0         0 barf "rcols() - unable to parse LINES option.\n";
491             }
492             }
493              
494             # Since we do not know how many lines there are in advance, things get a bit messy
495 11         20 my ( $index_start, $index_end ) = ( 0, -1 );
496 11 100 66     30 $index_start = $x if defined($x) and $x ne '';
497 11 100 66     27 $index_end = $y if defined($y) and $y ne '';
498 11   50     34 my $line_step = $c || 1;
499              
500             # $line_rev = 0/1 for normal order/reversed
501             # $line_start/_end refer to the first and last line numbers that we want
502             # (the values of which we may not know until we've read in all the file)
503 11         20 my ( $line_start, $line_end, $line_rev );
504 11 100 66     44 if ( ($index_start >= 0 and $index_end < 0) ) {
    50 33        
    0 0        
    0 0        
    0          
505             # eg 0:-1
506 10         15 $line_rev = 0; $line_start = $index_start;
  10         16  
507             } elsif ( $index_end >= 0 and $index_start < 0 ) {
508             # eg -1:0
509 1         3 $line_rev = 1; $line_start = $index_end;
  1         2  
510             } elsif ( $index_end >= $index_start and $index_start >= 0 ) {
511             # eg 0:10
512 0         0 $line_rev = 0; $line_start = $index_start; $line_end = $index_end;
  0         0  
  0         0  
513             } elsif ( $index_start > $index_end and $index_end >= 0 ) {
514             # eg 10:0
515 0         0 $line_rev = 1; $line_start = $index_end; $line_end = $index_start;
  0         0  
  0         0  
516             } elsif ( $index_start <= $index_end ) {
517             # eg -5:-1
518 0         0 $line_rev = 0;
519             } else {
520             # eg -1:-5
521 0         0 $line_rev = 1;
522             }
523              
524 11         14 my @ret;
525              
526 11         17 my ($k,$fhline);
527              
528 11         16 my $line_num = -1;
529 11         15 my $line_ctr = $line_step - 1; # ensure first line is always included
530 11         31 my $index = -1;
531 11         13 my $pdlsize = 0;
532 11         16 my $extend = 10000;
533              
534 11         15 my $line_store; # line numbers of saved data
535              
536             RCOLS_IO: {
537              
538 11 50       13 if ($options->{COLIDS}) {
  11         22  
539 0 0       0 print STDERR "rcols: processing COLIDS option\n" if $options->{VERBOSE};
540 0         0 undef $!;
541 0 0       0 if (defined($fhline = <$fh>) ) { # grab first line's fields for column IDs
542 0         0 $fhline =~ s/\r?\n$//; # handle DOS on unix files better
543 0 0       0 my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline);
544 0         0 @{$options->{COLIDS}} = @v;
  0         0  
545             } else {
546 0 0       0 die "rcols: reading COLIDS info, $!" if $!;
547 0         0 last RCOLS_IO;
548             }
549             }
550              
551 11         184 while( defined($fhline = <$fh>) ) {
552              
553             # chomp $fhline;
554 50         279 $fhline =~ s/\r?\n$//; # handle DOS on unix files better
555              
556 50         103 $line_num++;
557              
558             # the order of these checks is important, particularly whether we
559             # check for line_ctr before or after the pattern matching
560             # Prior to PDLA 2.003 the line checks were done BEFORE the
561             # pattern matching
562             #
563             # need this first check, even with it almost repeated at end of loop,
564             # incase the pattern matching excludes $line_num == $line_end, say
565 50 50 33     109 last if defined($line_end) and $line_num > $line_end;
566 50 50 33     171 next if defined($line_start) and $line_num < $line_start;
567 50 100 100     263 next if $options->{EXCLUDE} and $fhline =~ /$options->{EXCLUDE}/;
568 43 100 100     167 next if $options->{INCLUDE} and not $fhline =~ /$options->{INCLUDE}/;
569 37 50       75 next unless ++$line_ctr == $line_step;
570 37         59 $line_ctr = 0;
571              
572 37         43 $index++;
573 37 100       129 my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline);
574              
575             # map empty fields '' to undef value
576 37 100       74 @v = map { $_ eq '' ? undef : $_ } @v;
  82         225  
577              
578             # if the first line, set up the output piddles using all the columns
579             # if the user doesn't specify anything
580 37 100       83 if ( $index == 0 ) {
581              
582             # Handle implicit multicolumns in command line
583 10 100       23 if ($#explicit_cols < 0) { # implicit single col data
584 3         11 @explicit_cols = ( 0 .. $#v );
585             }
586 10 100 66     31 if (scalar(@explicit_cols)==1 and ref($explicit_cols[0]) eq "ARRAY") {
587 1 50       3 if ( !scalar(@{$explicit_cols[0]}) ) { # implicit multi-col data
  1         4  
588 1         12 @explicit_cols = ( [ 0 .. $#v ] );
589             }
590             }
591 10         17 my $implicit_pdls = 0;
592 10         18 my $is_explicit = {};
593 10         17 foreach my $col (@explicit_cols) {
594 19 100       35 if (ref($col) eq "ARRAY") {
595 1 50       4 $implicit_pdls++ if !scalar(@$col);
596             } else {
597 18         44 $is_explicit->{$col} = 1;
598             }
599             }
600 10 50       24 if ($implicit_pdls > 1) {
601 0         0 die "rcols: only one implicit multicolumn piddle spec allowed, found $implicit_pdls!\n";
602             }
603 10         17 foreach my $col (@explicit_cols) {
604 19 50 66     52 if (ref($col) eq "ARRAY" and !scalar(@$col)) {
605 0         0 @$col = grep { !$is_explicit->{$_} } ( 0 .. $#v );
  0         0  
606             }
607             }
608            
609             # remove declared perl columns from pdl data list
610 10         14 $k = 0;
611 10         18 my @pdl_cols = ();
612 10         14 foreach my $col (@explicit_cols) {
613             # strip out declared perl cols so they won't be read into piddles
614 19 100       53 if ( ref($col) eq "ARRAY" ) {
    50          
615 1         3 @$col = grep { !$is_perl_col[$_] } @{$col};
  3         9  
  1         3  
616 1         2 push @pdl_cols, [ @{$col} ];
  1         3  
617             } elsif (!$is_perl_col[$col]) {
618 18         35 push @pdl_cols, $col;
619             }
620             }
621             # strip out perl cols in explicit col list for return at end
622 10         17 @end_perl_cols = @perl_cols;
623 10         14 foreach my $col (@explicit_cols) {
624 19 50 66     72 if ( ref($col) ne "ARRAY" and defined($is_perl_col[$col]) ) {
625 0         0 @end_perl_cols = grep { $_ != $col } @end_perl_cols;
  0         0  
626             }
627             };
628              
629             # sort out the types of the piddles
630 10         36 my @types = _handle_types( $#pdl_cols, $$options{DEFTYPE}, $$options{TYPES} );
631 10 50       22 if ( $options->{VERBOSE} ) { # dbg aid
632 0         0 print "Reading data into piddles of type: [ ";
633 0         0 foreach my $t ( @types ) {
634 0         0 print $t->shortctype() . " ";
635             }
636 0         0 print "]\n";
637             }
638              
639 10         17 $k = 0;
640 10         15 for (@explicit_cols) {
641             # Using mixed list+piddle data structure for performance tradeoff
642             # between memory usage (perl list) and speed of IO (PDLA operations)
643 19 100       38 if (ref($_) eq "ARRAY") {
644             # use multicolumn piddle here
645 1         3 push @ret, [ $class->zeroes($types[$k++],scalar(@{$_}),1), [] ];
  1         8  
646             } else {
647 18 50       97 push @ret, ($is_perl_col[$_] ? [ [], [] ] : [ $class->zeroes($types[$k],1), [] ]);
648 18 50       55 $k++ unless $is_perl_col[$_];
649             }
650             }
651 10         21 for (@end_perl_cols) { push @ret, [ [], [] ]; }
  0         0  
652              
653 10         26 $line_store = [ $class->zeroes(long,1), [] ]; # only need to store integers
654             }
655              
656             # if necessary, extend PDLA in buffered manner
657 37         61 $k = 0;
658 37 100       81 if ( $pdlsize < $index ) {
659 9         18 for (@ret, $line_store) { _ext_lastD( $_->[0], $extend ); }
  26         58  
660 9         18 $pdlsize += $extend;
661             }
662              
663             # - stick perl arrays onto end of $ret
664 37         51 $k = 0;
665 37         64 for (@explicit_cols, @end_perl_cols) {
666 69 100       121 if (ref($_) eq "ARRAY") {
667 5         7 push @{ $ret[$k++]->[1] }, [ @v[ @$_ ] ];
  5         20  
668             } else {
669 64         77 push @{ $ret[$k++]->[1] }, $v[$_];
  64         166  
670             }
671             }
672              
673             # store the line number
674 37         44 push @{$line_store->[1]}, $line_num;
  37         61  
675              
676             # need to burp out list if needed
677 37 100       72 if ( $index >= $nextburpindex ) {
678 10         19 for (@ret, $line_store) { _burp_1D($_,$index); }
  29         61  
679 10         19 $nextburpindex = $index + $chunksize;
680             }
681              
682             # Thanks to Frank Samuelson for this
683 37 50 33     242 last if defined($line_end) and $line_num == $line_end;
684             }
685              
686             }
687              
688 11 100       106 close($fh) unless $is_handle;
689              
690             # burp one final time if needed and
691             # clean out additional ARRAY ref level for @ret
692 11         32 for (@ret, $line_store) {
693 30 100 100     70 _burp_1D($_,$index) if defined $_ and scalar @{$_->[1]};
  29         119  
694 30         96 $_ = $_->[0];
695             }
696              
697             # have we read anything in? if not, return empty piddles
698 11 100       30 if ( $index == -1 ) {
699 1 50       4 print "Warning: rcols() did not read in any data.\n" if $options->{VERBOSE};
700 1 50       4 if ( wantarray ) {
701 0         0 foreach ( 0 .. $#explicit_cols ) {
702 0 0       0 if ( $is_perl_col[$_] ) {
703 0         0 $ret[$_] = PDLA->null;
704             } else {
705 0         0 $ret[$_] = [];
706             }
707             }
708 0         0 for ( @end_perl_cols ) { push @ret, []; }
  0         0  
709 0         0 return ( @ret );
710             } else {
711 1         6 return PDLA->null;
712             }
713             }
714              
715             # if the user has asked for lines => 0:-1 or 0:10 or 1:10 or 1:-1,
716             # - ie not reversed and the last line number is known -
717             # then we can skip the following nastiness
718 10 50 66     54 if ( $line_rev == 0 and $index_start >= 0 and $index_end >= -1 ) {
      66        
719 9         17 for (@ret) {
720             ## $_ = $_->mv(-1,0)->slice("0:${index}")->mv(0,-1) unless ref($_) eq 'ARRAY';
721 17 50       143 $_ = $_->mv(-1,0)->slice("0:${index}") unless ref($_) eq 'ARRAY'; # cols are dim(0)
722             };
723 9 50       29 if ( $options->{VERBOSE} ) {
724 0 0       0 if ( ref($ret[0]) eq 'ARRAY' ) {
725 0         0 print "Read in ", scalar( @{ $ret[0] } ), " elements.\n";
  0         0  
726             } else {
727 0         0 print "Read in ", $ret[0]->nelem, " elements.\n";
728             }
729             }
730 9 100       192 wantarray ? return(@ret) : return $ret[0];
731             }
732              
733             # Work out which line numbers we want. First we clean up the piddle
734             # containing the line numbers that have been read in
735 1         6 $line_store = $line_store->slice("0:${index}");
736              
737             # work out the min/max line numbers required
738 1 50       4 if ( $line_rev ) {
739 1 50 33     9 if ( defined($line_start) and defined($line_end) ) {
    50          
740 0         0 my $dummy = $line_start;
741 0         0 $line_start = $line_end;
742 0         0 $line_end = $dummy;
743             } elsif ( defined($line_start) ) {
744 1         3 $line_end = $line_start;
745             } else {
746 0         0 $line_start = $line_end;
747             }
748             }
749 1 50       4 $line_start = $line_num + 1 + $index_start if $index_start < 0;
750 1 50       3 $line_end = $line_num + 1 + $index_end if $index_end < 0;
751              
752 1         3 my $indices;
753              
754 18     18   160 { no warnings 'precedence';
  18         61  
  18         44772  
  1         2  
755 1 50       2 if ( $line_rev ) {
756 1         208 $indices = which( $line_store >= $line_end & $line_store <= $line_start )->slice('-1:0');
757             } else {
758 0         0 $indices = which( $line_store >= $line_start & $line_store <= $line_end );
759             }
760             }
761              
762             # truncate the piddles
763 1         13 for my $col ( @explicit_cols ) {
764 2 50       8 if ( ref($col) eq "ARRAY" ) {
765 0         0 for ( @$col ) {
766 0         0 $ret[$_] = $ret[$_]->index($indices);
767             }
768             } else {
769 2 50       20 $ret[$col] = $ret[$col]->index($indices) unless $is_perl_col[$col] };
770             }
771              
772             # truncate/reverse/etc the perl arrays
773 1         5 my @indices_array = list $indices;
774 1         4 foreach ( @explicit_cols, @end_perl_cols ) {
775 2 50       7 if ( $is_perl_col[$_] ) {
776 0         0 my @temp = @{ $ret[$_] };
  0         0  
777 0         0 $ret[$_] = [];
778 0         0 foreach my $i ( @indices_array ) { push @{ $ret[$_] }, $temp[$i] };
  0         0  
  0         0  
779             }
780             }
781              
782             # print some diagnostics
783 1 50       4 if ( $options->{VERBOSE} ) {
784 0         0 my $done = 0;
785 0         0 foreach my $col (@explicit_cols) {
786 0 0       0 last if $done;
787 0 0       0 next if $is_perl_col[$col];
788 0         0 print "Read in ", $ret[$col]->nelem, " elements.\n";
789 0         0 $done = 1;
790             }
791 0         0 foreach my $col (@explicit_cols, @end_perl_cols) {
792 0 0       0 last if $done;
793 0         0 print "Read in ", $ret[$col]->nelem, " elements.\n";
794 0         0 $done = 1;
795             }
796             }
797              
798             # fix 2D pdls to match what wcols generates
799 1         3 foreach my $col (@ret) {
800 2 50       7 next if ref($col) eq "ARRAY";
801 2 50       46 $col = $col->mv(0,1) if $col->ndims == 2;
802             }
803              
804 1 50       26 wantarray ? return(@ret) : return $ret[0];
805             }
806              
807              
808             =head2 wcols
809              
810             =for ref
811              
812             Write ASCII columns into file from 1D or 2D piddles and/or 1D listrefs efficiently.
813              
814             Can take file name or *HANDLE, and if no file/filehandle is given defaults to STDOUT.
815              
816             Options (case insensitive):
817              
818             HEADER - prints this string before the data. If the string
819             is not terminated by a newline, one is added. (default B<''>).
820              
821             COLSEP - prints this string between columns of data. Defaults to
822             $PDLA::IO::Misc::defcolsep.
823              
824             FORMAT - A printf-style format string that is cycled through
825             column output for user controlled formatting.
826              
827             =for usage
828              
829             Usage: wcols $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; # or
830             wcols $format_string, $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options];
831              
832             where the $dataN args are either 1D piddles, 1D perl array refs,
833             or 2D piddles (as might be returned from rcols() with the [] column
834             syntax and/or using the PERLCOLS option). dim(0) of all piddles
835             written must be the same size. The printf-style $format_string,
836             if given, overrides any FORMAT key settings in the option hash.
837              
838             e.g.,
839              
840             =for example
841              
842             $x = random(4); $y = ones(4);
843             wcols $x, $y+2, 'foo.dat';
844             wcols $x, $y+2, *STDERR;
845             wcols $x, $y+2, '|wc';
846              
847             $x = sequence(3); $y = zeros(3); $c = random(3);
848             wcols $x,$y,$c; # Orthogonal version of 'print $x,$y,$c' :-)
849              
850             wcols "%10.3f", $x,$y; # Formatted
851             wcols "%10.3f %10.5g", $x,$y; # Individual column formatting
852              
853             $x = sequence(3); $y = zeros(3); $units = [ 'm/sec', 'kg', 'MPH' ];
854             wcols $x,$y, { HEADER => "# x y" };
855             wcols $x,$y, { Header => "# x y", Colsep => ', ' }; # case insensitive option names!
856             wcols " %4.1f %4.1f %s",$x,$y,$units, { header => "# Day Time Units" };
857              
858             $a52 = sequence(5,2); $y = ones(5); $c = [ 1, 2, 4 ];
859             wcols $a52; # now can write out 2D pdls (2 columns data in output)
860             wcols $y, $a52, $c # ...and mix and match with 1D listrefs as well
861              
862             NOTES:
863              
864             1. Columns are separated by whitespace by default, use
865             C<$PDLA::IO::Misc::defcolsep> to modify the default value or
866             the COLSEP option
867              
868             2. Support for the C<$PDLA::IO::Misc::colsep> global value
869             of PDLA-2.4.6 and earlier is maintained but the initial value
870             of the global is undef until you set it. The value will be
871             then be picked up and used as if defcolsep were specified.
872              
873             3. Dim 0 corresponds to the column data dimension for both
874             rcols and wcols. This makes wcols the reverse operation
875             of rcols.
876              
877             =cut
878              
879             *wcols = \&PDLA::wcols;
880              
881             sub PDLA::wcols {
882 4 50   4 0 3234 barf 'Usage: wcols($optional_format_string, 1_or_2D_pdls, *HANDLE|"filename", [\%options])' if @_<1;
883              
884             # handle legacy colsep variable
885 4 50       14 $usecolsep = (defined $colsep) ? $colsep : $defcolsep;
886              
887             # if last argument is a reference to a hash, parse the options
888 4         12 my ($format_string, $step, $fh);
889 4         0 my $header;
890 4 100       14 if ( ref( $_[-1] ) eq "HASH" ) {
891 2         3 my $opt = pop;
892 2         9 foreach my $key ( keys %$opt ) {
893 2 50       18 if ( $key =~ /^H/i ) { $header = $opt->{$key}; } # option: HEADER
  0 50       0  
    50          
894 0         0 elsif ( $key =~ /^COLSEP/i ) { $usecolsep = $opt->{$key}; } # option: COLSEP
895 2         7 elsif ( $key =~ /^FORMAT/i ) { $format_string = $opt->{$key}; } # option: FORMAT
896             else {
897 0         0 print "Warning: wcols does not understand option <$key>.\n";
898             }
899             }
900             }
901 4 100 100     19 if (ref(\$_[0]) eq "SCALAR" || $format_string) {
902 3 100       9 $format_string = shift if (ref(\$_[0]) eq "SCALAR");
903             # 1st arg not piddle, explicit format string overrides option hash FORMAT
904 3         5 $step = $format_string;
905 3         24 $step =~ s/(%%|[^%])//g; # use step to count number of format items
906 3         7 $step = length ($step);
907             }
908 4         7 my $file = $_[-1];
909 4         6 my $file_opened;
910 4   33     29 my $is_handle = !UNIVERSAL::isa($file,'PDLA') &&
911             !UNIVERSAL::isa($file,'ARRAY') &&
912             _is_io_handle $file;
913 4 50       11 if ($is_handle) { # file handle passed directly
914 4         8 $fh = $file; pop;
  4         6  
915             }
916             else{
917 0 0       0 if (ref(\$file) eq "SCALAR") { # Must be a file name
918 0         0 $fh = gensym;
919 0 0       0 if (!$is_handle) {
920 0 0 0     0 $file = ">$file" unless $file =~ /^\|/ or $file =~ /^\>/;
921 0 0       0 open $fh, $file or barf "File $file can not be opened for writing\n";
922             }
923 0         0 pop;
924 0         0 $file_opened = 1;
925             }
926             else{ # Not a filehandle or filename, assume something else
927             # (probably piddle) and send to STDOUT
928 0         0 $fh = *STDOUT;
929             }
930             }
931              
932 4         10 my @p = @_;
933 4 50       35 my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->dim(0);
  0         0  
934 4         9 my @dogp = (); # need to break 2D pdls into a their 1D pdl components
935 4         10 for (@p) {
936 8 50       13 if ( ref $_ eq 'ARRAY' ) {
937 0 0       0 barf "wcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n;
  0         0  
938 0         0 push @dogp, $_;
939             } else {
940 8 50 33     41 barf "wcols: 1D args must have same number of elements\n" if $_->dim(0) != $n or $_->getndims > 2;
941 8 50       23 if ( $_->getndims == 2 ) {
942 0         0 push @dogp, $_->dog;
943             } else {
944 8         18 push @dogp, $_;
945             }
946             }
947             }
948 4 50       7 if ( defined $header ) {
949 0 0       0 $header .= "\n" unless $header =~ m/\n$/;
950 0         0 print $fh $header;
951             }
952 4         9 my $i;
953 4         6 my $pcnt = scalar @dogp;
954 4         14 for ($i=0; $i<$n; $i++) {
955 16 100       26 if ($format_string) {
956 12         14 my @d;
957 12         19 my $pdone = 0;
958 12         17 for (@dogp) {
959 24         43 push @d,_at_1D($_,$i); $pdone++;
  24         36  
960 24 100       49 if (@d == $step) {
961 12         48 printf $fh $format_string,@d;
962 12 50       28 printf $fh $usecolsep unless $pdone==$pcnt;
963 12         34 $#d = -1;
964             }
965             }
966 12 50 33     30 if (@d && !$i) {
967 0         0 my $str;
968 0 0       0 if ($#dogp>0) {
969 0         0 $str = ($#dogp+1).' columns don\'t';
970             } else {
971 0         0 $str = '1 column doesn\'t';
972             }
973 0         0 $str .= " fit in $step column format ".
974             '(even repeated) -- discarding surplus';
975 0         0 carp $str;
976             # printf $fh $format_string,@d;
977             # printf $fh $usecolsep;
978             }
979             } else {
980 4         7 my $pdone = 0;
981 4         8 for (@dogp) {
982 8         12 $pdone++;
983 8 100       13 print $fh _at_1D($_,$i) . ( ($pdone==$pcnt) ? '' : $usecolsep );
984             }
985             }
986 16         44 print $fh "\n";
987             }
988 4 50       8 close($fh) if $file_opened;
989 4         14 return 1;
990             }
991              
992             =head2 swcols
993              
994             =for ref
995              
996             generate string list from C format specifier and a list of piddles
997              
998             C takes an (optional) format specifier of the printf
999             sort and a list of 1D piddles as input. It returns a perl
1000             array (or array reference if called in scalar context)
1001             where each element of the array is the string generated by
1002             printing the corresponding element of the piddle(s) using
1003             the format specified. If no format is specified it uses the
1004             default print format.
1005              
1006             =for usage
1007              
1008             Usage: @str = swcols format, pdl_1,pdl_2,pdl_3,...;
1009             or $str = swcols format, pdl_1,pdl_2,pdl_3,...;
1010              
1011             =cut
1012              
1013             *swcols = \&PDLA::swcols;
1014              
1015             sub PDLA::swcols{
1016 0     0 0 0 my ($format_string,$step);
1017              
1018 0         0 my @outlist;
1019              
1020 0 0       0 if (ref(\$_[0]) eq "SCALAR") {
1021 0         0 $step = $format_string = shift; # 1st arg not piddle
1022 0         0 $step =~ s/(%%|[^%])//g; # use step to count number of format items
1023 0         0 $step = length ($step);
1024             }
1025            
1026 0         0 my @p = @_;
1027 0 0       0 my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->nelem;
  0         0  
1028 0         0 for (@p) {
1029 0 0       0 if ( ref $_ eq 'ARRAY' ) {
1030 0 0       0 barf "swcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n;
  0         0  
1031             } else {
1032 0 0 0     0 barf "swcols: 1D args must have same number of elements\n" if $_->nelem != $n or $_->getndims!=1;
1033             }
1034             }
1035              
1036 0         0 my $i;
1037 0         0 for ($i=0; $i<$n; $i++) {
1038 0 0       0 if ($format_string) {
1039 0         0 my @d;
1040 0         0 for (@p) {
1041 0         0 push @d,_at_1D($_,$i);
1042 0 0       0 if (@d == $step) {
1043 0         0 push @outlist,sprintf $format_string,@d;
1044 0         0 $#d = -1;
1045             }
1046             }
1047 0 0 0     0 if (@d && !$i) {
1048 0         0 my $str;
1049 0 0       0 if ($#p>0) {
1050 0         0 $str = ($#p+1).' columns don\'t';
1051             } else {
1052 0         0 $str = '1 column doesn\'t';
1053             }
1054 0         0 $str .= " fit in $step column format ".
1055             '(even repeated) -- discarding surplus';
1056 0         0 carp $str;
1057             # printf $fh $format_string,@d;
1058             # printf $fh $usecolsep;
1059             }
1060             } else {
1061 0         0 for (@p) {
1062 0         0 push @outlist,sprintf _at_1D($_,$i),$usecolsep;
1063             }
1064             }
1065             }
1066 0 0       0 wantarray ? return @outlist: return \@outlist;
1067             }
1068              
1069              
1070             =head2 rgrep
1071              
1072             =for ref
1073              
1074             Read columns into piddles using full regexp pattern matching.
1075            
1076              
1077             Options:
1078            
1079             UNDEFINED: This option determines what will be done for undefined
1080             values. For instance when reading a comma-separated file of the type
1081             C<1,2,,4> where the C<,,> indicates a missing value.
1082            
1083             The default value is to assign C<$PDLA::undefval> to undefined values,
1084             but if C is set this is used instead. This would normally
1085             be set to a number, but if it is set to C and PDLA is compiled
1086             with Badvalue support (see L) then undefined values are set to
1087             the appropriate badvalue and the column is marked as bad.
1088            
1089             DEFTYPE: Sets the default type of the columns - see the documentation for
1090             L
1091            
1092             TYPES: A reference to a Perl array with types for each column - see
1093             the documentation for L
1094            
1095             BUFFERSIZE: The number of lines to extend the piddle by. It might speed
1096             up the reading a little bit by setting this to the number of lines in the
1097             file, but in general L is a better choice
1098              
1099             Usage
1100              
1101             =for usage
1102              
1103             ($x,$y,...) = rgrep(sub, *HANDLE|"filename")
1104              
1105             e.g.
1106              
1107             =for example
1108              
1109             ($x,$y) = rgrep {/Foo (.*) Bar (.*) Mumble/} $file;
1110              
1111             i.e. the vectors C<$x> and C<$y> get the progressive values
1112             of C<$1>, C<$2> etc.
1113              
1114             =cut
1115              
1116             sub rgrep (&@) {
1117 1 50   1 1 959 barf 'Usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename", [{OPTIONS}])'
1118             if $#_ > 2;
1119              
1120 1         4 my (@ret,@v,$nret); my ($m,$n)=(-1,0); # Count/PDLA size
  1         3  
1121 1         2 my $pattern = shift;
1122              
1123 1         4 my $is_handle = _is_io_handle $_[0];
1124 1 50       4 my $fh = $is_handle ? $_[0] : gensym;
1125 1 50 0     4 open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle;
1126              
1127 1 50       5 if (ref($pattern) ne "CODE") {
1128 0         0 die "Got a ".ref($pattern)." for rgrep?!";
1129             }
1130              
1131            
1132             # set up default options
1133 1         9 my $opt = new PDLA::Options( {
1134             DEFTYPE => $deftype,
1135             TYPES => [],
1136             UNDEFINED => $PDLA::undefval,
1137             BUFFERSIZE => 10000
1138             } );
1139             # Check if the user specified options
1140 1   50     7 my $u_opt = $_[1] || {};
1141 1         5 $opt->options( $u_opt);
1142              
1143 1         4 my $options = $opt->current();
1144              
1145             # If UNDEFINED is set to .*bad.* then undefined are set to
1146             # bad - unless we have a Perl that is not compiled with Bad support
1147 1         4 my $undef_is_bad = ($$options{UNDEFINED} =~ /bad/i);
1148 1 50 33     4 if ($undef_is_bad && !$PDLA::Bad::Status) {
1149 0         0 carp "UNDEFINED cannot be set to Badvalue when PDLA hasn't been compiled with Bad value support - \$PDLA::undefval used instead\n";
1150 0         0 $undef_is_bad = 0;
1151             }
1152             barf "Unknown PDLA type given for DEFTYPE.\n"
1153 1 50       5 unless ref($$options{DEFTYPE}) eq "PDLA::Type";
1154              
1155              
1156 1         18 while(<$fh>) {
1157 5 50       15 next unless @v = &$pattern;
1158              
1159 5         44 $m++; # Count got
1160 5 100       12 if ($m==0) {
1161 1         2 $nret = $#v; # Last index of values to return
1162              
1163             # Handle various columns as in rcols - added 18/04/05
1164 1         5 my @types = _handle_types( $nret, $$options{DEFTYPE}, $$options{TYPES} );
1165 1         3 for (0..$nret) {
1166             # Modified 18/04/05 to use specified precision.
1167 2         10 $ret[$_] = [ PDLA->zeroes($types[$_], 1), [] ];
1168             }
1169             } else { # perhaps should only carp once...
1170 4 50       10 carp "Non-rectangular rgrep" if $nret != $#v;
1171             }
1172 5 100       11 if ($n<$m) {
1173 1         4 for (0..$nret) {
1174 2         6 _ext_lastD( $ret[$_]->[0], $$options{BUFFERSIZE} ); # Extend PDLA in buffered manner
1175             }
1176 1         3 $n += $$options{BUFFERSIZE};
1177             }
1178 5         10 for(0..$nret) {
1179             # Set values - '1*' is to ensure numeric
1180             # We now (JB - 18/04/05) also check for defined values or not
1181             # Ideally this should include Badvalue support..
1182 10 50       22 if ($v[$_] eq '') {
1183             # Missing value - let us treat this specially
1184 0 0       0 if ($undef_is_bad) {
1185 0         0 set $ret[$_]->[0], $m, $$options{DEFTYPE}->badvalue();
1186             # And set bad flag on $ref[$_]!
1187 0         0 $ret[$_]->[0]->badflag(1);
1188             } else {
1189 0         0 set $ret[$_]->[0], $m, $$options{UNDEFINED};
1190             }
1191             } else {
1192 10         26 set $ret[$_]->[0], $m, 1*$v[$_];
1193             }
1194             }
1195             }
1196            
1197 1 50       5 close($fh) unless $is_handle;
1198 1         4 for (@ret) { $_ = $_->[0]->slice("0:$m")->copy; }; # Truncate
  2         10  
1199 1 50       15 wantarray ? return(@ret) : return $ret[0];
1200             }
1201              
1202              
1203             =head2 rdsa
1204              
1205             =for ref
1206              
1207             Read a FIGARO/NDF format file.
1208              
1209             Requires non-PDLA DSA module. Contact Frossie (frossie@jach.hawaii.edu)
1210              
1211             Usage:
1212              
1213             =for usage
1214              
1215             ([$xaxis],$data) = rdsa($file)
1216              
1217             =for example
1218              
1219             $x = rdsa 'file.sdf'
1220              
1221             Not yet tested with PDLA-1.9X versions
1222              
1223             =cut
1224              
1225 0     0 1 0 sub rdsa{PDLA->rdsa(@_)}
1226              
1227 18     18   185 use vars qw/ $dsa_loaded /;
  18         53  
  18         9329  
1228             sub PDLA::rdsa {
1229 0     0 0 0 my $class = shift;
1230 0 0       0 barf 'Usage: ([$xaxis],$data) = rdsa($file)' if $#_!=0;
1231 0         0 my $file = shift; my $pdl = $class->new; my $xpdl;
  0         0  
  0         0  
1232 0 0       0 eval 'use DSA' unless $dsa_loaded++;
1233 0 0       0 barf 'Cannot use DSA library' if $@ ne "";
1234              
1235 0         0 my $status = 0;
1236              
1237             # Most of this stuff stolen from Frossie:
1238              
1239 0         0 dsa_open($status);
1240 0         0 dsa_named_input('IMAGE',$file,$status);
1241 0 0       0 goto skip if $status != 0;
1242              
1243 0         0 dsa_get_range('IMAGE',my $vmin,my $vmax,$status);
1244 0         0 my @data_dims;
1245 0         0 dsa_data_size('IMAGE',5, my $data_ndims, \@data_dims, my $data_elements,
1246             $status);
1247 0         0 dsa_map_data('IMAGE','READ','FLOAT',my $data_address,my $data_slot,
1248             $status);
1249              
1250 0         0 @data_dims = @data_dims[0..$data_ndims-1];
1251 0 0       0 print "Dims of $file = @data_dims\n" if $PDLA::verbose;
1252 0         0 $pdl->set_datatype($PDLA_F);
1253 0         0 $pdl->setdims([@data_dims]);
1254 0         0 my $dref = $pdl->get_dataref;
1255 0         0 mem2string($data_address,4*$data_elements,$$dref);
1256 0         0 $pdl->upd_data();
1257              
1258 0 0       0 if (wantarray) { # Map X axis values
1259 0         0 my @axis_dims;
1260 0         0 dsa_axis_size('IMAGE',1,5, my $axis_ndims, \@axis_dims,
1261             my $axis_elements, $status);
1262 0         0 dsa_map_axis_data('IMAGE',1,'READ','FLOAT',my $axis_address,
1263             my $axis_slot,$status);
1264 0         0 @axis_dims = @axis_dims[0..$axis_ndims-1];
1265 0         0 $xpdl = $class->new;
1266 0         0 $xpdl->set_datatype($PDLA_F);
1267 0         0 $xpdl->setdims([@axis_dims]);
1268 0         0 my $xref = $xpdl->get_dataref;
1269 0         0 mem2string($axis_address,4*$axis_elements,$$xref);
1270 0         0 $xpdl->upd_data();
1271             }
1272              
1273 0         0 skip: dsa_close($status);
1274              
1275 0 0       0 barf("rdsa: obtained DSA error") if $status != 0;
1276              
1277 0         0 return ($xpdl,$pdl);
1278             }
1279              
1280             =head2 isbigendian
1281              
1282             =for ref
1283              
1284             Determine endianness of machine - returns 0 or 1 accordingly
1285              
1286             =cut
1287              
1288              
1289              
1290 66     66 0 207 sub PDLA::isbigendian { return 0; };
1291             *isbigendian = \&PDLA::isbigendian;
1292              
1293              
1294              
1295              
1296             =head2 rasc
1297              
1298             =for ref
1299              
1300             Simple function to slurp in ASCII numbers quite quickly,
1301             although error handling is marginal (to nonexistent).
1302              
1303             =for usage
1304              
1305             $pdl->rasc("filename"|FILEHANDLE [,$noElements]);
1306              
1307             Where:
1308             filename is the name of the ASCII file to read or open file handle
1309             $noElements is the optional number of elements in the file to read.
1310             (If not present, all of the file will be read to fill up $pdl).
1311             $pdl can be of type float or double (for more precision).
1312              
1313             =for example
1314              
1315             # (test.num is an ascii file with 20 numbers. One number per line.)
1316             $in = PDLA->null;
1317             $num = 20;
1318             $in->rasc('test.num',20);
1319             $imm = zeroes(float,20,2);
1320             $imm->rasc('test.num');
1321              
1322             =cut
1323              
1324 0     0 1 0 sub rasc {PDLA->rasc(@_)}
1325             sub PDLA::rasc {
1326 18     18   9506 use IO::File;
  18         32647  
  18         9732  
1327 3     3 0 23 my ($pdl, $file, $num) = @_;
1328 3 100       11 $num = -1 unless defined $num;
1329 3         6 my $fi = $file;
1330 3 50       19 my $is_openhandle = defined fileno $fi ? 1 : 0;
1331 3 50       8 unless ($is_openhandle) {
1332 3 50 33     16 barf 'usage: rasc $pdl, "filename"|FILEHANDLE, [$num_to_read]'
1333             if !defined $file || ref $file;
1334 3 100       19 $fi = new IO::File "<$file" or barf "Can't open $file";
1335             }
1336 2         178 $pdl->_rasc(my $ierr=null,$num,$fi);
1337 2 50       29 close $fi unless $is_openhandle;
1338 2         12 return all $ierr > 0;
1339             }
1340              
1341             # ----------------------------------------------------------
1342              
1343             =head2 rcube
1344              
1345             =for ref
1346              
1347             Read list of files directly into a large data cube (for efficiency)
1348              
1349             =for usage
1350              
1351             $cube = rcube \&reader_function, @files;
1352              
1353             =for example
1354              
1355             $cube = rcube \&rfits, glob("*.fits");
1356              
1357             This IO function allows direct reading of files into a large data cube,
1358             Obviously one could use cat() but this is more memory efficient.
1359              
1360             The reading function (e.g. rfits, readfraw) (passed as a reference)
1361             and files are the arguments.
1362              
1363             The cube is created as the same X,Y dims and datatype as the first
1364             image specified. The Z dim is simply the number of images.
1365              
1366             =cut
1367              
1368             sub rcube {
1369              
1370 0     0 1   my $reader = shift;
1371              
1372 0 0         barf "Usage: blah" unless ref($reader) eq "CODE";
1373              
1374 0           my $k=0;
1375 0           my ($im,$cube,$tmp,$nx,$ny);
1376 0           my $nz = scalar(@_);
1377              
1378 0           for my $file (@_) {
1379 0 0         print "Slice ($k) - reading file $file...\n" if $PDLA::verbose;
1380 0           $im = &$reader($file);
1381 0           ($nx, $ny) = dims $im;
1382 0 0         if ($k == 0) {
1383 0 0         print "Creating $nx x $ny x $nz cube...\n" if $PDLA::verbose;
1384 0           $cube = $im->zeroes($im->type,$nx,$ny,$nz);
1385             }
1386             else {
1387 0 0 0       barf "Dimensions do not match for file $file!\n" if
1388             $im->getdim(0) != $nx or $im->getdim(1) != $ny ;
1389              
1390             }
1391 0           $tmp = $cube->slice(":,:,($k)");
1392 0           $tmp .= $im;
1393 0           $k++;
1394             }
1395              
1396 0           return $cube;
1397             }
1398              
1399              
1400              
1401              
1402              
1403              
1404             *_rasc = \&PDLA::_rasc;
1405              
1406              
1407              
1408             ;
1409              
1410              
1411             =head1 AUTHOR
1412              
1413             Copyright (C) Karl Glazebrook 1997, Craig DeForest 2001,
1414             2003, and Chris Marshall 2010. All rights reserved. There is
1415             no warranty. You are allowed to redistribute this software
1416             / documentation under certain conditions. For details, see
1417             the file COPYING in the PDLA distribution. If this file is
1418             separated from the PDLA distribution, the copyright notice
1419             should be included in the file.
1420              
1421             =cut
1422              
1423              
1424              
1425              
1426              
1427             # Exit with OK status
1428              
1429             1;
1430              
1431