view release on metacpan or  search on metacpan

venn  view on Meta::CPAN

getopts '=R:e:q:v:12:' => \my %o ; # <-- -  -q\" と-20を実装せよ
my $optR0 = defined $o{R} && $o{R} eq 0 ; 
my $optv0 = defined $o{v} && $o{v} eq 0 ; 
my $opt20 = defined $o{2} && $o{2} eq 0 ; 
my $optq0 = defined $o{q} && $o{q} eq 0 ;
$o{q} //= "'" ; # $optq0の定義の後に来ないといけない。
do { select STDERR ; HELP_MESSAGE () } if ! @ARGV ; # 引数が無いときはヘルプを出して終了。

# & proc_split ; # 何かの意図でforkしていたが、その必要は無いので消した。

my @fqE ; # E = Each ; 各ファイルにおいて、各行の文字列の頻度表を格納する ; fq は frequenchy の略 (#) 
my %fqA ; # A = All ; 全ファイルにおいて、各行の文字列の頻度表を格納する
my $N = 0 ; # 対象ファイルの個数を数える。

if ( $o{1} ) # オプション -1 : 1番目のファイルの各行を、残り(n-1)個と単にそれぞれ比較。
{
  & pairwise_cmp ; 
  & secondary_info unless $opt20 ;
  exit 0 ;
}

& read_all ;
& usual_proc ; 
& secondary_info unless $opt20 ; 
exit 0 ; 

## forkを使った処理をしている。主要な動作を別のプロセスから監視するため。
sub proc_split 
{
  my $pid = fork ; 
  # die "Cannot fork: $!" unless defined $pid ; ### !! fork 失敗の場合は次のif文は実行しない
  if ( $pid ) { 
    wait ; 
    my $procsec = tv_interval ${ dt_start } ; 
    #print STDERR BOLD ITALIC DARK CYAN "($Script + memory release --> " . $procsec . " sec.)\n" ;
    exit ;
  }
}

## オプション-1の時の処理
# 2021年6月8日に、このサブルーチン以外はリファクタした(つまりここから続く関数1個だけリファクタしてない。)
sub pairwise_cmp 
{
  # READING 
  my $dummy = <> if $o{'='} ;
  while ( <> ) { 
      chomp ; 
      s/\r$// unless $optR0 ;
      $fqE[$N]{$_} ++ ; 
      $fqA{$_} ++ ;
      if ( eof ) { $N++ ; my $dummy = <> if $o{'='} && ! eof() ; last } ; 
  }
  while ( <> ) { 
      chomp ; 
      $fqE[$N]{$_} ++ if exists $fqA{$_} ;
      #$fqA{$_} ++ ;
      if ( eof ) { $N++ ; my $dummy = <> if $o{'='} && ! eof() } ; 
  }

  # Printing
  say join "\t", "*", (map {"file$_"} 1 .. $N) ; # , $optv0 ? () :  ('strmin','strmax') ; 
  #my @out ; 
  #push @out , scalar keys %fqA ; 
  say join "\t" , 'freq' , map { sum0 values %{$fqE[$_]} }  0 .. $N-1 ;
  say join "\t" , 'card' , map { scalar keys %{$fqE[$_]} }  0 .. $N-1 ;
  #for my $B ( sort { $a <=> $b } keys %BfqA ) { 
  #    my @out = map { $_ // 0 } map { $BfqE { $B } [$_] } 0 .. $N -1   ;
  #    push @out , $BfqA1{$B} , $BfqA2{$B}  if ! $optv0 ;
  #say join "\t" , $BfqA{$B} , @out ; #, 
  #}
}

## それぞれのファイルを全部読む
sub read_all 
{
  my $dummy = <> if $o{'='} ;
  while ( <> ) { 
      chomp ; 
      s/\r$// unless $optR0 ;
      $_ = eval $o{e} if exists $o{e} ;
      $fqE[$N]{$_} ++ ; 
      $fqA{$_} ++ ;
      if ( eof ) { $N++ ; my $dummy = <> if $o{'='} && ! eof() } ; #<-- eofの括弧ある無しを使い分けた
  }
}

## 普通に数える。
sub usual_proc 
{
  # Summing 
  my %BfqE ; # 添え字は、どの集合に含まれるかを2進数で考えた数 2番目の添え字はファイル番号 0始まり
  my %BfqA ; # BはBitPatternまたはBinaryの略。
  my %BfqA1 ; # 最小値 $BfqA1{ $B } でそのビットパターンで最小の文字列を格納
  my %BfqA2 ; # 最大値 
  for my $word ( keys %fqA ) {  # word とはいえ通常は元の1行分の文字列。
    my @which = grep { exists $fqE[$_]{$word} } 0 .. $N-1 ; # その文字列をどのファイルが持つか
    my $B = sum0 map { 1 << $_ } @which ; # ビットパターン ## <-- - 良い演算子は無いだろうか?? 
    $BfqA { $B } ++ ; # 異なる個数を数える
    $BfqE { $B } [ $_ ] += $fqE [ $_ ] { $word } for @which ; # 1行前と異なり、のべ数を計数。
    next if $optv0 ;
    $BfqA1{$B} //= $word ; $BfqA1{$B} = $word if $BfqA1{$B} gt $word ; # 文字列最小値の格納
    $BfqA2{$B} //= $word ; $BfqA2{$B} = $word if $BfqA2{$B} lt $word ; # 文字列最大値の格納
  }

  # Printing
  say join "\t", "cardi.", (map {"file$_"} 1 .. $N) , $optv0 ? () :  ('strmin','strmax') ; 
  my @B = keys %BfqA ; 
  @B = sort { $BfqA1{$a} cmp $BfqA1{$b} } @B unless $optv0 ;
  for my $B ( @B ) { 
    my @out = map { $_ // 0 } map { $BfqE { $B } [$_] } 0 .. $N -1   ;
    do { $_ = "$o{q}$_$o{q}" for $BfqA1{$B} , $BfqA2{$B} } unless $optv0 || $optq0 ; # 値があれば囲む
    $BfqA2{$B} = '' if $BfqA1{$B} eq $BfqA2{$B} ; # 値一定なら空文字列変換(除去はしない。TSVは列数一定とすべし)
    push @out , ($BfqA1{$B} , $BfqA2{$B}) if ! $optv0 ;
    say join "\t" , qq[$BfqA{$B}.] , @out ; # 最初の列はピリオドを付加する(数であること保ちつつ他と視認識別容易に) 
  }
}

sub secondary_info 
{ 
  my $procsec = tv_interval ${ dt_start } ; #time - $time0 ; # このプログラムの処理にかかった秒数。比較する2個の時刻は秒単位なので、±1秒未満の誤差は発生する。
  * d3 = sub { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ;
  print STDERR BOLD ITALIC DARK CYAN & d3 ( $. ) . " lines processed in total. $N files. " ; 
  print STDERR BOLD ITALIC DARK CYAN "($Script ; " . $procsec . " sec.)\n" ;
}

# ヘルプの扱い
sub VERSION_MESSAGE {}
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 ;
    exit 0 ;
}
=encoding utf8
=head1
    
    $0 ファイル名の並び

    入力: 改行区切りで値の書き込まれた1個またはそれ以上のファイル

    出力:
      ファイルが n 個入力として与えられた場合、それらn個のファイルに
      出現した各行の値について、それがどのファイルに出現したかに応じて、最大
      2 ** n -1 通りに分類し、各分類(出力の各行(縦方向)に相当)において
      異なる値が何通り出現したか(横方向の第1列目)、それらの値がi番目の
      ファイルに何回出現したか(横方向の第i+1列目)の数を出力する。

    オプション: 
       -= : 入力の各ファイルにおいて、1行目を読み飛ばす。
       -1 : 1番目のファイルの各行を、残り(n-1)個と単にそれぞれ比較。
       -e perl_cmd_string ; 各行をchompした後の$_について、どう加工するか指定。-e 'substr $_,0,4' など。
       -q 0 : 値をクオーテーションで囲まない。
       -q STR; 0以外の値が指定されたら、その文字で囲む。"'" や'"'または必要に応じエスケープして指定せよ。
       -v 0 : 出力の各行において、右側の2列に、各分類の文字列としての最小値と最大値は出力しない。
       -R 0 ; 行末の\rを除去しない(Windows形式の改行に通常時は対処するが、-R0によりそれを解除。)

    利用例(実験例) : 
       cat somefile | venn 
           # somefile の行数と、異なる行の値の個数が分かる。
       venn <(seq 1 3)  <(seq 3 5)  <(seq 5 18) 
           # <( .. ) はプロセス置換なので、Unix-like のシェルでないと動かない可能性はある。
       venn -v0 <(saikoro) <(saikoro) <(saikoro)
           # saikoro はこの$0を作った著者がこの$0と共に提供される別のプログラム。

    開発メモ: 
      * 入力したファイル名を出力するようにしたい。(現状file1, file2..のような表示のみ)
      * 共通して計数対象としない値を -#で指定可能としたい。
      * 文字列の min と max 以外 *も* 出力できるようにしたい。
      * -1 指定時の実装は十分ではない。