diff --git a/lib/PDL/Basic.pm b/lib/PDL/Basic.pm index 0ad70e464..764a3749f 100644 --- a/lib/PDL/Basic.pm +++ b/lib/PDL/Basic.pm @@ -356,10 +356,10 @@ sub PDL::ndcoords { unshift(@d,scalar(@dims)); unshift(@d,$type) if defined($type); my $out = PDL->zeroes(@d); - for my $d(0..$#dims) { + for my $d (0..$#dims) { my $w = $out->index($d); $w = $w->mv($d,0) if $d != 0; - $w .= xvals($w); + $w .= xvals($w->type, $w->dims); } $out; } diff --git a/lib/PDL/IO/FITS.pm b/lib/PDL/IO/FITS.pm index 3d547970b..85b8b1f42 100644 --- a/lib/PDL/IO/FITS.pm +++ b/lib/PDL/IO/FITS.pm @@ -2223,7 +2223,7 @@ sub _prep_table { $internaltype[$i] = 'P'; my $dims = $var->shape; - (my $t = $dims->slice("(0)")) .= 1; + (my $t = $dims->slice("(0)")) .= pdl($dims->type, 1); $rpt = $dims->prod; =pod diff --git a/lib/PDL/IO/Misc.pd b/lib/PDL/IO/Misc.pd index e078171dd..847896b0a 100644 --- a/lib/PDL/IO/Misc.pd +++ b/lib/PDL/IO/Misc.pd @@ -122,9 +122,7 @@ 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" ) { @@ -134,7 +132,7 @@ sub _burp_1D { } else { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) - $data->slice("$start:$index") .= pdl($databox); + $data->slice("$start:$index") .= pdl($data->type, $databox); } $_[0] = [ $data, [] ]; } @@ -340,401 +338,401 @@ my $usecolsep; # This is the colsep value that is actually used 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>) ) { + 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 ); } + } - # chomp $fhline; - $fhline =~ s/\r?\n$//; # handle DOS on unix files better + # 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"; + } + } + } - $line_num++; + # CHUNKSIZE controls memory/time tradeoff of ndarray IO + my $chunksize = $options->{CHUNKSIZE} || $defchunksize; + my $nextburpindex = -1; - # 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; + # which columns are to be read into ndarrays and which into perl arrays? + my @end_perl_cols = (); # unique perl cols to return at end - $index++; - my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); + my @perl_cols = (); # perl cols index list from PERLCOLS option + @perl_cols = @{ $$options{PERLCOLS} } if $$options{PERLCOLS}; - # map empty fields '' to undef value - @v = map { $_ eq '' ? undef : $_ } @v; + 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"; - # if the first line, set up the output ndarrays using all the columns - # if the user doesn't specify anything - if ( $index == 0 ) { + my ( @explicit_cols ) = @_; # call specified columns to read + # print STDERR "rcols: \@explicit_cols is @explicit_cols\n"; - # 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 ); - } - } + # 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"; + } + } - # 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"; - } + # 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; + } - $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, [ [], [] ]; } + my @ret; - $line_store = [ $class->zeroes(long,1), [] ]; # only need to store integers - } + my ($k,$fhline); - # if necessary, extend PDL in buffered manner - $k = 0; - if ( $pdlsize < $index ) { - for (@ret, $line_store) { _ext_lastD( $_->[0], $extend ); } - $pdlsize += $extend; - } + 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; - # - 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[$_]; - } - } + my $line_store; # line numbers of saved data - # store the line number - push @{$line_store->[1]}, $line_num; + RCOLS_IO: { - # need to burp out list if needed - if ( $index >= $nextburpindex ) { - for (@ret, $line_store) { _burp_1D($_,$index); } - $nextburpindex = $index + $chunksize; - } + 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; + } + } - # Thanks to Frank Samuelson for this - last if defined($line_end) and $line_num == $line_end; - } + 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; + 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]; -} + # 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; - } -} + # 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]; -} + # 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; + # 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; + 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 ); - } -} + { 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 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] }; - } -} + # 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; - } -} + # 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; -} + # 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]; + wantarray ? return(@ret) : return $ret[0]; } diff --git a/lib/PDL/Primitive.pd b/lib/PDL/Primitive.pd index fd69f8054..e8a0e3340 100644 --- a/lib/PDL/Primitive.pd +++ b/lib/PDL/Primitive.pd @@ -3198,7 +3198,7 @@ sub PDL::interpND { my $index = shift; my $options = shift; - barf 'Usage: interp_nd($source,$index,[{%options}])\n' + barf 'Usage: interpND($source,$index[,{%options}])' if(defined $options and ref $options ne 'HASH'); my $opt = defined $options ? $options : {}; @@ -3254,6 +3254,7 @@ sub PDL::interpND { $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) { @@ -3299,6 +3300,7 @@ sub PDL::interpND { $y = $y->slice(":,($i)"); } + $samp = $samp->convert($source->type->enum) if $samp->type != $source->type; return $samp; } elsif($method =~ m/^f(ft|ourier)?/i) { @@ -3334,7 +3336,7 @@ sub PDL::interpND { } 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"); @@ -4072,8 +4074,8 @@ sub PDL::setops { # are not equal to their neighbours. # my $ts; - ($ts = $s1->index($i1)) .= 1 if $i1->nelem() > 0; - ($ts = $s2->index($i2)) .= 1 if $i2->nelem() > 0; + ($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); diff --git a/t/image2d.t b/t/image2d.t index 4388f3fd8..b42100630 100644 --- a/t/image2d.t +++ b/t/image2d.t @@ -261,8 +261,8 @@ is_pdl $im, $im2, "polyfill using default algorithm"; # 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)').=1; - $fit->slice('(0),:,(1)').=1; + $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); diff --git a/t/io-misc.t b/t/io-misc.t index 2af005a80..4daf8fe81 100644 --- a/t/io-misc.t +++ b/t/io-misc.t @@ -28,9 +28,9 @@ my $x = do { local $PDL::undefval = -1; rcols $file, [], { colsep=>',' }; }; - -is( (sum($x<0)==2 && $x->getdim(0)==5 && $x->getdim(1)==3), 1, "rcols with undefval and missing cols" ); -unlink $file || warn "Could not unlink $file: $!"; +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 ############# @@ -43,18 +43,14 @@ print $fileh <getdim(0)==5), 1, "rcols with filename" ); +is_pdl $x, pdl('1 2 3 4 5'), "rcols with filename"; +is_pdl $y, pdl('2 33 7 9 66'), "rcols with filename"; ($x,$y) = rcols $file, "/FOO/",0,1; -$x = long($x); -$y=long($y); - -is( (sum($x)==6 && max($y)==33 && $y->getdim(0)==2), 1, "rcols with filename + pattern" ); +is_pdl $x, pdl('2 4'), "rcols with filename + pattern"; +is_pdl $y, pdl('33 9'), "rcols with filename + pattern"; ############# Test rcols with file handle with nothing left ############# @@ -62,9 +58,8 @@ open my $fh, '<', $file; # Pull in everything: my @slurp = <$fh>; # Now apply rcols: -$@ = ''; $x = eval { rcols $fh }; -is($@, '', 'rcols does not die on a used file handle'); +is $@, '', 'rcols does not die on a used file handle'; close $fh; ############### Test rgrep with FILEHANDLE ##################### @@ -79,12 +74,11 @@ fjrhfiurhe foo"5" jjjj -66- EOD close($fileh); -open(OUT, $file) || die "Can not open $file for reading\n"; +open OUT, $file or die "Can not open $file for reading\n"; ($x,$y) = rgrep {/foo"(.*)".*-(.*)-/} *OUT; -$x = long($x); $y=long($y); -close(OUT); - -is( (sum($x)==15 && max($y)==66 && $y->getdim(0)==5), 1, "rgrep" ); +close OUT; +is_pdl $x, pdl('1 2 3 4 5'), "rgrep"; +is_pdl $y, pdl('2 33 7 9 66'), "rgrep"; ########### Explicit test of byte swapping ################# @@ -128,16 +122,16 @@ close($fileh); $x = PDL->null; $x->rasc($file,20); -is( abs($x->sum - 5.13147) < .01, 1, "rasc on null ndarray" ); +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( abs($y->sum - 5.13147) < .01, 1, "rasc on existing ndarray" ); +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" ); +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 +unlink($file) || warn "Could not unlink $file: $!"; # clean up ####################################################### # Tests of rcols() options @@ -185,31 +179,31 @@ $PDL::IO::Misc::deftype = short; ($x,$y) = rcols $file; is( $x->get_datatype, short->enum, "rcols: can read in as 'short'" ); -unlink $file || warn "Could not unlink $file: $!"; +unlink($file) or warn "Could not unlink $file: $!"; ($fileh,$file) = tempfile( DIR => $tempd ); eval { wcols $x, $y, $fileh }; -is(!$@,1, "wcols" ); -unlink $file || warn "Could not unlink $file: $!"; +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(!$@,1, "wcols FORMAT option"); -unlink $file || warn "Could not unlink $file: $!"; +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(!$@,1, "wcols format_string"); -unlink $file || warn "Could not unlink $file: $!"; +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(!$@,1, "wcols format_string override"); +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 || warn "Could not unlink $file: $!"; +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; diff --git a/t/ppt-10_physical_piddles.t b/t/ppt-10_physical_piddles.t index 50c864e8b..f3a0ac842 100644 --- a/t/ppt-10_physical_piddles.t +++ b/t/ppt-10_physical_piddles.t @@ -16,6 +16,7 @@ BEGIN { use threads; use threads::shared; use Test::More; +use Test::PDL; use Test::Exception; use PDL::LiteF; use PDL::Parallel::threads qw(retrieve_pdls); @@ -82,11 +83,11 @@ threads->create(sub { # Have this thread touch one of the values, and have it double-check # that the value is correctly set - my $tid_plus_1 = double($tid + 1); - my $five = double(5); - $workspace($tid) .= pdl($workspace->type, $tid_plus_1->sqrt + $five->sqrt); + 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) .= pdl($workspace->type, $tid_plus_1->sqrt + $five->sqrt); + $to_test(0) .= $val; $success_hash{$type_letter} = ($workspace->at($tid,0) == $to_test->at(0)); } @@ -120,8 +121,7 @@ for my $type_letter (keys %workspaces) { $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. - ok(all($workspace == $expected), "Sharing $type ndarrays works") - or diag("Got workspace of $workspace; expected $expected"); + is_pdl $workspace, $expected, "Sharing $type ndarrays works"; } ###################################################### diff --git a/t/primitive-interpolate.t b/t/primitive-interpolate.t index 0c6e8d381..2acaa1d06 100644 --- a/t/primitive-interpolate.t +++ b/t/primitive-interpolate.t @@ -34,6 +34,10 @@ subtest interpND => sub { 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; + 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'); }; subtest PCHIP => sub {