File Coverage

blib/lib/Sport/Analytics/NHL/Report/ES.pm

Criterion	Covered	Total	%
statement	116	170	68.2
branch	28	44	63.6
condition	22	44	50.0
subroutine	14	16	87.5
pod	6	6	100.0
total	186	280	66.4

package Sport::Analytics::NHL::Report::ES;

use v5.10.1;
use strict;
use warnings FATAL => 'all';
use experimental qw(smartmatch);

use parent 'Sport::Analytics::NHL::Report';

use Sport::Analytics::NHL::Config;
use Sport::Analytics::NHL::Errors;
use Sport::Analytics::NHL::Util;

use Storable qw(dclone);
use Data::Dumper;

=head1 NAME

Sport::Analytics::NHL::Report::ES - Class for the NHL HTML ES report.

=head1 SYNOPSYS

Class for the NHL HTML ES report. Should not be constructed directly, but via Sport::Analytics::NHL::Report (q.v.)
As with any other HTML report, there are two types: old (pre-2007) and new (2007 and on). Parsers of them may have something in common but may turn out to be completely different more often than not.

=head1 METHODS

=over 2

=item C

Get the headers of the player tables in the new HTML.

 Arguments: HTML element with the team table
 Returns: the array of headers.

=item C

Get the headers of the player tables in the old HTML.

 Arguments: HTML element with the team table
 Returns: the array of headers.

=item C

Cleaning up and standardizing the parsed data.

 Arguments: none
 Returns: void. Everything is in the $self.

=item C

Parse the ES html tree into a boxscore object

 Arguments: none
 Returns: void. Everything is in the $self.

=item C

Parse a team's table in the new HTML.

 Arguments: HTML element with the team table
 Returns: the team hashref.

=item C

Parse a team's table in the old HTML.

 Arguments: HTML element with the team table
 Returns: the team hashref.

=back

=cut

my %NORMAL_FIELDS = (
	S => {
		G => 'goals', 'A' => 'assists', P => 'points', FW => 'faceOffWins',
		PN => 'penalties', FL => 'faceOffLosses', 'F%' => 'faceOffPct',
		TOI => 'timeOnIce', AVG => 'averageTimeShift', S => 'shots', MS => 'misses',
		'+/-' => 'plusMinus', 'A/B' => 'attemptsBlocked', HT => 'hits',
		GV => 'giveaways', TK => 'takeaways', BS => 'blocked', SHF => 'shifts',
		TOIPP => 'powerPlayTimeOnIce', TOISH => 'shortHandedTimeOnIce', TOITOT => 'timeOnIce',
		PP => 'powerPlayTimeOnIce', SH => 'shortHandedTimeOnIce', EV => 'evenTimeOnIce',
		TOIEV => 'evenTimeOnIce', POS => 'position', 'No.' => 'number', TOI => 'timeOnIce',
		PIM => 'penaltyMinutes', TOISHF => 'shifts', TOIAVG => 'averageIceTime', SHOTT => 'shots',
	},
);
my %LIVE_FIELDS = (
	S => [qw(shortHandedGoals shortHandedAssists powerPlayGoals powerPlayAssists evenStrengthGoals evenStrengthAssists)],
	G => [qw(pim goals assists)]
);
my %FRENCH = (
	'TOIDN/SH' => 'TOISH',
	'TOI' => '14:19',
	'TOIFÃ/EV' => 'TOIEV',
	'TOIMOY' => 'TOIAVG',
	'LB' => 'BS',
	'MG' => 'FW',
	'TOIAN/PP' => 'TOIPP',
	'LANC.' => 'S',
	'PP' => 'TK',
	'B' => 'G',
	'LR' => 'MS',
	'M%' => 'F%',
	'PUN' => 'PN',
	'MP' => 'FL',
	'MO' => 'FL',
	'TOIPR' => 'TOISHF',
	'R' => 'GV',
	'MIN' => 'PIM',
	'TENT/BL' => 'A/B',
	'MÃ' => 'HT'
);

sub get_old_headers ($$;$) {

	my $self         = shift;
	my $team_summary = shift;

	my $header_row = $self->get_sub_tree(0, [ 0 ], $team_summary);
	my $headers_num = scalar @{$header_row->{_content}};
	my @headers;

	for my $h (0..$headers_num-1) {
		for ($h) {
			when (0) {
				$headers[$h] = 'No.';
			}
			when (1) {
				$headers[$h] = 'POS';
			}
			when (2) {
				$headers[$h] = 'name';
			}
			default {
				$headers[$h] =
					$self->get_sub_tree(0, [$h,0,1], $header_row)   ||
					$self->get_sub_tree(0, [$h,0,0,1], $header_row) ||
					'';
				if (ref $headers[$h]) {
					$headers[$h] =
						$self->get_sub_tree(0, [$h,0,2], $header_row) ||
						$self->get_sub_tree(0, [$h,0,0,2], $header_row);
				}
			}
		}
	}
	my $shots_row = $self->get_sub_tree(0, [1], $team_summary);
	my $h = 0;
	my $shot_offset;
	for my $header (@headers) {
		unless ($header) {
			$shot_offset = $h;
			last;
		}
		$h++;
	}
	for my $h (2..$#{$shots_row->{_content}}) {
		my $subshot = $self->get_sub_tree(0, [$h,0,0,0], $shots_row);
		last unless $subshot;
		splice(@headers, $shot_offset-1+$h, 0, "SHOT" . $subshot);
	}
	splice(@headers, $shot_offset, 1);
	@headers = grep { /\S/ } @headers;
	@headers;
}

sub get_new_headers ($$) {

	my $self         = shift;
	my $team_summary = shift;

	my $header_row = $self->get_sub_tree(0, [ 0,0,0 ], $team_summary);
	my $headers_num = scalar @{$header_row->{_content}};
	my @headers;

	for my $h (0..$headers_num-1) {
		for ($h) {
			when (0) {
				$headers[$h] = 'name';
			}
			default {
				$headers[$h] =
					$self->get_sub_tree(0, [$h,0,], $header_row)   ||
					'';
			}
		}
	}
	unshift(@headers, qw(No. POS));
	my $shots_row = $self->get_sub_tree(0, [0,0,1], $team_summary);

	for my $h (0..$#{$shots_row->{_content}}) {
		my $subcol = $self->get_sub_tree(0, [$h,0], $shots_row);
		splice(@headers, 10+$h, 0, "TOI$subcol") if $subcol;
	}
	splice(@headers, 9, 1);
	@headers = grep { /\S/ } @headers;
	for my $header (@headers) {
		$header = $FRENCH{$header} if $FRENCH{$header};
		$header = 'TOIEV' if $header =~ /TOIF.*EV/;
		$header = 'HT' if $header =~ /^M./ && $header ne 'MS' && $header ne 'M%' && $header ne 'MO' && $header ne 'MG';
	}
	@headers;
}

sub parse_old_team_summary ($$) {

	my $self         = shift;
	my $team_summary = shift;

	my $roster = [];

	my @headers = $self->get_old_headers($team_summary);
	my $g = 2;
	while (my $player_row = $self->get_sub_tree(0, [$g], $team_summary)) {
		my $player = {};
		for my $h (0..$#headers) {
			$player->{$headers[$h]} = $self->get_sub_tree(0, [$h,0,0], $player_row);
		}
		push(@{$roster}, $player) if
			$player->{name} && $player->{name} !~ /TOTALS/ && $player->{name} !~ /team penalty/i;
		$g++;
	}
	$roster;
}

sub parse_new_team_summary ($$) {

	my $self         = shift;
	my $team_summary = shift;

	my @headers = $self->get_new_headers($team_summary);
	my @rosters;
	my $g = 2;
	my $roster = [];
	while (my $player_row = $self->get_sub_tree(0, [0,0,$g], $team_summary)) {
		my $player = {};
		for my $h (0..$#headers) {
			$player->{$headers[$h]} = $self->get_sub_tree(0, [$h,0], $player_row);
		}
		push(@{$roster}, $player) if
			$player->{'No.'} && $player->{'No.'} =~ /\S/ && $player->{'No.'} !~ /\D/;
		if ($player->{'No.'} && $player->{'No.'} =~ /TOTALS/) {
			push(@rosters, $roster);
			$roster = [];
		}
		$g++;
	}
	@rosters;
}

sub parse ($$) {

	my $self = shift;

	my $body_size = scalar @{$self->{html}{_content}};
	if ($self->{old}) {
		my $away_summary = $self->get_sub_tree(0, [3,(0)x$#{$self->{head}}]);
		$self->{teams}[0]{roster} = $self->parse_old_team_summary($away_summary);
		my $home_summary = $self->get_sub_tree(0, [5,(0)x$#{$self->{head}}]);
		$self->{teams}[1]{roster} = $self->parse_old_team_summary($home_summary);
	}
	else {
		my $summary = $self->get_sub_tree(0, [$body_size/2,7]);
		my @rosters = $self->parse_new_team_summary($summary);
		$self->{teams}[0]{roster} = dclone $rosters[0];
		$self->{teams}[1]{roster} = dclone $rosters[1];
	}
}

sub normalize ($$) {

	my $self       = shift;

	for my $team (@{$self->{teams}}) {
		for my $player (@{$team->{roster}}) {
			$player->{'No.'} =~ s/\D//g;
			if ($player->{POS} eq 'G') {
				delete @{$player}{qw(BS +/- SHF FW FL F% A/B)};
			}
			for my $field (keys %{$player}) {
				$player->{$field} ||= $field eq 'TOIAVG' ? '0:00' : 0;
				$player->{$field} =~ s/^\s+//;
				$player->{$field} =~ s/\s+$//;
				$player->{$field} =~ s/\;/:/g;
				if ($player->{$field} =~ /:/) {
					$player->{$field} =~ s/^(\d+):(\d+)$/$1*60+$2/e;
				}
				elsif ($field ne 'name' && $field ne 'POS') {
					$player->{$field} = 0 if $player->{$field} !~ /\d/;
					$player->{$field} += 0;
				}
				$player->{$field} += 0 if $player->{$field} =~ /^\-?\d+$/;
			}
			$player->{name} = "$2 $1" if $player->{name} =~ /^(\S.*\S)\,\s+(\S.*)$/;
			$player->{start} = 2;
			$player->{status} = 'X';
			for my $field (qw(G A PIM)) {
				$player->{$field} ||= 0E0;
			}
			for my $field (keys %{$NORMAL_FIELDS{S}}) {
				$player->{$NORMAL_FIELDS{S}->{$field}} = delete $player->{$field}
					if exists $player->{$field};
			}
			my $pos = $player->{position} eq 'G' ? 'G' : 'S';
			for my $field (@{$LIVE_FIELDS{$pos}}) {
				$player->{$field} ||= 0E0;
			}
			if ($player->{position} ne 'G') {
				$player->{faceoffTaken} = $player->{faceOffWins} + $player->{faceOffLosses};
				$player->{timeOnIce} = $player->{evenTimeOnIce} + $player->{powerPlayTimeOnIce} + $player->{shortHandedTimeOnIce} if defined $player->{evenTimeOnIce};
			}
		}
	}
}

1;

=head1 AUTHOR

More Hockey Stats, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Sport::Analytics::NHL::Report::ES

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back