File Coverage

blib/lib/DataCube/Schema.pm

Criterion	Covered	Total	%
statement	28	180	15.5
branch	3	42	7.1
condition	2	32	6.2
subroutine	8	36	22.2
pod	8	33	24.2
total	49	323	15.1

package DataCube::Schema;

use strict;
use warnings;
use Digest::MD5;

sub new {
    my($class,%opts) = @_;
    bless {
        %opts,
        parents           => {},
        measures          => [],
        hierarchies       => [],
        computed_measures => [],
    }, ref($class) || $class;
}

sub add_hierarchy {
    my($self,@hierarchy) = @_;
    $self->add_strict_hierarchy(undef,@hierarchy);
}

sub add_strict_hierarchy {
    my($self,@hierarchy) = @_;
    for(my $i = 0; $i < $#hierarchy; $i++){
        next unless my $parent = $hierarchy[$i];
        my $child = $hierarchy[$i+1];
        $self->{parents}->{$parent}->{$child} = undef;
    }
    $self->{field_names}->{$_} = undef for grep { defined } @hierarchy;
    push @{$self->{hierarchies}}, [@hierarchy];
}

sub initialize {
    my($self,%opts)      = @_;
    $self->{fields}      = [sort keys %{$self->{field_names}}];
    my $name             = join("\t", @{$self->{fields}});
    $self->{name}        = length($name) ? $name : 'overall';
    $self->{name_digest} = Digest::MD5->new->add($self->{name})->hexdigest;
    field_count:{
        ($self->{field_count}) = 0 and last field_count if $self->{name} eq 'overall';
         $self->{field_count}  = $self->{name} =~ s/\t/\t/g + 1;
    }
    measure_string:
    for(my $i = 0; $i < @{$self->{measures}}; $i++){
        my @measure = @{$self->{measures}->[$i]};
        next measure_string if $self->{measures}->[$i][2] || $self->{measures}->[$i][0] eq 'key_count';
        $self->{measures}->[$i][2] = join('__',@{$self->{measures}->[$i]});
    }
    $self->{initialized} = 1;
    return $self;
}

sub columns {
    my($self) = @_;
    return $self->fields, $self->measure_names
}

sub measure_names {
    my($self) = @_;
    map { $_->[2] } $self->measures
}

sub confine_to {
    my($self,@fields) = @_;
    $self->{confine_to} = join("\t",sort @fields);
    return $self;
}

sub confine_to_base {
    my($self) = @_;
    $self->{confine_to_base} = 1;
    return $self;
}

sub is_confined {
    my($self) = @_;
    return $self->{confine_to};
}

sub strict_dimensions {
    my($self) = @_;
    return [] unless $self->has_strict_hierarchies;
    my $hierarchies = $self->hierarchies;
    my @dims;
    for(@$hierarchies){
        push @dims, $_->[0] if defined $_->[0];
    }
    return \@dims;
}

sub has_strict_hierarchies {
    my($self) = @_;
    my $hierarchies = $self->hierarchies;
    for(@$hierarchies){
        return 1 if defined $_->[0];
    }
    return 0;
}

sub has_asserted_lattice_points {
    my($self) = @_;
    my $points = $self->{asserted_lattice_points};
    return 1 if $points
         && ref($points)
         && ref($points) =~ /^hash$/i
         && keys %$points;
    return 0;
}

sub add_strict_dimension {
    my($self,$dimension) = @_;
    $self->add_strict_hierarchy($dimension);
}

sub add_dimension {
    my($self,$dimension) = @_;
    $self->add_hierarchy($dimension);
}

sub add_measure {
    my($self,@measure) = @_;
    @measure = ('key_count') if @measure == 1 && $measure[0] eq 'count';
    push @{$self->{measures}}, [@measure];
}

sub add_computed_measure {
    my($self,@measure) = @_;
    push @{$self->{computed_measures}}, [@measure];
}

sub suppress_lattice_point {
    my($self,@point) = @_;
    my $point = join("\t",sort @point);
    $self->{suppressed_lattice_points}->{$point} = undef;
}

sub filter_lattice_point {
    my( $self, $code ) = @_;
    push @{ $self->{lattice_point_filters} }, $code;
}

sub assert_lattice_point {
    my($self,@point,%point,$name) = @_;
    assert_opts:{
        if(@point % 2 == 0){
            %point = @point;
            $point{dims} ||= $point{dimensions};
            if($point{dims} && ref($point{dims}) =~ /^array$/i){
                @point = @{$point{dims}};
                $name  = $point{name} if $point{name};
            }
        }
    }
    my $point = join("\t",sort @point);
    $self->{lattice_point_names}->{$point} = $name;
    $self->{asserted_lattice_points}->{$point} = undef;
    return $self;
}

sub is_initialized {
    my($self) = @_;
    return $self->{initialized};
}

sub measures {
    my($self) = @_;
    @{$self->{measures}}
}

sub hierarchies {
    my($self) = @_;
    return $self->{hierarchies}
}

sub field_names {
    my($self) = @_;
    sort keys %{$self->{field_names}}
}

sub fields {
    my($self) = @_;
    return @{$self->{fields}};
}

sub field_count {
    my($self) = @_;
    return $self->{field_count};
}

sub measure_count {
    my($self) = @_;
    return scalar @{$self->{measures}};
}

sub name {
    my($self) = @_;
    return $self->{name};
}

sub name_digest {
    my($self) = @_;
    return $self->{name_digest};
}

sub lattice_point_name {
    my($self) = @_;
    return $self->{lattice_point_name};
}

sub asserted_lattice_points {
    my($self) = @_;
    return $self->{asserted_lattice_points};
}

sub safe_file_name {
    my($self) = @_;
    my $name = $self->name;
   (my $file_name = $name) =~ s/\t+/__/g;
    $file_name = $self->lattice_point_name
        if defined($self->lattice_point_name);
    return $file_name;
}

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

    my %types;

    for( $self->fields ) {
        $types{ $_ } = 'text'
    }

    for( $self->measures ) {
        if( $_->[0] eq 'sum' ) {
            $types{ $_->[2] } = 'numeric not null';
            next
        }
        die "Measure $_->[0] not yet implemented in pg_types";
    }

    %types;
}




sub check_conflicts {
    my($self) = @_;
    my @conflicts;

    strict_assertions:{
        last strict_assertions unless $self->has_asserted_lattice_points && $self->has_strict_hierarchies;
        my $strict = $self->strict_dimensions;
        my $points = $self->asserted_lattice_points;
        for(@$strict){
            my $dim = $_;
            for(keys %$points){
                my @fields = split/\t/,$_,-1;
                my %fields = map { $_ => undef } @fields;
                push @conflicts, {
                    category      => 'strict dimensions versus asserted lattice points',
                    dimension     => $dim,
                    lattice_point => $_,
                    message       => "\n\n\tThe dimension\n\n\t\t$dim\n\n\tis marked as strict ".
                                     "but this conflicts with the asserted lattice point:\n\n\t\t$_\n\n\t" .
                                     "which does not contain this dimension\n",
                } unless exists $fields{$dim};
            }
        }
    }

    confine:{
        if(my $confine = $self->is_confined){
            my @confine = split/\t/,$confine,-1;
            my %confine = map { $_ => undef } @confine;
            for(@confine){
                my $dim = $_;
                unless(exists $self->{field_names}->{$_}){
                    push @conflicts, {
                        category  => 'confined lattice point is not valid',
                        confine   => $confine,
                        dimension => $_,
                        message   => "\n\n\tThe dimension\n\n\t\t$dim\n\n\tis confined ".
                                     "but no such dimension exists in your schema\n",
                    };
                }
                for(keys %{$self->{parents}}){
                    my $parent = $_;
                    if(exists $self->{parents}->{$parent}->{$dim} && ! exists $confine{$parent}){
                        push @conflicts, {
                            category  => 'confined lattice point breaks hierarchical constraints',
                            confine   => $confine,
                            dimension => $dim,
                            parent    => $parent,
                            message   => "\n\n\tThe dimension\n\n\t\t$dim\n\n\tis confined ".
                                     "but the parent:\n\n\t\t$parent\n\n\tis not included\n",
                        };
                    }
                }
            }
        }
    }

    if(@conflicts){
        printf "\nconflicts were detected in your schema that must be resolved before cube creation:\n";
        print '-'x100,"\n\n";
        for(@conflicts){
            my $reason = $_;
            for(sort keys %$reason){
                next if /^message$/i;
                printf " %-15s  =>  %s\n",$_,$reason->{$_};
            }
            print "\n message:" . $reason->{message};
            print "\n",'-'x100,"\n";
        }
        die "\nplease fix these conflicts before continuing\n\n";
    }

    return $self;
}




1;






__END__