view release on metacpan or  search on metacpan

scripts/colpairs  view on Meta::CPAN

sub pickN ( $@ ) { 
	my $n = shift @_ ; 
	splice @_ , 0, $n ; 
}


sub reading  ( ) { 
    if ( $o{'='} ) { 
        my $head = <> ; 
        chomp $head ; 
        @heads = split /\t/ , $head , -1 ;
    }

    while ( <> ) { 
        chomp ; 
        my @F = split /\t/ , $_ , -1 ; 

        if ( ! $o{N} && !$o{T} ) 
        { 
            for my $i ( 0 .. $#F ) { 
                for my $j ( 0 .. $#F ) { 
                    $pf -> [ $i ] [ $j ] { $F[$i] . "\t" . $F[$j] } ++ ; 
                }
            }
        }
        elsif ( ! $o{T} )
        { 
            for my $i ( 0 .. $#F ) { 
                for my $j ( 0 .. $#F ) { 
                    $pf -> [ $i ] [ $j ] { $F[$i] } { $F[$j] } ++ ; 
                }
            }
        }
        else
        {
            for my $i ( 0 .. $#F ) { 
                for my $j ( 0 .. $#F ) { 
                    for my $k ( 0 .. $#F ) {
                        $tf -> [ $i ] [ $j ] [ $k ] { $F[$i] . "\t" . $F[$j] } { $F[$k] } ++ ; 
                    }
                }
            }
        }



        $rows ++ ;
    }
}

sub showing1 ( ) { 
    my $cols = @{ $pf } ; 
    
    @heads = ( 1 .. $cols ) unless @heads ; #defined $cols 
    my @diag = map { scalar keys %{ $pf -> [$_][$_]}}  0 .. $cols -1 ; 

    # 出力表の表頭
    my @out = ( (BOLD 'pairs') , map { UNDERLINE $_ } 1 .. $cols ) ; 
    push @out , UNDERLINE YELLOW 'col_' . ($o{'='} ? 'name' : 'num')   ;
    push @out , UNDERLINE('minstr') , UNDERLINE('maxstr') if 0 ne ($o{v}//'')  ; 
    say join "\t" , @out ; 

    # 出力表の各行
    my $cell ; # $cell -> [] [] 
    for my $i ( 0 .. $cols - 1 ) { 
        my @out = () ;

        # 表側
        push @out , ($i+1).':' ; #. color('reset') ; # 列番号

        # 右上の部分
        for my $j ( 0 .. $i -1 ) { 
            push @out , color('blue') . sprintf ( "%2.4f" , $cell->[$i][$j] * 100 ). color('reset');
             #( min values %{ $pf->[$i][$j] } )  . "-" . ( max values %{ $pf->[$i][$j] } ) ; 
        }
        # 対角線の部分
        push @out, color('bright_green') . (scalar keys %{$pf->[$i][$i]}) . color('reset') ; 

        # 左下の部分
        for my $j ( $i + 1 .. $cols -1 )  {
            my $val0 =  scalar keys %{ $pf->[$i][$j] } ;
            my $prod = $diag[$i] * $diag[$j] ;
            my $dmin = max $diag[$i] , $diag[$j] ;
            my $val = $val0 ;
            $val = color('bright_yellow') . $val . color( 'reset') . ':' if $val0 == $rows ; # 組合せ数 == データ行数 
            $val = color('yellow').$val.color('reset') . '*' if $val0 == $prod ; # 組合せ数 == 2列それぞれの全組合せ数
            $val = color('cyan').$val.color('reset') . '-' if $val0 == $dmin ; # 組合せ数 == 2列それぞれの異なり数の少ない方
            push @out , $val ; 
            my $tmp = min $prod, $rows ; 
            $cell -> [$j][$i] = $tmp == $dmin ? "nan" : ( $val0 - $dmin ) / ( $tmp  - $dmin ) ; #  スコアの計算
        }
        push @out , YELLOW $heads[$i] ; # color ( 'green') . $heads [$i] . color ( 'reset') ; # 入力列の名前を追加
        push @out , tabsplit1 (minstr keys %{ $pf->[$i][$i] } ) if 0 ne ( $o{v} // '') ; 
        push @out , tabsplit1 (maxstr keys %{ $pf->[$i][$i] } ) if 0 ne ( $o{v} // '') ; 
        print join "\t" , @out ;
        print "\n" ; 
    }
}

sub showing2 ( ) { 
    my $cols = @{ $pf } ; 
    @heads = ( 1 .. $cols ) unless @heads ; #defined $cols
    my @diag = map { scalar keys %{ $pf -> [$_][$_]}}  0 .. $cols -1 ;

    # 出力表の表頭
    my @out = ( (BOLD 'freq').'(min-mid-max)' , map { UNDERLINE $_ } 1 .. $cols ) ; 
    push @out , UNDERLINE YELLOW 'col_' . ($o{'='} ? 'name' : 'num')   ;
    push @out , UNDERLINE('q_value') if 0.9 < ($o{v}//'1')  ; 
    say join "\t" , @out ; 

    # 出力表の各行
    my $cell ; # $cell -> [] [] 
    for my $i ( 0 .. $cols - 1 ) { 
        my @out = () ;
        push @out , ($i+1) . ':' ;

        # 左下
        for my $j ( 0 .. $i - 1 ) { 
            my $val = do { my $t = pickN 1, ( qval $pf -> [$j][$i] ) ; $t =~ s/\t/|/r } ; 
            push @out , $val ;
        }
        # 対角線
        my $val = join'-',(min values%{$pf->[$i][$i]}),(midval $pf->[$i][$i]),(max values%{$pf->[$i][$i]}) ; 
        push @out , BRIGHT_GREEN $val ; 

        # 右上
        for my $j ( $i+1 .. $cols -1 ) { 
            my ( $val ) ; # セルの一つの値
            my @tmp ;
            push @tmp , min values %{ $pf->[$i][$j] } ;
            push @tmp , midval $pf->[$i][$j]  ; 
            push @tmp , max values %{ $pf->[$i][$j] }  ; 
            $val = join "-" , @tmp ; 
            push @out , $val ;
        }

        push @out , YELLOW $heads [$i] ; 
        #push @out , UNDERLINE('most_freq') if 0.9 < ($o{v}//'1')  ; 
        push @out , join "\t" , pickN $o{m}, @{[ map { tabsplit1 $_ } qval $pf->[$i][$i] ]} if 0.9 < ($o{v}//'1')  ; 

        print join "\t" , @out ;
        print "\n" ; 
    }
}

# 非決定性
sub nonDeterminability ( $$ ) { 
    my $cnt = 0 ;
    my $pfij = $pf -> [ $_[0] ][ $_[1] ] ; 

    for ( keys %{ $pfij } ) { # $pfijv
        if ( 1 < scalar keys %{ $pfij -> { $_ } } ) { 
        	$cnt ++ ; 
        	push @{ $pfijv -> [ $_[0] ] [ $_[1] ] } , $_ ; # <-- なんか難しいかも
        }
    }
    return $cnt ; 
}

sub showing3 ( ) { 
    my $cols = @{ $pf } ; 
    @heads = ( 1 .. $cols ) unless @heads ; #defined $cols
    my @diag = map { scalar keys %{ $pf -> [$_][$_]}}  0 .. $cols -1 ;

    # 出力表の表頭
    my @out = ( ( BOLD 'undec' ) , map { UNDERLINE $_ } 1 .. $cols ) ; 
    push @out , UNDERLINE YELLOW 'col_' . ($o{'='} ? 'name' : 'num')   ;
    push @out , UNDERLINE('value_not_determining_other_column_value') if 0.9 < ($o{v}//'1')  ; 
    say join "\t" , @out ; 

    # 出力表の各行
    my $cell ; # $cell -> [] [] 
    for my $i ( 0 .. $cols - 1 ) { 
        my @out = () ;
        push @out , ($i+1) . ':' ;

        # 左下
        my @o2 ; 
        for my $j ( 0 .. $cols - 1 ) { 
            my $val =  nonDeterminability ( $i , $j ) ; 
            push @o2 , $val ;
        }
        my $tmp = ( min grep { $_ != 0 } @o2 ) // '0' ; 
        my $posj ; # どこで最小値となったのか
        do { $o2[$_] == $tmp and $o2[$_] = BOLD $o2[$_] and $posj //= $_ } for 0 .. $#o2 ; 

        push @out , @o2 ;
        push @out , YELLOW $heads [$i] ; # 列名または列番号を挿入
        my @o3 = sort {  keys %{$pf->[$i][$posj]{$b}}  <=> keys %{$pf->[$i][$posj]{$a}} || $a cmp $b }  @{ $pfijv->[$i][$posj] } ;
        $_ = $_ . FAINT '(' .  (keys $pf->[$i][$posj]{$_} ) .')' for @o3 ; 
        push @out , pickN $o{m}, @o3 ; # @{ $pfijv->[$i][$posj] } ;


        say join "\t" , @out ;

        next ;
        # 対角線の部分
        # push @out, color('bright_green') . (scalar keys %{$pf->[$i][$i]}) . color('reset') ; 
        push @out, 0 ; 

        # 右上
        for my $j ( $i+1 .. $cols -1 ) { 
            my $val =  nonDeterminability ( $i , $j ) ; 
            push @out , $val ;
        }

        push @out , YELLOW $heads [$i] ; 
        say join "\t" , @out ; next ;
    }
}


sub showing4 ( ) { 
    my $cols = @{ $tf } ; 
    @heads = ( 1 .. $cols ) unless @heads ; #defined $cols
    my @diag = map { scalar keys %{ $tf -> [$_][$_][$_]}}  0 .. $cols -1 ;

    # 出力表の表頭
    print GREEN join ("\t" , "wC" , 1 .. $cols , "dis") , "\n" ; 

    # 出力表の各行
    my $cell ; # $cell -> [] [] 
    for my $i ( 0 .. $cols - 1 ) { 
        my @out = () ;
        push @out , color('green') . ($i+1) . color('reset') ;

        # 左下
        for my $j ( 0 .. $i - 1 ) { 
            push @out , color('blue') . join ( "," , whichColDet ( $i , $j , 1 ) ) . color('reset') ;#whichColDet ( $i , $j ) ; 
        }
        # 対角線の部分
        #push @out, color('bright_green') . ( scalar keys %{ $tf->[$i][$i][$i] } ) . color('reset') ; 
        my @diagD = whichColDet ( $i, $i , 0 ) ; 
        my %seen ; $seen{$_} =  1 for @diagD ; 
        push @out , color('bright_green') . join ( ',' , @diagD ) . color('reset') ; 

        # 右上
        for my $j ( $i+1 .. $cols -1 ) { 
            push @out , join (',', grep { ! $seen{$_} } whichColDet ( $i , $j , 0 ) ) ; 
        }

        # さらに1列
        push @out, color('bright_green') . ( scalar keys %{ $tf->[$i][$i][$i] } ) . color('reset') ; 

        push @out , color ( 'green') . $heads [$i] . color ( 'reset') ; 
        print join "\t" , @out ;
        print "\n" ; 
    }
}

sub whichColDet ( $$ $ ) { 

    my $tfij = $tf ->[ $_[0] ][ $_[1] ] ; 
    my @ret ; 

    for ( 0 .. scalar @{ $tfij } -1 ) { 
        next if $_ == $_[0] || $_ == $_[1] ;
        my $cnt = 0 ;
        for my $vi ( keys %{ $tfij -> [$_] } ) { 
            $cnt ++ if 1 < scalar keys %{ $tfij -> [$_]{$vi} } ;
        }
        push @ret , $_ + 1 if $cnt == $_[2] ;
    }
    return @ret ;
}