/*
 * File: rlrgint.r
 *  Large integer arithmetic
 */

#ifdef LargeInts

/*
 *  Conventions:
 *
 *  Lrgints entering this module and leaving it are too large to
 *  be represented with T_Integer.  So, externally, a given value
 *  is always T_Integer or always T_Lrgint.
 *
 *  Routines outside this module operate on bignums by calling
 *  a routine like
 *
 *      bigadd(da, db, dx)
 *
 *  where da, db, and dx are pointers to tended descriptors.
 *  For the common case where one argument is a T_Integer, these
 *  call routines like
 *
 *      bigaddi(da, IntVal(*db), dx).
 *
 *  The bigxxxi routines can convert an integer to bignum form;
 *  they use itobig.
 *
 *  The routines that actually do the work take (length, address)
 *  pairs specifying unsigned base-B digit strings.  The sign handling
 *  is done in the bigxxx routines.
 */

/*
 * Type for doing arithmetic on (2 * NB)-bit nonnegative numbers.
 *  Normally unsigned but may be signed (with NB reduced appropriately)
 *  if unsigned arithmetic is slow.
 */

/* The bignum radix, B */

#define B            ((word)1 << NB)

/* Lrgint digits in a word */

#define WORDLEN  (WordBits / NB + (WordBits % NB != 0))

/* size of a bignum block that will hold an integer */

#define INTBIGBLK  sizeof(struct b_bignum) + sizeof(DIGIT) * WORDLEN

/* lo(uword d) :            the low digit of a uword
   hi(uword d) :            the rest, d is unsigned
   signed_hi(uword d) :     the rest, d is signed
   dbl(DIGIT a, DIGIT b) : the two-digit uword [a,b] */

#define lo(d)        ((d) & (B - 1))
#define hi(d)        ((uword)(d) >> NB)
#define dbl(a,b)     (((uword)(a) << NB) + (b))

#if ((-1) >> 1) < 0
#define signed_hi(d) ((word)(d) >> NB)
#else
#define signbit      ((uword)1 << (WordBits - NB - 1))
#define signed_hi(d) ((word)((((uword)(d) >> NB) ^ signbit) - signbit))
#endif

/* LrgInt(dptr dp) : the struct b_bignum pointed to by dp */

#define LrgInt(dp)   (BlkD((*dp),Lrgint))

/* LEN(struct b_bignum *b) : number of significant digits */

#define LEN(b)       ((b)->lsd - (b)->msd + 1)

/* DIG(struct b_bignum *b, word i): pointer to ith most significant digit */
/*  (NOTE: This macro expansion often results in a very long string,
 *   that has been known to cause problems with the C compiler under VMS.
 *   So when DIG is used, keep it to one use per line.)
 */

#define DIG(b,i)     (&(b)->digits[(b)->msd+(i)])

/* ceil, ln: ceil may be 1 too high in case ln is inaccurate */

#undef ceil
#define ceil(x)      ((word)((x) + 1.01))
#define ln(n)        (log((double)n))

/* copied from oref.c */

#define RandVal (RanScale*(k_random=(RandA*(long)k_random+RandC)&0x7fffffffL))

/*
 * Prototypes.
 */

static int mkdesc	(struct b_bignum *x, dptr dx);
static void itobig	(word i, struct b_bignum *x, dptr dx);

static void decout	(FILE *f, DIGIT *n, word l);

int bigaddi	(dptr da, word i, dptr dx);
int bigsubi	(dptr da, word i, dptr dx);
static int bigmuli	(dptr da, word i, dptr dx);
static int bigdivi	(dptr da, word i, dptr dx);
static int bigmodi	(dptr da, word i, dptr dx);
static int bigpowi	(dptr da, word i, dptr dx);
static int bigpowii	(word a, word i, dptr dx);
static word bigcmpi	(dptr da, word i);

static DIGIT add1	(DIGIT *u, DIGIT *v, DIGIT *w, word n);
static word sub1	(DIGIT *u, DIGIT *v, DIGIT *w, word n);
static void mul1	(DIGIT *u, DIGIT *v, DIGIT *w, word n, word m);
static int div1
   (DIGIT *a, DIGIT *b, DIGIT *q, DIGIT *r, word m, word n, struct b_bignum *b1, struct b_bignum *b2);
static void compl1	(DIGIT *u, DIGIT *w, word n);
static word cmp1	(DIGIT *u, DIGIT *v, word n);
static DIGIT addi1	(DIGIT *u, word k, DIGIT *w, word n);
static void subi1	(DIGIT *u, word k, DIGIT *w, word n);
static DIGIT muli1	(DIGIT *u, word k, int c, DIGIT *w, word n);
static DIGIT divi1	(DIGIT *u, word k, DIGIT *w, word n);
static DIGIT shifti1	(DIGIT *u, word k, DIGIT c, DIGIT *w, word n);
static word cmpi1	(DIGIT *u, word k, word n);

#define bdzero(dest,l)  memset(dest, '\0', (l) * sizeof(DIGIT))
#define bdcopy(src, dest, l)  memcpy(dest, src, (l) * sizeof(DIGIT))

/*
 * mkdesc -- put value into a descriptor
 */

static int mkdesc(x, dx)
struct b_bignum *x;
dptr dx;
{
   word xlen, cmp;
   static DIGIT maxword[WORDLEN] = { 1U << ((WordBits - 1) % NB) };

   /* suppress leading zero digits */

   while (x->msd != x->lsd &&
          *DIG(x,0) == 0)
      x->msd++;

   /* put it into a word if it fits, otherwise return the bignum */

   xlen = LEN(x);

   if (xlen < WORDLEN ||
       (xlen == WORDLEN &&
        ((cmp = cmp1(DIG(x,0), maxword, (word)WORDLEN)) < 0 ||
        (cmp == (word)0 && x->sign)))) {
      word val = -(word)*DIG(x,0);
      word i;

      for (i = x->msd; ++i <= x->lsd; )
	 val = (word)((uword)val << NB) - x->digits[i];
      if (!x->sign)
	 val = -val;
      dx->dword = D_Integer;
      IntVal(*dx) = val;
      }
   else {
      dx->dword = D_Lrgint;
      BlkLoc(*dx) = (union block *)x;
      }
   return Succeeded;
}

/*
 *  i -> big
 */

static void itobig(i, x, dx)
word i;
struct b_bignum *x;
dptr dx;
{
#ifdef DebugHeap
   x->title = T_Lrgint;
#endif					/* DebugHeap */
   x->lsd = WORDLEN - 1;
   x->msd = WORDLEN;
   x->sign = 0;

   if (i == 0) {
      x->msd--;
      *DIG(x,0) = 0;
      }
   else if (i < 0) {
      word d = lo(i);

      if (d != 0) {
         d = B - d;
         i += B;
         }
      i = - signed_hi(i);
      x->msd--;
      *DIG(x,0) = d;
      x->sign = 1;
      }

   while (i != 0) {
      x->msd--;
      *DIG(x,0) = lo(i);
      i = hi(i);
      }

   dx->dword = D_Lrgint;
   BlkLoc(*dx) = (union block *)x;
}

/*
 *  string -> bignum
 */

word bigradix(sign, r, s, end_s, result)
int sign;                      /* '-' or not */
int r;                          /* radix 2 .. 36 */
char *s, *end_s;                        /* input string */
union numeric *result;          /* output T_Integer or T_Lrgint */
{
   struct b_bignum *b;
   DIGIT *bd;
   word len;
   int c;

   if (r == 0)
      return CvtFail;
   len = ceil((end_s - s) * ln(r) / ln(B));
   Protect(b = alcbignum(len), return RunError);
   bd = DIG(b,0);

   bdzero(bd, len);

   if (r < 2 || r > 36)
      return CvtFail;

   for (c = ((s < end_s) ? *s++ : ' '); isalnum(c);
        c = ((s < end_s) ? *s++ : ' ')) {
      c = tonum(c);
      if (c >= r)
	 return CvtFail;
      muli1(bd, (word)r, c, bd, len);
      }

   /*
    * Skip trailing white space and make sure there is nothing else left
    *  in the string. Note, if we have already reached end-of-string,
    *  c has been set to a space.
    */
   while (isspace(c) && s < end_s)
      c = *s++;
   if (!isspace(c))
      return CvtFail;

   if (sign == '-')
      b->sign = 1;

   /* put value into dx and return the type */

   { struct descrip dx;
   (void)mkdesc(b, &dx);
   if (Type(dx) == T_Lrgint)
     result->big = BlkD(dx, Lrgint);
   else
     result->integer = IntVal(dx);
   return Type(dx);
   }
}

/*
 *  bignum -> real
 */

int bigtoreal(dptr da, double *d)
{
   word i;
   double r = 0;
   struct b_bignum *b = BlkD(*da,Lrgint);

   for (i = b->msd; i <= b->lsd; i++)
      r = r * B + b->digits[i];

   if (isinf(r))
     return 0;

   *d = (b->sign ? -r : r);
   return 1;
}

/*
 *  real -> bignum
 */

int realtobig(da, dx)
dptr da, dx;
{
   struct b_bignum *b;
   word i, blen, d;
   int sgn;
   double x;

   GetReal(da, x);

   if ((sgn = (x < 0)))
      x = -x;
   blen = ln(x) / ln(B) + 0.99;
   for (i = 0; i < blen; i++)
      x /= B;
   if (x >= 1.0) {
      x /= B;
      blen += 1;
      }

   Protect(b = alcbignum(blen), return RunError);
   for (i = 0; i < blen; i++) {
      d = (x *= B);
      *DIG(b,i) = d;
      x -= d;
      }

   b->sign = sgn;
   return mkdesc(b, dx);
}

/*
 *  bignum -> string
 */

int bigtos(da, dx)
dptr da, dx;
{
   tended struct b_bignum *a, *temp;
   word alen = LEN(LrgInt(da));
   word slen = ceil(alen * ln(B) / ln(10));
   char *p, *q;

   a = LrgInt(da);
   Protect(temp = alcbignum(alen), fatalerr(0,NULL));
   if (a->sign)
      slen++;
   Protect(q = alcstr(NULL,slen), fatalerr(0,NULL));
   bdcopy(DIG(a,0),
          DIG(temp,0),
          alen);
   p = q += slen;
#ifdef VMS
   {
      DIGIT *tempdg;
      for (;;) {
         tempdg = DIG(temp,0);
         if (!cmpi1(tempdg, (word)0, alen))
            break;
         *--p = '0' + divi1(tempdg, (word)10, tempdg, alen);
      }
   }
#else
   while (cmpi1(DIG(temp,0),
                (word)0, alen))
      *--p = '0' + divi1(DIG(temp,0),
                         (word)10,
                         DIG(temp,0),
                         alen);
#endif			/* VMS */
   if (a->sign)
      *--p = '-';
   StrLen(*dx) = q - p;
   StrLoc(*dx) = p;
   return NoCvt;	/* The mnemonic is wrong, but the signal means */
			/* that the string is allocated and not null- */
			/* terminated. */
}

/*
 *  bignum -> file
 */

void bigprint(f, da)
FILE *f;
dptr da;
{
   struct b_bignum *a, *temp;
   word alen = LEN(LrgInt(da));
   word slen, dlen;
   struct b_bignum *blk = BlkD(*da,Lrgint);

   slen = blk->lsd - blk->msd;
   dlen = slen * NB * 0.3010299956639812	/* 1 / log2(10) */
      + log((double)blk->digits[blk->msd]) * 0.4342944819032518 + 0.5;
						/* 1 / ln(10) */
   if (dlen >= MaxDigits) {
      fprintf(f, "integer(~10^%ld)",(long)dlen);
      return;
      }

   /* not worth passing this one back */
   Protect(temp = alcbignum(alen), fatalerr(0, NULL));

   a = LrgInt(da);
   bdcopy(DIG(a,0),
          DIG(temp,0),
          alen);
   if (a->sign)
      putc('-', f);
   decout(f,
          DIG(temp,0),
          alen);
}

/*
 * decout - given a base B digit string, print the number in base 10.
 */
static void decout(f, n, l)
FILE *f;
DIGIT *n;
word l;
{
   DIGIT i = divi1(n, (word)10, n, l);

   if (cmpi1(n, (word)0, l))
      decout(f, n, l);
   putc('0' + i, f);
}

/*
 *  da -> dx
 */

int cpbignum(da, dx)
dptr da, dx;
{
   struct b_bignum *a, *x;
   word alen = LEN(LrgInt(da));

   Protect(x = alcbignum(alen), return RunError);
   a = LrgInt(da);
   bdcopy(DIG(a,0),
          DIG(x,0),
          alen);
   x->sign = a->sign;
   return mkdesc(x, dx);
}

/*
 *  da + db -> dx
 */

int bigadd(da, db, dx)
dptr da, db;
dptr dx;
{
   tended struct b_bignum *a, *b;
   struct b_bignum *x;
   word alen, blen;
   word c;

   if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) {
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(db));
      a = LrgInt(da);
      b = LrgInt(db);
      if (a->sign == b->sign) {
         if (alen > blen) {
            Protect(x = alcbignum(alen + 1), return RunError);
            c = add1(DIG(a,alen-blen),
                     DIG(b,0),
                     DIG(x,alen-blen+1),
                     blen);
            *DIG(x,0) =
                addi1(DIG(a,0),
                      c,
                      DIG(x,1),
                      alen-blen);
            }
         else if (alen == blen) {
            Protect(x = alcbignum(alen + 1), return RunError);
            *DIG(x,0) =
               add1(DIG(a,0),
                    DIG(b,0),
                    DIG(x,1),
                    alen);
            }
         else {
            Protect(x = alcbignum(blen + 1), return RunError);
            c = add1(DIG(b,blen-alen),
                     DIG(a,0),
                     DIG(x,blen-alen+1),
                     alen);
            *DIG(x,0) =
               addi1(DIG(b,0),
                     c,
                     DIG(x,1),
                     blen-alen);
            }
         x->sign = a->sign;
         }
      else {
         if (alen > blen) {
            Protect(x = alcbignum(alen), return RunError);
            c = sub1(DIG(a,alen-blen),
                     DIG(b,0),
                     DIG(x,alen-blen),
                     blen);
            subi1(DIG(a,0),
                  -c,
                  DIG(x,0),
                  alen-blen);
            x->sign = a->sign;
            }
         else if (alen == blen) {
            Protect(x = alcbignum(alen), return RunError);
            if (cmp1(DIG(a,0),
                     DIG(b,0),
                     alen) > 0) {
               (void)sub1(DIG(a,0),
                          DIG(b,0),
                          DIG(x,0),
                          alen);
               x->sign = a->sign;
               }
            else {
               (void)sub1(DIG(b,0),
                          DIG(a,0),
                          DIG(x,0),
                          alen);
               x->sign = b->sign;
               }
            }
         else {
            Protect(x = alcbignum(blen), return RunError);
            c = sub1(DIG(b,blen-alen),
                     DIG(a,0),
                     DIG(x,blen-alen),
                     alen);
            subi1(DIG(b,0),
                  -c,
                  DIG(x,0),
                  blen-alen);
            x->sign = b->sign;
            }
         }
      return mkdesc(x, dx);
      }
   else if (Type(*da) == T_Lrgint)    /* bignum + integer */
      return bigaddi(da, IntVal(*db), dx);
   else if (Type(*db) == T_Lrgint)    /* integer + bignum */
      return bigaddi(db, IntVal(*da), dx);
   else {                             /* integer + integer */
      struct descrip td;
      char tdigits[INTBIGBLK];

      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      return bigaddi(&td, IntVal(*db), dx);
      }
}

/*
 *  da - db -> dx
 */

int bigsub(da, db, dx)
dptr da, db, dx;
{
   struct descrip td;
   char tdigits[INTBIGBLK];
   tended struct b_bignum *a, *b;
   struct b_bignum *x;
   word alen, blen;
   word c;

   if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) {
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(db));
      a = LrgInt(da);
      b = LrgInt(db);
      if (a->sign != b->sign) {
         if (alen > blen) {
            Protect(x = alcbignum(alen + 1), return RunError);
            c = add1(DIG(a,alen-blen),
                     DIG(b,0),
                     DIG(x,alen-blen+1),
                     blen);
            *DIG(x,0) =
               addi1(DIG(a,0),
                     c,
                     DIG(x,1),
                     alen-blen);
            }
         else if (alen == blen) {
            Protect(x = alcbignum(alen + 1), return RunError);
            *DIG(x,0) =
               add1(DIG(a,0),
                    DIG(b,0),
                    DIG(x,1),
                    alen);
            }
         else {
            Protect(x = alcbignum(blen + 1), return RunError);
            c = add1(DIG(b,blen-alen),
                     DIG(a,0),
                     DIG(x,blen-alen+1),
                     alen);
            *DIG(x,0) =
               addi1(DIG(b,0),
                     c,
                     DIG(x,1),
                     blen-alen);
            }
         x->sign = a->sign;
         }
      else {
         if (alen > blen) {
            Protect(x = alcbignum(alen), return RunError);
            c = sub1(DIG(a,alen-blen),
                     DIG(b,0),
                     DIG(x,alen-blen),
                     blen);
            subi1(DIG(a,0),
                  -c,
                  DIG(x,0),
                  alen-blen);
            x->sign = a->sign;
            }
         else if (alen == blen) {
            Protect(x = alcbignum(alen), return RunError);
            if (cmp1(DIG(a,0),
                     DIG(b,0),
                     alen) > 0) {
               (void)sub1(DIG(a,0),
                          DIG(b,0),
                          DIG(x,0),
                          alen);
               x->sign = a->sign;
               }
            else {
               (void)sub1(DIG(b,0),
                          DIG(a,0),
                          DIG(x,0),
                          alen);
               x->sign = 1 ^ b->sign;
               }
            }
         else {
            Protect(x = alcbignum(blen), return RunError);
            c = sub1(DIG(b,blen-alen),
                     DIG(a,0),
                     DIG(x,blen-alen),
                     alen);
            subi1(DIG(b,0),
                      -c,
                      DIG(x,0),
                      blen-alen);
            x->sign = 1 ^ b->sign;
            }
         }
      return mkdesc(x, dx);
      }
   else if (Type(*da) == T_Lrgint)     /* bignum - integer */
      return bigsubi(da, IntVal(*db), dx);
   else if (Type(*db) == T_Lrgint) {   /* integer - bignum */
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      alen = LEN(LrgInt(&td));
      blen = LEN(LrgInt(db));
      a = LrgInt(&td);
      b = LrgInt(db);
      if (a->sign != b->sign) {
         if (alen == blen) {
            Protect(x = alcbignum(alen + 1), return RunError);
            *DIG(x,0) =
               add1(DIG(a,0),
                    DIG(b,0),
                    DIG(x,1),
                    alen);
            }
         else {
            Protect(x = alcbignum(blen + 1), return RunError);
            c = add1(DIG(b,blen-alen),
                     DIG(a,0),
                     DIG(x,blen-alen+1),
                     alen);
            *DIG(x,0) =
               addi1(DIG(b,0),
                     c,
                     DIG(x,1),
                     blen-alen);
            }
         x->sign = a->sign;
         }
      else {
         if (alen == blen) {
            Protect(x = alcbignum(alen), return RunError);
            if (cmp1(DIG(a,0),
                     DIG(b,0),
                     alen) > 0) {
               (void)sub1(DIG(a,0),
                          DIG(b,0),
                          DIG(x,0),
                          alen);
               x->sign = a->sign;
               }
            else {
               (void)sub1(DIG(b,0),
                          DIG(a,0),
                          DIG(x,0),
                          alen);
               x->sign = 1 ^ b->sign;
               }
            }
         else {
            Protect(x = alcbignum(blen), return RunError);
            c = sub1(DIG(b,blen-alen),
                     DIG(a,0),
                     DIG(x,blen-alen),
                     alen);
            subi1(DIG(b,0),
                  -c,
                  DIG(x,0),
                  blen-alen);
            x->sign = 1 ^ b->sign;
            }
         }
      return mkdesc(x, dx);
      }
   else {                              /* integer - integer */
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      return bigsubi(&td, IntVal(*db), dx);
      }

}

/*
 *  da * db -> dx
 */

int bigmul(da, db, dx)
dptr da, db, dx;
{
   tended struct b_bignum *a, *b;
   struct b_bignum *x;
   word alen, blen;

   if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) {
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(db));
      a = LrgInt(da);
      b = LrgInt(db);
      Protect(x = alcbignum(alen + blen), return RunError);
      mul1(DIG(a,0),
           DIG(b,0),
           DIG(x,0),
           alen, blen);
      x->sign = a->sign ^ b->sign;
      return mkdesc(x, dx);
      }
   else if (Type(*da) == T_Lrgint)    /* bignum * integer */
      return bigmuli(da, IntVal(*db), dx);
   else if (Type(*db) == T_Lrgint)    /* integer * bignum */
      return bigmuli(db, IntVal(*da), dx);
   else {                             /* integer * integer */
      struct descrip td;
      char tdigits[INTBIGBLK];

      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      return bigmuli(&td, IntVal(*db), dx);
      }
}

/*
 *  da / db -> dx
 */

int bigdiv(da, db, dx)
dptr da, db, dx;
{
   tended struct b_bignum *a, *b, *x, *tu, *tv;
   word alen, blen;
   struct descrip td;
   char tdigits[INTBIGBLK];

   /* Put *da into large integer format. */
   if (Type(*da) != T_Lrgint) {
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      da = &td;
      }

   if (Type(*db) == T_Lrgint) {         /* bignum / bignum */
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(db));
      if (alen < blen) {
         *dx = zerodesc;
         return Succeeded;
         }
      a = LrgInt(da);
      b = LrgInt(db);
      Protect(x = alcbignum(alen - blen + 1), return RunError);
      if (blen == 1)
         divi1(DIG(a,0),
               (word)*DIG(b,0),
               DIG(x,0),
               alen);
      else {
         Protect(tu = alcbignum(alen + 1), return RunError);
         Protect(tv = alcbignum(blen), return RunError);
         if (div1(DIG(a,0),
                  DIG(b,0),
                  DIG(x,0),
                  NULL, alen-blen, blen, tu, tv) == RunError)
            return RunError;
            }
      x->sign = a->sign ^ b->sign;
      return mkdesc(x, dx);
      }
   else                                 /* bignum / integer */
      return bigdivi(da, IntVal(*db), dx);
}

/*
 *  da % db -> dx
 */

int bigmod(da, db, dx)
dptr da, db, dx;
{
   tended struct b_bignum *a, *b, *x, *temp, *tu, *tv;
   word alen, blen;
   struct descrip td;
   char tdigits[INTBIGBLK];

   /* Put *da into large integer format. */
   if (Type(*da) != T_Lrgint) {
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      da = &td;
      }

   if (Type(*db) == T_Lrgint) {        /* bignum % bignum */
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(db));
      if (alen < blen) {
         cpbignum(da, dx);
         return Succeeded;
         }
      a = LrgInt(da);
      b = LrgInt(db);
      Protect(x = alcbignum(blen), return RunError);
      if (blen == 1) {
	 Protect(temp = alcbignum(alen), return RunError);
         *DIG(x,0) =
            divi1(DIG(a,0),
                  (word)*DIG(b,0),
                  DIG(temp,0),
                  alen);
         }
      else {
         Protect(tu = alcbignum(alen + 1), return RunError);
         Protect(tv = alcbignum(blen), return RunError);
         if (div1(DIG(a,0),
                  DIG(b,0),
                  NULL,
                  DIG(x,0),
                  alen-blen, blen, tu, tv) == RunError)
            return RunError;
            }
      x->sign = a->sign;
      return mkdesc(x, dx);
      }
   else				       /* bignum % integer */
      return bigmodi(da, IntVal(*db), dx);
}

/*
 *  -i -> dx
 */

int bigneg(da, dx)
dptr da, dx;
{
   struct descrip td;
   char tdigits[INTBIGBLK];
   int cpstat;

   /* Put *da into large integer format. */
   if (Type(*da) != T_Lrgint) {
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      da = &td;
      }
   LrgInt(da)->sign ^= 1;       /* Temporarily change the sign */
   cpstat = cpbignum(da, dx);
   LrgInt(da)->sign ^= 1;       /* Change it back */

   return cpstat;
}

/*
 *  da ^ db -> dx
 */

int bigpow(da, db, dx)
dptr da, db, dx;
{
   CURTSTATE();

   if (Type(*db) == T_Lrgint) {
      struct b_bignum *b;
      b = LrgInt ( db );

      if (Type(*da) == T_Lrgint) {
	 if ( b->sign ) {
	    /* bignum ^ -bignum = 0 */
	    *dx = zerodesc;
	    return Succeeded;
	    }
	 else
	    /* bignum ^ +bignum = guaranteed overflow */
	    ReturnErrNum(307, RunError);
	 }
      else if ( b->sign )
	 /* integer ^ -bignum */
	 switch ( IntVal ( *da ) ) {
	    case 1:
	       *dx = onedesc;
	       return Succeeded;
	    case -1:
	       /* Result is +1 / -1, depending on whether *b is even or odd. */
	       if ( ( b->digits[ b->lsd ] ) & 01 )
		  MakeInt ( -1, dx );
	       else
		  *dx = onedesc;
	       return Succeeded;
	    case 0:
	       ReturnErrNum(204,RunError);
	    default:
	       /* da ^ (negative int) = 0 for all non-special cases */
	       *dx = zerodesc;
	       return Succeeded;
	    }
      else {
	 /* integer ^ +bignum */
	 word n, blen;
	 register DIGIT nth_dig, mask;

	 b = LrgInt ( db );
	 blen = LEN ( b );

	 /* We scan the bits of b from the most to least significant.
	  * The bit position in b is represented by the pair ( n, mask )
	  * where n is the DIGIT number (0 = most sig.) and mask is the
	  * the bit mask for the current bit.
	  *
	  * For each bit (most sig to least) in b,
	  *  for each zero, square the partial result;
	  *  for each one, square it and multiply it by a */
	 *dx = onedesc;
	 for ( n = 0; n < blen; ++n ) {
	    nth_dig = *DIG ( b, n );
	    for ( mask = 1U << ( NB - 1 ); mask; mask >>= 1 ) {
	       if ( bigmul ( dx, dx, dx ) == RunError )
		  return RunError;
	       if ( nth_dig & mask )
		  if ( bigmul ( dx, da, dx ) == RunError )
		     return RunError;
	       }
	    }
	 }
      return Succeeded;
      }
   else if (Type(*da) == T_Lrgint)    /* bignum ^ integer */
      return bigpowi(da, IntVal(*db), dx);
   else                               /* integer ^ integer */
      return bigpowii(IntVal(*da), IntVal(*db), dx);
}

int bigpowri( a, db, drslt )
double a;
dptr   db, drslt;
{
   register double retval;
   register word n;
   register DIGIT nth_dig, mask;
   struct b_bignum *b;
   word blen;
   CURTSTATE();

   b = LrgInt ( db );
   blen = LEN ( b );
   if ( b->sign ) {
      if ( a == 0.0 )
	 ReturnErrNum(204, RunError);
      else
	 a = 1.0 / a;
      }

   /* We scan the bits of b from the most to least significant.
    * The bit position in b is represented by the pair ( n, mask )
    * where n is the DIGIT number (0 = most sig.) and mask is the
    * the bit mask for the current bit.
    *
    * For each bit (most sig to least) in b,
    *  for each zero, square the partial result;
    *  for each one, square it and multiply it by a */
   retval = 1.0;
   for ( n = 0; n < blen; ++n ) {
      nth_dig = *DIG ( b, n );
      for ( mask = 1U << ( NB - 1 ); mask; mask >>= 1 ) {
	 retval *= retval;
	 if ( nth_dig & mask )
	    retval *= a;
	 }
      }

#ifdef DescriptorDouble
   drslt->vword.realval = retval;
#else					/* DescriptorDouble */
   Protect(BlkLoc(*drslt) = (union block *)alcreal(retval), return RunError);
#endif					/* DescriptorDouble */
   drslt->dword = D_Real;
   return Succeeded;
}

/*
 *  iand(da, db) -> dx
 */

int bigand(da, db, dx)
dptr da, db, dx;
{
   tended struct b_bignum *a, *b, *x, *tad, *tbd;
   word alen, blen, xlen;
   word i;
   DIGIT *ad, *bd;
   struct descrip td;
   char tdigits[INTBIGBLK];

   if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) {
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(db));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(da);
      b = LrgInt(db);
      Protect(x = alcbignum(xlen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] & bd[i];

      if (a->sign & b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   else if (Type(*da) == T_Lrgint) {   /* iand(bignum,integer) */
      itobig(IntVal(*db), (struct b_bignum *)tdigits, &td);
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(&td));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(da);
      b = LrgInt(&td);
      Protect(x = alcbignum(alen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] & bd[i];

      if (a->sign & b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   else if (Type(*db) == T_Lrgint) {   /* iand(integer,bignum) */
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      alen = LEN(LrgInt(&td));
      blen = LEN(LrgInt(db));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(&td);
      b = LrgInt(db);
      Protect(x = alcbignum(blen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] & bd[i];

      if (a->sign & b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   /* not called for iand(integer,integer) */

   return mkdesc(x, dx);
}

/*
 *  ior(da, db) -> dx
 */

int bigor(da, db, dx)
dptr da, db, dx;
{
   tended struct b_bignum *a, *b, *x, *tad, *tbd;
   word alen, blen, xlen;
   word i;
   DIGIT *ad, *bd;
   struct descrip td;
   char tdigits[INTBIGBLK];

   if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) {
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(db));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(da);
      b = LrgInt(db);
      Protect(x = alcbignum(xlen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] | bd[i];

      if (a->sign | b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   else if (Type(*da) == T_Lrgint) {   /* ior(bignum,integer) */
      itobig(IntVal(*db), (struct b_bignum *)tdigits, &td);
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(&td));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(da);
      b = LrgInt(&td);
      Protect(x = alcbignum(alen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] | bd[i];

      if (a->sign | b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   else if (Type(*db) == T_Lrgint) {   /* ior(integer,bignym) */
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      alen = LEN(LrgInt(&td));
      blen = LEN(LrgInt(db));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(&td);
      b = LrgInt(db);
      Protect(x = alcbignum(blen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] | bd[i];

      if (a->sign | b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   /* not called for ior(integer,integer) */

   return mkdesc(x, dx);
}

/*
 *  xor(da, db) -> dx
 */

int bigxor(da, db, dx)
dptr da, db, dx;
{
   tended struct b_bignum *a, *b, *x, *tad, *tbd;
   word alen, blen, xlen;
   word i;
   DIGIT *ad, *bd;
   struct descrip td;
   char tdigits[INTBIGBLK];

   if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) {
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(db));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(da);
      b = LrgInt(db);
      Protect(x = alcbignum(xlen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] ^ bd[i];

      if (a->sign ^ b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   else if (Type(*da) == T_Lrgint) {   /* ixor(bignum,integer) */
      itobig(IntVal(*db), (struct b_bignum *)tdigits, &td);
      alen = LEN(LrgInt(da));
      blen = LEN(LrgInt(&td));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(da);
      b = LrgInt(&td);
      Protect(x = alcbignum(alen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] ^ bd[i];

      if (a->sign ^ b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   else if (Type(*db) == T_Lrgint) {   /* ixor(integer,bignum) */
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      alen = LEN(LrgInt(&td));
      blen = LEN(LrgInt(db));
      xlen = alen > blen ? alen : blen;
      a = LrgInt(&td);
      b = LrgInt(db);
      Protect(x = alcbignum(blen), return RunError);

      if (alen == xlen && !a->sign)
         ad = DIG(a,0);
      else {
         Protect(tad = alcbignum(xlen), return RunError);
         ad = DIG(tad,0);
         bdzero(ad, xlen - alen);
         bdcopy(DIG(a,0),
                &ad[xlen-alen], alen);
         if (a->sign)
	    compl1(ad, ad, xlen);
         }

      if (blen == xlen && !b->sign)
         bd = DIG(b,0);
      else {
         Protect(tbd = alcbignum(xlen), return RunError);
         bd = DIG(tbd,0);
         bdzero(bd, xlen - blen);
         bdcopy(DIG(b,0),
                &bd[xlen-blen], blen);
         if (b->sign)
	    compl1(bd, bd, xlen);
         }

      for (i = 0; i < xlen; i++)
         *DIG(x,i) =
            ad[i] ^ bd[i];

      if (a->sign ^ b->sign) {
         x->sign = 1;
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      }
   /* not called for ixor(integer,integer) */

   return mkdesc(x, dx);
}

/*
 *  bigshift(da, db) -> dx
 */

int bigshift(da, db, dx)
dptr da, db, dx;
{
   tended struct b_bignum *a, *x, *tad;
   word alen;
   word r = IntVal(*db) % NB;
   word q = (r >= 0 ? IntVal(*db) : (IntVal(*db) - (r += NB))) / NB;
   word xlen;
   DIGIT *ad;
   struct descrip td;
   char tdigits[INTBIGBLK];

   if (Type(*da) == T_Integer) {
      itobig(IntVal(*da), (struct b_bignum *)tdigits, &td);
      da = &td;
      }

   alen = LEN(LrgInt(da));
   xlen = alen + q + 1;
   if (xlen <= 0) {
      MakeInt(-LrgInt(da)->sign, dx);
      return Succeeded;
      }
   else {
      a = LrgInt(da);
      Protect(x = alcbignum(xlen), return RunError);

      if (a->sign) {
         Protect(tad = alcbignum(alen), return RunError);
         ad = DIG(tad,0);
         bdcopy(DIG(a,0),
                ad, alen);
         compl1(ad, ad, alen);
         }
      else
         ad = DIG(a,0);

      if (q >= 0) {
         *DIG(x,0) =
            shifti1(ad, r, (DIGIT)0,
                    DIG(x,1),
                    alen);
         bdzero(DIG(x,alen+1),
                q);
         }
      else
         *DIG(x,0) =
            shifti1(ad, r, ad[alen+q] >> (NB-r),
                    DIG(x,1), alen+q);

      if (a->sign) {
         x->sign = 1;
         *DIG(x,0) |=
            B - (1L << r);
         compl1(DIG(x,0),
                DIG(x,0),
                xlen);
         }
      return mkdesc(x, dx);
      }
   }

/*
 *  negative if da < db
 *  zero if da == db
 *  positive if da > db
 */

word bigcmp(da, db)
dptr da, db;
{
   if (Type(*da) == T_Lrgint && Type(*db) == T_Lrgint) {
      word alen, blen;
      struct b_bignum *a = LrgInt(da);
      struct b_bignum *b = LrgInt(db);
      if (a->sign != b->sign)
         return (b->sign - a->sign);
      alen = LEN(a);
      blen = LEN(b);
      if (alen != blen)
         return (a->sign ? blen - alen : alen - blen);

      if (a->sign)
         return cmp1(DIG(b,0),
                     DIG(a,0),
                     alen);
      else
         return cmp1(DIG(a,0),
                     DIG(b,0),
                     alen);
      }
   else if (Type(*da) == T_Lrgint)    /* cmp(bignum, integer) */
      return bigcmpi(da, IntVal(*db));
   else                               /* cmp(integer, bignum) */
      return -bigcmpi(db, IntVal(*da));
}

/*
 *  ?da -> dx
 */

int bigrand(da, dx)
dptr da, dx;
{
   tended struct b_bignum *x, *a, *td, *tu, *tv;
   word alen = LEN(LrgInt(da));
   DIGIT *d;
   word i;
   double rval;

   Protect(x = alcbignum(alen), return RunError);
   Protect(td = alcbignum(alen + 1), return RunError);
   d = DIG(td,0);
   a = LrgInt(da);

   for (i = alen; i >= 0; i--) {
      rval = RandVal;
      d[i] = rval * B;
      }

   Protect(tu = alcbignum(alen + 2), return RunError);
   Protect(tv = alcbignum(alen), return RunError);
   if (div1(d, DIG(a,0),
            NULL,
            DIG(x,0),
            (word)1, alen, tu, tv) == RunError)
      return RunError;
   addi1(DIG(x,0),
         (word)1,
         DIG(x,0),
         alen);
   return mkdesc(x, dx);
}

/*
 *  da + i -> dx
 */

int bigaddi(da, i, dx)
dptr da, dx;
word i;
{
   tended struct b_bignum *a;
   struct b_bignum *x;
   word alen;

   if (i < 0 && i > MinLong)
      return bigsubi(da, -i, dx);
   else if (i < 0 || i >= B ) {
      struct descrip td;
      char tdigits[INTBIGBLK];

      itobig(i, (struct b_bignum *)tdigits, &td);
      return bigadd(da, &td, dx);
      }
   else {
      alen = LEN(LrgInt(da));
      a = LrgInt(da);
      if (a->sign) {
	 Protect(x = alcbignum(alen), return RunError);
         subi1(DIG(a,0),
               i,
               DIG(x,0),
               alen);
         }
      else {
         Protect(x = alcbignum(alen + 1), return RunError);
         *DIG(x,0) =
            addi1(DIG(a,0),
                  i,
                  DIG(x,1),
                  alen);
         }
      x->sign = a->sign;
      return mkdesc(x, dx);
      }
}

/*
 *  da - i -> dx
 */

int bigsubi(da, i, dx)
dptr da, dx;
word i;
{
   tended struct b_bignum *a;
   struct b_bignum *x;
   word alen;

   if (i < 0 && i > MinLong)
      return bigaddi(da, -i, dx);
   else if (i < 0 || i >= B) {
      struct descrip td;
      char tdigits[INTBIGBLK];

      itobig(i, (struct b_bignum *)tdigits, &td);
      return bigsub(da, &td, dx);
      }
   else {
      alen = LEN(LrgInt(da));
      a = LrgInt(da);
      if (a->sign) {
         Protect(x = alcbignum(alen + 1), return RunError);
         *DIG(x,0) =
            addi1(DIG(a,0),
                  i,
                  DIG(x,1),
                  alen);
         }
      else {
         Protect(x = alcbignum(alen), return RunError);
         subi1(DIG(a,0),
               i,
               DIG(x,0),
               alen);
         }
      x->sign = a->sign;
      return mkdesc(x, dx);
      }
}

/*
 *  da * i -> dx
 */

static int bigmuli(da, i, dx)
dptr da, dx;
word i;
{
   tended struct b_bignum *a;
   struct b_bignum *x;
   word alen;

   if (i <= -B || i >= B) {
      struct descrip td;
      char tdigits[INTBIGBLK];

      itobig(i, (struct b_bignum *)tdigits, &td);
      return bigmul(da, &td, dx);
      }
   else {
      alen = LEN(LrgInt(da));
      a = LrgInt(da);
      Protect(x = alcbignum(alen + 1), return RunError);
      if (i >= 0)
         x->sign = a->sign;
      else {
         x->sign = 1 ^ a->sign;
         i = -i;
         }
      *DIG(x,0) =
         muli1(DIG(a,0),
               i, 0,
               DIG(x,1),
               alen);
      return mkdesc(x, dx);
      }
}

/*
 *  da / i -> dx
 */

static int bigdivi(da, i, dx)
dptr da, dx;
word i;
{
   tended struct b_bignum *a;
   struct b_bignum *x;
   word alen;

   if (i <= -B || i >= B) {
      struct descrip td;
      char tdigits[INTBIGBLK];

      itobig(i, (struct b_bignum *)tdigits, &td);
      return bigdiv(da, &td, dx);
      }
   else {
      alen = LEN(LrgInt(da));
      a = LrgInt(da);
      Protect(x = alcbignum(alen), return RunError);
      if (i >= 0)
         x->sign = a->sign;
      else {
         x->sign = 1 ^ a->sign;
         i = -i;
         }
      divi1(DIG(a,0),
            i,
            DIG(x,0),
            alen);
      return mkdesc(x, dx);
      }
}

/*
 *  da % i -> dx
 */

static int bigmodi(da, i, dx)
dptr da, dx;
word i;
{
   tended struct b_bignum *a, *temp;
   word alen;
   word x;

   if (i <= -B || i >= B) {
      struct descrip td;
      char tdigits[INTBIGBLK];

      itobig(i, (struct b_bignum *)tdigits, &td);
      return bigmod(da, &td, dx);
      }
   else {
      alen = LEN(LrgInt(da));
      a = LrgInt(da);
      temp = a;			/* avoid trash pointer */
      Protect(temp = alcbignum(alen), return RunError);
      x = divi1(DIG(a,0),
                Abs(i),
                DIG(temp,0),
                alen);
      if (a->sign)
	 x = -x;
      MakeInt(x, dx);
      return Succeeded;
      }
}

/*
 *  da ^ i -> dx
 */

static int bigpowi(da, i, dx)
dptr da, dx;
word i;
{
   int n = WordBits;

   if (i > 0) {
      /* scan bits left to right.  skip leading 1. */
      while (--n >= 0)
         if (i & ((uword)1 << n))
	    break;
      /* then, for each zero, square the partial result;
         for each one, square it and multiply it by a */
      *dx = *da;
      while (--n >= 0) {
         if (bigmul(dx, dx, dx) == RunError)
	    return RunError;
         if (i & ((uword)1 << n))
            if (bigmul(dx, da, dx) == RunError)
	       return RunError;
         }
      }
   else if (i == 0) {
      *dx = onedesc;
      }
   else {
      *dx = zerodesc;
      }
   return Succeeded;
}

/*
 *  a ^ i -> dx
 */

static int bigpowii(a, i, dx)
word a, i;
dptr dx;
{
   word x, y;
   int n = WordBits;
   int isbig = 0;
   CURTSTATE();

   if (a == 0 || i <= 0) {              /* special cases */
      if (a == 0 && i <= 0)             /* 0 ^ negative -> error */
         ReturnErrNum(204,RunError);
      if (i == 0) {
         *dx = onedesc;
         return Succeeded;
         }
      if (a == -1) {                    /* -1 ^ [odd,even] -> [-1,+1] */
         if (!(i & 1))
	    a = 1;
         }
      else if (a != 1) {                /* 1 ^ any -> 1 */
         a = 0;
         }                   /* others ^ negative -> 0 */
      MakeInt(a, dx);
      }
   else {
      int over_flow = 0;
      struct descrip td;
      char tdigits[INTBIGBLK];

      /* scan bits left to right.  skip leading 1. */
      while (--n >= 0)
         if (i & ((uword)1 << n))
	    break;
      /* then, for each zero, square the partial result;
         for each one, square it and multiply it by a */
      x = a;
      while (--n >= 0) {
         if (isbig) {
            if (bigmul(dx, dx, dx) == RunError)
	       return RunError;
	    }
         else {
            y = mul(x, x, &over_flow);
            if (!over_flow)
               x = y;
            else {
               itobig(x, (struct b_bignum *)tdigits, &td);
               if (bigmul(&td, &td, dx) == RunError)
   	          return RunError;
               isbig = (Type(*dx) == T_Lrgint);
               }
            }
         if (i & ((uword)1 << n)) {
            if (isbig) {
               if (bigmuli(dx, a, dx) == RunError)
		  return RunError;
	       }
            else {
               y = mul(x, a, &over_flow);
               if (!over_flow)
                  x = y;
               else {
                  itobig(x, (struct b_bignum *)tdigits, &td);
                  if (bigmuli(&td, a, dx) == RunError)
   		  return RunError;
                  isbig = (Type(*dx) == T_Lrgint);
                  }
               }
            }
         }
      if (!isbig) {
	 MakeInt(x, dx);
	 }
      }
   return Succeeded;
}

/*
 *  negative if da < i
 *  zero if da == i
 *  positive if da > i
 */

static word bigcmpi(da, i)
dptr da;
word i;
{
   struct b_bignum *a = LrgInt(da);
   word alen = LEN(a);

   if (i > -B && i < B) {
      if (i >= 0)
         if (a->sign)
	    return -1;
         else
	    return cmpi1(DIG(a,0),
	                 i, alen);
      else
         if (a->sign)
	    return -cmpi1(DIG(a,0),
	                  -i, alen);
         else
	    return 1;
      }
   else {
      struct descrip td;
      char tdigits[INTBIGBLK];

      itobig(i, (struct b_bignum *)tdigits, &td);
      return bigcmp(da, &td);
      }
}

/* These are all straight out of Knuth vol. 2, Sec. 4.3.1. */

/*
 *  (u,n) + (v,n) -> (w,n)
 *
 *  returns carry, 0 or 1
 */

static DIGIT add1(u, v, w, n)
DIGIT *u, *v, *w;
word n;
{
   uword dig, carry;
   word i;

   carry = 0;
   for (i = n; --i >= 0; ) {
      dig = (uword)u[i] + v[i] + carry;
      w[i] = lo(dig);
      carry = hi(dig);
      }
   return carry;
}

/*
 *  (u,n) - (v,n) -> (w,n)
 *
 *  returns carry, 0 or -1
 */

static word sub1(u, v, w, n)
DIGIT *u, *v, *w;
word n;
{
   uword dig, carry;
   word i;

   carry = 0;
   for (i = n; --i >= 0; ) {
      dig = (uword)u[i] - v[i] + carry;
      w[i] = lo(dig);
      carry = signed_hi(dig);
      }
   return carry;
}

/*
 *  (u,n) * (v,m) -> (w,m+n)
 */

static void mul1(u, v, w, n, m)
DIGIT *u, *v, *w;
word n, m;
{
   word i, j;
   uword dig, carry;

   bdzero(&w[m], n);

   for (j = m; --j >= 0; ) {
      carry = 0;
      for (i = n; --i >= 0; ) {
         dig = (uword)u[i] * v[j] + w[i+j+1] + carry;
         w[i+j+1] = lo(dig);
         carry = hi(dig);
         }
      w[j] = carry;
      }
}

/*
 *  (a,m+n) / (b,n) -> (q,m+1) (r,n)
 *
 *  if q or r is NULL, the quotient or remainder is discarded
 */

static int div1(a, b, q, r, m, n, tu, tv)
DIGIT *a, *b, *q, *r;
word m, n;
struct b_bignum *tu, *tv;
{
   uword qhat, rhat;
   uword dig, carry;
   DIGIT *u, *v;
   word d;
   word i, j;

   u = DIG(tu,0);
   v = DIG(tv,0);

   /* D1 */
   for (d = 0; d < NB; d++)
      if (b[0] & (1L << (NB - 1 - d)))
         break;

   u[0] = shifti1(a, d, (DIGIT)0, &u[1], m+n);
   shifti1(b, d, (DIGIT)0, v, n);

   /* D2, D7 */
   for (j = 0; j <= m; j++) {
      /* D3 */
      if (u[j] == v[0]) {
         qhat = B - 1;
         rhat = (uword)v[0] + u[j+1];
         }
      else {
         uword numerator = dbl(u[j], u[j+1]);
         qhat = numerator / (uword)v[0];
         rhat = numerator % (uword)v[0];
         }

      while (rhat < (uword)B && qhat * (uword)v[1] > (uword)dbl(rhat, u[j+2])) {
         qhat -= 1;
         rhat += v[0];
         }

      /* D4 */
      carry = 0;
      for (i = n; i > 0; i--) {
         dig = u[i+j] - v[i-1] * qhat + carry;       /* -BSQ+B .. B-1 */
         u[i+j] = lo(dig);
         if ((uword)dig < (uword)B)
            carry = hi(dig);
         else carry = hi(dig) | -B;
         }
      carry = (word)(carry + u[j]) < 0;

      /* D5 */
      if (q)
	 q[j] = qhat;

      /* D6 */
      if (carry) {
         if (q)
	    q[j] -= 1;
         carry = 0;
         for (i = n; i > 0; i--) {
            dig = (uword)u[i+j] + v[i-1] + carry;
            u[i+j] = lo(dig);
            carry = hi(dig);
            }
         }
      }

   if (r) {
      if (d == 0)
         shifti1(&u[m+1], (word)d, (DIGIT)0, r, n);
      else
         r[0] = shifti1(&u[m+1], (word)(NB - d), u[m+n]>>d, &r[1], n - 1);
      }
   return Succeeded;
}

/*
 *  - (u,n) -> (w,n)
 *
 */

static void compl1(u, w, n)
DIGIT *u, *w;
word n;
{
   uword dig, carry = 0;
   word i;

   for (i = n; --i >= 0; ) {
      dig = carry - u[i];
      w[i] = lo(dig);
      carry = signed_hi(dig);
      }
}

/*
 *  (u,n) : (v,n)
 */

static word cmp1(u, v, n)
DIGIT *u, *v;
word n;
{
   word i;

   for (i = 0; i < n; i++)
      if (u[i] != v[i])
         return u[i] > v[i] ? 1 : -1;
   return 0;
}

/*
 *  (u,n) + k -> (w,n)
 *
 *  k in 0 .. B-1
 *  returns carry, 0 or 1
 */

static DIGIT addi1(u, k, w, n)
DIGIT *u, *w;
word k;
word n;
{
   uword dig, carry;
   word i;

   carry = k;
   for (i = n; --i >= 0; ) {
      dig = (uword)u[i] + carry;
      w[i] = lo(dig);
      carry = hi(dig);
      }
   return carry;
}

/*
 *  (u,n) - k -> (w,n)
 *
 *  k in 0 .. B-1
 *  u must be greater than k
 */

static void subi1(u, k, w, n)
DIGIT *u, *w;
word k;
word n;
{
   uword dig, carry;
   word i;

   carry = -k;
   for (i = n; --i >= 0; ) {
      dig = (uword)u[i] + carry;
      w[i] = lo(dig);
      carry = signed_hi(dig);
      }
}

/*
 *  (u,n) * k + c -> (w,n)
 *
 *  k in 0 .. B-1
 *  returns carry, 0 .. B-1
 */

static DIGIT muli1(u, k, c, w, n)
DIGIT *u, *w;
word k;
int c;
word n;
{
   uword dig, carry;
   word i;

   carry = c;
   for (i = n; --i >= 0; ) {
      dig = (uword)k * u[i] + carry;
      w[i] = lo(dig);
      carry = hi(dig);
      }
   return carry;
}

/*
 *  (u,n) / k -> (w,n)
 *
 *  k in 0 .. B-1
 *  returns remainder, 0 .. B-1
 */

static DIGIT divi1(u, k, w, n)
DIGIT *u, *w;
word k;
word n;
{
   uword dig, remain;
   word i;

   remain = 0;
   for (i = 0; i < n; i++) {
      dig = dbl(remain, u[i]);
      w[i] = dig / k;
      remain = dig % k;
      }
   return remain;
}

/*
 *  ((u,n) << k) + c -> (w,n)
 *
 *  k in 0 .. NB-1
 *  c in 0 .. B-1
 *  returns carry, 0 .. B-1
 */

static DIGIT shifti1(u, k, c, w, n)
DIGIT *u, c, *w;
word k;
word n;
{
   uword dig;
   word i;

   if (k == 0) {
      bdcopy(u, w, n);
      return 0;
      }

   for (i = n; --i >= 0; ) {
      dig = ((uword)u[i] << k) + c;
      w[i] = lo(dig);
      c = hi(dig);
      }
   return c;
}

/*
 *  (u,n) : k
 *
 *  k in 0 .. B-1
 */

static word cmpi1(u, k, n)
DIGIT *u;
word k;
word n;
{
   word i;

   for (i = 0; i < n-1; i++)
      if (u[i])
	 return 1;
   if (u[n - 1] == (DIGIT)k)
      return 0;
   return u[n - 1] > (DIGIT)k ? 1 : -1;
}

#else					/* LargeInts */
/* static char junk;			/* prevent empty module */
#endif					/* LargeInts */


#' @title Scatter Histogram
#'
#' @param x the x parameter, a vector
#' @param y the y parameter, a vector
#' @param xlab the x label
#' @param ylab the y label
#'
#' @return A plot, a scatter histogram
#' @export
#'
#' @importFrom graphics layout hist par barplot mtext
#'
#' @examples
#' \dontrun{with(ddt, scatterhist(LENGTH,WEIGHT, xlab="LENGTH"))}
scatterhist = function(x, y, xlab="", ylab=""){
  zones=matrix(c(2,0,1,3), ncol=2, byrow=TRUE)
  layout(zones, widths=c(4/5,1/5), heights=c(1/5,4/5))
  xhist = hist(x, plot=FALSE)
  yhist = hist(y, plot=FALSE)
  top = max(c(xhist$counts, yhist$counts))
  par(mar=c(3,3,1,1))
  plot(x,y)
  par(mar=c(0,3,1,1))
  barplot(xhist$counts, axes=FALSE, ylim=c(0, top), space=0)
  par(mar=c(3,0,1,1))
  barplot(yhist$counts, axes=FALSE, xlim=c(0, top), space=0, horiz=TRUE)
  par(oma=c(3,3,0,0))
  mtext(xlab, side=1, line=1, outer=TRUE, adj=0,
        at=.8 * (mean(x) - min(x))/(max(x)-min(x)))
  mtext(ylab, side=2, line=1, outer=TRUE, adj=0,
        at=(.8 * (mean(y) - min(y))/(max(y) - min(y))))
}


equityhistory <- function(symbol, from=NULL, to=Sys.Date(), source='yahoo', period='days') {
    ## function returns a dataframe of adjusted prices
    ## period = 'days' (default), 'weeks', 'months', 'quarters', or 'years'

    ## e.g., adjusted_price(c("SPY","EFA", "IJS", "EEM","AGG"), from='2005-01-01')
    ##       adjusted_price(c("SPY","EFA", "IJS", "EEM","AGG"), from='2005-01-01')

    ## install.packages('quantmod')

    ## Download historical info into dataframes with each symbol name.
    ## The last column from yahoo is the adjusted price.
    ## "While closing price merely refers to the cost of shares at the end of the day,
    ##  the adjusted closing price considers other factors like dividends, stock splits,
    ##  and new stock offerings. Since the adjusted closing price begins where the
    ##  closing price ends, it can be called a more accurate measure of stocks' value"
    if (is.null(from)) {
        ## from not specified so grab earliest to date
        quantmod::getSymbols(symbol,
                             src = source,
                             to  = to,
                             auto.assign = TRUE,
                             warnings = FALSE)
    } else {
        quantmod::getSymbols(symbol,
                             src = source,
                             from = from,
                             to  = to,
                             auto.assign = TRUE,
                             warnings = FALSE)
    }

    ## index of an xts object is the date
    ## can access using zoo::index()
    ## dates <- as.Date( zoo::index( get(symbols[1]) ) )

    ## copy XTS OHLCV format data for 1st symbol to variable asset
    asset <- get(symbol[1])
    if (period != 'days') {
        ## convert OHLCV format data to some other period
        asset <- xts::to.period(asset, period=period)
    }

    ## find column numbers with closing and adjusted prices
    colclose <- which(grepl('Close',    names(asset)))
    coladj   <- which(grepl('Adjusted', names(asset)))

    ## copy 1st asset information into XTS objects for closing and adjusted prices
    closeprice <- asset[, colclose]
    adjprice   <- asset[, coladj]

    ## merge adjusted prices for additional symbols, if any
    if (length(symbol) > 1) {
        for (i in 2:length(symbol)) {
            asset <- get(symbol[i])
            if (period != 'days') {
                ## convert OHLCV format data to some other period
                asset <- xts::to.period(asset, period=period)
            }
            closeprice <- merge(closeprice, asset[, colclose])
            adjprice   <- merge(adjprice  , asset[, coladj])
        }
    }

    ## fix names and return
    names(closeprice) <- symbol
    names(adjprice)   <- symbol

    ## calculate TWR
    twr  <- adjprice / xts::lag.xts(adjprice, 1) - 1
    ## remove 1st row since NA
    twr <- twr[-1,]

    ## ## the following does the same with matrices
    ## ## calculate return
    ## ## convert to matrix until maybe someday if I learn xts
    ## adjpricem <- as.matrix(adjprice)
    ## nrows <- nrow(adjpricem)
    ## twrm <- adjpricem[2:nrows,] / adjpricem[1:(nrows-1),] - 1
    ## ## convert back to xts
    ## ## twr <- xts::as.xts(twrm)

    return(list(close = closeprice, adjprice = adjprice, twr=twr))
}

## out <- equityhistory(c('SPY', 'IWM', 'EFA', 'AGG', 'SHV'), from='1995-01-01', period='years')
## twr <- out$twr


# Euler1 in R

myMap    <- function(n) n
myFilter <- function(n) ifelse(n%%3 == 0 || n%%5 == 0, n, 0)
myReduce <- function(m,n) m+n

euler1 <- function(n) {
    mapped   = Map(myMap, 1:n)
    filtered = Filter(myFilter, mapped)
    Reduce(myReduce, filtered)
}

euler1(999)


# Day 4: Giant Squid

get_day4_input_path <- function() {
    paste(getwd(), "/2021/Day 4/Day4_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day4_input_path())

    call_numbers <- unlist(strsplit(readings[1], ","))
    row_size <- 5
    boards <- parse_boards(readings[3:length(readings)], row_size)

    for (i in seq_len(length(call_numbers))) {
        boards <- update_boards_p1(boards, row_size, call_numbers[i])

        if (length(boards) == 1) {
            calc_winning_board(boards[[1]], call_numbers[i])
            break
        }
    }
}

part2 <- function() {
    readings <- readLines(get_day4_input_path())

    call_numbers <- unlist(strsplit(readings[1], ","))
    row_size <- 5
    boards <- parse_boards(readings[3:length(readings)], row_size)

    for (i in seq_len(length(call_numbers))) {
        if (length(boards) > 1) {
            boards <- update_boards_p2(boards, row_size, call_numbers[i])
        } else {
            # Finish filling out the last board
            match <- which(boards[[1]] == call_numbers[i], arr.ind = TRUE)
            if (length(match) > 0) {
                boards[[1]][match[1, 1], match[1, 2]] <- "0"
                if (is_winning_board(boards[[1]], row_size, match)) {
                    calc_winning_board(boards[[1]], call_numbers[i])
                    break
                }
            }
        }
    }
}

parse_boards <- function(input, row_size) {
    boards <- list()

    i <- 1
    board_num <- 1
    while (i < length(input)) {
        first_row <- i
        last_row <- i + row_size - 1
        board <- matrix(unlist(strsplit(R.oo::trim(input[first_row:last_row]),
                                        "\\s+")),
                        ncol = 5)
        boards[[board_num]] <- board

        # Skip rows between boards
        i <- i + row_size + 1
        board_num <- board_num + 1
    }

    boards
}

update_boards_p1 <- function(boards, row_size, call_num) {
    for (i in seq_len(length(boards))) {
        match <- which(boards[[i]] == call_num, arr.ind = TRUE)
        if (length(match) > 0) {
            boards[[i]][match[1, 1], match[1, 2]] <- "0"
            if (is_winning_board(boards[[i]], row_size, match)) {
                boards <- list(boards[[i]])
                break
            }
        }
    }
    boards
}

update_boards_p2 <- function(boards, row_size, call_num) {
    indices_to_remove <- ""
    for (i in seq_len(length(boards))) {
        match <- which(boards[[i]] == call_num, arr.ind = TRUE)
        if (length(match) > 0) {
            boards[[i]][match[1, 1], match[1, 2]] <- "0"
            if (is_winning_board(boards[[i]], row_size, match)) {
                indices_to_remove <- paste(indices_to_remove, i)
            }
        }
    }

    # Remove winning boards from the pool
    indices <- rev(strtoi(unlist(strsplit(R.oo::trim(indices_to_remove), " "))))
    for (i in seq_len(length(indices))) {
        index_to_remove <- indices[i]
        boards <- boards[-index_to_remove]
        if (length(boards) == 1) {
            break
        }
    }
    boards
}

is_winning_board <- function(board, row_size, last_match) {
    sum(board[last_match[1, 1], ] == "0") == row_size ||
    sum(board[, last_match[1, 2]] == "0") == row_size
}

calc_winning_board <- function(board, call_num) {
    print(board)
    print(call_num)
    print(sum(strtoi(board)) * strtoi(call_num))
}

part1()
part2()


# Type of data
class(dat)
dim(dat)
names(dat)

# Summary stats
summary(dat)
str(dat)
pairs(dat)

# Sneak peek
head(dat)
tail(dat)
dat[sample(nrow(dat), 5), ]

# Remove annoying naming into normal ones
library(rattle)
names(dat) = normVarNames(names(dat))

# Sanitize dates
library(lubridate)
dat$date = ymd(dat$date)

# Remove NAs
dat = na.omit(dat)

# Subset numeric columns
dat[, sapply(dat, is.numeric)]

# Feature selection
library(FSelector)
information.gain(target ~ ., data=dat)

# Resample missing values
library(randomForest)
datnum = dat[, sapply(dat, is.numeric)]
datnum[names(datnum)] = na.roughfix(datnum[names(datnum)])


################################################################################
#    **************************** R companion for **************************
#
# Kenny, D. A., Kashy, D. A., & Cook, W. L. (2006). Dyadic data analysis.
# New York: Guilford Press.
#
# written by Avi Kluger: avik@savion.huji.ac.il
#
#                              CHAPTER 7 -- APIM
# TEST APIM with SEM
################################################################################
rm(list = ls())                               # Clean the Global Environment
cat ("\014")                                  # Clean the R console
if (is.null(dev.list()) == FALSE) dev.off()   # Clean Plots

Table8.9 <-  "26   6766478665
22 85  74766584
17 5375  345345
19 549564  9473
25 65746586  54
22 4265546483  "

Table8.9_df <- read.fwf(textConnection(Table8.9), widths = c(3, rep(1, 12)))
colnames(Table8.9_df) <- c("Age", paste(c("liking", "smiling"),
                          rep(LETTERS[1:6], each = 2), sep = "_"))

Table8.9_df$id <- as.numeric(rownames(Table8.9_df))

if (!require("TripleR")) install.packages("TripleR");
suppressPackageStartupMessages(library(TripleR))

liking_long_df   <- matrix2long(Table8.9_df[, grep("liking",
                                                 colnames(Table8.9_df))])
smiling_long_df  <- matrix2long(Table8.9_df[, grep("smiling",
                                                 colnames(Table8.9_df))])
Table8.9_long_df <- cbind(liking_long_df, smiling_long_df[, 3])

colnames(Table8.9_long_df)[3:4] <- c("smiling", "liking")

fitTable8.9 <- RR(liking + smiling ~ actor.id*partner.id,
                  data = Table8.9_long_df)
fitTable8.9

# Prepare data for correlation with age
if (!require("tidyverse")) install.packages("tidyverse");
suppressPackageStartupMessages(library(tidyverse))

srmEffectsWithIndividualDifferences <-
          cbind(fitTable8.9$univariate[[1]]$effects,
                    fitTable8.9$univariate[[2]]$effects)
srmEffectsWithIndividualDifferences$id <- as.numeric(
                                         srmEffectsWithIndividualDifferences$id)
srmEffectsWithIndividualDifferences <-
          cbind(srmEffectsWithIndividualDifferences,
          Table8.9_df[, c("Age", "id")])

junk <- grep("id", colnames(srmEffectsWithIndividualDifferences))

srmEffectsWithIndividualDifferences <-
                          srmEffectsWithIndividualDifferences[, -junk]
colnames(srmEffectsWithIndividualDifferences) [5] <- "Age"
round(cor(srmEffectsWithIndividualDifferences$Age,
      srmEffectsWithIndividualDifferences[, -5]), 2)


library(sbtools)
library(dataRetrieval)
library(sf) # Requires GEOS, GDAL, proj4

is_logged_in() # check if logged in

item_file_download(sb_id = "5a83025ce4b00f54eb32956b",
                   names = "huc8_05010007_example.zip",
                   destinations = "Data/huc8_05010007_example.zip",
                   overwrite_file = TRUE)

huc_poly <- st_read('Data/huc8_05010007_example')

class(huc_poly) # check type

str(huc_poly) # get data structure

head(huc_poly) # top

st_geometry(huc_poly)

st_bbox(huc_poly) # get boundary box coords

st_crs(huc_poly) # get CRS

huc_gages <- whatNWISdata(huc = "05010007", parameterCd = "00060", service="uv")

head(huc_gages)

# Downloaded packages are found ‘/tmp/RtmpZBp8m6/downloaded_packages’
# Resource: https://www.r-bloggers.com/beyond-basic-r-mapping/


#######      R wrappers for the eval script

eval_2d_km = function(pred, real_lat, real_long) {
  real = data.frame(lat=real_lat, long=real_long)
  eval_full(real_lat=real_lat, real_long=real_long, pred_lat=pred$lat, pred_long=pred$long)
}

eval_full = function(real_lat,real_long, pred_lat, pred_long) {
  d = data.frame(real_lat,real_long, pred_lat, pred_long)
  write_nns(d,"/tmp/tmp.pred")
  system("python ../geo_eval/eval.py < /tmp/tmp.pred | tee /tmp/tmp.results | awk '/^--/{x=1} x'")
  invisible(load_eval_results("/tmp/tmp.results"))
}

load_eval_results = function(filename) {
  # col.names = "km loc1.admin1 loc2.admin1 region1 region2 div1 div2 metro1 metro2"
  col.names = "km state1 state2 region1 region2"
  col.names = strsplit(col.names, " ")[[1]]
  outcomes = read_nns(pipe(sprintf("cat %s | awk '/^--/{exit} 1'",filename)), col.names=col.names)
  list(outcomes=outcomes)
}

eval_center_guess = function(sp_lat, sp_long) {
  lat_ctr = mean(sp_lat$train$y)
  long_ctr= mean(sp_long$train$y)

  eval_full(real_lat=sp_lat$test$y, real_long=sp_long$test$y, pred_lat=lat_ctr, pred_long=long_ctr)
  # system("mv /tmp/tmp.results ../results/center_guess.log")
  #
  # lat_dev =  sp_lat$test$y - lat_ctr
  # long_dev= sp_long$test$y - long_ctr
  # dists = sqrt(lat_dev**2 + long_dev**2)
  # list(
  #   avg_dist = mean(dists),
  #   med_dist = median(dists)
  #   )
}

load_slda = function(filename) {
  # Oh so the way it works is, the last 2303 - 25 + 1 = 2279 lines are the
  #   output for the test set.  The format is
  # auth_id lat_guess lat_true long_guess long_true

  cmd = paste("cat",filename," | awk 'NF==5 && /^[0-9]/'")
  d = read.table(pipe(cmd),col.names=c('id','pred_lat','real_lat','pred_long','real_long'))
  # d = read.table(pipe(cmd),col.names=c('id','pred_long','real_long','pred_lat','real_lat'))
  d
}

eval_one_slda = function(slda_data) {
  with(slda_data, eval_full(real_lat=real_lat, real_long=real_long, pred_lat=pred_lat, pred_long=pred_long))
}

eval_all_slda = function() {
  for (k in c(1,5,10,20,30,40)) {
    print(k)
    d=load_slda(sprintf("../geoslda_201008_camera/runslda.test.%d.out",k))
    eval_one_slda(d)
    system(sprintf("mv /tmp/tmp.results ../results_201008_camera/test/slda.%d.eval",k))
  }
}


#' @export
#' @title cbindPad
#' @description This function adds in NAs to fill in missing rows for combining multiple data sources
#' @param \code{x} = vector, matrix
#' @param \code{y} = vector or matrix to join to \code{x}
#' @return  \code{w}
#' @examples
#' A = matrix(c(2, 4, 3, 1, 5, 7), nrow=2, ncol=3, byrow = TRUE)
#' B = matrix(c(1, 5, 7), nrow=3, ncol=1, byrow = TRUE)
#' cbindPad(A,B)
#' [,1] [,2] [,3] [,4]
#' [1,]    2    4    3    1
#' [2,]    1    5    7    5
#' [3,]   NA   NA   NA    7
#'
#' C=c(1,2,3,4,5)
#' D=c(6,7,8,9,10,11,12,13,14,15)
#' cbindPad(C,D)
#' x  y
#' [1,]  1  6
#' [2,]  2  7
#' [3,]  3  8
#' [4,]  4  9
#' [5,]  5 10
#' [6,] NA 11
#' [7,] NA 12
#' [8,] NA 13
#' [9,] NA 14
#' [10,] NA 15
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
cbindPad <- function(x,y) {
	if(!is.vector(x)) {
	xx <- nrow(x)
	xy <- ncol(x)
	yy <- length(y)
	w <- matrix(NA,nrow=max(c(xx,yy)),ncol=xy+1)
	w[1:xx,1:xy] <- as.matrix(x)
	w[1:yy,(xy+1)] <- y
	return(w)
	} else {
	xx <- length(x)
	yy <- length(y)
	f <- which.max(c(xx,yy))
	if(f==1) y <- c(y,rep(NA,xx-yy))
	if(f==2) x <- c(x,rep(NA,yy-xx))
	w <- cbind(x,y)
	return(w)
	}

}


#  James Rekow

meanOverDOCCreator = function(MVec = NULL, lambdaVec = NULL, N = 20, iStrength = 1, univ = 1,
                              sigmaMax = 0.1, thresholdMult = 10 ^ (-4), maxSteps = 10 ^ 4,
                              tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01){

  source("abdListCreator.r")
  source("DOCProcedure.r")

  if(is.null(MVec)){

    MVec = seq(40, 200, 40)

  } #  end if

  if(is.null(lambdaVec)){

  lambdaVec = seq(0, 200, 50)

  } #  end if

  meanOverProducer = function(inputVec){

    M = inputVec[1]
    lambda = inputVec[2]

    abdList = abdListCreator(M = M, N = N, iStrength = iStrength, univ = univ, sigmaMax = sigmaMax,
                             thresholdMult = thresholdMult, maxSteps = maxSteps, tStep = tStep,
                             intTime = intTime, interSmplMult = interSmplMult, lambda = lambda,
                             returnParams = FALSE, conGraph = NULL)

    doc = DOCProcedure(abdList)
    meanOver = mean(doc[[1]])

    return(meanOver)

  } #  end meanOVerProducer function

  inputMat = expand.grid(MVec, lambdaVec)
  meanOver = apply(inputMat, 1, meanOverProducer)

  meanOverDOC = data.frame(M = inputMat[ , 1], lambda = inputMat[ , 2], meanOver)

  return(meanOverDOC)

} #  end meanOverDOCCreator function


#' Line segments parameterised by location, direction and distance
#'
#' This is a polar parameterisation of [geom_segment()]. It is
#' useful when you have variables that describe direction and distance.
#' The angles start from east and increase counterclockwise.
#'
#' @eval rd_aesthetics("geom", "spoke")
#' @inheritParams layer
#' @inheritParams geom_segment
#' @export
#' @examples
#' df <- expand.grid(x = 1:10, y=1:10)
#' df$angle <- runif(100, 0, 2*pi)
#' df$speed <- runif(100, 0, sqrt(0.1 * df$x))
#'
#' ggplot(df, aes(x, y)) +
#'   geom_point() +
#'   geom_spoke(aes(angle = angle), radius = 0.5)
#'
#' ggplot(df, aes(x, y)) +
#'   geom_point() +
#'   geom_spoke(aes(angle = angle, radius = speed))
geom_spoke <- function(mapping = NULL, data = NULL,
                       stat = "identity", position = "identity",
                       ...,
                       na.rm = FALSE,
                       show.legend = NA,
                       inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    geom = GeomSpoke,
    stat = stat,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      ...
    )
  )
}

#' @export
#' @rdname geom_spoke
#' @usage NULL
stat_spoke <- function(...) {
  message("stat_spoke is deprecated, please use geom_spoke")
  geom_spoke(...)
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomSpoke <- ggproto("GeomSpoke", GeomSegment,
  setup_data = function(data, params) {
    data$radius <- data$radius %||% params$radius
    data$angle <- data$angle %||% params$angle

    transform(data,
      xend = x + cos(angle) * radius,
      yend = y + sin(angle) * radius
    )
  },
  required_aes = c("x", "y", "angle", "radius")
)


library(assertthat)
library(rlearner)
library(tictoc)
library(grf)

source("data_structures.r")

methods<-function(){
  #return (c(raw_method,raw_plus_rand,raw_plus_rand,raw_plus_rand))
  return (c(raw_method,r_boost,r_lasso,causal_forest_ate))
}

raw_plus_rand<-function(data){
  r<- runif(1, 3, 10)
  return (raw_method(data)+r)
}
methods_names<-function(){
  return (c("raw","r_boost","r_lasso","causal_forest"))
}

run_methods<-function(data){
  assert_that(is(data,"data"))

  ates<-0
  for(i in 1:length(methods())){
    ates[i]<-methods()[[i]](data)
  }

  return (ates)
}

r_lasso<-function(data){
  tic("rlasso")
  assert_that(is(data,"data"))

  rlasso_fit = rlasso(data$X, data$W*1, data$Y)

  predictions <- predict(rlasso_fit,data$X)

  ate <- mean(predictions)

  toc()

  return(ate)
}

r_boost<-function(data){
  tic("rboost")
  assert_that(is(data,"data"))

  rboost_fit = rboost(data$X, data$W*1, data$Y)
  predictions <- predict(rboost_fit,data$X)

  ate <- mean(predictions)

  toc()

  return(ate)
}

causal_forest_ate<-function(data){
  tic("causal_forest")
  assert_that(is(data,"data"))

  c_forest = causal_forest(data$X, data$Y, data$W*1)

  predictions<-predict(c_forest,data$X)[["predictions"]]

  ate <- mean(predictions)

  toc()
  return (ate)
}

ate_from_predictions<-function(predictions,W){
  assert_that(is.numeric(predictions))
  assert_that(is.logical(W))
  assert_that(length(predictions)==length(W))

  ind_tr<-which(W)
  ind_contr<-which(!W)

  est_tr = predictions[ind_tr]
  est_contr = predictions[ind_contr]

  m_tr<-mean(est_tr)
  m_contr<-mean(est_contr)
  return (m_tr-m_contr)
}

raw_method<-function(data){
  tic("raw_method")
  assert_that(is(data,"data"))

  mean_treated<-mean(data$Y[data$W])
  mean_control<-mean(data$Y[!data$W])

  ate<-mean_treated-mean_control
  toc()
  return (ate)
}


library(devtools)
load_all()
ss <- try(simulateGP::create_system(
    nidx=400000,
    nidy=400000,
    nidu=0,
    nu=3,
    na=0,
    nb=0,
    var_x.y=sample(c(0, runif(5, 0.001, 0.1)), 1),
    nsnp_x=80,
    nsnp_y=80,
    var_gx.x=runif(1, 0.01, 0.1),
    var_gy.y=runif(1, 0.01, 0.1),
    var_gx.y=runif(1, 0.001, 0.01),
    mu_gx.y=runif(1, -0.005, 0.005),
    prop_gx.y=runif(1, 0, 1),
    var_gy.x=runif(1, 0.001, 0.01),
    mu_gy.x=runif(1, -0.005, 0.005),
    prop_gy.x=runif(1, 0, 1)
))

o <- test_system(ss)

theoretical approach to simulating ss

g -> x
g -> y
g -> u -> x
g -> u -> y
g -> x -> y

a <- init_parameters(
var_x.y=sample(c(0, runif(5, 0.001, 0.1)), 1),
nsnp_x=80,
nsnp_y=80,
var_gx.x=runif(1, 0.01, 0.1),
var_gy.y=runif(1, 0.01, 0.1),
var_gx.y=runif(1, 0.001, 0.01),
mu_gx.y=runif(1, -0.005, 0.005),
prop_gx.y=runif(1, 0, 1),
var_gy.x=runif(1, 0.001, 0.01),
mu_gy.x=runif(1, -0.005, 0.005),
prop_gy.x=runif(1, 0, 1)
)
a <- sample_system_effects(a)

u <- rnorm(1000)
x <- rnorm(1000) + u*2
y <- rnorm(1000) + u + x*4

lm(x ~ u)
lm(y ~ u)

expected_gwas(9, 10000, 5, 99)

expected_gwas(0, 10000, 1, 2)

x <- rnorm(10000)
y <- rnorm(10000) + x
summary(lm(y ~ x))$coeff[2,3]^2

(cor(x,y)^2 * 10000-2) / (1-cor(x,y)^2)

pop <- simulate_population(a, 500000)

# direct effects
emp <- estimate_system_effects(pop)

expx <- expected_gwas(a$eff_gx.x/sqrt(0.5), 500000, 1, 1)
plot(x$x$bhat[x$x$inst == 'x'], expx$bhat)
abline(0,1)

expyx <- expected_gwas(a$eff_gy.x/sqrt(0.5), 500000, 1, 1)
plot(x$x$bhat[x$x$inst == 'y'], expyx$bhat)
abline(0,1)

expxy <- expected_gwas(a$eff_gx.x/sqrt(0.5) * a$eff_x.y + a$eff_gx.y/sqrt(0.5), 500000, 1, 1)
plot(x$y$bhat[x$y$inst == 'x'], expxy$bhat)
abline(0,1)

expy <- expected_gwas(a$eff_gy.y/sqrt(0.5), 500000, 1, 1)
plot(x$y$bhat[x$y$inst == 'y'], expy$bhat)
abline(0,1)

expx <- expected_gwas(a$eff_gx.x/sqrt(0.5), 500000, 1, 1)
plot(emp$x$se[emp$x$inst == 'x'], expx$se)
abline(0,1)

expyx <- expected_gwas(a$eff_gy.x/sqrt(0.5), 500000, 1, 1)
plot(emp$x$se[emp$x$inst == 'y'], expyx$se)
abline(0,1)

expxy <- expected_gwas(a$eff_gx.x/sqrt(0.5) * a$eff_x.y + a$eff_gx.y/sqrt(0.5), 500000, 1, 1)
plot(emp$y$se[emp$y$inst == 'x'], expxy$se)
abline(0,1)

expy <- expected_gwas(a$eff_gy.y/sqrt(0.5), 500000, 1, 1)
plot(emp$y$se[emp$y$inst == 'y'], expy$se)
abline(0,1)

F = rsq / ()

alternative_expected_gwas <- function(eff, n, vx, vy)
{
	rsq <- eff^2 * vx / vy
	fval = (rsq * (n-2)) / (1 - rsq)
	tval = sqrt(fval)
	se = abs(eff / tval)
	p <- pt(abs(tval), n-1, lower.tail=FALSE)
	dat <- tibble::data_frame(bhat=eff, se=se, fval=tval^2, pval=p, n=n)
	return(dat)
}

# problem - not getting correct standard error
# fval seems to be only correct if half sample size is assumed??

n <- 10000
nsnp <- 100
eff <- rnorm(nsnp)
maf <- runif(nsnp)/2
h2 <- 0.5
g <- make_geno(n, nsnp, maf)
grs <- g %*% eff
y <- grs + rnorm(n, sd=sqrt(var(grs)))


# context("Parameter estimation")

set.seed(15)
n <- 200
P <- 1
psi  <- c(.01, .01)
mu_d <- c(.05, .05)
eta  <- c(.8, .9)
Pi   <- .2

dat <- raphylo(n, P=P, psi = psi, mu_d = mu_d, Pi = Pi, eta = eta)

# Estimation via L-BFGS-B

ans0 <- suppressWarnings({
  aphylo_mle(
    dat ~ mu_d + psi + eta + Pi,
    params = c(.05, .05, .05, .05, .5, .5, .5)
    )
})

# Methods ----------------------------------------------------------------------
# test_that("Methods", {

  # Printing
  expect_silent(suppressWarnings(print(ans0)))

  # Plotting
  expect_silent(plot(ans0))
  expect_silent(plot_logLik(ans0))

  # Extracting coef and others
  expect_equal(coef(ans0), ans0$par)
  expect_equal(vcov(ans0), ans0$varcovar)

# })

# ------------------------------------------------------------------------------
# test_that("MCMC", {
  ans1 <- suppressWarnings(
    aphylo_mcmc(dat ~ mu_d + psi + eta + Pi, params = ans0$par,
                priors = function(p) 1,
                control = list(
                  nsteps = 4e3, burnin=1e3, thin=20,
                  conv_checker = NULL, nchains=1
                  )
                )
  )

  # Testing the window function
  expect_equal(window(ans1, 2000)$hist, window(ans1$hist, 2000))

  # Checking expectations. It is difficult to do so with PI, so we exclude it.
  expect_equal(ans0$par[-7], ans1$par[-7], tolerance = 0.1, scale = 1)

  # Plotting
  expect_silent(plot(ans1))
  expect_silent(plot_logLik(ans1))

  # Extracting coef and others
  expect_equal(coef(ans1), ans1$par)
  expect_equal(vcov(ans1), ans1$varcovar)
# })

# test_that("MCMC: in a degenerate case all parameters goes to the prior", {

set.seed(1)
dat <- suppressWarnings(raphylo(50, Pi=0, mu_d=c(0, 0), psi=c(0,0)))
dat$tip.annotation[] <- 9L

ans1 <- suppressWarnings(
  aphylo_mcmc(dat ~ mu_d + psi + Pi,
              params = c(rep(2/12, 4), 2/12),
              priors = function(x) dbeta(x, 2, 10),
              control = list(
                nsteps = 4e3, burnin=2e3, nchains=2,
                kernel = fmcmc::kernel_adapt(
                  lb = 0, ub = 1, eps = .05
                  ),
                conv_checker = NULL
                ),
              check_informative = FALSE
              )
  )

ans2 <- suppressWarnings(
  aphylo_mcmc(
    dat ~ mu_d + psi + Pi,
    params = c(rep(2/22, 4), 2/22),
    priors = function(x) dbeta(x, 2, 20),
    control = list(
      nsteps = 4e3, burnin=2e3, nchains=2,
      kernel = fmcmc::kernel_adapt(
        lb = 0, ub = 1, eps = .05),
      conv_checker = NULL
      ),
    check_informative = FALSE
    )
)

  # Should converge to the prior
expect_true(all(abs(unname(coef(ans1)) - rep(2/12, 5)) < .025))
expect_true(all(abs(unname(coef(ans2)) - rep(2/22, 5)) < .025))

# })

# test_that("mu_d and mu_s work", {

  dat   <- c(1, 2, 1, 3, 2, 4, 2, 5, 3, 6, 6, 7, 6, 8, 4, 9, 4, 10)
  dat   <- as.phylo(matrix(dat, ncol=2, byrow = TRUE))
  types <- c(1, 1, 1, 1, 1, 0, 1, 1, 1, 1)

  set.seed(1)

  tree <- raphylo(
    tree      = dat,
    tip.type  = types[dat$tip.label],
    node.type = types[dat$node.label],
    psi       = c(0, 0),
    eta       = c(1,1),
    mu_d      = c(.9,0),
    mu_s      = c(0,0),
    Pi        = 0
  )

  plot(tree)

  ans_mcmc <- suppressWarnings(aphylo_mcmc(tree ~ mu_d + mu_s, priors = function(p) {
    c(dbeta(p[c("mu_d0", "mu_d1")], 10, 2),
      dbeta(p[c("mu_s0", "mu_s1")], 2, 10))
  }, control = list(nsteps = 4e3, burnin = 1e3, nchains = 1)))

  ans_mcmc_pll <- suppressWarnings(aphylo_mcmc(tree ~ mu_d + mu_s, priors = function(p) {
    c(dbeta(p[c("mu_d0", "mu_d1")], 10, 2),
      dbeta(p[c("mu_s0", "mu_s1")], 2, 10))
  }, control = list(nsteps = 4e3, burnin = 1e3, nchains = 2, multicore = TRUE)))

  ans_mle <- aphylo_mle(tree ~ mu_d + mu_s, priors = function(p) {
    c(dbeta(p[c("mu_d0", "mu_d1")], 10, 2),
      dbeta(p[c("mu_s0", "mu_s1")], 2, 10))
  })

  expect_equivalent(
    predict(ans_mle, loo = FALSE), predict(ans_mcmc, loo = FALSE),
    tol=.1, scale = 1
    )

# })


 DGBRFS Example Program Results

 Solution(s)
             1          2
 1     -2.0000     1.0000
 2      3.0000    -4.0000
 3      1.0000     7.0000
 4     -4.0000    -2.0000

 Backward errors (machine-dependent)
       1.1E-16    9.9E-17
 Estimated forward error bounds (machine-dependent)
       1.6E-14    1.9E-14


#!/usr/bin/env Rscript
args = commandArgs(trailingOnly=TRUE)

firstFile = args[1]
numFiles = as.integer(args[2])

rows = nrow(read.table(firstFile))-1
colm = ncol(read.table(firstFile))

emptyVert <- matrix(nrow=rows,ncol=numFiles)
tumorOcc <- matrix(nrow=rows,ncol=numFiles)
healthOcc <- matrix(nrow=rows,ncol=numFiles)

fileName <- substr(firstFile,1, nchar(firstFile)-5)

for (i in 1:numFiles) {
  currFile = paste(fileName,i,".out",sep="");
  emptyVert[,i] = read.table(currFile)[-1,2]
  tumorOcc[,i] = read.table(currFile)[-1,3]
  healthOcc[,i] = read.table(currFile)[-1,4]
}

rows = nrow(emptyVert)

avrOcc <- matrix(nrow=rows,ncol=colm)
stdOcc <- matrix(nrow=rows,ncol=colm)

avrOcc[,1] = read.table(currFile)[-1,1]
stdOcc[,1] = read.table(currFile)[-1,1]

for (j in 1:rows){
  avrOcc[j,2] = mean(emptyVert[j,])
  avrOcc[j,3] = mean(tumorOcc[j,])
  avrOcc[j,4] = mean(healthOcc[j,])

  stdOcc[j,2] = sd(emptyVert[j,])
  stdOcc[j,3] = sd(tumorOcc[j,])
  stdOcc[j,4] = sd(healthOcc[j,])
}

finalMatrix <- cbind(avrOcc[,1:4],stdOcc[,3:4])
output <- paste(fileName,numFiles,"_statOcc.out",sep="");

write.table(format(finalMatrix, digits = 4, scientific = F, trim = T, drop0trailing = T), quote = F, file=output, row.names=F, col.names=F, sep = "\t")


## @knitr p1

n = 100
x = 1:n
y = x + runif(n)

## @knitr p2

plot(x, y)
plot(x, log(y))

## @knitr p3

too_many_na = function(d, threshold, axis) {
    # check arguments and issue warnings
    if (!all(sapply(d, is.numeric))) warning("Non-numerical elements")
    if (!is.numeric(threshold)) warning("Threshold should be a number")
    if ((threshold < 0) & (threshold > 0)) warning("Threshold should be in (0,1)")
    ## if axis isn't 1 or 2, we will throw an error anyway
    #if (!(axis %in% c(1,2))) warning("Axis must be in 1 or 2")

    ## if you wanted to throw an error instead of giving a warning
    # stopifnot(all(sapply(d, is.numeric)))
    ## or if you have loaded the testthat package
    # expect_that(all(sapply(d, is.numeric)), is_true())

    # do your thing
    na_prop  = apply(is.na(d), axis, mean)
    indices = unname(which(na_prop > threshold))
    return(indices)
}

## @knitr session
print(sessionInfo(), locale=FALSE)


library(cummeRbund)
args <- commandArgs(trailingOnly=TRUE)
error_file <- file(args[1], open="wt")
sink(error_file, type="message")
cuff <- readCufflinks()
sig_genes <- readRDS('significant_genes.rds')
k_means_cluster<-csCluster(sig_genes,k=as.numeric(args[3]))
Cluster_Num <- k_means_cluster$cluster
Cluster_Num <- Cluster_Num[order(Cluster_Num)]
k_means_cluster_data <- data.frame(Cluster_Num)
write.table(k_means_cluster_data, 'k_means_cluster.txt', sep="\t",quote=FALSE)
k_means_cluster_plot <- csClusterPlot(k_means_cluster)
png(args[2],width = 10, height = 10, units= 'in',res=600)
print(k_means_cluster_plot)
dev.off()


context("data_dredge_correlation")

library(magrittr)
library(mnmacros)
#library(testthat)

rm(list = ls())
set.seed(0)

y1 <- seq(-10, 10, .5) %>% as.integer()
y2 <- y1 + y1 %>% length() %>% rnorm()
y3 <- y1^3 + y1 %>% length() %>% rnorm()
y4 <- y1 %>% length() %>% rep('a', .)
y5 <- y4 %>% factor()
y6 <- y1 %>% length() %>% rep(T, .)
y7 <- y1 %>% length() %>% rep(5, .) %>% as.integer()

# not enough columns
expect_error(
  data.frame(y1) %>% data_dredge_correlation(),
  "good_column_count >= 2")

# not enough _good_ columns
expect_error(
  data.frame(y1, y4) %>% data_dredge_correlation(),
  "good_column_count >= 2")

# simple 2 column test
actual <- data.frame(y1, y2) %>% data_dredge_correlation()
expected <- data.frame(
  column_a = c("y1"),
  column_b = c("y2"),
  estimate = c(0.9882),
  p.value = c(0),
  lag = c(0),
  stringsAsFactors = F)
expect_equal(actual, expected, tolerance = 0.001)

# simple 3 column test
actual <- data.frame(y1, y2, y3) %>% data_dredge_correlation()
expected <- data.frame(
  column_a = c("y1", "y1", "y2"),
  column_b = c("y2", "y3", "y3"),
  estimate = c(0.9882, 0.9136, 0.9049),
  p.value = c(0, 0, 0),
  lag = c(0, 0, 0),
  stringsAsFactors = F)
expect_equal(actual, expected, tolerance = 0.001)

# mixed case test
actual <-
  data.frame(y1, y2, y4, stringsAsFactors = F) %>%
  data_dredge_correlation()
expected <- data.frame(
  column_a = c("y1"),
  column_b = c("y2"),
  estimate = c(0.9882),
  p.value = c(0),
  lag = c(0),
  stringsAsFactors = F)
expect_equal(actual, expected, tolerance = 0.001)

# no variation test
actual <- data.frame(y1, y7) %>% data_dredge_correlation()
expect_equal(actual %>% nrow(), 0)

# big mixed case test
actual <-
  data.frame(y1, y2, y3, y4, y5, y6, y7, stringsAsFactors = F) %>%
  data_dredge_correlation()
expected <- data.frame(
  column_a = c("y1", "y1", "y2"),
  column_b = c("y2", "y3", "y3"),
  estimate = c(0.9882, 0.9136, 0.9049),
  p.value = c(0, 0, 0),
  lag = c(0, 0, 0),
  stringsAsFactors = F
)
expect_equal(actual, expected, tolerance = 0.001)