view release on metacpan or  search on metacpan

digitdemog  view on Meta::CPAN

    next if $freq{$_} ++ && $o{1} ; # && の前後の順序に注意
    my $len = length $_ ; 
    $Lfrq{$len} ++ ;
    $M{$len}[0] = $_ if ! defined $M{$len}[0] || $M{$len}[0] gt $_ ; 
    $M{$len}[1] = $_ if ! defined $M{$len}[1] || $M{$len}[1] lt $_ ;     
    next unless $oL4 ; 
    $M{$len}[2] = $_ if ! defined $M{$len}[2] ; 
    $M{$len}[3] = $_ ;
  }
  print join ( "\t", map {UNDERLINE $_} qw[length freq minstr maxstr] , $oL4 ? qw[first_str last_str ]:() ) , "\n" ;
  for ( sort { $a <=> $b } keys %M ) {  # 数値 (文字列の長さを表す)でソート 
    my @str = @{ $M{$_} } ;
    my @prt = $optq0 ? @str : map { defined $_ ? qq['$_'] : undef } @str ;
    $prt[1] = DARK '<-- same' if $str[1] eq $str[0] ; 
    $prt[3] = DARK '<-- same' if $oL4 and defined $str[3] and $str[3] eq $str[2] ; #|| $str[3] eq $str[1]; 
    for my $p ($oL4? 0..3 : 0..1 )  { 
      $prt[$p] = $prt[$p] . DARK "(" . $freq{ $str[$p] } . ")" if $freq{ $str[$p] } != $Lfrq{$_} ;
    }
    print join ( "\t" , $_ , $Lfrq{$_}, @prt ) , "\n" ;
  }
}

sub d3 ($) { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ; # 数を3桁区切りに変換する。

sub majority2 ( @ ) { 
  # いろんな値を配列で受け取り、頻度2以上のものについて、多い順番に返す。# 同一の入力でも、同じ頻度ならどっちが優先されるかは不明。
  my %h ; # ヒストグラム
  ++ $h { $_ } for ( @_ ) ;
  my $m = max values %h ; 
  $h{$_} == 1 and delete $h{$_} for keys %h ;  #++ $m if $m == 1;  # 頻度の最大値が1なら、次の処理で空列を返すようにする。
  my %h2 ; 
  my @out ; 
  for ( keys %h ) { push @{ $h2{ $h{$_} } } , $_ } 
  for ( sort { $b <=> $a } keys %h2 ) { push @out , @{ $h2{$_} } } 
  return @out  ;#first { $h {$_} == $m } keys %h
} # リストから最も成分の多いものをさらにひとつだけ選ぶ.

sub backslash ($$) { # 制御文字を一部エスケープシーケンスに変化させる。 arg2 は シングルクォーテーションを何に変化させるか。
  do{ my $c = eval qq["$_"] ; $_[0] =~ s/$c/$_/g and $_[0] =~ s/'/$_[1]/g } for qw[\a \n \r \f \t \e] ; 
  return $_[0] ; # 
}

sub stock ($$$$) { # arg2が参照する配列で arg1 個蓄えるが、arg3の値を後ろに追加。さらに、arg4の0/1に応じて、pop/shift(後ろ出し/前出し)する。
  my @ary = uniq @{ ${$_[1]} }, $_[2] ; 
  @{ ${$_[1]} } = splice @ary, ( $_[3] ? max 0,scalar @ary - $_[0] : 0 ) , $_[0] ;
} ;  # 各行の例をストックするための関数

##
## 普通のモードのmain関数
##

sub main_normal ( ) { 

  my %freq ; # 同じ行が来たかどうかの判定に使う。数が集計される。
  my %S1 ; # $S1{$v}{$pos} のように使う。 出現回数の集計表 ; # ここの $v は 文字と言うよりパターンを示す。'a'とか [1-3]とか。ここでは「文字」と呼ぶ。
  my %S2 ; # $S2{$v}{$pos} = "行番号+行番号+...行番号+" (Lとする); $vが出現した桁$posに対応する行番号を蓄える。
  my %S3 ; # @ { $S3{ F } } によって、分割表で頻度 F 回現れた 行番号集合の値 L (%S2の持つ値)を参照できるようにする。
  my %mark ; # $mark{ L } がピリオドをピリオド付ける。 ( -. で使う。)
  my %Gs  ; # @{ $G { $v } { $pos } [ 0 or 1 ] } で 行の具体例を格納。 ( -g で使う。)
  my $maxlen = 0 ; # 文字列の最大長
  my $eol = "EOL" . int rand 8 ; # 各行の終わりを示す。## saikoro -g10,3 でいろいろ試した。

  @e = map { decode_utf8 $_ } @e unless $optu0  ;
  unshift @e , "$eol\$" ;  # 正規表現パターン群に $eol を 最初に 追加。 # 「行末」は頻度が多いので最初に持ってきた。
  #push @e , "$eol\$" ;  # 正規表現パターン群に $eol を 最後に 追加。# ここは、unshift でも push でも良い。
  my @eqr ; # 「e をqrされた 」により名付けた。
  my @exu ; # 「eにおいて、エスケープ(escape)してユニコード(unicode)で表した部分がある」により名付けた
  for ( 0 .. $#e ) { 
    my $eout = $e[$_] =~ s/#.*$//r ; # 正規表現で、コメント#の部分は除去する。
    my @F  = split /([[:^ascii:]])/o , $eout , 0 ; # パターンで切った最後は空文字列なら切り落とすための0
    grep { $_ =  (sprintf '\x{%02X}', ord $_ ) if m/[[:^ascii:]]/ } @F ;
    my $p = join '' , @F ;
    $eqr [ $_ ] = qr/$p/ ; # あらかじめ正規表現として先にコンパイルすることで高速化。
    push @exu , $p ;
  }
  
  # split で割るためのパターンの設定。
  my $piecePattern = @e ? do{ my$t=join'|',@exu,'.','\n';qr/$t/o} : qr//o ; # @exuに1文字(.)と改行文字を追加した。

  $header = <> if $o{'='} ; 
  while ( <> ) { 
    chomp if 0 eq ($o{n}//'') ; #-n0 で改行文字を除去。
    next if $freq{$_} ++ && $o{1} ; # && の前後の順序に注意
    s/\r$// unless $optw0 ;    
    $_ = decode_utf8 $_ unless $optu0 ;
     # ▽ パターンに文字列を分解。
    my @vvec = m/$piecePattern/go ; 
    push @vvec , $eol ; # 各行をバラバラにした後に、$eolを最後に追加。
    splice @vvec , $width, if defined $width ; 
    $maxlen = @vvec if $maxlen < @vvec ; # 最大長の保管
    for my $pos ( 0 .. $#vvec ) {
      my $char = $vvec [ $pos ] ; # 実際の文字(列)。  (パターンにはまだ分類していない。)
      my $v  ; # どのパターンまたは文字として認識するか。(分類されたパターンなのである。)
       # ▽ どのパターンにマッチしたかを$vに格納する。次の2行のコードで。
      $char =~ $eqr[$_] and do { $v = $e[$_] ; last } for 0 .. $#e ; # 指定したパターンの数が多いと遅くなるであろう。頻度の高いパターンを先に置くと早くなる。
      $v //= "'$vvec[$pos]'" ; # 前行の処理で当てはまらない場合。クォーテーションを付加するようにした。
      $S1 { $v } { $pos } ++ ; 
      $S2 { $v } { $pos } .= "$.+" if $o{'.'} ; # <-- $S2{..}で、その「文字」がその桁で現れた、「行番号集合」L が結果的に生成される。
      do { for my $way (0,1) { & stock ( $o{g} , \$Gs{$v}{$pos}[$way] , $_ , $way ) } } if $o{g}  ; # 改行文字はここでは除去せず
    }
  } # ← 入力読み取り処理の終わり
  if ( $o{'.'} ) {  ## 複雑な処理である↓ # $S1{ .. }　で その「文字」が「各桁」で、何回 (b回) 現れたのか。... # この  ; 「b回」現れた L を S3に保管。
    for my $v ( keys %S1 ){ 
      push @{  $S3 { $S1{$v}{$_} }  }, $S2{$v}{$_} for keys %{ $S1{$v} } ; 
    } 
    for( keys %S3 ){ # 各「文字」が各桁で何回現れたか(頻度) の 数 それぞれに対して
      my @pcand  = majority2 @{ $S3{$_} }  ; # 行番号集合L を考えて、そういうLで最も頻度の高いものを取り出す。
      grep { $mark { $pcand [$_] } = '.' . ( '0' x $_ ) } 0 .. min $#pcand , $o{'.'} - 1 if @pcand ; 
    }  
  }
  # 出力

  my $ex = "example${sep}..${sep}example" ; # 具体例を表す列の表頭をどうするか?
  say join "\t" , map { UNDERLINE YELLOW $_ } (0+$o{o}) .. ($maxlen+$o{o}-1) , 'char' , 'code' , 'freq' , $o{g} ? $ex :() ; # 行頭の出力
  my %vcate ; $vcate{$_} = 2 for @e ; # omit する
  my @vset ; # 表示する値の配列。順番は、 (1). 引数に渡された正規表現いくつか (2). 非cntrl文字 (3). cntrl文字(4). 各行の終わり
  push @vset , @e[ 1 .. $#e ] ; # (1).
  push @vset , sort {length $a <=> length $b or $a cmp $b } grep { ! $vcate { $_ } and ! /[[:cntrl:]]/ } keys %S1 ; # (2)
  push @vset , sort {length $a <=> length $b or $a cmp $b } grep { ! $vcate { $_ } and /[[:cntrl:]]/ } keys %S1 ; #(3)
  push @vset , $e[ 0 ] ;
  my $take = sub ($$) { splice @{$_[1]} , 0, $_[0] } ; # 配列参照arg2からその配列の先頭arg1個取ってくる。
  my $take2 = sub ($$$) { uniq $take->($_[0],$_[1]) , $take->($_[0],$_[2]) } ;# 配列参照2個(arg2,arg3)から、それぞれarg1個取って、uniq する。
  my $ucd = sub ($){ ( sprintf 'U+%06X', ord $_[0] ) =~ s/(00)+((..)+$)/$2/r } ; # Unicode の符号位置を返す。2桁以上の偶数桁になるように。
  for my $v ( @vset ){ # <-- ソート順には注意したい
    my @out = map { $S1{$v}{$_} // 0 } 0 .. ( $maxlen - 1 ) ; 
    my @pvec = grep { $out[$_] } $o{g}=~/\.$/o ? reverse 0..$#out : 0..$#out ;  # 何桁目を見るか、そして、優先的にどこから見るか。
    my @pv = map { [ grep { $out[$_] } @{$_} ] } [0..$#out] , [reverse 0..$#out] ;  # 何桁目を見るか、そして、優先的にどこから見るか。
    my @example = $take2 -> ( $o{g} , map { my $way = $_ ; [ map{ @{$Gs{$v}{$_}[ $way ]} } @{$pv[$way]} ] } 0,1 ) if $o{g} ;
    @example = map{ backslash $_ , q['] } @example unless 0 eq ($o{b}//'') ; # -b0の指定が無ければ、改行などの文字をエスケープする。
    my $subtotal = sum0 @out ;  # その文字の出現回数 -- @out をさらに加工する前にここで取得。
    next until y_filter ( $subtotal )  ; 
    do { $out[$_] .= $mark{ $S2{$v}{$_} // '' } // '' if $out[$_] } for 0 .. $#out ; # 数字の後ろにピリオド付加
    @out = map { $_ eq 0 ? $o{0} : $_ } @out if defined $o{0} ;  # 頻度値がゼロの場合の置換
    my $code = do { my $c = substr $v,1,1 ; $v eq "$eol\$" ? 'end' : $vcate{$v} ? '---' : $ucd -> ($c) } ; # 文字コード取得。$vの加工前にここで処理。
    $v = $o{'$'} if $v eq "$eol\$" ; 
    $v = backslash $v , q["] ; 
    push @out , (YELLOW BOLD $v) , $code , (YELLOW $subtotal) ; 
    push @out, join $sep , @example ;
    say join "\t" , @out ;
  }
}

## ヘルプの扱い
sub VERSION_MESSAGE { } # --version でこの関数が使われる。
sub HELP_MESSAGE {
    use FindBin qw[ $Script ] ; 
    $ARGV[1] //= '' ;
    open my $FH , '<' , $0 ;
    while(<$FH>){
        s/\$0/$Script/g ;
        print $_ if s/^=head1// .. s/^=cut// and $ARGV[1] =~ /^o(p(t(i(o(ns?)?)?)?)?)?$/i ? m/^\s+\-/ : 1;
    }
    close $FH ;
    $o{v} = 0 ;
    exit 0 ;
}
=encoding utf8 

=begin JapaneseManual 

=head1

digitdist 

    入力の各行に対して，先頭から(0始まり) n 桁目にどんな文字が現れたかをクロス集計する。
    -L が指定されると、文字列長ごとの、文字列の最小値と最大値が出力される。

 想定されている使い方 : 
    1. 何も分からない文字列集合について、具体的な値の様子を確かめる最初の1歩である。
    2. ルールを発見する。極めて少数の例から、データの値の破損やテスト値を見つける。
    3. 特異な値について、更に深く調べる対象とする。

オプション : 
   --help  : このオンラインヘルプを表示する。

  入力の扱い方 : 以下で N は数値を示す。str は文字列を示す。
   -=     : 先頭行(1行目)を読み飛ばす
   -1     : データで全く同じ行が2回以上来たら、読み飛ばす。(-L2と-L4と-.の指定時は適用されない。)
   -n 0   : 改行文字を除去する(各行を読み取って、通常なら行末の改行文字の様子も出力する)。
   -u 0   : バイナリで処理する(通常は UTF-8で処理をする)
   -w 0   ; 通常は、Windows形式の改行文字が来たらUNIX形式の改行文字に変換しているが、その動作を解除する。

  動作モードの変更 : 
   -L2    ; 文字列長毎に、文字列の最小値と最大値を取り出す。両者が一致する場合は、後者を空文字列にする。
   -L4    ; 文字列長毎に、文字列の最小値と最大値の他に、最初に現れたもの、最後に現れたものも表示する。

  実質的な処理に与えるオプション : 
   -. 0    : 通常出力表の値で "同じ数." と表示された値は、全く共通する行に由来することを示すが、その出力の仕方を抑制。
   -. N    : 出力表の異なる頻度の値ごとに、どれが全く共通する行に由来するのかN個まで表示。未指定なら1。頻度の後にピリオドが付き、さらに0が最大N-1個付く。
   -e str : このオプションは何回も指定できる。strは正規表現であり、最初のパターンにマッチするものを計数対象にする。
   --width N : 出力表の頻度の値の部分が最大N列に制限される。この指定は、「例」には影響しない。

  出力へ影響するオプション : 
   -0 str : 出力のゼロを別の文字列strに置換する。
   -2 0   : 標準エラー出力に出力する二次情報を抑制する。