Commit 8c3defbe authored by David Flynn's avatar David Flynn Committed by David Flynn
Browse files

tools: add perl modules for log parsing and result collation

This commit provides a set of MPEG::PCC perl modules that may be used to
parse TMC13 log files.  An example script collect-tmc13.pl demonstrates
their use.
parent 850a3291
package MPEG::PCC::CSV;
use strict;
use Text::CSV;
use Exporter qw(import);
our @EXPORT = qw(
LoadFile
);
sub LoadFile {
my ($name) = @_;
my $fh;
if (ref $name eq 'GLOB') {
$fh = $name;
} else {
open $fh, "<:encoding(utf8)", $name or die "$name: $!";
}
# drop any comment lines at the start
my $comment = "";
my $first_non_comment_line;
while (my $line = <$fh>) {
unless ($line =~ m{^\#}) {
# Avoiding dependency from IO::Unread::unread $fh, $line;
$first_non_comment_line = $line;
last;
}
$comment .= $line;
}
my $csv = Text::CSV->new({binary => 1});
my $cols = do {
open my $tmpfh, '<', \$first_non_comment_line or die;
$csv->getline($tmpfh);
};
# handle empty file case
return wantarray ? ([], [], $comment) : [] unless defined $cols;
for (my $i = 0; $i < scalar @$cols; $i++) {
# add fake column names if any are missing
next if defined $cols->[$i] && !($cols->[$i] =~ m{^\s*$});
$cols->[$i] = "_$i";
}
$csv->column_names($cols);
my $rows = $csv->getline_hr_all($fh);
return wantarray ? ($rows, $cols, $comment) : $rows;
}
1;
package MPEG::PCC::Collate;
use utf8;
use strict;
use warnings;
use MPEG::PCC::Util qw{uniq};
use List::Util qw{min max pairmap pairgrep};
use Scalar::Util qw{looks_like_number};
use Exporter qw(import);
our @EXPORT = qw(
accumulateResult summariseResult
);
our @out_order_cols = qw{
config sequence variant framenum
enc.status dec.status dec.enc.match
enc.wtime enc.utime
dec.wtime dec.utime
enc.ext.utime dec.ext.utime enc.ext.maxrssk dec.ext.maxrssk
enc.ext.bits enc.bits enc.ext.bpp enc.bpp
enc.bpp.geometry enc.bpp.colour enc.bpp.reflectance
enc.bits.geometry enc.bits.colour enc.bits.reflectance
enc.bits.frameindexs
src.numpoints dec.numpoints
src.framecount dec.framecount
dec.y-psnr dec.cb-psnr dec.cr-psnr dec.reflectance-psnr
dec.post-recolour.y-psnr
dec.post-recolour.cb-psnr dec.post-recolour.cr-psnr
dec.post-recolour.reflectance-psnr
dec.y-hpsnr dec.cb-hpsnr dec.cr-hpsnr dec.reflectance-hpsnr
dec.d1-psnr dec.d2-psnr
};
our @fold_mean_geom = qw{
};
our @fold_mean_arith = qw{
enc.bpp
enc.bpp.geometry enc.bpp.colour enc.bpp.reflectance
dec.y-psnr dec.cb-psnr dec.cr-psnr dec.reflectance-psnr
dec.d1-psnr dec.d2-psnr
dec.post-recolour.y-psnr
dec.post-recolour.cb-psnr dec.post-recolour.cr-psnr
dec.post-recolour.reflectance-psnr
};
our @fold_sum = (@fold_mean_arith, qw{
src.framecount dec.framecount
enc.ext.utime enc.wtime enc.utime
dec.ext.utime dec.wtime dec.utime
enc.ext.bits
enc.bits enc.bits.geometry enc.bits.colour enc.bits.reflectance
enc.bits.frameindexs
src.numpoints dec.numpoints
});
our @fold_max = qw{
enc.ext.maxrssk dec.ext.maxrssk
dec.y-hpsnr dec.cb-hpsnr dec.cr-hpsnr dec.reflectance-hpsnr
};
our @fold_uniq = qw{ enc.status dec.status dec.enc.match };
##
# accumulate results for frame into %$result_acc
#
sub accumulateResult {
my ($result_acc, $frame) = @_;
# accumulate additively
foreach my $key (@fold_sum) {
next unless exists $frame->{$key} && $frame->{$key} ne '';
$$result_acc{"count.$key"} = 1 + ($$result_acc{"count.$key"} || 0);
$$result_acc{$key} = $frame->{$key} + ($$result_acc{$key} || 0);
delete $frame->{$key};
}
# accumulate maximum
foreach my $key (@fold_max) {
next unless exists $frame->{$key};
next unless $frame->{$key};
$$result_acc{$key} = max($frame->{$key},$$result_acc{$key} || 0);
delete $frame->{$key};
}
# accumulate log for geometric mean calculation
foreach my $key (@fold_mean_geom) {
next unless exists $frame->{$key};
if (!$frame->{$key} > 0) {
$$result_acc{"invalid.$key"} = 1;
next;
}
$$result_acc{"count.$key"} = 1 + ($$result_acc{"count.$key"} || 0);
$$result_acc{$key} = log($frame->{$key}) + ($$result_acc{$key} || 0);
delete $frame->{$key};
}
# accumulate unique values
foreach my $key (@fold_uniq) {
next unless exists $frame->{$key};
$$result_acc{$key} = [uniq($frame->{$key}, @{$$result_acc{$key}})];
delete $frame->{$key};
}
$result_acc;
}
##
# reduce the accumulation state to summary results
#
sub summariseResult {
my ($result_acc) = @_;
# geometric means (relies on sum of logs)
foreach my $key (@fold_mean_geom) {
next unless exists $$result_acc{$key};
if ($$result_acc{"invalid.$key"}) {
$$result_acc{$key} = 'NaN';
next;
}
$$result_acc{$key} =
exp($$result_acc{$key} / $$result_acc{"count.$key"});
}
# arithmetic mean
foreach my $key (@fold_mean_arith) {
$$result_acc{$key} = !$$result_acc{"count.$key"} ? undef :
$$result_acc{$key} / $$result_acc{"count.$key"};
}
# convert to friendly string
foreach my $key (@fold_uniq) {
$$result_acc{$key} = join ':', @{$$result_acc{$key}}
if defined $$result_acc{$key};
}
# ratio from totals
$$result_acc{'enc.ext.bpp'} =
$$result_acc{'enc.ext.bits'} / $$result_acc{'src.numpoints'}
if $$result_acc{'src.numpoints'};
# tidyup any formatting
map {
if (looks_like_number($_)) {
$_ = sprintf "%f", $_;
s/\.?0*$//;
}
} values %$result_acc;
return $result_acc;
}
1;
package MPEG::PCC::Parse::Experiment::Df;
use strict;
use warnings;
use MPEG::PCC::Parse::Tmc3;
use MPEG::PCC::Parse::Time;
use MPEG::PCC::Parse::Utils;
use MPEG::PCC::Parse::Ply;
use MPEG::PCC::Parse::PcError;
use Exporter qw(import);
our @EXPORT = qw(
readTmc3Results readTmc3ResultsOneFrame readTmc3ResultsOneBin
);
##
# One frame per file mode (ie not sequence encoding)
sub readTmc3Results {
my ($base_path, $src_file) = @_;
my ($frame) = $src_file =~ m{/([^/]+)$};
my $ret_ply = readTmc3ResultsOneFrame(@_);
my $ret_bin = readTmc3ResultsOneBin(@_);
return {%$ret_ply, %$ret_bin, frame => $frame};
}
##
# process a binary, allowing results to be aggregated
sub readTmc3ResultsOneBin {
my ($base_path) = @_;
my $file_bytes = -s "$base_path.bin";
my ($enc_utime, $enc_maxrssk) = readTime("$base_path.bin.time");
my ($dec_utime, $dec_maxrssk) = readTime("$base_path.bin.decoded.time");
my $enc_log = readEncLog("$base_path.bin.log");
my $dec_log = readDecLog("$base_path.bin.decoded.log");
my $enc_status = readFileFirstLine("$base_path.bin.status");
my $dec_status = readFileFirstLine("$base_path.bin.decoded.status");
my %ret = (
"enc.ext.bits" => $file_bytes * 8,
"enc.ext.utime" => $enc_utime,
"dec.ext.utime" => $dec_utime,
"enc.ext.maxrssk" => $enc_maxrssk,
"dec.ext.maxrssk" => $dec_maxrssk,
"enc.status" => $enc_status,
"dec.status" => $dec_status,
%$enc_log,
%$dec_log,
);
return \%ret;
}
##
# process a frame, allowing results to be aggregated
sub readTmc3ResultsOneFrame {
my ($base_path, $src_file) = @_;
my ($num_src_points) = readPly("$src_file");
my ($num_dec_points) = readPly("$base_path.bin.decoded.ply");
my $distortion_e2e =
readDistortion("$base_path.bin.decoded.pc_error", "dec.");
my $distortion_prc =
readDistortion(
"$base_path.bin.decoded.pc_error_postrecolour",
"dec.post-recolour.");
my ($enc_md5,undef) =
split / /, readFileFirstLine("$base_path.bin.ply.md5") // "";
my ($dec_md5,undef) =
split / /, readFileFirstLine("$base_path.bin.decoded.ply.md5") // "";
my $dec_enc_match = "mismatch";
if (!$enc_md5 || !$enc_md5) {
$dec_enc_match = "missing";
}
elsif ($enc_md5 eq $dec_md5) {
$dec_enc_match = "ok"
}
my %ret = (
"src.numpoints" => $num_src_points,
"src.framecount" => 1,
"dec.numpoints" => $num_dec_points,
"dec.framecount" => 1,
"dec.enc.match" => $dec_enc_match,
%$distortion_e2e,
%$distortion_prc,
);
return \%ret;
}
package MPEG::PCC::Parse::PcError;
use strict;
use warnings;
use Exporter qw(import);
our @EXPORT = qw(readDistortion);
##
# mapping table for readDistortion
our %readDistortion_key2key = (
'h. (p2point)' => 'd1-hmse', # hausdorff error
'h.,PSNR (p2point)' => 'd1-hpsnr', # hausdorff error
'h. (p2plane)' => 'd2-hmse', # hausdorff error
'h.,PSNR (p2plane)' => 'd2-hpsnr', # hausdorff error
'mseF (p2point)' => 'd1-mse',
'mseF,PSNR (p2point)' => 'd1-psnr',
'mseF (p2plane)' => 'd2-mse',
'mseF,PSNR (p2plane)' => 'd2-psnr',
'c[0], F' => 'y-mse',
'c[1], F' => 'cb-mse',
'c[2], F' => 'cr-mse',
'c[0],PSNRF' => 'y-psnr',
'c[1],PSNRF' => 'cb-psnr',
'c[2],PSNRF' => 'cr-psnr',
'r, F' => 'reflectance-mse',
'r,PSNR F' => 'reflectance-psnr',
'h.c[0], F' => 'y-hmse',
'h.c[1], F' => 'cb-hmse',
'h.c[2], F' => 'cr-hmse',
'h.c[0],PSNRF' => 'y-hpsnr',
'h.c[1],PSNRF' => 'cb-hpsnr',
'h.c[2],PSNRF' => 'cr-hpsnr',
'h.r, F' => 'reflectance-hmse',
'h.r,PSNR F' => 'reflectance-hpsnr',
);
##
# parse output of pc_error
sub readDistortion {
my ($file, $key_prefix) = @_;
open my $fh, '<', $file
or return {};
my %result;
# skip over all the preamble,
while (<$fh>) {
if (m{^PCC quality measurement software, version (.*)}) {
$result{"$key_prefix.dmetric.version"} = $1;
next;
}
last if m{^3. Final \(symmetric\).};
}
# read in the record
our %readDistortion_key2key;
while (<$fh>) {
chomp;
# change in indentation breaks the record
last unless m{^ };
s/^\s*//;
my ($key, $val) = split /\s*:\s*/;
$result{$key_prefix.$readDistortion_key2key{$key}} = $val;
}
return \%result;
}
1;
package MPEG::PCC::Parse::Ply;
use strict;
use warnings;
use Exporter qw(import);
our @EXPORT = qw(readPly);
##
# cache of ply data to reduce number of lookups
our %ply_cache;
##
# parse ply file for interesting parameters
sub readPly {
my ($file) = @_;
our %ply_cache;
return $ply_cache{$file} if exists $ply_cache{$file};
open my $fh, '<', $file
or return ();
# check it is a ply file
return () unless (<$fh> =~ m{^ply});
my $numpoints;
while (<$fh>) {
chomp;
# avoid the data section
last if m{^end_header};
if (m{^element vertex (\d+)}) { $numpoints = $1; next; }
}
return $ply_cache{$file} = $numpoints;
}
1;
package MPEG::PCC::Parse::Time;
use strict;
use warnings;
use Exporter qw(import);
our @EXPORT = qw(readTime);
##
# parse output of /bin/time.
# returns (user_time, maxrss)
sub readTime {
my ($file) = @_;
open my $fh, '<', $file
or return ('?');
chomp (my $line = <$fh>);
my $utime;
my $maxrssk;
foreach (split / /, $line) {
if (m{^(\d+\.\d+)user$}) { $utime = $1; next; }
if (m{^(\d+)maxresident}) { $maxrssk = $1; next; }
}
return ($utime, $maxrssk);
}
1;
package MPEG::PCC::Parse::Tmc3;
use strict;
use warnings;
use Exporter qw(import);
our @EXPORT = qw(readEncLog readDecLog);
##
# parse output of encoder log
sub readEncLog {
my ($file) = @_;
open my $fh, '<', $file
or return {};
my %result;
while (<$fh>) {
chomp;
if (m{^(positions|colors|reflectances|\w+) bitstream size (\d+) B \((\d+(\.\d+(e[+-]\d+)?)?) bpp\)}) {
my %map = (
positions => 'geometry',
colors => 'colour',
reflectances => 'reflectance',
);
my $key = $map{$1} || $1;
no warnings;
$result{"enc.bits.$key"} += $2 * 8;
$result{"enc.bpp.$key"} += $3;
next;
}
if (m{^Total bitstream size (\d+) B}) {
$result{'enc.bits'} = $1 * 8;
next;
}
if (m{^Processing time \(wall\): (\d+(\.\d+)?) s}) {
$result{'enc.wtime'} = $1;
next;
}
if (m{^Processing time \(user\): (\d+(\.\d+)?) s}) {
$result{'enc.utime'} = $1;
next;
}
}
return \%result;
}
##
# parse output of decoder log
sub readDecLog {
my ($file) = @_;
open my $fh, '<', $file
or return {};
my %result;
while (<$fh>) {
chomp;
if (m{^Processing time \(wall\): (\d+(\.\d+)?) s}) {
$result{'dec.wtime'} = $1;
next;
}
if (m{^Processing time \(user\): (\d+(\.\d+)?) s}) {
$result{'dec.utime'} = $1;
next;
}
}
return \%result;
}
1;
package MPEG::PCC::Parse::Utils;
use strict;
use warnings;
use Exporter qw(import);
our @EXPORT = qw(readFileFirstLine);
##
# cat the first line of a file.
sub readFileFirstLine {
my ($file) = @_;
open my $fh, '<', $file
or return ();
chomp (my $line = <$fh>);
return $line;
}
1;
package MPEG::PCC::Util;
use strict;
use warnings;
use Exporter qw(import);
our @EXPORT_OK = qw(uniq);
##
# From List::MoreUtils::uniq, licensed as follows:
# > This library is free software; you can redistribute it and/or modify
# > it under the same terms as Perl itself, either Perl version 5.8.4
# > or, at your option, any later version of Perl 5 you may have
# > available.
sub uniq (@)
{
my %seen = ();
my $k;
my $seen_undef;
grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
}
1;
#!/usr/bin/env perl
#
# This is an example to illustrate how to use the log parser. This
# tool is compatible with the experiment structure in Makefile.tmc13-step.
#
# Usage:
# collect-tmc13.pl <condition> <sequence> <variant> <base_path> <src_ply>
#
# Where:
# <condition> is a CTC test condition name
# <sequence> is the sequence name
# <variant> is the CTC test point variant
# <base_path> is the path used by MPEG::PCC::Parse::Experiment::Df
# <src_ply> is the source ply
#
use strict;
use FindBin;
use lib "$FindBin::Bin";
use MPEG::PCC::Parse::Experiment::Df;
# the set of output columns
# NB: it seems pointless, but useful if this script were to process more
# than one file at a time.
my %columns;
# process all the data (to get list of columns)
my @results;
# To process multiple files, turn the following into a loop:
my ($condition, $sequence, $variant, $base_path, $src_ply) = @ARGV;
my $line = readTmc3Results($base_path, $src_ply);
@columns{keys %$line} = ();
$line->{config} = $condition;
$line->{sequence} = $sequence;
$line->{variant} = $variant;
push @results, $line;