view release on metacpan or  search on metacpan

coldigits  view on Meta::CPAN

#!/usr/bin/perl 
use 5.014 ; use warnings ; 
use Time::HiRes qw [ gettimeofday tv_interval ] ;
my ${ dt_start } = [ gettimeofday ] ; 
use Encode qw[ decode_utf8 encode_utf8 ] ; 
use Getopt::Std ; getopts '=0:BM:R:e:i:u:v:y:' , \my %o  ; 
use Term::ANSIColor qw[ color :constants ] ; $Term::ANSIColor::AUTORESET = 1 ;
use FindBin qw[ $Script ] ; 
use autodie qw [ open ] ;
use List::Util qw[ min max ] ; 
use Scalar::Util qw [ dualvar ]  ; 

* d3 = exists $o{','} && $o{','} eq 0 ? sub{$_[0]} : sub { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ;
my $time0 = time ; 
my $help = 0  ; # オンラインヘルプの文面の表示をしたか否か。
my $readLines  ; # 読み取った行数
my $sec = $o{'@'} // 15 ; # 何秒おきにアラームを発生させるか
$o{y} //= "2.." if $o{M} ; 
our @y_ranges ; 
& y_init () ; 

$SIG{INT} = sub { exit } ;
$SIG{ALRM} = sub { 
  my $n = $.  =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr ; # 3桁ごとに区切る。
  say STDERR GREEN "$n lines read ($Script). " , scalar localtime ; 
  alarm $sec 
} ; 
alarm $sec ;

* R0proc = exists $o{R} && $o{R} eq 0 ? sub {} : sub { s/\r$// } ; 
* decode = ($o{u}//'') ne 0 ? * decode_utf8 : sub ( $ ) { $_[0] } ; 
$o{0} //= '-' ; # 行列状の出力で 値が 0 の場合に出力する文字
my $isep = $o{i} // "\t" ;  # 入力の区切り文字
$o{e} = decode ( $o{e} ) if exists $o{e} ;
* len = ! exists $o{e} ? sub ( $ ) { length $_[0]  } : sub ($) { my @c = $_[0] =~ m/$o{e}/g ; scalar @c } ;

my $neoM = ! exists $o{M} ; 
my $noB = ! $o{B} ; 
my @cn =  & colnames if $o{'='} ;  # Column Names の頭文字
my @Cij  ; # $Cij[列番]{桁数} により、0始まり何番の列に、何桁のものが、何件あったかを示す。
my %Cj  ; # $Cj{ 桁数} > 0 により、その桁数のものが存在したことを示す。digit length のつもり。
my @Cj  ; # 出力の時に使う。 sort { $a <=> $b } keys %Cj ;
my @E1  ; # $E1[$i] = [入力$i列目(出力$i行目)の最も右のjの値(位置) , 入力での出現値 , その位置と出現値の頻度 ] 。
my @E2  ; # [位置, 出現値, 頻度]  ; $E2[$j] で $E1[$j] に準じるものになる。 形式は同様。
my @out ; # 出力時に、各行で何をタブ区切りで表示するかを格納する。

binmode STDOUT, "utf8" if ($o{u}//'') ne 0 ; 
 
## -- -
M : # オプション -M が指定された時。
while( <> ) { 
  chomp ; & R0proc ; 
  my @F = split /$isep/o , decode( $_ ) , -1 ; 
  for ( 0 .. $#F ) {
    my %jd = do { my %z ; $z{$_}++ for split //, $F[$_], 0 ;   map{ $_,$z{$_} }   grep { &y_filter($z{$_}) } keys %z } if exists $o{M} ; 
    for my $j (  $neoM ? do { my $j = len ( $F[$_] ) ; & y_filter ( $j ) ? ($j) : () } : keys %jd )  {
      $neoM ? $Cij [ $_ ] { $j } ++ : do { $Cij [ $_ ] { $jd {$j} } { $j } ++ ; $j = $jd{$j} } ; # $Cij[入力列番]{文字列長} か $Cij[入力列番]{出現頻度}{出現文字}
      $Cj { $j } ++  ; # $Cj { 出現頻度 } をカウント。
      $E1[$_] = [ $j , $F[$_] , 0 ] if ( $E1[$_]->[0] // "-Inf" ) < $j ;  # # [(仕分け)位置(名の文字列), 出現値, 頻度]  ; ここでの $_ は列番号である。
      $E1[$_]->[2] ++ if $E1[$_]->[0] == $j && $E1[$_]->[1] eq $F[$_] ; 
      $E2[$_] = [ $j , $F[$_] , 0 ] if ( $E2[$_]->[0] // "-Inf" ) < $j && $F[$_] ne $E1[$_]->[1] ; # && $E1[$_]->[0] == $j ;  
      $E2[$_]->[2] ++ if exists $E2[$_]->[1] && $E2[$_]->[1] eq $F[$_] ;     
    }
  }
} 
& output () ; 
exit 0 ; 

# 出力;
sub cseq ( $$$ ) {  # 出力の各セルにおいて、出現した文字の全てを、いい具合にまとめる。
  my $lc = $_[0] ; # limit char 
  my $i = $_[1] ;  # 出力の各行(入力の各列)に対応
  my $j = $_[2] ;  # 出力の各列(集計した時の仕分け先)に対応
  #my @Z = sort keys %{ $Cij[$i]{$Cj[$j]} } ; #  文字列 $Cij[$i]{$x}で入力$i番目の列に、文字$xを持つセルの、出現件数を示す。$Cj[$j]で、その出現件数の、頻度数を表す。
  my @Z = sort keys %{  $Cij [$i] { $_[2] }  } ; #  文字列 $Cij[$i]{$x}で入力$i番目の列に、文字$xを持つセルの、出現件数を示す。$Cj[$j]で、その出現件数の、頻度数を表す。
  #return @Z > $lc ? do{ $Z[1] //= '' ; $Z[-1] //= '' ; "$Z[0]$Z[1]..$Z[-2]$Z[-1]" . FAINT "(".@Z.")" }  : @Z ? join ('', @Z). FAINT "(".@Z.")" : FAINT $o{0} ;
  return @Z > $lc ? do{ $_ //= '' for 1,2,-3,-2  ; "$Z[0]$Z[1]$Z[2]..$Z[-3]$Z[-2]$Z[-1]" . FAINT "(".@Z.")" }  : @Z ? join ('', @Z). FAINT "(".@Z.")" : FAINT $o{0} ;
}

sub output () { 
  my $lc = exists $o{M} ? defined $o{M} ? $o{M} : 15 : undef ; # -Mオプションに寄り、出力の各セルに、何文字を超えたら、省略記法にするかについて。 Limit Char の頭文字
  @Cj = sort { $a <=> $b } keys %Cj ;
  say join "\t" , map { UNDERLINE $_ } YELLOW ('col') , ( $noB ? @Cj:qw[min max]) , ($o{v}//'') eq 0 ? () : map { GREEN "eg.$_". FAINT "(freq)" } 1..2 ;  
  for my $i ( 0 .. $#Cij ) {
    @out = () ; 
    push @out , YELLOW $cn [ $i ] // YELLOW $i + 1 ; # 入力の列名
    if ( $noB ) { 
      #push @out , $neoM  ?  $Cij[ $i ] { $Cj[$_] } // FAINT $o{0}  :  & cseq ( $lc, $i, $_ ) for  0 .. $#Cj  ; # Cij で集計した中身を出力する。
      push @out , $neoM  ?  $Cij[ $i ] { $Cj[$_] } // FAINT $o{0}  :  & cseq ( $lc, $i, $Cj [$_] ) for  0 .. $#Cj  ; # Cij で集計した中身を出力する。
    } else { 
      my ($m1,$m2) = do { my @t = keys %{$Cij[$i] } ; ( min(@t) , max(@t) ) } ; 
      next if ! defined $m1 ; # continue 節に 飛ぶ。
      my ($v1,$v2) = map { $neoM ? "$Cij[$i]{$_}": cseq( $lc, $i , $_ ) } $m1 , $m2  ;  # <-- - 
      push @out , $m1!=$m2  ?  "$m1\[$v1\]"  :  "$m1\[$v1\]=" , UNDERLINE BOLD($m2)."[$v2]" ; 
    }
    if ( not 0 eq ($o{v}//'') ) {  # 入力で与えられた出現値の具体例を与える。
      push @out , GREEN $E1[$i]->[1] . '' . FAINT "($E1[$i]->[2])" if exists $E1[$i]->[2] ;
      push @out , GREEN $E2[$i]->[1] . '' . FAINT "($E2[$i]->[2])" if exists $E2[$i]->[2] ;
    } 
  } continue {
    say join "\t" , @out ; 
  }
}

=for comment 
# 出力(-M); 
  push @out , do { my @t = sort keys %{ $Cij[$i]{$Cj[$_]} } ; @t > $m ? "$t[0]..$t[-1](".@t.")" : join '', @t }  for 0 .. $#Cj ;