File Coverage

blib/lib/Astro/QDP/Parse.pm

Criterion	Covered	Total	%
statement	155	163	95.0
branch	29	38	76.3
condition	11	17	64.7
subroutine	22	22	100.0
pod	3	3	100.0
total	220	243	90.5

# --8<--8<--8<--8<--
#
# Copyright (C) 2008 Smithsonian Astrophysical Observatory
#
# This file is part of Astro::QDP::Parse
#
# Astro::QDP::Parse is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .
#
# -->8-->8-->8-->8--

package Astro::QDP::Parse;

use strict;
use warnings;
use 5.008;

use Carp;

our $VERSION = '0.13';

use Text::Abbrev;

use Clone qw( clone );
use IO::File;
use Regexp::Common qw{ number };
use List::Util qw{ first };
use List::MoreUtils qw{ pairwise };
use Params::Validate qw{ :all };

## no critic (ProhibitAccessOfPrivateData)


my $have_PDL = eval 'use PDL::Core qw( pdl ); 1;';	## no critic


require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
        read_qdpfile
        parse_qdp
        parse_qdpfile
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
);

sub _normalize_keys { return lc $_[0] };

my %parse_qdp_spec = (
                      as_pdl => { type => BOOLEAN, default => 0 },
                      normalize => { type => BOOLEAN, default => 0},
                     );

#========================================================================


sub parse_qdpfile
{
    my @pos = ( shift );
    my ( $file ) = validate_pos( @pos, { type => SCALAR } );

    my %opt = validate_with( params => \@_,
                             spec => \%parse_qdp_spec,
                             normalize_keys => \&_normalize_keys
                           );

    croak( "piddle output requested, but PDL is not available\n" )
      if $opt{as_pdl} && ! $have_PDL;

    my $lines = read_qdpfile( $file );

    return parse_qdp( $lines, \%opt );
}

#-------------------------------------------------------------------
sub read_qdpfile
{
    my ( $file ) = @_;
    my $fh = new IO::File $file
      or croak( __PACKAGE__, "::read_qdpfile: unable to open $file\n" );

    my @lines;

    my $line;
    while ( defined( $line = $fh->getline ) ) {
        chomp $line;
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;

        if ( $line =~ /-$/ ) {
            chop $line;
            chomp( my $l1   =  $fh->getline );
            $l1    =~ s/^\s+//;
            $l1    =~ s/\s+$//;
            $line .= " $l1";
            redo unless $fh->eof;
        }

        push @lines,  $line;
    }
    $fh->close;
    return \@lines;
}

#-------------------------------------------------------------------
sub parse_qdp
{
    my @pos = ( shift );
    my ( $lines ) = validate_pos( @pos, { type => ARRAYREF } );

    my %opt = validate_with( params => \@_,
                             spec => \%parse_qdp_spec,
                             normalize_keys => \&_normalize_keys
                           );

  my $hdr = _parse_qdp_hdr( $lines );

  return _parse_qdp_datagroups( $hdr, $lines, \%opt );
}

#-------------------------------------------------------------------
sub _parse_qdp_hdr
{
  my ( $lines ) = @_;

  my %hdr     = ( serr => [],
                  terr => [],
                  skip => 0,
                  plt  => [],
                );     # header info

  # serr and terr must be at the beginning of the qdp file.
  while( $lines->[0] =~ /^\s*read\s+(s|t)(?:err)?\s+(.*)/i )
  {
      chomp( my $line = shift @$lines);

      $hdr{lc $1 . 'err'} = [ split(' ', $2) ];
  }

  {
      # now find first line of data so can figure out vectors
      my $dline = first { /^$RE{num}{real}/ } @$lines;

      croak( "no data in qdp file?\n" )
        if ! defined $dline;

      chomp $dline;
      my @data = split(' ', $dline);
      $hdr{ncols} = @data;
  }

  #------------------
  # determine number of vectors. a vector consists of a data column plus
  # 0, 1, or 2 error columns.
  my $nvec = $hdr{ncols} - @{$hdr{serr}} - 2 * @{$hdr{terr}};

  # initialize list of vectors
  my @vec = map { { errtype => 0 } } 1..$nvec;

  # set non-default error types
  $vec[$_-1]{errtype} = 1 foreach @{$hdr{serr}};
  $vec[$_-1]{errtype} = 2 foreach @{$hdr{terr}};

  # flush out vectors, creating indices to data file columns
  # for each vector component (data and error column(s))
  my $idx = 0;
  my $hdg = 0;
  for my $vec ( @vec )
  {
      $vec->{hdg} = $hdg++;
      $vec->{start} = $idx;
      $idx += $vec->{errtype} + 1;
      $vec->{data} = [];
      if ( $vec->{errtype} == 1 )
      {
          $vec->{err} = [];
      }
      elsif ( $vec->{errtype} == 2 )
      {
          $vec->{elo} = [];
          $vec->{ehi} = [];
      }
  }

  $hdr{vecs} = \@vec;

  return \%hdr;
}

#-------------------------------------------------------------------
sub _parse_qdp_datagroups
{
  my ( $hdr, $lines, $opts ) = @_;

  my @groups;

  my $vdg = 0;
  my $dg  = 1;
  while ( @$lines )
  {
      my ( $x, @y) = _parse_qdp_datagroup( $hdr, $lines, $opts );

      $x->{vdg} = $vdg;
      for my $y ( @y )
      {
          $y->{vdg} = $vdg;
          $y->{dg} = $dg++;
          push @groups, { x => $x, y => $y };
      }
      $vdg++;
  }

  delete $hdr->{vecs};
  delete $hdr->{skip};

  return \@groups, $hdr;
}


#-------------------------------------------------------------------
sub _parse_qdp_datagroup
{
  my ( $hdr, $lines, $opt ) = @_;

  # make copy of vector templates, as the templates
  # are reused for "vertical" data groups.
  my $vecs = clone $hdr->{vecs};

  # create a list of arrayrefs, in the same order as the input data tokens,
  # to speed up processing of data
  my @drefs = map {   $_->{errtype} == 0 ? ( $_->{data} )
                    : $_->{errtype} == 1 ? ( $_->{data}, $_->{err} )
                    :                      ( $_->{data}, $_->{elo}, $_->{ehi} )
                }
               @$vecs;

  _parse_horiz_datagroup( $hdr, $lines, @drefs );

  if ( $opt->{as_pdl} )
  {
      for my $vec ( @$vecs )
      {
          $vec->{$_} = pdl( $vec->{$_} )
            foreach grep { exists $vec->{$_} }
                           qw ( data err elo ehi );
      }
  }

  if ( $opt->{normalize} )
  {
      $_->{elo} = $_->{ehi} = delete $_->{err}
        foreach grep { exists $_->{err} } @$vecs;
  }

  return @$vecs;
}

#-------------------------------------------------------------------
sub _parse_horiz_datagroup {

    my ( $hdr, $lines, @cols ) = @_;

    my $nskip = 0;
    while( @$lines )
    {
        my $line = shift @$lines;
        chomp $line;

        if ( $hdr->{skip} && $line =~ /^\s*NO\s+/ )
        {
            # $NO is the number of *additional* NO lines
            my $NO = 0;
            $NO++ while $NO < @$lines && $lines->[$NO] =~ /^\s*NO\s+/;

            if ( $hdr->{skip} && $hdr->{skip} <= $NO+1 )
            {
                splice(@$lines, 0, $NO);
                return;
            }
        }


        if ( $line =~ /^\s*$RE{num}{real}/ || $line =~ /^\s*NO\s+/ )
        {
            my @data = map { $_ eq 'NO' ? undef : $_ } split( ' ', $line );
            if ( @data != @cols )
            {
                croak( 'unexpected number of data points: ',
                     'got ', scalar @data,
                     ' expected ', scalar @cols,
                     "\n" );
            }

            push @{$_}, shift @data foreach @cols;
        }

        else
        {
            _parse_plt_command( $hdr, $line );
        }
    }

    return;
}

#-------------------------------------------------------------------

my %PLT = abbrev qw( skip off single double );

sub _parse_plt_command {

    my ( $hdr, $line ) = @_;


    push @{ $hdr->{plt} }, $line;


    # need to process some .pco commands (e.g. skip) while reading
    # in data; if it's an indirection ("@filename") recursively handle that

    if ( $line =~ /^\s*\@(.*)/ )
    {
        my $lines = read_qdpfile($1);

        # don't push the expanded commands in the saved list of plt commands
        my $plts = $hdr->{plt};
        $hdr->{plt} = [];
        _parse_plt_command( $hdr, $_ ) foreach @$lines;
        $hdr->{plt} = $plts;
    }

    else
    {
        my ( $cmd, @opts ) = split( ' ', $line );

        $cmd = $PLT{lc $cmd} || '';

        if ( $cmd eq 'skip' )
        {
            my $opt = $PLT{lc $opts[0]};
            croak( "unrecognized argument to PLT skip command: $opts[0]\n" )
              unless defined $opt;

            $hdr->{skip} = { off    => 0,
                             single => 1,
                             double => 2,
                           }->{$opt};
        }
    }

    return;
}

1;


__END__