/* merge two datasets to creata a new dataset */

g_merge: ;

clear adat,bdat,xa,xb,va,vb;
closeall f1a,f1b,fhh ;

/* clear filenameA,filenameB,varlistA,varlistB,xA,xB,xAindex,XBindex,nxA,nxB,big_merge ;
clear idAindex,idBindex,idAname,idBname,nomatch_opt,outdata,by_row,by_append,matchtype ; */


@ Read first file @
open f1a=^filenameA ;
if f1a le 0 ;
   call grbl2_error("ERROR opening first input file"  $+filenameA ,1);
   stop;
endif;
rowsA=rowsf(f1a);
if big_merge ne 1 ;
  Adat=readr(f1a,rowsf(f1a)) ;
  call close(f1a);
endif;

open f1b=^filenameB ;
if f1b le 0 ;
   call grbl2_error("ERROR opening 2nd input file"  $+filenameB,1) ;
   stop;
endif;
rowsB=rowsf(f1b);
if big_merge ne 1 ;
  bdat=readr(f1b,rowsf(f1b)) ;
  call close(f1b);
endif;

if missrv(xaindex,0)==0 ;
   call grbl2_error("ERROR: no X variables specified for first  file"  $+filenamea,1) ;
   stop;
endif;

if missrv(xbindex,0)==0 ;
   call grbl2_error("ERROR: no X variables specified for 2nd  file"  $+filenameb,1) ;
   stop;
endif;

if big_merge ne 1 ;
  XA=adat[.,xaindex];
  xb=bdat[.,xbindex];
endif;

if by_row==1 and  nva>0 and nvb>0 ;
  if big_merge ne 1 ;
     vva=adat[.,vaindex];
     vvb=bdat[.,vbindex];
  endif;
endif;


@ three modes:
    by_row=1 : row by row. First row of file1 merged with first row of file 2,
         etc.
         if extra rows, vars for the non-extra file are set to missing
   by_row=0  : match rows in FILEA with same ID row in FILEB.
         There can be multiple rows with same ID in fileA, but ONLY one with this ID in
         fileB (more precisely, only the first row with this id is used).
  by_append=1 : append files

@

if by_row==0 and by_append==0;
  if ismiss(idaindex) or ismiss(idbindex) ;
     call grbl2_error("ERROR: for merge by ID, you must specify an IDA and an IDB ",1);
     stop;
  endif;
  if rows(idaindex) ne rows(idbindex)  ;
     call grbl2_error("ERROR: you must specify the same number of ID variables for IDA and IDB ",1);
     stop;
  endif;
  if big_merge ne 1 ;
    xida=adat[.,idaindex];
    xidb=bdat[.,idbindex];
  endif;
endif;

@ build list of output variables. @
if by_append==0;
  xaname_new=upper(xaname_new);
  outvars=xaname_new~seqa(1,1,rows(xaname_new))~zeros(rows(xaname_new),1);      @ 2nd col = location in xa; 3rd= location in xb @
  for jj (1,rows(xbindex),1);
     vb=upper(xbname_new[jj]);
     tt=indcv(vb,xaname_new);
     if scalmiss(tt) ;     @ unique name @
        outvars=outvars|(vb~0~jj);
    else ;
        outvars[tt,3]=jj;
    endif;
  endfor;
else ;
   xaname_new=upper(xaname_new); xbname_new=upper(xbname_new);
   outvars=unique(xaname_new|xbname_new,0);
   inda=indcv(xaname_new,outvars);
   indb=indcv(xbname_new,outvars);
endif ;

outdat={};
ma1=miss(zeros(1,cols(xa)),0);
ma2=miss(zeros(1,cols(xb)),0) ;
blankrow=miss(zeros(1,rows(outvars)),0);

if by_append==1 ;
  j2=rowsa+rowsb; j2orig=j2;
else;
  if by_row==1 ;
    j2orig=maxc(rowsa|rowsb);
    j2=j2orig;
  else ;
    j2=rowsa; j2orig=j2;
    bmatches=zeros(rowsb,1);
  endif;
endif;

doverify=0;
if by_row==1 ;                       @ check verification stuff @
  if nva>0 or nvb>0;
     if nva ne nvb ;
         call grbl2_error("Error: # of verification variables is not the same.",1);
         "VerfiyA: " $;; format /ld 1,8; $vAnames' ;
         "VerfiyB: " $;; format /ld 1,8; $vbnames' ;
     else;
         doverify=1;
     endif;
  endif;
endif;

didwrite=0;
irow=0;
t=outvars[.,1];
create fhh=^outdata with ^t,0,4;

@ quick writing allowed (If NONE of the variables are in both files ) @
doquick=0;              @ assume can NOT quick write (must check each variable @
oldind=0;
oldtt=0;
if by_append ne 1 ;
  foo1=outvars[.,2].==0 ;
  foo2=outvars[.,3].==0 ;
  foo=foo1+foo2 ;
  if sumc(foo.==1) eq rows(Foo) ; doquick=1 ;endif;
endif;

idoneA=0;
idoneB=0;

do while 1==1      ;            @ big do loop, for multipass merges @


if big_merge==1  ;               @ multipass? then read in xa,xb,       @
   if idoneA ge rowsA ;
      xa=miss(1,1);
   else;
       adat=readr(f1a,10000);
       XA=adat[.,xaindex];
       xida=adat[.,idaindex];
       idonea=idonea+rows(xa);
       if by_row==1 and  nva>0 and nvb>0 ;   vva=adat[.,vaindex]; endif;
   endif;
   if idoneb ge rowsb ;
      xb=miss(1,1);
   else;
       bdat=readr(f1b,10000);
       xb=bdat[.,xbindex];
       xidb=bdat[.,idbindex];
       idoneb=idoneb+rows(xb);
       if by_row==1 and  nva>0 and nvb>0 ;   vvb=bdat[.,vbindex]; endif;
   endif;
    j2=maxc(rows(xa)|rows(xb));
endif;



for jj (1,j2,1);        @ build new data line at a time @

 if scalmiss(xa) and scalmiss(xb); break ; endif;

  arow=blankrow ;

  if by_append==0 ;

    if jj le rows(xa) and not(scalmiss(xa)) ; arowA=xa[jj,.]; else ; arowA=ma1 ; endif;  @ always true if by_row ne 1 @
    if by_row==1 ;       @ use matching row of B @
         if jj le rows(xb) and not(scalmiss(xb)) ; arowB=xB[jj,.]; else ; arowb=ma2 ; endif;
    else ;         @ use first index match in b, if it exists @
        indvala=xida[jj,.] ;
        if oldind==indvala;      @ no need to lookup if already known @
           tt=oldtt ;
        else;
          oldind=indvala ;
          tt=indnv_n(indvala,xidb);      @ find match ... @
          oldtt=tt;
        endif;
        if missrv(tT,0)==0   ;
            arowb=ma2 ;
        else;
            arowb=xb[tt,.];
        endif;
    endif;

  else ;                   @ by append @

       if jj le rows(xa) ; arowa=xA[jj,.]; else ; arowa=xb[jj-rows(xa),.]; endif;

  endif;

  if by_append==1 ;
     if jj le rows(xa) ;      @ first file @
        arow[inda]=arowa ;
     else;
        arow[indb]=arowa ;
     endif;

  else ;       @ not append @

    if doquick==1 ;
       arow=arowa~arowb ;
    else;
     for kk (1,rows(outvars),1);        @ build each line a column at a time @

      ixatA=outvars[kk,2]; ixatB=outvars[kk,3] ;

       if matchtype$=="A" and ixata gt 0 ;     @ type A, and var exists in FileA @
          arow[kk]=arowa[ixatA];

       elseif (matchtype$=="A" or matchtype$=="AB" or matchtype$=="") and ixata eq 0 ;     @ type A or AB, but var does not exist in File A  @
          arow[kk]=arowb[ixatB];

       elseif matchtype$=="B" and ixatb gt 0 ;     @ type B, and var exists in FileB @
           arow[kk]=arowb[ixatb];
       elseif (matchtype$=="B" or matchtype$=="BA") and ixatb eq 0 ;     @ type B or BA, but var does not exist in FileB  @
          arow[kk]=arowa[ixata];

       elseif (matchtype$=="AB" or matchtype$=="") and ixata gt 0  ;     @ type AB, and var does exist in FileA @
            arow[kk]=arowa[ixata];
            if scalmiss(arow[kk]) and ixatb gt 0 ;   @ A value is missing, and var exists in B @
                arow[kk]=arowb[ixatb];
            endif;

       elseif matchtype$=="BA" and ixatb gt 0  ;     @ type BA, and var exists in FileB @
            arow[kk]=arowb[ixatb];
            if scalmiss(arow[kk]) and ixata gt 0 ;   @ B value is missing, and var exists in A @
                arow[kk]=arowa[ixata];
            endif;
        endif;
      endfor;        @ kk @
     endif;           @ doquick @

    endif;        @ append? @

    if doverify==1 ;
        foo= (vva[jj,.].==vvb[jj,.])';
        if sumc(foo) ne rows(foo) ;
            call grbl2_error("Error: verification failure at line " $+ g_ftos2(jj,1),1);
            format /ld 15,5 ;
            "A: " ;;vva[jj,.];
            "B: " ;;vvb[jj,.];
            stop;
        endif;
    endif;

    outdat=outdat|arow ;
    if rows(outdat)>1000 ;
       foo=writer(fhh,outdat);
      if foo ne rows(outdat);
          call grbl2_error("ERROR: unable to write all " $+ g_ftos2(rows(outdat),1) $+ " rows of data to " $+ outdata,1);
          a=close(fhh);
          stop;
      endif;
      didwrite=didwrite+rows(outdat);
       if irow==0 ;
         ?;?;
        irow=csrlin; irow=irow-1;
       endif;
       locate irow,1;
         " Rows written: " ;; didwrite ;; " of " ;; j2orig ;; "     ";
      outdat={} ;
   endif;
endfor ;       @ jj @

if big_merge==1 ;
    if scalmiss(xa) and scalmiss(xb); break ; endif;
else ;
  break ;
endif;

endo;                  @ BIG do loop (multipass read/writes @

if not(scalmiss(outdat));
       foo=writer(fhh,outdat);
       if foo ne rows(outdat);
          call grbl2_error("ERROR: unable to write all " $+ g_ftos2(rows(outdat),1) $+ " rows of data to " $+ outdata,1);
          a=close(fhh);
          stop;
      endif;
endif;

a=close(fhh);



output file=^outfile ;
output on ;
"-----------------------------------------";
" Merged GAUSS dataset created. ";;$datestr(0);;" " ;; timestr(0); ?;
format /ld 1,8;
" :  First Input file (with " ;; g_addcomma(rows(xa),0);;" rows): ";
"      " ;;$filenameA ;
"    2nd Input file (with " ;; g_addcomma(rows(xb),0) ;;" rows): ";
"      " ;;$filenameb ;
?;
" :  Output file (with " ;; g_addcomma(didwrite,0);;" rows): ";
"      " ;;$outdata ;
"    Variables written to output file: ";
call g_showvec(t,6,10,"  ");
?;


rb="By-Index"|"By-Row"|"Append";
rrb=rb[by_row+1];
if by_append==1 ; rrb="Append"; endif;
amtype=matchtype; if amtype$=="" ; amtype="AB"; endif;
" : Merge type: " ;; format /ld 1,8;$amtype;;", ";;$rrb;

format /ld 1,8;
if by_row==0 and by_append==0;
  "    Using indices: ";
  "     First file: ";; $idAname' ;
  "     2nd file: ";; $idBname' ;
endif;
?;
? ;
output off ;

return ;


/*******************/
@ vector version of indnv -- match a vector of values to a row in  a matrix (finds first match if multiple matches) @
proc indnv_n(avec,amtx);
local j,tmp,i,tmp1,tmp2,vs;
if cols(avec)==1 ; avec=avec'; endif;
if cols(avec) ne cols(amtx);
  "ERROR in INDNV_N -- column mismatch ";
  stop;
endif;
vs=zeros(rows(avec),1);
for j (1,rows(avec),1);
  tmp=avec[j,.];
  tmp1= amtx.== tmp ;
  tmp2=sumc(tmp1').==cols(amtx);
  vs[j]=indnv(1,tmp2);
endfor;
retp(vs);
endp;
