#!/usr/bin/perl
# apclass_dgenetab3c.inc.pl
# altparclassify2b.pl: dgenetab3Btall($selfbtall,$genetab)

=item     dgenetableFromBtall($selfbtall,$genetab);

  ### identityclass infile is alntab: 
  ###  Qid Qclen Qtlen Tid Tclen Ttlen Align Ident Bits
  ###    1     2     3   4     5     6     7     8    9
  ### sort ^Qclen, ^Align, vQtlen, vTtlen, =Qid, =Tid : now
  $ALNSORTORD='-k2,2nr -k7,7nr -k3,3n -k6,6n -k1,1 -k4,4';  #add vQtlen/3 before vTt/6 IDs to order ties

  ### this infile is btall: 
  ###  Qid Tid  Bits Ident Align Qclen Tclen = ($td,$rd,$bs,$idn,$al,$tw,$rw)
  ###    1   2    3     4     5     6     7  
  ### sort ^Qclen, ^Align, ^Ident, vTclen, =Qid, =Tid : now
  my $BTALLSORTORDold='-k6,6nr -k5,5nr -k4,4nr -k7,7n -k1,1 -k2,2';   

  ### dgenetab3Btall  btall sort: 
  ###  Qid Tid  Bits Ident Align Qclen Tclen = ($td,$rd,$bs,$idn,$al,$tw,$rw)
  ###    1   2    3     4     5     6     7  
  ### sort ^Align, ^Ident,  ^Qclen, vTclen, =Qid, =Tid : ??? link largest aligns together 1st
  my $BTALLSORTORDnu='-k5,5nr -k4,4nr -k6,6nr -k7,7n -k1,1 -k2,2';   

  ## or? put all qid together, can dump group at next Qid
  ### sort ^Qclen, =Qid, ^Align, ^Ident, vTclen, =Tid 
  my $BTALLSORTORD_byqid='-k6,6nr -k1,1 -k5,5nr -k4,4nr -k7,7n -k2,2';   
  

  dgene group method as per  genes/altparsnpdist.pl,
    a. collect pairs stats apvals{ id } { jd} = tot_pident, tot_aln,
       a0. per id, Qtlen, Ttlen, 
    a1. add other apsnpdist stats: idmax, snpvar, ..
    b.  call alt/par from pair stats
    c.  @idungr= sort ids as above? hi align, hi pident, then q/t size, ..

    d.  
     while (@idungr > 0) {
          $atid= shift @idungr; next if($sgroup{$atid});
          @jid=  grep{ not $sgroup{$_} } keys %{$apvals{$atid}};
          @jid= sort _pairsort($atid,$a,$b)  @jid
          @sgr=($atid);
          for my $jd (@jid) {
            ($taln,$pident,$idmax,$svar,...)= @pvals= @{$apvals{$atid}{$jd}{@kvals}}
            $isap= apclass($taln,$pident,$idmax,$svar,...) 
            if($isap <= cALT) { push @sgr,$jd; }  
          }

        my $sgid= "p" . ++$SGID;  push @sgid,$sgid; 
        my %sgr= map{ $_,1 } @sgr;
        my $ti=0; for my $xid (@sgr) { ++$ti; $sgroup{$xid}= $sgid . "t$ti"; } # add altnum, using new sort order?
        @idungr= grep{ not $sgr{$_} } @idungr;
      }
      
      my(%egid); 
      for my $id (@ids) { #(@$ida) 
       for my $jd (@ids) { # (@$jda)
        next if($id eq $jd or $id =~ /^ID/); 
        my $idp= $sgroup{$id}||"na";  
        my $jdp= $sgroup{$jd}||"na"; 
        my $ispar= $apvals->{$id}{$jd}{ispar}; #?? is this bad
        my $palt=($ispar>=cPAR)?"par_e":($ispar<=cALT)?"alt_e":"unk_e";
        $egid{$id}{$jd}= "$egid$idp,$palt,$jdp";  
       }
      }
      return(\%egid); #?? need pair hash?
    
=cut

use strict; 

our ($DEBUG, $ALTAL, $ALTPI, $PARAL, $PARPI, $IDPRE);
our ($nsizes,$aasizeh,$trsizeh,$cdspanh,$aaqualh);
our ($sortedbtall);
our (%apval); 

use constant { cALT => -1, cPAR => 1, cUNK => 0, cMISS => 0, };
use constant { SNP_LOWN => 5, SNP_HISKEW => 30, NPARDUP => 1.5, }; # snpdist_pairs
use constant { SNP_IDMAX_ISPAR => 35, SNP_IDMAX_ISALT => 85, SNP_IDMAX_NPARCUT => 55, }; # NOT const, 
my($IDX_PAR,$IDX_ALT,$IDX2CN)=(SNP_IDMAX_ISPAR,SNP_IDMAX_ISALT,SNP_IDMAX_NPARCUT); # 55 best? idx2cn 85,35 == max,min, weed,hum differ on best

my $DGHDR=0;  

# my($ispar_tc,$npar_tc,$idmax_tc)= class_idmax($idmax_sd, $cni, $cnj); 
#  cni,j are genexcopy nums, not here yet
sub apclass_idmax_cn {  
  my($idmax,$cna,$cnb)=@_; 
  my($IDX_ALT1C,$IDX_PAR2C)= ($idmax + 0.05, $idmax - 0.05); # test..

  my $cn=$cna; if($cnb>0){ $cn=($idmax < $IDX2CN)? _max($cna,$cnb) : _min($cna,$cnb); }  
  my ($cidp,$idxc)= ($idmax <= 0)? (cUNK,$idmax)
    : ($idmax>=$IDX_ALT)?(cALT,$idmax) 
    : ($idmax<=$IDX_PAR)?(cPAR,$idmax)  
    : ($cn >= NPARDUP)?(cPAR,$IDX_PAR2C)  
    : (cALT,$IDX_ALT1C); 
  return (wantarray)? ($cidp,$cn,$idxc) : $cidp; 
}

sub apclass_aligntotident {  
  my($aligntot,$pident)=@_; 
  my $apclass = cUNK;
  # my $pi= ($al<1) ? 0 : int(0.5 + 1000 * $idn/$al)/10;
  if($aligntot >= $ALTAL and $pident >= $ALTPI) {
    $apclass= cALT;
  } elsif($aligntot >= $PARAL and $pident >= $PARPI) { # $ALTAL >> PARAL ?
    $apclass= cPAR;  
  } else {
    $apclass= cUNK; # rd,td not same locus
  }
  return $apclass; 
}

sub apclass {  # add sense/orinet param? or leave out
  my($alntot,$pident,$idmax,$svar)=@_;
  my $cap= apclass_aligntotident($alntot,$pident); 
  if($idmax>0){ $cap= apclass_idmax_cn($idmax); }
  return $cap;
}

sub put_apgroup {
  my($outh, $gid, $apclass,$didtr)=@_;

  my $idpre= $IDPRE || "dg"; #? bug
  my $sgid= $idpre . sprintf "%06d",$gid;
  my @apd= keys %{ $apclass->{$gid} };
  @apd= sort{ $apclass->{$gid}{$a}->[1] <=> $apclass->{$gid}{$b}->[1] or $a cmp $b} @apd; # sort by ti
  my $nalt= @apd; my $ntrs=0; # $ntrs += $nalt;

  for my $rd (@apd) {
    my($cla,$ti,$rlen)= @{ $apclass->{$gid}{$rd} };
    next if($didtr->{$rd}); # ?? paralog in two+ gid ?
    my $trid= $sgid."t$ti";    
    my($aaqual,$trlen)=(0,0);
    if($nsizes and ref($aaqualh)) {
      $aaqual=$aaqualh->{$rd}||0; $trlen= $trsizeh->{$rd}||0;
    } 
    unless($aaqual and $trlen) {
      $aaqual="$rlen,1%,ac"; $trlen=$rlen; # rlen from btall should be ok
    }

    my ($laltids, $lparids, $lchrlocs)= ("noalt","nopar","noloc");
    my @altd= grep{ $apclass->{$gid}{$_}->[0] =~ m/^(alt|main)/ } @apd; # eq "alt" 
    my @pard= grep{ $apclass->{$gid}{$_}->[0] =~ m/^par/ } @apd; # par,parc
    ## Change: dont need these long alt/par id lists per trid. replace w/ Notes/qual statement, per pubids
    ## .. include some kind of trid x dgroup align val, nalt/npar, 
    my($notes,$na)=("");
    # $na=@altd; if($na>0){ @altd=splice(@altd,0,9) if($na>9); $laltids= "nalt:$na," . join",",@altd; }
    # $na=@pard; if($na>0){ @pard=splice(@pard,0,9) if($na>9); $lparids= "npar:$na," . join",",@pard; }
    if($na=@altd){ $laltids= "nalt:$na" ; }
    if($na=@pard){ $lparids= "npar:$na" ; }
    $notes .= "$laltids,$lparids,";
 
    use constant NOTE_APVAL => 1;
    if(NOTE_APVAL and @altd > 1) {
      my $nalt= @altd;
      my($salnt,$spid,$sidmax,$nrev)=(0) x 9;
      for my $td (@altd) {
        my($alnt,$pid,$asense,$idmax)= map{ $apval{$rd}{$td}{$_}||0 } qw(alntot pident asense idmax); # idmax svar others?
        $salnt += $alnt; $spid += $pid; $sidmax += $idmax;  $nrev++ if($asense<0);
      }
      my $paln= sprintf"%.0f%%", 100*$salnt/$trlen/$nalt; # ave pct align
      my $pidn= sprintf"%.0f%%", $spid/$nalt; # ave pct ident
      my $idmax= sprintf"%.0f", $sidmax/$nalt; # ave pct ident
      $notes .= "aln:$paln,idn:$pidn,anti:$nrev,"; $notes.="idmax:$idmax," if($sidmax>0);
    }
       
    #UPD2020: add TRlen col : BAD trlen here, is aalen*3
    #o print $outh join("\t",qw(dRnaID OrigID  dGeneID AltI  APClass AAqual TRlen lAltIDs lParIDs lChrLocs))."\n" 
    #o print $outh join("\t",$trid,$rd,$sgid,$ti,$cla,$aaqual,$trlen,$laltids,$lparids,$lchrlocs)."\n";

    print $outh join("\t",qw(dRnaID OrigID  dGeneID AltI  APClass AAqual TRlen Notes))."\n" 
      unless($DGHDR++);
    print $outh join("\t",$trid,$rd,$sgid,$ti,$cla,$aaqual,$trlen,$notes)."\n";
    $ntrs++; $didtr->{$rd}++;
  }
  return($ntrs);
}


sub dgenetab3Btall {
  my($selfbtall,$otab)= @_;

  ## sort, see asmdupfilter identityclass; 
  # my($td,$rd,$bs,$idn,$al,$tw,$rw)=@v=split; # btall cols
  #old: my $BTALLSORTORD='-k6,6nr -k5,5nr -k4,4nr -k7,7n -k1,1 -k2,2';   
  #nu ? my $BTALLSORTORD='-k5,5nr -k4,4nr -k6,6nr -k7,7n -k1,1 -k2,2';   
  ## or put all qid together, can dump group at next Qid
  ## sort ^Qclen, =Qid, ^Align, ^Ident, vTclen, =Tid 
  my $BTALLSORTORD='-k6,6nr -k1,1 -k5,5nr -k4,4nr -k7,7n -k2,2';   

  my $SGID=0;
  #g my $DGHDR=0;  
  
  warn "#dgenetab3Btall($selfbtall,$otab)\n" if $DEBUG;
  my($ok,$hin)= (0,undef);  
  my $isgz= ($selfbtall =~ m/.gz$/)?1:0;
  if($sortedbtall) {
    $ok= ($isgz) ? open($hin,"gunzip -c $selfbtall |") : open($hin,$selfbtall); 
    # ($ok,$hin)= openRead($selfbtall); # not here
  } else { 
    my $tmpdir= './';
    $ok= ($isgz) ? open($hin,"gunzip -c $selfbtall | sort -T $tmpdir $BTALLSORTORD |")  
          : open($hin,"sort -T $tmpdir $BTALLSORTORD $selfbtall |"); 
  }
  return (0) unless($ok);

  my(%tsize,@ids); # %apval, : above global now
  while(<$hin>) { 
    next if(/^\W/); chomp;  my @v= split"\t"; 
    my($rd,$td,$bs,$idn,$al,$rw,$tw)= @v; # btall cols
    my $tor=0;
    if(@v > 8) {
      my($rspan,$tspan)=@v[7,8]; 
      if($$tspan=~m/:\-/) { $tor= -1; } if($$tspan=~m/:\+/) { $tor= 1; }
    }
    
    unless($tsize{$rd}){ $tsize{$rd}=$rw; push @ids, $rd; }
    if($rd eq $td) {  
      #? $apval{$rd}{"self"}{alntot}=$al; $apval{$rd}{"self"}{pident}=100;  #?? keep self?
      next; } 
    elsif( $apval{$td}{$rd}{alntot} ) {
      # symmetric .. dont fill in 1/2
      next;
    }
    # my $pi= ($al<1) ? 0 : int(0.5 + 1000 * $idn/$al)/10;
    my $pi= ($al<1) ? 0 : 100 * $idn/$al;
    $apval{$rd}{$td}{'alntot'}=$al;
    $apval{$rd}{$td}{'pident'}=$pi;
    if($tor < 0) { $apval{$rd}{$td}{'asense'}=$tor; }

    my $isap= apclass($al,$pi,0,0); # add $tor for asense
    $apval{$rd}{$td}{'ispar'}= $isap;
    # $tsize{$td}=$tw;
 } close($hin);

  # make gene table
  use constant PUT_EACH_GROUP => 1; # test
  my $outh= *STDOUT;
  if($otab) {
    rename($otab,"$otab.old") if(-f $otab);
    open(OUT,">$otab"); $outh= *OUT;
  }

  my($ngid,$ntrs)=(0,0);
  my(%sgroup, %apclass, %didtr);
  my @idungr= @ids;
  while (@idungr > 0) {
    my $atid= shift @idungr; next if($sgroup{$atid});
    my @sgr=(); # add at end ($atid);
    my @jid=  grep{ not $sgroup{$_} } keys %{$apval{$atid}};
    #x @jid= sort { $tsize{$b} <=> $tsize{$a} } @jid;
    for my $jd (@jid) {
      my($isap)= $apval{$atid}{$jd}{'ispar'}||$apval{$jd}{$atid}{'ispar'}||0;  
      # my($isap,$alntot,$pident,$idmax,$svar,$asense)= map{ $apval{$atid}{$jd}{$_}||0 } 
      #   qw(ispar alntot pident idmax svar asense);
      # my $isap= apclass($alntot,$pident,$idmax,$svar);
      
      if($isap <= cALT) { push @sgr,$jd; }  #  cALT => -1, cPAR => 1, cUNK => 0, cMISS => 0, 
      # could also collect cPAR here, @pargr ? but want all, may belong to other atid
    }
    
    use constant SGR_KIDS => 1; # need this recurse, how many levels? grand-kids?
    # this helps, problem: kid link is weaker than yet-to-be dgroup:
    # .. should mark and check strength if alt-link (tot align * pident)
    # .. eg. want apvalmax{id} vs apval{id}{jd} ?
    if(SGR_KIDS and @sgr>0){
      my @kgr=(); my %sgr= map{ $_,1 } ($atid,@sgr);
      for my $jd (@sgr) {
        my @kid= grep{ not ($sgr{$_} or $sgroup{$_}) } keys %{$apval{$jd}};
        for my $kd (@kid) {
          my($isap)= $apval{$jd}{$kd}{'ispar'}||$apval{$kd}{$jd}{'ispar'}||0;  
          if($isap <= cALT) { push @kgr,$kd; $sgr{$kd}=2; }
        }
      }
      push @sgr, @kgr;
    }

    # my $sgid= "p" . ++$SGID;  
    my $sgid= ++$SGID;
    unshift @sgr, $atid;
    my %sgr= map{ $_,1 } @sgr;
    my $ti=0; my $nalt= @sgr;
    @sgr= sort { $tsize{$b} <=> $tsize{$a} } @sgr;
    for my $xid (@sgr) { 
      ++$ti; my $rw=$tsize{$xid}||0;
      my $tcla=($nalt == 1) ? "uni" : ($ti==1)? "main" : "alt"; #? no par
      $apclass{$sgid}{$xid}= [ $tcla, $ti, $rw ]; 
      $sgroup{$xid}= "$sgid.$ti";  # decimal sgid.altnum
      }
      
    # could dump out this sgid group now, drop memory ..
    
    @idungr= grep{ not $sgr{$_} } @idungr;
    
    if(PUT_EACH_GROUP) {
      my $nput= put_apgroup($outh, $sgid, \%apclass, \%didtr);
      if($nput){ $ntrs+= $nput; $ngid++; }
      %apclass=();
    }
    # $outh, $gid,$apclass,$didtr
  }

  if(PUT_EACH_GROUP) {
    close(OUT) if($otab);
    return($ngid,$ntrs);
  }
  
  my $idpre= $IDPRE || "dg"; #? bug
  my @gid= sort{ $a <=> $b } keys %apclass;
  for my $gid (@gid) {
    $ngid++;
    my $sgid= $idpre . sprintf "%06d",$gid;
    my @apd= keys %{ $apclass{$gid} };
    @apd= sort{ $apclass{$gid}{$a}->[1] <=> $apclass{$gid}{$b}->[1] or $a cmp $b} @apd; # sort by ti
    my $nalt= @apd; # $ntrs += $nalt;

    for my $rd (@apd) {
      my($apclass,$ti,$rlen)= @{ $apclass{$gid}{$rd} };
      next if($didtr{$rd}); # ?? paralog in two+ gid ?
      my $trid= $sgid."t$ti";    
      my($aaqual,$trlen)=(0,0);
      if($nsizes and ref($aaqualh)) {
        $aaqual=$aaqualh->{$rd}||0; $trlen= $trsizeh->{$rd}||0;
      } 
      unless($aaqual and $trlen) {
        $aaqual="$rlen,1%,ac"; $trlen=$rlen; # rlen from btall should be ok
      }
  
      my ($laltids, $lparids, $lchrlocs)= ("noalt","nopar","noloc");
      my @altd= grep{ $apclass{$gid}{$_}->[0] =~ m/^(alt|main)/ } @apd; # eq "alt" 
      my @pard= grep{ $apclass{$gid}{$_}->[0] =~ m/^par/ } @apd; # par,parc
      my($na);
      $na=@altd; if($na>0){ @altd=splice(@altd,0,9) if($na>9); $laltids= "nalt:$na," . join",",@altd; }
      $na=@pard; if($na>0){ @pard=splice(@pard,0,9) if($na>9); $lparids= "npar:$na," . join",",@pard; }
      
      #UPD2020: add TRlen col : BAD trlen here, is aalen*3
      print $outh join("\t",qw(dRnaID OrigID  dGeneID AltI  APClass AAqual TRlen lAltIDs lParIDs lChrLocs))."\n" 
        unless($DGHDR++);
      print $outh join("\t",$trid,$rd,$sgid,$ti,$apclass,$aaqual,$trlen,$laltids,$lparids,$lchrlocs)."\n";
      $ntrs++; $didtr{$rd}++;
    }
  }
  close(OUT) if($otab);
  return($ngid,$ntrs);
}  

1;

