#!/usr/bin/perl
my
${ dt_start } = [ gettimeofday ] ;
use
Term::ANSIColor
qw/:constants color/
;
$Term::ANSIColor::AUTORESET
= 1 ;
@ARGV
= ( (
grep
m/^-/ ,
@ARGV
) , (
grep
!m/^-/ ,
@ARGV
) )
if
!
grep
/^--$/ ,
@ARGV
;
getopts
'=e:q:v:1'
=> \
my
%o
;
my
$flag_v0
=
defined
$o
{v} &&
$o
{v} eq 0 ;
do
{
select
STDERR ; HELP_MESSAGE () }
if
!
@ARGV
;
& proc_split ;
my
@fq
;
my
%fq_
;
my
$N
= 0 ;
if
(
$o
{1} )
{
& pairwise_cmp ;
& secondary_info ;
exit
0 ;
}
& read_all ;
& usual_proc ;
& secondary_info ;
exit
0 ;
sub
proc_split
{
my
$pid
=
fork
;
if
(
$pid
) {
wait
;
my
$procsec
= tv_interval ${ dt_start } ;
exit
;
}
}
sub
pairwise_cmp
{
my
$dummy
= <>
if
$o
{
'='
} ;
while
( <> ) {
chomp
;
$fq
[
$N
]{
$_
} ++ ;
$fq_
{
$_
} ++ ;
if
(
eof
) {
$N
++ ;
my
$dummy
= <>
if
$o
{
'='
} && !
eof
() ;
last
} ;
}
while
( <> ) {
chomp
;
$fq
[
$N
]{
$_
} ++
if
exists
$fq_
{
$_
} ;
if
(
eof
) {
$N
++ ;
my
$dummy
= <>
if
$o
{
'='
} && !
eof
() } ;
}
say
join
"\t"
,
"*"
, (
map
{
"file$_"
} 1 ..
$N
) ;
say
join
"\t"
,
'freq'
,
map
{ sum0
values
%{
$fq
[
$_
]} } 0 ..
$N
-1 ;
say
join
"\t"
,
'card'
,
map
{
scalar
keys
%{
$fq
[
$_
]} } 0 ..
$N
-1 ;
}
sub
read_all
{
my
$dummy
= <>
if
$o
{
'='
} ;
while
( <> ) {
chomp
;
$_
=
eval
$o
{e}
if
exists
$o
{e} ;
$fq
[
$N
]{
$_
} ++ ;
$fq_
{
$_
} ++ ;
if
(
eof
) {
$N
++ ;
my
$dummy
= <>
if
$o
{
'='
} && !
eof
() } ;
}
}
sub
usual_proc
{
my
%bfq
;
my
%bfq_
;
my
%bfq_min
;
my
%bfq_max
;
for
my
$k
(
keys
%fq_
) {
my
@which
=
grep
{
exists
$fq
[
$_
]{
$k
} } 0 ..
$N
-1 ;
my
$B
= sum0
map
{ 1 <<
$_
}
@which
;
$bfq_
{
$B
} ++ ;
$bfq
{
$B
} [
$_
] +=
$fq
[
$_
] {
$k
}
for
@which
;
next
if
$flag_v0
;
$bfq_min
{
$B
} //=
$k
;
$bfq_min
{
$B
} =
$k
if
$bfq_min
{
$B
} gt
$k
;
$bfq_max
{
$B
} //=
$k
;
$bfq_max
{
$B
} =
$k
if
$bfq_max
{
$B
} lt
$k
;
}
say
join
"\t"
,
"cardi."
, (
map
{
"file$_"
} 1 ..
$N
) ,
$flag_v0
? () : (
'strmin'
,
'strmax'
) ;
for
my
$B
(
sort
{
$bfq_min
{
$a
} cmp
$bfq_min
{
$b
} }
keys
%bfq_
) {
my
@out
=
map
{
$_
// 0 }
map
{
$bfq
{
$B
} [
$_
] } 0 ..
$N
-1 ;
eval
{
$bfq_min
{
$B
} =
qq["$bfq_min{$B}"]
;
$bfq_max
{
$B
} =
qq["$bfq_max{$B}"]
}
unless
exists
$o
{
q} and $o{q}
eq 0 ;
push
@out
, (
$bfq_min
{
$B
} ne
$bfq_max
{
$B
})? (
$bfq_min
{
$B
} ,
$bfq_max
{
$B
}) :
$bfq_min
{
$B
} ,
""
if
!
$flag_v0
;
say
join
"\t"
,
qq[$bfq_{$B}.]
,
@out
;
}
}
sub
secondary_info
{
my
$procsec
= tv_interval ${ dt_start } ;
* d3 =
sub
{
$_
[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ;
print
STDERR BOLD ITALIC DARK CYAN & d3 ( $. ) .
" lines processed. "
;
print
STDERR BOLD ITALIC DARK CYAN
"($Script ; "
.
$procsec
.
" sec.)\n"
;
}
sub
VERSION_MESSAGE {}
sub
HELP_MESSAGE {
$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 ;
}