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.

scripts/MPEG/PCC/CSV.pm

+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;

scripts/MPEG/PCC/Collate.pm

+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;

scripts/MPEG/PCC/Parse/Experiment/Df.pm

+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;
+}

scripts/MPEG/PCC/Parse/PcError.pm

+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;

scripts/MPEG/PCC/Parse/Ply.pm

+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;

scripts/MPEG/PCC/Parse/Time.pm

+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;

scripts/MPEG/PCC/Parse/Tmc3.pm

+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;

scripts/MPEG/PCC/Parse/Utils.pm

+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;

scripts/MPEG/PCC/Util.pm

+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;

scripts/collect-tmc13.pl

+#!/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;
+
+# output data
+BLOCK: {
+	my @out_order_cols = (
+		qw{config sequence variant},