File Coverage

blib/lib/Text/NumericData/File.pm

Criterion	Covered	Total	%
statement	277	390	71.0
branch	78	176	44.3
condition	24	72	33.3
subroutine	25	33	75.7
pod	22	29	75.8
total	426	700	60.8

package Text::NumericData::File;

# Document and properly test the pipe stuff!
# Think about replacing MaxInterval by something more generic (sorted index according to given expression)

#textdata version x
#see POD below!

use Text::NumericData::Calc qw(linear_value formula_function expression_function);
use Text::NumericData;
use Text::ASCIIPipe;
use sort 'stable';

# This is just a placeholder because of a past build system bug.
# The one and only version for Text::NumericData is kept in
# the Text::NumericData module itself.
our $VERSION = '1';
$VERSION = eval $VERSION;

our @ISA = ('Text::NumericData');

# interpolation types
my $none   = 0;
my $linear = 1;
my $spline = 2;

our %help =
(
  interpolate => 'use interpolation inter-/extrapolation for correlation of data sets (choose linear or spline, or 0 for switching it off)'
);

our %defaults =
(
  interpolate => 'linear'
);

sub new
{
	my $class = shift;
	my $config = shift;
	my $self = $class->SUPER::new($config);
	$self->{in_file} = shift;
	if(defined $config->{interpolate} and $config->{interpolate} eq 'spline')
	{
		require Math::Spline;
		$self->{intmethod} = $spline;
	}
	elsif(defined $config->{interpolate} and not $config->{interpolate})
	{
		$self->{intmethod} = $none;
	}
	else{ $self->{intmethod} = $linear; }

	$self->{config}{pipemode} = $config->{pipemode}
		if(defined $config->{pipemode});

	if(defined $self->{in_file})
	{
		$self->read_all();
	}
	return $self;
}

sub init
{
	#not touching in_file! this is only handled by Read
	#as is out_file!
	my $self = shift;
	$self->SUPER::init();
	$self->{config}{indexformat} = '%6E' unless defined $self->{config}->{indexformat};
	$self->{config}{extrapol} = 1 unless defined $self->{config}{extrapol};
	$self->{data} = [];
	$self->{records} = 0;
	$self->{data_index} = [];
	$self->{sorted_data} = [];
	$self->{raw_header} = [];
	$self->{buffer} = ""; #containing the raw lines read by readhead (the'd be lost from stdin otherwise)
	$self->{splines} = [];
	$self->{splinex} = undef;
}

sub read_head
{
	my $self = shift;
	return $self->read_all($_[0], 1);
}

# Return values mimicking Text::ASCIIPipe::pull_file.
# <0: failure
#  0: successful, but nothing more to expect
# >0: successful, more could be there
sub read_all
{
	my ($self, $infile, $justhead) = @_;
	$self->init(); #do we really want full init?
	$self->{in_file} = $infile if defined $infile;

	my $handle;

	if(ref $self->{in_file}){ $handle = $self->{in_file}; }
	elsif(not defined $self->{in_file} or $self->{in_file} eq ''){ $handle = \*STDIN; }
	else{ open($handle, $self->{in_file}) or return 0; }

	my $data = 0;
	binmode($handle);
	my $l;
	$self->{buffer} = '';

	my $state;
	while(defined ($state = Text::ASCIIPipe::fetch($handle, $l)))
	{
		if($state == $Text::ASCIIPipe::line)
		{
			if(!$data)
			{
				$self->{buffer}.= $l if($justhead);
				if($self->line_check(\$l))
				{
					last if $justhead;
					$data = 1;
				}
				else
				{
					$self->make_naked($l);
					push(@{$self->{raw_header}}, $l);
				}
			}
			if($data)
			{
				my $da = $self->line_data($l);
				if(defined $da)
				{
					push(@{$self->{data}}, $da);
					++$self->{records} if @{$da}; # count non-empty records
				}
			}
		}
		else
		{
			# If there is no prior decision, this enables pipe control codes on possibly following write operations.
			$self->{config}{pipemode} = 1 unless defined $self->{config}{pipemode};
			# anything but line and begin is an end
			last if $state != $Text::ASCIIPipe::begin;
		}
	}

	# Empty files aren't an error, or are they?
	# All fine: Loop ended with orderly file end marker.
	return  1 if(defined $state and $state != $Text::ASCIIPipe::allend);
	# Ended on EOF (or some esoteric error we still treat as such),
	# as there was no allend or error before that, just assume normal end of things.
	return  0 if(not defined $state);
	# If we hit allend, we did not stop with an orderly file end,
	# so must assume we got nothing at all.
	return -1; # if($state == allend) is already implied
}

# After reading Data, intialize interpolation.
sub prepare_splines
{
	my $self = shift;
	my $x = shift;

	$self->{splines} = [];
	$self->{splinex} = undef;
	my $i = 0;
	my @x;
	my @data; # the more effective data structe
	for my $d (@{$self->{data}})
	{
		# collect data, omitting duplicates
		next if grep {$_ == $d->[$x]} @x;
		push(@x, $d->[$x]);
		for(my $j = 0; $j <= $#{$d}; ++$j)
		{
			$data[$j][$i] = $d->[$j];
		}
		++$i;
	}
	die "Bad spline column index.\n" if($x < 0 or $x > $#data);

	$self->{splinex} = $x;

	# Not caring for undefined pieces of data, does Math::Spline care?
	for(my $j = 0; $j <= $#data; ++$j)
	{
		$self->{splines}[$j] = Math::Spline->new(\@x, $data[$j]);
	}
}

sub SplineY
{
	my $self = shift;
	my $val = shift;
	my $x = shift;
	my $y = shift;
	$x = 0 unless defined $x;
	$y = 1 unless defined $y;
	$self->prepare_splines($x) unless(defined $self->{splinex} and $self->{splinex} == $x);

	return $self->{splines}[$y]->evaluate($val);
}

sub spline_set
{
	my $self = shift;
	my $val = shift;
	my $x = shift;
	$x = 0 unless defined $x;
	$self->prepare_splines($x) unless(defined $self->{splinex} and $self->{splinex} == $x);

	my @set;
	for my $s (@{$self->{splines}})
	{
		push(@set,  $s->evaluate($val));
	}

	return \@set;
}

#compute_index(\arrayofcols)
sub compute_index
{
	my $self = shift;
	my $ar = shift;
	my $zahl = $self->{config}->{numregex};
	$ar = [0] unless defined $ar;
	foreach my $c (@{$ar}){ $self->{data_index}->[$c] = {};}
	foreach my $d (@{$self->{data}})
	{
		foreach my $c (@{$ar})
		{
			my $key = $d->[$c] =~ /$zahl/ ? sprintf($self->{config}->{indexformat}, $d->[$c]) : $d->[$c];
			$self->{data_index}->[$c]->{$key} = $d unless defined $self->{data_index}->[$c]->{$key};
		}
	}
}

#(col)
sub compute_sorted_index
{
	my $self = shift;
	my $xl = shift;
	$xl = [0] unless defined $xl;
	#compute any missing indices
	my @l = ();
	foreach my $x (@{$xl}){	push(@l, $x) unless defined $self->{data_index}->[$x]; }
	$self->compute_index(\@l);
	#now sort all concerned indices
	foreach my $x (@{$xl})
	{
		$self->{sorted_data}->[$x] = [];
		foreach my $k (sort {$a <=> $b} keys %{$self->{data_index}->[$x]})
		{
			push(@{$self->{sorted_data}->[$x]}, $self->{data_index}->[$x]->{$k});
		}
	}
}


sub write_data
{
	my $self = shift;
	my $handle = shift;
	my $selection = shift;
	for(my $i = 0; $i <= $#{$self->{data}}; ++$i)
	{
		print $handle ${$self->data_line($self->{data}->[$i],$selection)};
	}
	return 1; # real error checking?
}

#Write(file, columns)
#maybe adding limits in future...
sub write_all
{
	my $self = shift;
	my $file = shift;
	my $selection = shift;
	$self->{out_file} = $file if defined $file;
	my $handle;
	if(ref $self->{out_file}){ $handle = $self->{out_file}; }
	elsif(not defined $self->{out_file} or $self->{out_file} eq ''){ $handle = STDOUT; }
	else{ open($handle, '>', $self->{out_file}) or return 0; }
	binmode($handle);

	Text::ASCIIPipe::file_begin($handle) if($self->{config}{pipemode});
	#header
	$self->write_head($handle, $selection);
	#data
	$self->write_data($handle, $selection);
	Text::ASCIIPipe::file_end($handle) if($self->{config}{pipemode});
	return 1; # real error checking?
}

# An inconsistency in first release was write_header, not write_head,
# as it matches read_head. Providing this wrapper now.
sub write_header
{
	my $self = shift; # No real need to shift here, but keeping in style.
	return $self->write_head(@_);
}

sub write_head
{
	my $self = shift;
	my $handle = shift;

	my $selection = shift;
	# If there is no old raw header, do a new one automaticaly.
	if(@{$self->{raw_header}})
	{
		foreach my $h (@{$self->{raw_header}})
		{
			print $handle ${$self->comment_line($h)};
		}
		if(defined $selection)
		{
			print $handle ${$self->title_line($selection)};
		}
	}
	else
	{
		return $self->write_new_header($handle,$selection);
	}
	return 1;
}

sub write_new_header
{
	my $self = shift;
	my $handle = shift;
	my $selection = shift;
	print $handle ${$self->comment_line(\$self->{title})} if defined $self->{title};
	foreach my $c (@{$self->{comments}}){ print $handle ${$self->comment_line(\$c)}; }
	print $handle ${$self->title_line($selection)};
	return 1;
}

sub set_of_noint
{
	my $self = shift;
	my $value = shift;
	my $zahl = $self->{config}->{numregex};
	$value = sprintf($self->{config}->{indexformat}, $value) if $value =~ /$zahl/;
	my $x = shift;
	$x = 0 unless defined $x;
	defined $self->{data_index}->[$x] or $self->compute_index([$x]);
	return $self->{data_index}->[$x]->{$value};
}

sub set_of
{
	my $self = shift;
	#the easy way
	my $set = $self->set_of_noint(@_);
	return $set
		if (defined $set or $self->{intmethod} == $none);

	#so, we got to do some Work;
	my $val = shift;
	my $x = shift;
	$x = 0 unless defined $x;
	if($self->{intmethod} == $spline)
	{
		return $self->spline_set($val, $x);
	}
	#find suitable data value pairs for interpolation
	my $sets = $self->neighbours($val, $x);
	return undef unless defined $sets and $#{$sets} == 1;
	#compute
	my @set = ();

	for(my $y = 0; $y <= $#{$sets->[0]}; ++$y)
	{
		if($y != $x)
		{
			push(@set, linear_value($val, [$sets->[0][$x], $sets->[1][$x]], [$sets->[0][$y],$sets->[1][$y]]));
		}
		else{ push(@set, $val); }
	}

	return \@set;
}

sub y_noint
{
	my $self = shift;
	my $val = shift;
	my $x = shift;
	my $y = shift;
	$x = 0 unless defined $x;
	$y = 1 unless defined $y;
	my $set = $self->set_of($val,$x);
	return defined $set ? $set->[$y] : undef;
}


sub y
{
	my $self = shift;
	#the easy way
	my $y = $self->y_noint(@_);
	return $y
		if (defined $y or $self->{intmethod} == $none);

	#so, we got to do some Work;
	my $val = shift;
	my $x = shift;
	$y = shift;
	$x = 0 unless defined $x;
	$y = 1 unless defined $y;
	if($self->{intmethod} == $spline)
	{
		return $self->spline_y($val, $x, $y);
	}
	#find suitable data value pairs for interpolation
	my $sets = $self->neighbours($val, $x);
	return undef unless defined $sets and $#{$sets} == 1;
	#compute
	#print STDERR "Sets: ";
	#for(@{$sets}){ print STDERR "(@{$_}) "; }
	#print STDERR "\n";
	return linear_value($val, [$sets->[0][$x], $sets->[1][$x]], [$sets->[0][$y],$sets->[1][$y]]);
}

#it should be configurable wheter extrapolation is acceptable

sub neighbours
{
	my $self = shift;
	my $val = shift;
	my $x = shift;

	my $n = undef;
	my $e = undef;

	unless($self->{config}{orderedint})
	{
		defined $self->{sorted_data}->[$x] or $self->compute_sorted_index([$x]);
		return undef unless $#{$self->{sorted_data}->[$x]} > 0; #senseless when not at least two points there

		foreach my $v (@{$self->{sorted_data}->[$x]})
		{
			$n = $e;
			$e = $v;
			if($v->[$x] > $val and defined $n){ last; }
		}
	}
	else
	{
		if(defined $self->{data}[0] and $self->{data}[0][$x] < $val)
		{
			foreach my $v (@{$self->{data}})
			{
				$n = $e;
				$e = $v;
				if($v->[$x] > $val and defined $n){ last; }
			}
		}
		else
		{
			foreach my $v (@{$self->{data}})
			{
				$n = $e;
				$e = $v;
				if($v->[$x] < $val and defined $n){ last; }
			}
		}
	}
	return undef unless defined $n; #catches both  empty array and one-element-array
	unless($self->{config}{extrapol})
	{
		#check if we have left and right neighbour
		return undef unless (($n->[$x] <= $val and $e->[$x] >= $val) or ($n->[$x] >= $val and $e->[$x] <= $val))
	}
	return [$n,$e];
}

sub max
{
	my $self = shift;
	my $formula = shift;
	my $ff = expression_function($formula);
	return undef unless defined $ff;
	my $max = undef;
	foreach my $d (@{$self->{data}})
	{
		my $nm = &$ff([$d]);
		$max = $nm if !defined $max or $nm > $max;
	}
	return $max;
}

# A little Hack for now...
# Return the two indices for the two biggest expression values.
# Idea: Between those, the "real" maximum is to be found, perhaps using non-linear interpolation.
sub max_interval
{
	my $self = shift;
	my $formula = shift;
	my $ff = expression_function($formula);
	return undef unless defined $ff;
	my @maxval;
	my @maxidx;
	for my $idx (1..$#{$self->{data}})
	{
		my $nm = &$ff([$self->{data}[$idx]]);
		if(@maxval)
		{
			if($nm >= $maxval[0])
			{
				$maxval[1] = $maxval[0];
				$maxval[0] = $nm;
				$maxidx[1] = $maxidx[0];
				$maxidx[0] = $idx;
			}
			elsif($nm > $maxval[1])
			{
				$maxval[1] = $nm;
				$maxidx[1] = $idx;
			}
		}
		else
		{
			@maxidx = ($idx, $idx);
			@maxval = ($nm, $nm);
		}
	}
	return @maxidx;
}

sub min
{
	my $self = shift;
	my $formula = shift;
	$formula = '-('.$formula.')';
	return -1*$self->max($formula);
}

sub sort_func
{
	my $self = shift;
	my $cols = shift;
	my $down = shift;
	my $sortcode = 'my $r; ';
	my $i = -1;
	# tested example sortcode:
	# '{ my $c; ($c= $a->[0] <=> $b->[0]) ? $c : ($c= $a->[1] <=> $b->[1]) ? $c : 0 }'
	foreach my $prec (@{$cols})
	{
		# Ensure only integer values enter evalued code.
		# Invalid numbers get parsed to zero, as perl does normally.
		my $c = $prec =~ /^(\d+)/ ? $1 : 0;
		my $r = '$r';
		my $a = '$a';
		my $b = '$b';
		if(defined $down and $down->[++$i])
		{
			$a = '$b';
			$b = '$a';
		}
		$sortcode .= "($r= $a\->[$c] <=> $b\->[$c]) ? $r : ";
	}
	$sortcode .= '0';
	# Not sure... is it better to eval that function here or to to put the eval into the sort call?
	#print STDERR "Sort code: $sortcode\n";
	return eval 'sub {'.$sortcode.'}';
}

sub sort_data
{
	my $self = shift;
	my $cols = shift;
	my $down = shift;
	my $sortfunc = shift;
	unless(defined $sortfunc)
	{
		$sortfunc = $self->sort_func($cols,$down);
	}
	@{$self->{data}} = sort $sortfunc @{$self->{data}};
	return $sortfunc; # Possibility to reuse the sort function.
}

# Heck, this is the gut of txdcalc.
# I do wonder if I could make that use this function here...
# ... or a line-oriented version, rather.
sub calc
{
	my $self      = shift;
	my $formula   = shift; # formula string
	my $config    = shift; # {'byrow'=>0, 'bycol'=>0 }
	my $files     = shift; # list of files to use for [2,1] style refs
	my $workarray = shift; # \@A
	my $constants = shift; # \@C

	my $ff = formula_function($formula);
	return 0 unless defined $ff;

	require Text::NumericData::FileCalc;
	my $deletelist = Text::NumericData::FileCalc::file_calc
	(
	  $ff
	, $config
	, $self->{data}
	, $files
	, $workarray
	, $constants
	);
	return 0 unless defined $deletelist;
	$self->delete_rows($deletelist);

	return 1;
}

# delete indicated rows from data set
sub delete_rows
{
	my $self = shift;
	my $delist = shift;
	return unless defined $delist;
	my @delis = sort {$a <=> $b} @{$delist};
	while(@delis and $delis[0]<0){ shift(@delis); }
	while(@delis and $delis[$#delis]>$#{$self->{data}}){ pop(@delis); }

	return unless @delis;
	# This is designed to handle possibly many sparse deletes in one go.
	# One simple splice() wouldn't do it. Many would be wasteful.
	# This is a rather stupid approach, but at least linear and
	# light on index confusion.
	my @newdata;
	my $row = 0;
	while(@delis)
	{
		my $pi = shift(@delis);
		# splice off the leading part including the to-be-deleted one
		my @part = splice(@{$self->{data}}, 0, $pi-$row+1);
		$row += @part;
		pop(@part);
		push(@newdata, @part);
		# make sure the next index is different
		while(@delis and $delis[0] == $pi){ shift(@delis); }
	}
	push(@newdata, splice(@{$self->{data}}, 0));
	$self->{data} = \@newdata;
}

sub mean
{
	my ($self, $col, $xcol, $begin, $end) = @_;
	my $count = 0;
	my $sum = 0;
	defined $self->{sorted_data}->[$xcol] or $self->compute_sorted_index([$xcol]);
	foreach my $a (@{$self->{sorted_data}->[$xcol]})
	{
		if($a->[$xcol] >= $start)
		{
			if($a->[$xcol] <= $end){ $sum += $a->[$col]; ++$count; }
			else{ last; }
		}
	}
	return $count > 0 ? $sum/$count : undef;
}

sub get_sorted_data
{
	my $self = shift;
	my $x = shift;
	defined $self->{sorted_data}->[$x] or $self->compute_sorted_index([$x]);
	return $self->{sorted_data}->[$x];
}

sub columns
{
	my $self = shift;
	return @{$self->{data}} ? $#{$self->{data}[0]}+1 : 0;
}

1;

__END__