source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/Stat.pm @ 1904

package LATMOS::Accounts::Bases::Sql::Stat;

use 5.010000;
use strict;
use warnings;
use LATMOS::Accounts::Log;

use base qw(LATMOS::Accounts::Bases::Sql::objects);
use LATMOS::Accounts::I18N;

our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Accounts::Bases::Sql::Site - Common Location/Address object

=head1 DESCRIPTION

Store common to many people office address (typically building location).

=cut

sub _object_table { 'stat' }

sub _key_field { 'name' }

sub _has_extended_attributes { 1 }

sub _get_attr_schema {
    my ($class, $base) = @_;

    $class->SUPER::_get_attr_schema($base,
        {
            name   => { ro => 1, inline => 1, },
            cn     => { ro => 1, inline => 1, iname => 'name' },
            date   => { ro => 1, inline => 1, },
            create => { ro => 1, inline => 1, },
            filter => { multiple => 1 },
            refFilter => { multiple => 1 },
            refall => { },
            otype  => { },
            attribute => { },
            description => { },
            delay => { },
            lastStatId => { },
            aggregateFunction => {
                can_values => sub { qw(sum avg count) },
            },
            nullValue => { },
            display => { },
            needRun => {
                ro => 1,
                managed => 1,
                get => sub {
                    my ($attr) = @_;
                    my ($self) = $attr->object;

                    my $days = $self->_get_attributes('delay') || 7;
                    my $sth = $self->db->prepare(
                        q{
                        select tstamp from statsentry where okey = ?
                            and tstamp > now() - (? * '1 day'::interval)
                            order by tstamp desc
                            limit 1
                        }
                    );
                    $sth->execute($self->Iid, $days);
                    if (my $res = $sth->fetchrow_hashref) {
                        $self->base->log(LA_DEBUG, "Stat %s done recently: %s", $self->id, $res->{tstamp});
                        return undef;
                    } else {
                        return 1;
                    }
                },
            },
        }
    )
}

=head2 compute()

Compute stat value and return hash with var/val peer value

=cut

sub compute {
    my ($self) = @_;

    my $otype = $self->_get_attributes('otype') or return;
    my $attribute = $self->_get_attributes('attribute') or return;

    my %stats;
    my $reffiltered = undef;

    my $op = $self->_get_attributes('aggregateFunction');

    my ($refOtype, $refAttr) = ($otype, undef);

    foreach (split(/\./, $attribute)) {
        if (my $attr = $self->base->attribute($refOtype, $_)) {
            if (my $obj = $attr->reference) {
                ($refOtype, $refAttr) = ($obj, $attr);
            } else {
                ($refOtype, $refAttr) = (undef, undef);
            }
        }
    }

    if ($refAttr && $refOtype) {
        if (my @reffilter = $self->_get_attributes('refFilter')) {
            $reffiltered = {};
            foreach ($self->base->search_objects($refOtype, @reffilter)) {
                $reffiltered->{$_} = 1;
            }
        }
        if ($self->_get_attributes('refall') && $refAttr->has_values_list && !$op) {
            foreach ($refAttr->can_values) {
                if ($reffiltered && !$reffiltered->{$_}) {
                    next;
                }
                $stats{$_} = 0;
            } 
        }
    } else {
        $self->base->log(LA_ERR, "Cannot find attribute %s for object type %s", $attribute, $otype);
    }

    my %filtered;
    if (my @fil = $self->_get_attributes('filter')) {
        %filtered = map { $_ => 1 } $self->base->search_objects($otype, @fil);
    } else {
        %filtered = map { $_ => 1 } $self->base->list_objects($otype);
    }

    my %results = $self->base->attributes_summary_by_object($otype, $attribute);

    my $nullValue = $self->_get_attributes('nullValue');
    my %aggdata;
    if ($nullValue) {
        $results{ $_ } ||= [''] foreach(keys %filtered);
    }
    foreach my $id (keys %results) {
        $filtered{ $id } or next;
        foreach (@{ $results{ $id }}) {
            next unless (defined($_) || $nullValue);
            if ($_ && $reffiltered && !$reffiltered->{$_}) {
                next;
            }
            defined($_) && $_ ne '' or $_ = '(none)';
            if ($op) {
                push(@{$aggdata{$id}}, $_);
            } else {
                $stats{ $_ } ||= 0;
                $stats{ $_ }++;
            }
        }
    }
    if ($op) {
        foreach my $key (keys %aggdata) {
            if ($op eq 'sum') {
                my $sum = 0;
                $sum += $_ foreach (@{ $aggdata{$key} });
                $stats{ $key } = $sum;
            }
            elsif ($op eq 'count') {
                $stats{ $key } = scalar(@{ $aggdata{$key} });
            }
            elsif ($op eq 'average') {
                my $sum = 0;
                $sum += $_ foreach (@{ $aggdata{$key} });
                $stats{ $key } = $sum / scalar(@{ $aggdata{$key} });
            }
        }
    }

    return \%stats;
}

=head2 collect()

Store statistics for $attribute on $otype. @filters allow to limit result on
$otype object matching the filters

=cut

sub collect {
    my ($self) = @_;

    my $otype = $self->_get_attributes('otype') or return;
    my $attribute = $self->_get_attributes('attribute') or return;

    if (!$self->_get_attributes('needRun')) {
        return;
    }

    $self->base->log(LA_NOTICE, "Collecting data for stat: %s", $self->id);

    my $stats = $self->compute();

    my $sthr = $self->db->prepare(
        q{ INSERT INTO statsentry (okey) values (?) }
    );
    $sthr->execute($self->Iid);

    my $id = $self->db->last_insert_id(undef,undef,'statsentry',undef);

    my $sthv =  $self->db->prepare(
        q{
        INSERT INTO statvalues (sid, value, count) values (?,?,?)
        }
    );
    foreach (keys %$stats) {
        $sthv->execute($id, $_, $stats->{$_});
    }
    $self->_set_c_fields('lastStatId' => $id) or do {
        $self->base->log(LA_ERR, "Cannot update Stat object");
        return;
    };

    return 1;
}

=head2 getStat($id)

Return the statistics value for this stat entry.

If not given, C<$id> will be the last entry found

=cut

sub getStat {
    my ($self, $id) = @_;

    ($id) ||= $self->_get_attributes('lastStatId');

    if (!$id) {
        $self->base->log(LA_ERR, "No Stat Id given for stat name %s", $self->id);
        return;
    }

    my $sthentry = $self->db->prepare('SELECT * from statsentry where okey = ? and id = ?');
    $sthentry->execute($self->Iid, $id);
    if (!(my $res = $sthentry->fetchrow_hashref)) {
        $self->base->log(LA_ERR, "No stat entry %d found for stat %s", $id, $self->id);
        return;
    }

    my $sthvalues = $self->db->prepare("SELECT * FROM statvalues where sid = ?");
    $sthvalues->execute($id);

    my $stats = {};
    while (my $res = $sthvalues->fetchrow_hashref) {
        $stats->{$res->{value}} = $res->{count};
    }

    $stats
}

=head2 getAllStat()

Return a hashref containing all statistics value per date

=cut

sub getAllStat {
    my ($self) = @_;

    my $sth = $self->db->prepare(q{
        SELECT count, value, to_char(tstamp, 'YYYY-MM-DD HH24:MI') as d from statsentry join
                      statvalues
            on statsentry.id = statvalues.sid
            where statsentry.okey = ?
                order by statsentry.tstamp, value
    });
    $sth->execute($self->Iid);

    my $stats = {};
    while(my $res = $sth->fetchrow_hashref) {
        $stats->{$res->{d}}{$res->{value}} = $res->{count};
    }

    return $stats;
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Bases::Sql>

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.


=cut