Exemple #1
0
/* return the skeleton of a DAG/PDAG. */
SEXP dag2ug(SEXP bn, SEXP moral, SEXP debug) {

int i = 0, j = 0, k = 0, nnodes = 0, narcs = 0, row = 0;
int debuglevel = isTRUE(debug), *moralize = LOGICAL(moral);
int *nparents = NULL, *nnbr = NULL;
SEXP node_data, current, nodes, result, temp;

  /* get the nodes' data. */
  node_data = getListElement(bn, "nodes");
  nnodes = length(node_data);
  PROTECT(nodes = getAttrib(node_data, R_NamesSymbol));

  /* allocate and initialize parents' and neighbours' counters. */
  nnbr = Calloc1D(nnodes, sizeof(int));
  if (*moralize > 0)
    nparents = Calloc1D(nnodes, sizeof(int));

  /* first pass: count neighbours, parents and resulting arcs. */
  for (i = 0; i < nnodes; i++) {

    /* get the number of neighbours.  */
    current = VECTOR_ELT(node_data, i);
    nnbr[i] = length(getListElement(current, "nbr"));

    /* update the number of arcs to be returned. */
    if (*moralize > 0) {

      /* get also the number of parents, needed to account for the arcs added
       * for their moralization. */
      nparents[i] = length(getListElement(current, "parents"));
      narcs += nnbr[i] + nparents[i] * (nparents[i] - 1);

    }/*THEN*/
    else {

      narcs += nnbr[i];

    }/*ELSE*/

    if (debuglevel > 0)  {

      if (*moralize > 0) {

        Rprintf("* scanning node %s, found %d neighbours and %d parents.\n",
          NODE(i), nnbr[i], nparents[i]);
        Rprintf("  > adding %d arcs, for a total of %d.\n",
          nnbr[i] + nparents[i] * (nparents[i] - 1), narcs);

      }/*THEN*/
      else {

        Rprintf("* scanning node %s, found %d neighbours.\n", NODE(i), nnbr[i]);
        Rprintf("  > adding %d arcs, for a total of %d.\n", nnbr[i], narcs);

      }/*ELSE*/

    }/*THEN*/

  }/*FOR*/

  /* allocate the return value. */
  PROTECT(result = allocMatrix(STRSXP, narcs, 2));
  /* allocate and set the column names. */
  setDimNames(result, R_NilValue, mkStringVec(2, "from", "to"));

  /* second pass: fill the return value. */
  for (i = 0; i < nnodes; i++) {

    /* get to the current node. */
    current = VECTOR_ELT(node_data, i);
    /* get the neighbours. */
    temp = getListElement(current, "nbr");

    for (j = 0; j < nnbr[i]; j++) {

      SET_STRING_ELT(result, CMC(row, 0, narcs), STRING_ELT(nodes, i));
      SET_STRING_ELT(result, CMC(row, 1, narcs), STRING_ELT(temp, j));
      row++;

    }/*FOR*/

    /* if we are not creating a moral graph we are done with this node. */
    if (*moralize == 0)
      continue;

    /* get the parents. */
    temp = getListElement(current, "parents");

    for (j = 0; j < nparents[i]; j++) {

      for (k = j+1; k < nparents[i]; k++) {

        SET_STRING_ELT(result, CMC(row, 0, narcs), STRING_ELT(temp, k));
        SET_STRING_ELT(result, CMC(row, 1, narcs), STRING_ELT(temp, j));
        row++;
        SET_STRING_ELT(result, CMC(row, 0, narcs), STRING_ELT(temp, j));
        SET_STRING_ELT(result, CMC(row, 1, narcs), STRING_ELT(temp, k));
        row++;

      }/*FOR*/

    }/*FOR*/

  }/*FOR*/

  Free1D(nnbr);

  if (*moralize > 0) {

    /* be really sure not to return duplicate arcs in moral graphs when
     * shielded parents are present (the "shielding" nodes are counted
     * twice). */
    result = c_unique_arcs(result, nodes, FALSE);

    Free1D(nparents);

  }/*THEN*/

  UNPROTECT(2);

  return result;

}/*DAG2UG*/
Exemple #2
0
void bmerge_r(int xlowIn, int xuppIn, int ilowIn, int iuppIn, int col, int lowmax, int uppmax)
// col is >0 and <=ncol-1 if this range of [xlow,xupp] and [ilow,iupp] match up to but not including that column
// lowmax=1 if xlowIn is the lower bound of this group (needed for roll)
// uppmax=1 if xuppIn is the upper bound of this group (needed for roll)
{
    int xlow=xlowIn, xupp=xuppIn, ilow=ilowIn, iupp=iuppIn, j, k, ir, lir, tmp;
    SEXP class;
    ir = lir = ilow + (iupp-ilow)/2;           // lir = logical i row.
    if (o) ir = o[lir]-1;                      // ir = the actual i row if i were ordered

    ic = VECTOR_ELT(i,icols[col]-1);  // ic = i column
    xc = VECTOR_ELT(x,xcols[col]-1);  // xc = x column
    // it was checked in bmerge() that the types are equal
    
    switch (TYPEOF(xc)) {
    case LGLSXP : case INTSXP :   // including factors
        ival.i = INTEGER(ic)[ir];
        while(xlow < xupp-1) {
            mid = xlow + (xupp-xlow)/2;   // Same as (xlow+xupp)/2 but without risk of overflow
            xval.i = INTEGER(xc)[XIND(mid)];
            if (xval.i<ival.i) {          // relies on NA_INTEGER == INT_MIN, tested in init.c
                xlow=mid;
            } else if (xval.i>ival.i) {   // TO DO: is *(&xlow, &xupp)[0|1]=mid more efficient than branch?
                xupp=mid;
            } else { // xval.i == ival.i  including NA_INTEGER==NA_INTEGER
                // branch mid to find start and end of this group in this column
                // TO DO?: not if mult=first|last and col<ncol-1
                tmplow = mid;
                tmpupp = mid;
                while(tmplow<xupp-1) {
                    mid = tmplow + (xupp-tmplow)/2;
                    xval.i = INTEGER(xc)[XIND(mid)];
                    if (xval.i == ival.i) tmplow=mid; else xupp=mid;
                }
                while(xlow<tmpupp-1) {
                    mid = xlow + (tmpupp-xlow)/2;
                    xval.i = INTEGER(xc)[XIND(mid)];
                    if (xval.i == ival.i) tmpupp=mid; else xlow=mid;
                }
                // xlow and xupp now surround the group in xc, we only need this range for the next column
                break;
            }
        }
        tmplow = lir;
        tmpupp = lir;
        while(tmplow<iupp-1) {   // TO DO: could double up from lir rather than halving from iupp
            mid = tmplow + (iupp-tmplow)/2;
            xval.i = INTEGER(ic)[ o ? o[mid]-1 : mid ];   // reuse xval to search in i
            if (xval.i == ival.i) tmplow=mid; else iupp=mid;
        }
        while(ilow<tmpupp-1) {
            mid = ilow + (tmpupp-ilow)/2;
            xval.i = INTEGER(ic)[ o ? o[mid]-1 : mid ];
            if (xval.i == ival.i) tmpupp=mid; else ilow=mid;
        }
        // ilow and iupp now surround the group in ic, too
        break;
    case STRSXP :
        ival.s = ENC2UTF8(STRING_ELT(ic,ir));
        while(xlow < xupp-1) {
            mid = xlow + (xupp-xlow)/2;
            xval.s = ENC2UTF8(STRING_ELT(xc, XIND(mid)));
            tmp = StrCmp(xval.s, ival.s);  // uses pointer equality first, NA_STRING are allowed and joined to, then uses strcmp on CHAR().
            if (tmp == 0) {                // TO DO: deal with mixed encodings and locale optionally
                tmplow = mid;
                tmpupp = mid;
                while(tmplow<xupp-1) {
                    mid = tmplow + (xupp-tmplow)/2;
                    xval.s = ENC2UTF8(STRING_ELT(xc, XIND(mid)));
                    if (ival.s == xval.s) tmplow=mid; else xupp=mid;  // the == here handles encodings as well. Marked non-utf8 encodings are converted to utf-8 using ENC2UTF8.
                }
                while(xlow<tmpupp-1) {
                    mid = xlow + (tmpupp-xlow)/2;
                    xval.s = ENC2UTF8(STRING_ELT(xc, XIND(mid)));
                    if (ival.s == xval.s) tmpupp=mid; else xlow=mid;  // see above re ==
                }
                break;
            } else if (tmp < 0) {
                xlow=mid;
            } else {
                xupp=mid;
            }
        }
        tmplow = lir;
        tmpupp = lir;
        while(tmplow<iupp-1) {
            mid = tmplow + (iupp-tmplow)/2;
            xval.s = ENC2UTF8(STRING_ELT(ic, o ? o[mid]-1 : mid));
            if (xval.s == ival.s) tmplow=mid; else iupp=mid;   // see above re ==
        }
        while(ilow<tmpupp-1) {
            mid = ilow + (tmpupp-ilow)/2;
            xval.s = ENC2UTF8(STRING_ELT(ic, o ? o[mid]-1 : mid));
            if (xval.s == ival.s) tmpupp=mid; else ilow=mid;   // see above re == 
        }
        break;
    case REALSXP :
        class = getAttrib(xc, R_ClassSymbol);
        twiddle = (isString(class) && STRING_ELT(class, 0)==char_integer64) ? &i64twiddle : &dtwiddle;
        ival.ll = twiddle(DATAPTR(ic), ir, 1);
        while(xlow < xupp-1) {
            mid = xlow + (xupp-xlow)/2;
            xval.ll = twiddle(DATAPTR(xc), XIND(mid), 1);
            if (xval.ll<ival.ll) {
                xlow=mid;
            } else if (xval.ll>ival.ll) {
                xupp=mid;
            } else { // xval.ll == ival.ll) 
                tmplow = mid;
                tmpupp = mid;
                while(tmplow<xupp-1) {
                    mid = tmplow + (xupp-tmplow)/2;
                    xval.ll = twiddle(DATAPTR(xc), XIND(mid), 1);
                    if (xval.ll == ival.ll) tmplow=mid; else xupp=mid;
                }
                while(xlow<tmpupp-1) {
                    mid = xlow + (tmpupp-xlow)/2;
                    xval.ll = twiddle(DATAPTR(xc), XIND(mid), 1);
                    if (xval.ll == ival.ll) tmpupp=mid; else xlow=mid;
                }
                break;
            }
        }
        tmplow = lir;
        tmpupp = lir;
        while(tmplow<iupp-1) {
            mid = tmplow + (iupp-tmplow)/2;
            xval.ll = twiddle(DATAPTR(ic), o ? o[mid]-1 : mid, 1 );
            if (xval.ll == ival.ll) tmplow=mid; else iupp=mid;
        }
        while(ilow<tmpupp-1) {
            mid = ilow + (tmpupp-ilow)/2;
            xval.ll = twiddle(DATAPTR(ic), o ? o[mid]-1 : mid, 1 );
            if (xval.ll == ival.ll) tmpupp=mid; else ilow=mid;
        }
        break;
    default:
        error("Type '%s' not supported as key column", type2char(TYPEOF(xc)));
    }
    
    if (xlow<xupp-1) {      // if value found, low and upp surround it, unlike standard binary search where low falls on it
        if (col<ncol-1) bmerge_r(xlow, xupp, ilow, iupp, col+1, 1, 1);  // final two 1's are lowmax and uppmax
        else {
            int len = xupp-xlow-1;
            if (len>1) allLen1[0] = FALSE;
            for (j=ilow+1; j<iupp; j++) {   // usually iterates once only for j=ir
                k = o ? o[j]-1 : j;
                retFirst[k] = xlow+2;       // extra +1 for 1-based indexing at R level
                retLength[k]= len; 
            }
        }
    }
    else if (roll!=0.0 && col==ncol-1) {
        // runs once per i row (not each search test), so not hugely time critical
        if (xlow != xupp-1 || xlow<xlowIn || xupp>xuppIn) error("Internal error: xlow!=xupp-1 || xlow<xlowIn || xupp>xuppIn");
        if (rollToNearest) {   // value of roll ignored currently when nearest
            if ( (!lowmax || xlow>xlowIn) && (!uppmax || xupp<xuppIn) ) {
                if (  ( TYPEOF(ic)==REALSXP && REAL(ic)[ir]-REAL(xc)[XIND(xlow)] <= REAL(xc)[XIND(xupp)]-REAL(ic)[ir] )
                   || ( TYPEOF(ic)<=INTSXP && INTEGER(ic)[ir]-INTEGER(xc)[XIND(xlow)] <= INTEGER(xc)[XIND(xupp)]-INTEGER(ic)[ir] )) {
                    retFirst[ir] = xlow+1;
                    retLength[ir] = 1;
                } else {
                    retFirst[ir] = xupp+1;
                    retLength[ir] = 1;
                }
            } else if (uppmax && xupp==xuppIn && rollends[1]) {
                retFirst[ir] = xlow+1;
                retLength[ir] = 1;
            } else if (lowmax && xlow==xlowIn && rollends[0]) {
                retFirst[ir] = xupp+1;
                retLength[ir] = 1;
            }
        } else {
            // fix for #1405
            if (TYPEOF(ic) == REALSXP) {
                xvalupp.ll = REAL(xc)[XIND(xupp)];
                xvallow.ll = REAL(xc)[XIND(xlow)];
                ival.ll = REAL(ic)[ir];
            }
            if ( (   (roll>0.0 && (!lowmax || xlow>xlowIn) && (xupp<xuppIn || !uppmax || rollends[1]))
                  || (roll<0.0 && xupp==xuppIn && uppmax && rollends[1]) )
              && (   (TYPEOF(ic)==REALSXP && ((double)(ival.ll-xvallow.ll)-rollabs<1e-6 || 
                                              (double)(ival.ll-xvallow.ll) == rollabs)) // #1007 fix
                  || (TYPEOF(ic)<=INTSXP && (double)(INTEGER(ic)[ir]-INTEGER(xc)[XIND(xlow)])-rollabs<1e-6 ) 
                  || (TYPEOF(ic)==STRSXP)   )) {
                retFirst[ir] = xlow+1;
                retLength[ir] = 1;
            } else if
               (  (  (roll<0.0 && (!uppmax || xupp<xuppIn) && (xlow>xlowIn || !lowmax || rollends[0]))
                  || (roll>0.0 && xlow==xlowIn && lowmax && rollends[0]) )
              && (   (TYPEOF(ic)==REALSXP && ((double)(xvalupp.ll-ival.ll)-rollabs<1e-6 || 
                                              (double)(xvalupp.ll-ival.ll) == rollabs)) // 1007 fix
                  || (TYPEOF(ic)<=INTSXP && (double)(INTEGER(xc)[XIND(xupp)]-INTEGER(ic)[ir])-rollabs<1e-6 )
                  || (TYPEOF(ic)==STRSXP)   )) {
                retFirst[ir] = xupp+1;   // == xlow+2
                retLength[ir] = 1;
            }
        }
        if (iupp-ilow > 2 && retFirst[ir]!=NA_INTEGER) {  // >=2 equal values in the last column being rolling to the same point.  
            for (j=ilow+1; j<iupp; j++) {                 // will rewrite retFirst[ir] to itself, but that's ok
                if (o) k=o[j]-1; else k=j;
                retFirst[k] = retFirst[ir];
                retLength[k]= retLength[ir]; 
            }
        }
    }
    if (ilow>ilowIn && (xlow>xlowIn || (roll!=0.0 && col==ncol-1)))
        bmerge_r(xlowIn, xlow+1, ilowIn, ilow+1, col, lowmax, uppmax && xlow+1==xuppIn);
    if (iupp<iuppIn && (xupp<xuppIn || (roll!=0.0 && col==ncol-1)))
        bmerge_r(xupp-1, xuppIn, iupp-1, iuppIn, col, lowmax && xupp-1==xlowIn, uppmax);
}
SEXP bmerge(SEXP iArg, SEXP xArg, SEXP icolsArg, SEXP xcolsArg, SEXP isorted, SEXP rollarg, SEXP rollendsArg, SEXP nomatch, SEXP retFirstArg, SEXP retLengthArg, SEXP allLen1Arg)
{
    int xN, iN, protecti=0;
    roll = 0.0;
    nearest = FALSE;
    enc_warn = TRUE;
    if (isString(rollarg)) {
        if (strcmp(CHAR(STRING_ELT(rollarg,0)),"nearest") != 0) error("roll is character but not 'nearest'");
        roll=1.0;
        nearest=TRUE;       // the 1.0 here is just any non-0.0, so roll!=0.0 can be used later
    } else {
        if (!isReal(rollarg)) error("Internal error: roll is not character or double");
        roll = REAL(rollarg)[0];   // more common case (rolling forwards or backwards) or no roll when 0.0
    }
    rollabs = fabs(roll);

    i = iArg;
    x = xArg;  // set globals so bmerge_r can see them.
    if (!isInteger(icolsArg)) error("Internal error: icols is not integer vector");
    if (!isInteger(xcolsArg)) error("Internal error: xcols is not integer vector");
    if (LENGTH(icolsArg) > LENGTH(xcolsArg)) error("Internal error: length(icols) [%d] > length(xcols) [%d]", LENGTH(icolsArg), LENGTH(xcolsArg));
    icols = INTEGER(icolsArg);
    xcols = INTEGER(xcolsArg);
    xN = LENGTH(VECTOR_ELT(x,0));
    iN = LENGTH(VECTOR_ELT(i,0));
    ncol = LENGTH(icolsArg);    // there may be more sorted columns in x than involved in the join
    for(int col=0; col<ncol; col++) {
        if (icols[col]==NA_INTEGER) error("Internal error. icols[%d] is NA", col);
        if (xcols[col]==NA_INTEGER) error("Internal error. xcols[%d] is NA", col);
        if (icols[col]>LENGTH(i) || icols[col]<1) error("icols[%d]=%d outside range [1,length(i)=%d]", col, icols[col], LENGTH(i));
        if (xcols[col]>LENGTH(x) || xcols[col]<1) error("xcols[%d]=%d outside range [1,length(x)=%d]", col, xcols[col], LENGTH(x));
        int it = TYPEOF(VECTOR_ELT(i, icols[col]-1));
        int xt = TYPEOF(VECTOR_ELT(x, xcols[col]-1));
        if (it != xt) error("typeof x.%s (%s) != typeof i.%s (%s)", CHAR(STRING_ELT(getAttrib(x,R_NamesSymbol),xcols[col]-1)), type2char(xt), CHAR(STRING_ELT(getAttrib(i,R_NamesSymbol),icols[col]-1)), type2char(it));
    }
    if (!isInteger(retFirstArg) || LENGTH(retFirstArg)!=iN) error("retFirst must be integer vector the same length as nrow(i)");
    retFirst = INTEGER(retFirstArg);
    if (!isInteger(retLengthArg) || LENGTH(retLengthArg)!=iN) error("retLength must be integer vector the same length as nrow(i)");
    retLength = INTEGER(retLengthArg);
    if (!isLogical(allLen1Arg) || LENGTH(allLen1Arg) != 1) error("allLen1 must be a length 1 logical vector");
    allLen1 = LOGICAL(allLen1Arg);
    if (!isLogical(rollendsArg) || LENGTH(rollendsArg) != 2) error("rollends must be a length 2 logical vector");
    rollends = LOGICAL(rollendsArg);

    if (nearest && TYPEOF(VECTOR_ELT(i, icols[ncol-1]-1))==STRSXP) error("roll='nearest' can't be applied to a character column, yet.");

    for (int j=0; j<iN; j++) {
        // defaults need to populated here as bmerge_r may well not touch many locations, say if the last row of i is before the first row of x.
        retFirst[j] = INTEGER(nomatch)[0];   // default to no match for NA goto below
        // retLength[j] = 0;   // TO DO: do this to save the branch below and later branches at R level to set .N to 0
        retLength[j] = INTEGER(nomatch)[0]==0 ? 0 : 1;
    }
    allLen1[0] = TRUE;  // All-0 and All-NA are considered all length 1 according to R code currently. Really, it means any(length>1).

    o = NULL;
    if (!LOGICAL(isorted)[0]) {
        SEXP order = PROTECT(vec_init(length(icolsArg), ScalarInteger(1))); // rep(1, length(icolsArg))
        SEXP oSxp = PROTECT(forder(i, icolsArg, ScalarLogical(FALSE), ScalarLogical(TRUE), order, ScalarLogical(FALSE)));
        protecti += 2;
        if (!LENGTH(oSxp)) o = NULL;
        else o = INTEGER(oSxp);
    }

    if (iN) bmerge_r(-1,xN,-1,iN,0,1,1);

    UNPROTECT(protecti);
    return(R_NilValue);
}
Exemple #4
0
/* C-level interface to unique_arcs. */
SEXP c_unique_arcs(SEXP arcs, SEXP nodes, int warnlevel) {

    int i = 0, j = 0, k = 0, nrows = 0, uniq_rows = 0, n = length(nodes);
    int *checklist = NULL;
    SEXP result, try, node, dup;

    if (isNull(arcs)) {

        /* use NULL as a special jolly value which returns all possible arcs
         * given the specified node ordering. */
        nrows = n * (n - 1)/2;

        /* allocate the return value. */
        PROTECT(result = allocMatrix(STRSXP, nrows, 2));

        /* fill in the nodes' labels. */
        for (i = 0; i < n; i++) {

            node = STRING_ELT(nodes, i);

            for (j = i + 1; j < n; j++) {

                SET_STRING_ELT(result, CMC(k, 0, nrows), node);
                SET_STRING_ELT(result, CMC(k, 1, nrows), STRING_ELT(nodes, j));
                k++;

            }/*FOR*/

        }/*FOR*/

    }/*THEN*/
    else if (length(arcs) == 0) {

        /* the arc set is empty, nothing to do. */
        return arcs;

    }/*THEN*/
    else {

        /* there really is a non-empty arc set, process it. */
        nrows = length(arcs)/2;

        /* match the node labels in the arc set. */
        PROTECT(try = arc_hash(arcs, nodes, FALSE, FALSE));
        /* check which are duplicated. */
        PROTECT(dup = duplicated(try, FALSE));
        checklist = INTEGER(dup);

        /* count how many are not. */
        for (i = 0; i < nrows; i++)
            if (checklist[i] == 0)
                uniq_rows++;

        /* if there is no duplicate arc simply return the original arc set. */
        if (uniq_rows == nrows) {

            UNPROTECT(2);
            return arcs;

        }/*THEN*/
        else {

            /* warn the user if told to do so. */
            if (warnlevel > 0)
                warning("removed %d duplicate arcs.", nrows - uniq_rows);

            /* allocate and initialize the return value. */
            PROTECT(result = allocMatrix(STRSXP, uniq_rows, 2));

            /* store the correct arcs in the return value. */
            for (i = 0, k = 0; i < nrows; i++) {

                if (checklist[i] == 0) {

                    SET_STRING_ELT(result, k, STRING_ELT(arcs, i));
                    SET_STRING_ELT(result, k + uniq_rows, STRING_ELT(arcs, i + nrows));
                    k++;

                }/*THEN*/

            }/*FOR*/

        }/*ELSE*/

    }/*ELSE*/

    /* allocate, initialize and set the column names. */
    finalize_arcs(result);

    if (uniq_rows == 0)
        UNPROTECT(1);
    else
        UNPROTECT(3);

    return result;

}/*C_UNIQUE_ARCS*/
/* check neighbourhood sets and markov blankets for consistency.. */
SEXP bn_recovery(SEXP bn, SEXP strict, SEXP mb, SEXP debug, SEXP filter) {

int i = 0, j = 0, k = 0, n = 0, counter = 0;
short int *checklist = NULL, err = 0;
int *debuglevel = NULL, *checkmb = NULL, *nbrfilter = NULL;
SEXP temp, temp2, nodes, elnames = NULL, fixed;

  /* get the names of the nodes. */
  nodes = getAttrib(bn, R_NamesSymbol);
  n = LENGTH(nodes);

  /* allocate and initialize the checklist. */
  checklist = allocstatus(UPTRI_MATRIX(n));

  /* dereference the debug, mb and filter parameters. */
  debuglevel = LOGICAL(debug);
  checkmb = LOGICAL(mb);
  nbrfilter = INTEGER(filter);

  if (*debuglevel > 0) {

    Rprintf("----------------------------------------------------------------\n");

    if (*checkmb)
      Rprintf("* checking consistency of markov blankets.\n");
    else
      Rprintf("* checking consistency of neighbourhood sets.\n");

   }/*THEN*/

  /* scan the structure to determine the number of arcs.  */
  for (i = 0; i < n; i++) {

     if (*debuglevel > 0)
       Rprintf("  > checking node %s.\n",  NODE(i));

    /* get the entry for the (neighbours|elements of the markov blanket)
       of the node.*/
    temp = getListElement(bn, (char *)NODE(i));
    if (!(*checkmb))
      temp = getListElement(temp, "nbr");

    /* check each element of the array and identify which variable it
       corresponds to. */
    for (j = 0; j < LENGTH(temp); j++) {

      for (k = 0; k < n; k++) {

        /* increment the right element of checklist. */
        if (!strcmp(NODE(k), (char *)CHAR(STRING_ELT(temp, j))))
          checklist[UPTRI(i + 1, k + 1, n)]++;

      }/*FOR*/

    }/*FOR*/

  }/*FOR*/

  /* if A is a neighbour of B, B is a neighbour of A; therefore each entry in
   * the checklist array must be equal to either zero (if the corresponding
   * nodes are not neighbours) or two (if the corresponding nodes are neighbours).
   * Any other value (typically one) is caused by an incorrect (i.e. asymmetric)
   * neighbourhood structure. The same logic holds for the markov blankets. */
  for (i = 0; i < n; i++)
    for (j = i; j < n; j++) {

      if ((checklist[UPTRI(i + 1, j + 1, n)] != 0) &&
          (checklist[UPTRI(i + 1, j + 1, n)] != 2)) {

        if (*debuglevel > 0) {

          if (*checkmb)
            Rprintf("@ asymmetry in the markov blankets for %s and %s.\n",
              NODE(i), NODE(j));
          else
            Rprintf("@ asymmetry in the neighbourhood sets for %s and %s.\n",
              NODE(i), NODE(j));

        }/*THEN*/

        err = 1;

      }/*THEN*/

    }/*FOR*/

  /* no need to go on if the (neighbourhood sets|markov blankets) are symmetric;
   * otherwise throw either an error or a warning according to the value of the
   * strict parameter. */
  if (!err) {

    return bn;

  }/*THEN*/
  else if (isTRUE(strict)) {

    if (*checkmb)
      error("markov blankets are not symmetric.\n");
    else
      error("neighbourhood sets are not symmetric.\n");

  }/*THEN*/
  else {

    if (*checkmb)
      warning("markov blankets are not symmetric.\n");
    else
      warning("neighbourhood sets are not symmetric.\n");

  }/*ELSE*/

  /* build a correct structure to return. */
  PROTECT(fixed = allocVector(VECSXP, n));
  setAttrib(fixed, R_NamesSymbol, nodes);

  if (!(*checkmb)) {

    /* allocate colnames. */
    PROTECT(elnames = allocVector(STRSXP, 2));
    SET_STRING_ELT(elnames, 0, mkChar("mb"));
    SET_STRING_ELT(elnames, 1, mkChar("nbr"));

  }/*THEN*/

  for (i = 0; i < n; i++) {

    if (!(*checkmb)) {

      /* allocate the "mb" and "nbr" elements of the node. */
      PROTECT(temp = allocVector(VECSXP, 2));
      SET_VECTOR_ELT(fixed, i, temp);
      setAttrib(temp, R_NamesSymbol, elnames);

      /* copy the "mb" part from the old structure. */
      temp2 = getListElement(bn, (char *)NODE(i));
      temp2 = getListElement(temp2, "mb");
      SET_VECTOR_ELT(temp, 0, temp2);

    }/*THEN*/

    /* fix the neighbourhoods with an AND or an OR filter.
     * AND means that both neighbours have to see each other
     * to be neighbours, OR means that one neighbour at least
     * as to see the other one for both to be neighbours. */
    switch(*nbrfilter) {

      case AND_FILTER:

        /* rescan the checklist. */
        for (j = 0; j < n; j++)
          if (checklist[UPTRI(i + 1, j + 1, n)] == 2)
            if (i != j)
              counter++;

        /* allocate and fill the "nbr" element. */
        PROTECT(temp2 = allocVector(STRSXP, counter));

        for (j = 0; j < n; j++)
          if (checklist[UPTRI(i + 1, j + 1, n)] == 2)
            if (i != j)
              SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j));

        break;

      case OR_FILTER:

        /* rescan the checklist. */
        for (j = 0; j < n; j++)
          if (checklist[UPTRI(i + 1, j + 1, n)] >= 1)
            if (i != j)
              counter++;

        /* allocate and fill the "nbr" element. */
        PROTECT(temp2 = allocVector(STRSXP, counter));

        for (j = 0; j < n; j++)
          if (checklist[UPTRI(i + 1, j + 1, n)] >= 1)
            if (i != j)
              SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j));

        break;
    }

    if (*checkmb) {

      SET_VECTOR_ELT(fixed, i, temp2);
      UNPROTECT(1);

    }/*THEN*/
    else {

      SET_VECTOR_ELT(temp, 1, temp2);
      UNPROTECT(2);

    }/*ELSE*/

  }/*FOR*/

  if (*checkmb)
    UNPROTECT(1);
  else
    UNPROTECT(2);

return fixed;

}/*BN_RECOVERY*/
Exemple #6
0
std::string RChar2String(SEXP str)
{
  return string(CHAR(STRING_ELT(str, 0)));
}
Exemple #7
0
SEXP extract_col (SEXP x, SEXP j, SEXP drop, SEXP first_, SEXP last_) {
  SEXP result, index, new_index;
  int nrs, nrsx, i, ii, jj, first, last;

  nrsx = nrows(x);

  first = asInteger(first_)-1;
  last = asInteger(last_)-1;

  /* nrs = offset_end - offset_start - 1; */
  nrs = last - first + 1;
  

  PROTECT(result = allocVector(TYPEOF(x), nrs * length(j)));

  switch(TYPEOF(x)) {
    case REALSXP:
      for(i=0; i<length(j); i++) {
/*
Rprintf("j + i*nrs + first=%i\n", (int)(INTEGER(j)[i]-1 + i*nrs + first));
Rprintf("i=%i, j=%i, nrs=%i, first=%i\n", i, INTEGER(j)[i]-1, nrs, first);
*/
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            REAL(result)[(i*nrs) + ii] = NA_REAL;
          }
        } else {
          memcpy(&(REAL(result)[i*nrs]),
                 &(REAL(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(double));
        }
      }
      break;
    case INTSXP:
      for(i=0; i<length(j); i++) {
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            INTEGER(result)[(i*nrs) + ii] = NA_INTEGER;
          }
        } else {
          memcpy(&(INTEGER(result)[i*nrs]),
                 &(INTEGER(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(int));
        }
      }
      break;
    case LGLSXP:
      for(i=0; i<length(j); i++) {
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            LOGICAL(result)[(i*nrs) + ii] = NA_LOGICAL;
          }
        } else {
          memcpy(&(LOGICAL(result)[i*nrs]),
                 &(LOGICAL(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(int));
        }
      }
      break;
    case CPLXSXP:
      for(i=0; i<length(j); i++) {
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            COMPLEX(result)[(i*nrs) + ii].r = NA_REAL;
            COMPLEX(result)[(i*nrs) + ii].i = NA_REAL;
          }
        } else {
          memcpy(&(COMPLEX(result)[i*nrs]),
                 &(COMPLEX(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(Rcomplex));
        }
      }
      break;
    case RAWSXP:
      for(i=0; i<length(j); i++) {
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            RAW(result)[(i*nrs) + ii] = 0;
          }
        } else {
          memcpy(&(RAW(result)[i*nrs]),
                 &(RAW(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(Rbyte));
        }
      }
      break;
    case STRSXP:
      for(jj=0; jj<length(j); jj++) {
        if(INTEGER(j)[jj] == NA_INTEGER) {
          for(i=0; i< nrs; i++)
            SET_STRING_ELT(result, i+jj*nrs, NA_STRING);
        } else {
          for(i=0; i< nrs; i++)
            SET_STRING_ELT(result, i+jj*nrs, STRING_ELT(x, i+(INTEGER(j)[jj]-1)*nrsx+first));
        }
      }
      break;
    default:
      error("unsupported type");
  }

  if(nrs != nrows(x)) {
    copyAttributes(x, result);
    /* subset index */
    index = getAttrib(x, install("index"));
    PROTECT(new_index = allocVector(TYPEOF(index), nrs)); 
    if(TYPEOF(index) == REALSXP) {
      memcpy(REAL(new_index), &(REAL(index)[first]), nrs*sizeof(double)); 
    } else { /* INTSXP */
      memcpy(INTEGER(new_index), &(INTEGER(index)[first]), nrs*sizeof(int)); 
    }
    copyMostAttrib(index, new_index);
    setAttrib(result, install("index"), new_index);
    UNPROTECT(1);
  } else {
    copyMostAttrib(x, result); /* need an xts/zoo equal that skips 'index' */
  }

  if(!asLogical(drop)) { /* keep dimension and dimnames */
    SEXP dim;
    PROTECT(dim = allocVector(INTSXP, 2));
    INTEGER(dim)[0] = nrs;
    INTEGER(dim)[1] = length(j);
    setAttrib(result, R_DimSymbol, dim);
    UNPROTECT(1);

    SEXP dimnames, currentnames, newnames;
    PROTECT(dimnames = allocVector(VECSXP, 2));
    PROTECT(newnames = allocVector(STRSXP, length(j)));
    currentnames = getAttrib(x, R_DimNamesSymbol);

    if(!isNull(currentnames)) {
      SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(currentnames,0));
      if(!isNull(VECTOR_ELT(currentnames,1))) {
        /* if colnames isn't NULL set */
        for(i=0; i<length(j); i++) {
          SET_STRING_ELT(newnames, i, STRING_ELT(VECTOR_ELT(currentnames,1), INTEGER(j)[i]-1));
        }
        SET_VECTOR_ELT(dimnames, 1, newnames);
      } else {
        /* else set to NULL */
        SET_VECTOR_ELT(dimnames, 1, R_NilValue);
      }
      setAttrib(result, R_DimNamesSymbol, dimnames);
    }
    UNPROTECT(2);
  }

  UNPROTECT(1);
  return result;
}
SEXP gbm
(
    SEXP radY,       // outcome or response
    SEXP radOffset,  // offset for f(x), NA for no offset
    SEXP radX,        
    SEXP raiXOrder,        
    SEXP radWeight,
    SEXP radMisc,   // other row specific data (eg failure time), NA=no Misc
    SEXP rcRows,
    SEXP rcCols,
    SEXP racVarClasses,
    SEXP ralMonotoneVar,
    SEXP rszFamily, 
    SEXP rcTrees,
    SEXP rcDepth,       // interaction depth
    SEXP rcMinObsInNode,
    SEXP rdShrinkage,
    SEXP rdBagFraction,
    SEXP rcTrain,
    SEXP radFOld,
    SEXP rcCatSplitsOld,
    SEXP rcTreesOld,
    SEXP rfVerbose
)
{
    unsigned long hr = 0;

    SEXP rAns = NULL;
    SEXP rNewTree = NULL;
    SEXP riSplitVar = NULL;
    SEXP rdSplitPoint = NULL;
    SEXP riLeftNode = NULL;
    SEXP riRightNode = NULL;
    SEXP riMissingNode = NULL;
    SEXP rdErrorReduction = NULL;
    SEXP rdWeight = NULL;
    SEXP rdPred = NULL;

    SEXP rdInitF = NULL;
    SEXP radF = NULL;
    SEXP radTrainError = NULL;
    SEXP radValidError = NULL;
    SEXP radOOBagImprove = NULL;

    SEXP rSetOfTrees = NULL;
    SEXP rSetSplitCodes = NULL;
    SEXP rSplitCode = NULL;

    VEC_VEC_CATEGORIES vecSplitCodes;

    int i = 0;
    int iT = 0;
    int cTrees = INTEGER(rcTrees)[0];
    const int cResultComponents = 7;
    // rdInitF, radF, radTrainError, radValidError, radOOBagImprove
    // rSetOfTrees, rSetSplitCodes
    const int cTreeComponents = 8;
    // riSplitVar, rdSplitPoint, riLeftNode,
    // riRightNode, riMissingNode, rdErrorReduction, rdWeight, rdPred
    int cNodes = 0;
    int cTrain = INTEGER(rcTrain)[0];

    double dTrainError = 0.0;
    double dValidError = 0.0;
    double dOOBagImprove = 0.0;

    CGBM *pGBM = NULL;
    CDataset *pData = NULL;
    CDistribution *pDist = NULL;

    // set up the dataset
    pData = new CDataset();
    if(pData==NULL)
    {
        hr = GBM_OUTOFMEMORY;
        goto Error;
    }

    // initialize R's random number generator
    GetRNGstate();

    // initialize some things
    hr = gbm_setup(REAL(radY),
                   REAL(radOffset),
                   REAL(radX),
                   INTEGER(raiXOrder),
                   REAL(radWeight),
                   REAL(radMisc),
                   INTEGER(rcRows)[0],
                   INTEGER(rcCols)[0],
                   INTEGER(racVarClasses),
                   INTEGER(ralMonotoneVar),
                   CHAR(STRING_ELT(rszFamily,0)),
                   INTEGER(rcTrees)[0],
                   INTEGER(rcDepth)[0],
                   INTEGER(rcMinObsInNode)[0],
                   REAL(rdShrinkage)[0],
                   REAL(rdBagFraction)[0],
                   INTEGER(rcTrain)[0],
                   pData,
                   pDist);
    if(GBM_FAILED(hr))
    {
        goto Error;
    }
        
    // allocate the GBM
    pGBM = new CGBM();
    if(pGBM==NULL)
    {
        hr = GBM_OUTOFMEMORY;
        goto Error;
    }

    // initialize the GBM
    hr = pGBM->Initialize(pData,
                          pDist,
                          REAL(rdShrinkage)[0], 
                          cTrain, 
                          REAL(rdBagFraction)[0],
                          INTEGER(rcDepth)[0],
                          INTEGER(rcMinObsInNode)[0]);
    if(GBM_FAILED(hr))
    {
        goto Error;
    }

    // allocate the main return object
    PROTECT(rAns = allocVector(VECSXP, cResultComponents));

    // allocate the initial value
    PROTECT(rdInitF = allocVector(REALSXP, 1));
    SET_VECTOR_ELT(rAns,0,rdInitF);
    UNPROTECT(1); // rdInitF

    // allocate the predictions
    PROTECT(radF = allocVector(REALSXP, pData->cRows));
    SET_VECTOR_ELT(rAns,1,radF);
    UNPROTECT(1); // radF

    if(ISNA(REAL(radFOld)[0])) // check for old predictions
    {
        // set the initial value of F as a constant
        hr = pDist->InitF(pData->adY,
                          pData->adMisc,
                          pData->adOffset,
                          pData->adWeight,
                          REAL(rdInitF)[0], 
                          cTrain);
        for(i=0; i < pData->cRows; i++)
        {
            REAL(radF)[i] = REAL(rdInitF)[0];
        }
    }
    else
    {
        for(i=0; i < pData->cRows; i++)
        {
            REAL(radF)[i] = REAL(radFOld)[i];
        }
    }

    // allocate space for the performance measures
    PROTECT(radTrainError = allocVector(REALSXP, cTrees));
    PROTECT(radValidError = allocVector(REALSXP, cTrees));
    PROTECT(radOOBagImprove = allocVector(REALSXP, cTrees));
    SET_VECTOR_ELT(rAns,2,radTrainError);
    SET_VECTOR_ELT(rAns,3,radValidError);
    SET_VECTOR_ELT(rAns,4,radOOBagImprove);
    UNPROTECT(3); // radTrainError , radValidError, radOOBagImprove

    // allocate the component for the tree structures
    PROTECT(rSetOfTrees = allocVector(VECSXP, cTrees));
    SET_VECTOR_ELT(rAns,5,rSetOfTrees);
    UNPROTECT(1); // rSetOfTrees

    if(INTEGER(rfVerbose)[0])
    {
       Rprintf("Iter   TrainDeviance   ValidDeviance   StepSize   Improve\n");
    }
    for(iT=0; iT<cTrees; iT++)
    {
        hr = pGBM->iterate(REAL(radF),
                           dTrainError,dValidError,dOOBagImprove,
                           cNodes);
        if(GBM_FAILED(hr))
        {
            goto Error;
        }
        // store the performance measures
        REAL(radTrainError)[iT] = dTrainError;
        REAL(radValidError)[iT] = dValidError;
        REAL(radOOBagImprove)[iT] = dOOBagImprove;

        // allocate the new tree component for the R list structure
        PROTECT(rNewTree = allocVector(VECSXP, cTreeComponents));
        // riNodeID,riSplitVar,rdSplitPoint,riLeftNode,
        // riRightNode,riMissingNode,rdErrorReduction,rdWeight
        PROTECT(riSplitVar = allocVector(INTSXP, cNodes));
        PROTECT(rdSplitPoint = allocVector(REALSXP, cNodes));
        PROTECT(riLeftNode = allocVector(INTSXP, cNodes));
        PROTECT(riRightNode = allocVector(INTSXP, cNodes));
        PROTECT(riMissingNode = allocVector(INTSXP, cNodes));
        PROTECT(rdErrorReduction = allocVector(REALSXP, cNodes));
        PROTECT(rdWeight = allocVector(REALSXP, cNodes));
        PROTECT(rdPred = allocVector(REALSXP, cNodes));
        SET_VECTOR_ELT(rNewTree,0,riSplitVar);
        SET_VECTOR_ELT(rNewTree,1,rdSplitPoint);
        SET_VECTOR_ELT(rNewTree,2,riLeftNode);
        SET_VECTOR_ELT(rNewTree,3,riRightNode);
        SET_VECTOR_ELT(rNewTree,4,riMissingNode);
        SET_VECTOR_ELT(rNewTree,5,rdErrorReduction);
        SET_VECTOR_ELT(rNewTree,6,rdWeight);
        SET_VECTOR_ELT(rNewTree,7,rdPred);
        UNPROTECT(cTreeComponents); 
        SET_VECTOR_ELT(rSetOfTrees,iT,rNewTree);
        UNPROTECT(1); // rNewTree

        hr = gbm_transfer_to_R(pGBM,
                               vecSplitCodes,
                               INTEGER(riSplitVar),
                               REAL(rdSplitPoint),
                               INTEGER(riLeftNode),
                               INTEGER(riRightNode),
                               INTEGER(riMissingNode),
                               REAL(rdErrorReduction),
                               REAL(rdWeight),
                               REAL(rdPred),
                               INTEGER(rcCatSplitsOld)[0]);

        if((iT <= 9) ||
           ((iT+1+INTEGER(rcTreesOld)[0])/100 ==
            (iT+1+INTEGER(rcTreesOld)[0])/100.0) ||
            (iT==cTrees-1))
        {
            R_CheckUserInterrupt();
            if(INTEGER(rfVerbose)[0])
            {
               Rprintf("%6d %13.4f %15.4f %10.4f %9.4f\n",
                       iT+1+INTEGER(rcTreesOld)[0],
                       REAL(radTrainError)[iT],
                       REAL(radValidError)[iT],
                       REAL(rdShrinkage)[0],
                       REAL(radOOBagImprove)[iT]);
            }
        }
    }
    if(INTEGER(rfVerbose)[0]) Rprintf("\n");

    // transfer categorical splits to R
    PROTECT(rSetSplitCodes = allocVector(VECSXP, vecSplitCodes.size()));
    SET_VECTOR_ELT(rAns,6,rSetSplitCodes);
    UNPROTECT(1); // rSetSplitCodes

    for(i=0; i<(int)vecSplitCodes.size(); i++)
    {
        PROTECT(rSplitCode = 
                    allocVector(INTSXP, size_of_vector(vecSplitCodes,i)));
        SET_VECTOR_ELT(rSetSplitCodes,i,rSplitCode);
        UNPROTECT(1); // rSplitCode

        hr = gbm_transfer_catsplits_to_R(i,
                                         vecSplitCodes,
                                         INTEGER(rSplitCode));
    }
    // dump random number generator seed
    #ifdef NOISY_DEBUG
    Rprintf("PutRNGstate\n");
    #endif
    PutRNGstate();

Cleanup:
    UNPROTECT(1); // rAns
    #ifdef NOISY_DEBUG
    Rprintf("destructing\n");
    #endif

    if(pGBM != NULL)
    {
        delete pGBM;
        pGBM = NULL;
    }
    if(pDist != NULL)
    {
        delete pDist;
        pDist = NULL;
    }
    if(pData != NULL)
    {
        delete pData;
        pData = NULL;
    }

    return rAns;
Error:
    goto Cleanup;
}
/** Matrix products of dense triangular Matrices
 *
 * @param a triangular matrix of class "dtrMatrix"
 * @param b  ( ditto )
 * @param right logical, if true, compute b %*% a,  else  a %*% b
 * @param trans logical, if true, "transpose a", i.e., use t(a), otherwise a
 *
 * @return the matrix product, one of   a %*% b, t(a) %*% b,  b %*% a, or  b %*% t(a)
 *      depending on (right, trans) =    (F, F)    (F, T)      (T, F)        (T, T)
 */
SEXP dtrMatrix_dtrMatrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
    /* called from "%*%" : (x,y, FALSE,FALSE),
             crossprod() : (x,y, FALSE, TRUE) , and
	     tcrossprod(): (y,x, TRUE , TRUE)
     * 	     -
     * TWO cases : (1) result is triangular  <=> uplo's "match" (i.e., non-equal iff trans)
     * ===         (2) result is "general"
     */
    SEXP val,/* = in case (2):  PROTECT(dup_mMatrix_as_dgeMatrix(b)); */
	d_a = GET_SLOT(a, Matrix_DimSym),
	uplo_a = GET_SLOT(a, Matrix_uploSym),  diag_a = GET_SLOT(a, Matrix_diagSym),
	uplo_b = GET_SLOT(b, Matrix_uploSym),  diag_b = GET_SLOT(b, Matrix_diagSym);
    int rt = asLogical(right);
    int tr = asLogical(trans);
    int *adims = INTEGER(d_a), n = adims[0];
    double *valx = (double *) NULL /*Wall*/;
    const char
	*uplo_a_ch = CHAR(STRING_ELT(uplo_a, 0)), /* = uplo_P(a) */
	*diag_a_ch = CHAR(STRING_ELT(diag_a, 0)), /* = diag_P(a) */
	*uplo_b_ch = CHAR(STRING_ELT(uplo_b, 0)), /* = uplo_P(b) */
	*diag_b_ch = CHAR(STRING_ELT(diag_b, 0)); /* = diag_P(b) */
    Rboolean same_uplo = (*uplo_a_ch == *uplo_b_ch),
	matching_uplo = tr ? (!same_uplo) : same_uplo,
	uDiag_b = /* -Wall: */ FALSE;

    if (INTEGER(GET_SLOT(b, Matrix_DimSym))[0] != n)
	/* validity checking already "assures" square matrices ... */
	error(_("\"dtrMatrix\" objects in '%*%' must have matching (square) dimension"));
    if(matching_uplo) {
	/* ==> result is triangular -- "dtrMatrix" !
	 * val := dup_mMatrix_as_dtrMatrix(b) : */
	int sz = n * n;
	val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
	SET_SLOT(val, Matrix_uploSym, duplicate(uplo_b));
	SET_SLOT(val, Matrix_DimSym,  duplicate(d_a));
	SET_DimNames(val, b);
	valx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, sz));
	Memcpy(valx, REAL(GET_SLOT(b, Matrix_xSym)), sz);
	if((uDiag_b = (*diag_b_ch == 'U'))) {
	    /* unit-diagonal b - may contain garbage in diagonal */
	    for (int i = 0; i < n; i++)
		valx[i * (n+1)] = 1.;
	}
    } else { /* different "uplo" ==> result is "dgeMatrix" ! */
	val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
	SEXP
	    dn_a = GET_SLOT( a , Matrix_DimNamesSym),
	    dn   = GET_SLOT(val, Matrix_DimNamesSym);
	/* matrix product   a %*% b, t(a) %*% b,  b %*% a, or  b %*% t(a)
	 * (right, trans) =  (F, F)    (F, T)      (T, F)        (T, T)
	 *   set:from_a   =   0:0       0:1         1:1           1:0
	 */
	SET_VECTOR_ELT(dn, rt ? 1 : 0, VECTOR_ELT(dn_a, (rt+tr) % 2));
    }
    if (n >= 1) {
	double alpha = 1.;
	/* Level 3 BLAS - DTRMM(): Compute one of the matrix multiplication operations
	 * B := alpha*op( A )*B ["L"], or B := alpha*B*op( A ) ["R"],
	 *	where trans_A determines  op(A):=  A   "N"one  or
	 *				  op(A):= t(A) "T"ransposed */
	F77_CALL(dtrmm)(rt ? "R" : "L", uplo_a_ch,
			/*trans_A = */ tr ? "T" : "N", diag_a_ch, &n, &n, &alpha,
			REAL(GET_SLOT(a,   Matrix_xSym)), adims,
			REAL(GET_SLOT(val, Matrix_xSym)), &n);
    }
    if(matching_uplo) {
	make_d_matrix_triangular(valx, tr ? b : a); /* set "other triangle" to 0 */
	if(*diag_a_ch == 'U' && uDiag_b) /* result remains uni-diagonal */
	    SET_SLOT(val, Matrix_diagSym, duplicate(diag_a));
    }
    UNPROTECT(1);
    return val;
}
Exemple #10
0
SEXP r_strptr(SEXP x)
{
  return R_MakeExternalPtr( (void*) CHAR(STRING_ELT(x, 0)), R_NilValue, x );
}
Exemple #11
0
static SEXP scanVector(SEXPTYPE type, int maxitems, int maxlines,
		       int flush, SEXP stripwhite, int blskip, LocalData *d)
{
    SEXP ans, bns;
    int blocksize, c, i, n, linesread, nprev,strip, bch;
    char *buffer;
    R_StringBuffer strBuf = {NULL, 0, MAXELTSIZE};

    if (maxitems > 0) blocksize = maxitems;
    else blocksize = SCAN_BLOCKSIZE;

    R_AllocStringBuffer(0, &strBuf);
    PROTECT(ans = allocVector(type, blocksize));

    nprev = 0; n = 0; linesread = 0; bch = 1;

    if (d->ttyflag) sprintf(ConsolePrompt, "1: ");

    strip = asLogical(stripwhite);

    for (;;) {
	if(n % 10000 == 9999) R_CheckUserInterrupt();
	if (bch == R_EOF) {
	    if (d->ttyflag) R_ClearerrConsole();
	    break;
	}
	else if (bch == '\n') {
	    linesread++;
	    if (linesread == maxlines)
		break;
	    if (d->ttyflag) sprintf(ConsolePrompt, "%d: ", n + 1);
	    nprev = n;
	}
	if (n == blocksize) {
	    /* enlarge the vector*/
	    bns = ans;
	    if(blocksize > INT_MAX/2) error(_("too many items"));
	    blocksize = 2 * blocksize;
	    ans = allocVector(type, blocksize);
	    UNPROTECT(1);
	    PROTECT(ans);
	    copyVector(ans, bns);
	}
	buffer = fillBuffer(type, strip, &bch, d, &strBuf);
	if (nprev == n && strlen(buffer)==0 &&
	    ((blskip && bch =='\n') || bch == R_EOF)) {
	    if (d->ttyflag || bch == R_EOF)
		break;
	}
	else {
	    extractItem(buffer, ans, n, d);
	    if (++n == maxitems) {
		if (d->ttyflag && bch != '\n') { /* MBCS-safe */
		    while ((c = scanchar(FALSE, d)) != '\n')
			;
		}
		break;
	    }
	}
	if (flush && (bch != '\n') && (bch != R_EOF)) { /* MBCS-safe */
	    while ((c = scanchar(FALSE, d)) != '\n' && (c != R_EOF));
	    bch = c;
	}
    }
    if (!d->quiet) REprintf("Read %d item%s\n", n, (n == 1) ? "" : "s");
    if (d->ttyflag) ConsolePrompt[0] = '\0';

    if (n == 0) {
	UNPROTECT(1);
	R_FreeStringBuffer(&strBuf);
	return allocVector(type,0);
    }
    if (n == maxitems) {
	UNPROTECT(1);
	R_FreeStringBuffer(&strBuf);
	return ans;
    }

    bns = allocVector(type, n);
    switch (type) {
    case LGLSXP:
    case INTSXP:
	for (i = 0; i < n; i++)
	    INTEGER(bns)[i] = INTEGER(ans)[i];
	break;
    case REALSXP:
	for (i = 0; i < n; i++)
	    REAL(bns)[i] = REAL(ans)[i];
	break;
    case CPLXSXP:
	for (i = 0; i < n; i++)
	    COMPLEX(bns)[i] = COMPLEX(ans)[i];
	break;
    case STRSXP:
	for (i = 0; i < n; i++)
	    SET_STRING_ELT(bns, i, STRING_ELT(ans, i));
	break;
    case RAWSXP:
	for (i = 0; i < n; i++)
	    RAW(bns)[i] = RAW(ans)[i];
	break;
    default:
	UNIMPLEMENTED_TYPEt("scanVector", type);
    }
    UNPROTECT(1);
    R_FreeStringBuffer(&strBuf);
    return bns;
}
Exemple #12
0
/**
 * Add a note for an object
 *
 * @param repo S4 class git_repository
 * @param sha The sha string of object
 * @param commit S4 class git_commit
 * @param message Content of the note to add
 * @param ref Canonical name of the reference to use
 * @param author Signature of the notes note author
 * @param committer Signature of the notes note committer
 * @param force Overwrite existing note
 * @return S4 class git_note
 */
SEXP git2r_note_create(
    SEXP repo,
    SEXP sha,
    SEXP message,
    SEXP ref,
    SEXP author,
    SEXP committer,
    SEXP force)
{
    int err;
    SEXP result = R_NilValue;
    int overwrite = 0;
    git_oid note_oid;
    git_oid object_oid;
    git_signature *sig_author = NULL;
    git_signature *sig_committer = NULL;
    git_repository *repository = NULL;

    if (git2r_arg_check_sha(sha))
        git2r_error(git2r_err_sha_arg, __func__, "sha");
    if (git2r_arg_check_string(message))
        git2r_error(git2r_err_string_arg, __func__, "message");
    if (git2r_arg_check_string(ref))
        git2r_error(git2r_err_string_arg, __func__, "ref");
    if (git2r_arg_check_signature(author))
        git2r_error(git2r_err_signature_arg, __func__, "author");
    if (git2r_arg_check_signature(committer))
        git2r_error(git2r_err_signature_arg, __func__, "committer");
    if (git2r_arg_check_logical(force))
        git2r_error(git2r_err_logical_arg, __func__, "force");

    repository = git2r_repository_open(repo);
    if (!repository)
        git2r_error(git2r_err_invalid_repository, __func__, NULL);

    err = git2r_signature_from_arg(&sig_author, author);
    if (GIT_OK != err)
        goto cleanup;

    err = git2r_signature_from_arg(&sig_committer, committer);
    if (GIT_OK != err)
        goto cleanup;

    err = git_oid_fromstr(&object_oid, CHAR(STRING_ELT(sha, 0)));
    if (GIT_OK != err)
        goto cleanup;

    if (LOGICAL(force)[0])
        overwrite = 1;

    err = git_note_create(
              &note_oid,
              repository,
              CHAR(STRING_ELT(ref, 0)),
              sig_author,
              sig_committer,
              &object_oid,
              CHAR(STRING_ELT(message, 0)),
              overwrite);
    if (GIT_OK != err)
        goto cleanup;

    PROTECT(result = NEW_OBJECT(MAKE_CLASS("git_note")));
    err = git2r_note_init(&note_oid,
                          &object_oid,
                          repository,
                          CHAR(STRING_ELT(ref, 0)),
                          repo,
                          result);

cleanup:
    if (sig_author)
        git_signature_free(sig_author);

    if (sig_committer)
        git_signature_free(sig_committer);

    if (repository)
        git_repository_free(repository);

    if (R_NilValue != result)
        UNPROTECT(1);

    if (GIT_OK != err)
        git2r_error(git2r_err_from_libgit2, __func__, giterr_last()->message);

    return result;
}
/* backend to compute the cached values fro a single node. */
static SEXP cache_node_structure(int cur, SEXP nodes, int *amat, int nrows,
    int *status, int debuglevel) {

int i = 0, j = 0;
int num_parents = 0, num_children = 0, num_neighbours = 0, num_blanket = 0;
SEXP structure, names, mb, nbr, children, parents;

  if (debuglevel > 0)
    Rprintf("* node %s.\n", NODE(cur));

  for (i = 0; i < nrows; i++) {

    if (amat[CMC(cur, i, nrows)] == 1) {

      if (amat[CMC(i, cur, nrows)] == 0) {

        /* if a[i,j] = 1 and a[j,i] = 0, then i -> j. */
        if (debuglevel > 0)
          Rprintf("  > found child %s.\n", NODE(i));

        status[i] = CHILD;

        /* check whether this child has any other parent. */
        for (j = 0; j < nrows; j++) {

          if ((amat[CMC(j, i, nrows)] == 1) && (amat[CMC(i, j, nrows)] == 0)
                && (j != cur)) {

            /* don't mark a neighbour as in the markov blanket. */
            if (status[j] <= 1) {

              status[j] = BLANKET;

              if (debuglevel > 0)
                Rprintf("  > found node %s in markov blanket.\n", NODE(j));

            }/*THEN*/

          }/*THEN*/

        }/*FOR*/

      }/*THEN*/
      else {

        /* if a[i,j] = 1 and a[j,i] = 1, then i -- j. */
        if (debuglevel > 0)
          Rprintf("  > found neighbour %s.\n", NODE(i));

        status[i] = NEIGHBOUR;

      }/*ELSE*/

    }/*THEN*/
    else {

      if (amat[CMC(i, cur, nrows)] == 1) {

        /* if a[i,j] = 0 and a[j,i] = 1, then i <- j. */
        if (debuglevel > 0)
          Rprintf("  > found parent %s.\n", NODE(i));

        status[i] = PARENT;

      }/*THEN*/

    }/*ELSE*/

  }/*FOR*/

  /* count how may nodes fall in each category. */
  for (i = 0; i < nrows; i++) {

    switch(status[i]) {

      case CHILD:
        /* a child is also a neighbour and belongs into the markov blanket. */
        num_children++;
        num_neighbours++;
        num_blanket++;
        break;
      case PARENT:
        /* the same goes for a parent. */
        num_parents++;
        num_neighbours++;
        num_blanket++;
        break;
      case NEIGHBOUR:
        /* it's not known if this is parent or a children, but it's certainly a neighbour. */
        num_neighbours++;
        num_blanket++;
        break;
      case BLANKET:
        num_blanket++;
        break;
      default:
        /* this node is not even in the markov blanket. */
        break;

    }/*SWITCH*/

  }/*FOR*/

  if (debuglevel > 0)
    Rprintf("  > node %s has %d parent(s), %d child(ren), %d neighbour(s) and %d nodes in the markov blanket.\n",
      NODE(cur), num_parents, num_children, num_neighbours, num_blanket);

  /* allocate and initialize the names of the elements. */
  PROTECT(names = allocVector(STRSXP, 4));
  SET_STRING_ELT(names, 0, mkChar("mb"));
  SET_STRING_ELT(names, 1, mkChar("nbr"));
  SET_STRING_ELT(names, 2, mkChar("parents"));
  SET_STRING_ELT(names, 3, mkChar("children"));

  /* allocate the list and set its attributes. */
  PROTECT(structure = allocVector(VECSXP, 4));
  setAttrib(structure, R_NamesSymbol, names);

  /* allocate and fill the "children" element of the list. */
  PROTECT(children = allocVector(STRSXP, num_children));
  for (i = 0, j = 0; (i < nrows) && (j < num_children); i++) {

    if (status[i] == CHILD)
      SET_STRING_ELT(children, j++, STRING_ELT(nodes, i));

  }/*FOR*/

  /* allocate and fill the "parents" element of the list. */
  PROTECT(parents = allocVector(STRSXP, num_parents));
  for (i = 0, j = 0; (i < nrows) && (j < num_parents); i++) {

    if (status[i] == PARENT)
      SET_STRING_ELT(parents, j++, STRING_ELT(nodes, i));

  }/*FOR*/

  /* allocate and fill the "nbr" element of the list. */
  PROTECT(nbr = allocVector(STRSXP, num_neighbours));
  for (i = 0, j = 0; (i < nrows) && (j < num_neighbours); i++) {

    if (status[i] >= NEIGHBOUR)
      SET_STRING_ELT(nbr, j++, STRING_ELT(nodes, i));

  }/*FOR*/

  /* allocate and fill the "mb" element of the list. */
  PROTECT(mb = allocVector(STRSXP, num_blanket));
  for (i = 0, j = 0; (i < nrows) && (j < num_blanket + num_neighbours); i++) {

    if (status[i] >= BLANKET)
      SET_STRING_ELT(mb, j++, STRING_ELT(nodes, i));

  }/*FOR*/

  /* attach the string vectors to the list. */
  SET_VECTOR_ELT(structure, 0, mb);
  SET_VECTOR_ELT(structure, 1, nbr);
  SET_VECTOR_ELT(structure, 2, parents);
  SET_VECTOR_ELT(structure, 3, children);

  UNPROTECT(6);

  return structure;

}/*CACHE_NODE_STRUCTURE*/
SEXP c_dfRowsToList(SEXP s_df, SEXP s_pars, SEXP s_types, SEXP s_parnames, SEXP s_lens, SEXP s_cnames) {
  int *types = INTEGER(s_types);
  int npars = LENGTH(s_lens);
  int *lens = INTEGER(s_lens);
  int nrow_df = LENGTH(VECTOR_ELT(s_df, 0));
  int row, par, k; /* loop counters for rows, cols, params, vector param elements */
  int type; /* type of column we are currently handling */
  int parlen; /* length of param we are currently handling */
  int colcount = 0; /* when we iterate params, what is the (first) column of s_df that corresponds? */
  SEXP s_res, s_rowlist, s_parval, s_call;
  Rboolean all_missing;

  /* we iterate thru rows then params. */
  s_res = PROTECT(NEW_LIST(nrow_df));
  s_call = PROTECT(lang3(install("discreteNameToValue"), R_NilValue, R_NilValue));
  for (row = 0; row < nrow_df; row++) {
    s_rowlist = PROTECT(NEW_LIST(npars));
    /* convert row to R objects and define them in envir s_env */
    colcount = 0;
    for (par = 0; par < npars; par++) { /* iter thru params */
      parlen = lens[par];
      type = types[colcount];
      all_missing = TRUE;
      /* copy vector-param block of row to s_parval */
      if (type == 1) { /* numerics */
        s_parval = PROTECT(NEW_NUMERIC(parlen));
        for (k = 0; k < parlen; k++) {
          REAL(s_parval)[k] = REAL(VECTOR_ELT(s_df, colcount+k))[row];
          if (!ISNAN(REAL(s_parval)[k]))
            all_missing = FALSE;
        }
      } else if (type == 2) { /* integers */
        s_parval = PROTECT(NEW_INTEGER(parlen));
        for (k = 0; k < parlen; k++) {
          INTEGER(s_parval)[k] = INTEGER(VECTOR_ELT(s_df, colcount+k))[row];
          if (INTEGER(s_parval)[k] != NA_INTEGER)
            all_missing = FALSE;
        }
      } else if (type == 3) { /* factors */
        s_parval = PROTECT(NEW_CHARACTER(parlen));
        for (k = 0; k < parlen; k++) {
          SET_STRING_ELT(s_parval, k, STRING_ELT(VECTOR_ELT(s_df, colcount+k), row));
          if (STRING_ELT(s_parval, k) != NA_STRING)
            all_missing = FALSE;
        }
      } else if (type == 4) { /* logical */
        s_parval = PROTECT(NEW_LOGICAL(parlen));
        for (k = 0; k < parlen; k++) {
          LOGICAL(s_parval)[k] = LOGICAL(VECTOR_ELT(s_df, colcount+k))[row];
          if (LOGICAL(s_parval)[k] != NA_LOGICAL)
            all_missing = FALSE;
        }
      } else if (type == 5) { /* character */
        s_parval = PROTECT(NEW_CHARACTER(parlen));
        for (k = 0; k < parlen; k++) {
          SET_STRING_ELT(s_parval, k, STRING_ELT(VECTOR_ELT(s_df, colcount+k), row));
          if (STRING_ELT(s_parval, k) != NA_STRING)
            all_missing = FALSE;
        }
      }

      /* are all entries in s_parval NA ? */
      if (all_missing)
        s_parval = ScalarLogical(NA_LOGICAL);

      /* convert discrete names to values */
      if (!all_missing && type == 3) {
        SETCADR(s_call, VECTOR_ELT(s_pars, par));
        SETCADDR(s_call, s_parval);
        s_parval = PROTECT(eval(s_call, R_GlobalEnv));
        UNPROTECT(1); /* eval */
      }
      /* only support for cnames for num, int, log and char vecs currently */
      if (type == 1 || type == 2 || type == 4 || type == 5)
        SET_NAMES(s_parval, VECTOR_ELT(s_cnames, par));

      SET_VECTOR_ELT(s_rowlist, par, s_parval);
      SET_NAMES(s_rowlist, s_parnames);
      colcount += parlen;
      UNPROTECT(1); /* s_parval  */
    }
    SET_VECTOR_ELT(s_res, row, s_rowlist);
    UNPROTECT(1); /* s_rowlist */
  }
  UNPROTECT(2); /* s_res, s_call */
  return s_res;
}
Exemple #15
0
	/* GetNativeSystemInfo is XP or later */
	pGNSI = (PGNSI)
	    GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
			   "GetNativeSystemInfo");
	if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
	if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
	    strcat(ver, " x64");
    }
    SET_STRING_ELT(ans, 1, mkChar(ver));

    if((int)osvi.dwMajorVersion >= 5) {
	if(osvi.wServicePackMajor > 0)
	    snprintf(ver, 256, "build %d, Service Pack %d",
		     LOWORD(osvi.dwBuildNumber),
		     (int) osvi.wServicePackMajor);
	else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
    } else
	snprintf(ver, 256, "build %d, %s",
		 LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
    SET_STRING_ELT(ans, 2, mkChar(ver));
    GetComputerNameW(name, &namelen);
    wcstoutf8(buf, name, 1000);
    SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
#ifdef WIN64
    SET_STRING_ELT(ans, 4, mkChar("x86-64"));
#else
    SET_STRING_ELT(ans, 4, mkChar("x86"));
#endif
    GetUserNameW(user, &userlen);
    wcstoutf8(buf, user, 1000);
    SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8));
    SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
    SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
    PROTECT(ansnames = allocVector(STRSXP, 8));
    SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
    SET_STRING_ELT(ansnames, 1, mkChar("release"));
    SET_STRING_ELT(ansnames, 2, mkChar("version"));
    SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
    SET_STRING_ELT(ansnames, 4, mkChar("machine"));
    SET_STRING_ELT(ansnames, 5, mkChar("login"));
    SET_STRING_ELT(ansnames, 6, mkChar("user"));
    SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
    setAttrib(ans, R_NamesSymbol, ansnames);
    UNPROTECT(2);
    return ans;
}

SEXP do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    DWORD mtime;
    int ntime;
    double time;

    checkArity(op, args);
    time = asReal(CAR(args));
    if (ISNAN(time) || time < 0)
	errorcall(call, _("invalid '%s' value"), "time");
    ntime = 1000*(time) + 0.5;
    while (ntime > 0) {
	mtime = min(500, ntime);
	ntime -= mtime;
	Sleep(mtime);
	R_ProcessEvents();
    }
    return R_NilValue;
}

#ifdef LEA_MALLOC
#define MALLINFO_FIELD_TYPE size_t
struct mallinfo {
    MALLINFO_FIELD_TYPE arena;    /* non-mmapped space allocated from system */
    MALLINFO_FIELD_TYPE ordblks;  /* number of free chunks */
    MALLINFO_FIELD_TYPE smblks;   /* number of fastbin blocks */
    MALLINFO_FIELD_TYPE hblks;    /* number of mmapped regions */
    MALLINFO_FIELD_TYPE hblkhd;   /* space in mmapped regions */
    MALLINFO_FIELD_TYPE usmblks;  /* maximum total allocated space */
    MALLINFO_FIELD_TYPE fsmblks;  /* space available in freed fastbin blocks */
    MALLINFO_FIELD_TYPE uordblks; /* total allocated space */
    MALLINFO_FIELD_TYPE fordblks; /* total free space */
    MALLINFO_FIELD_TYPE keepcost; /* top-most, releasable (via malloc_trim) space */
};
extern R_size_t R_max_memory;

struct mallinfo mallinfo(void);
#endif 

SEXP in_memsize(SEXP ssize)
{
    SEXP ans;
    int maxmem = NA_LOGICAL;

    if(isLogical(ssize)) 
	maxmem = asLogical(ssize);
    else if(isReal(ssize)) {
	R_size_t newmax;
	double mem = asReal(ssize);
	if (!R_FINITE(mem))
	    error(_("incorrect argument"));
#ifdef LEA_MALLOC
#ifndef WIN64
	if(mem >= 4096)
	    error(_("don't be silly!: your machine has a 4Gb address limit"));
#endif
	newmax = mem * 1048576.0;
	if (newmax < R_max_memory)
	    warning(_("cannot decrease memory limit: ignored"));
	else
	    R_max_memory = newmax;
#endif
    } else
	error(_("incorrect argument"));
	
    PROTECT(ans = allocVector(REALSXP, 1));
#ifdef LEA_MALLOC
    if(maxmem == NA_LOGICAL)
	REAL(ans)[0] = R_max_memory;
    else if(maxmem)
	REAL(ans)[0] = mallinfo().usmblks;
    else
	REAL(ans)[0] = mallinfo().uordblks;
    REAL(ans)[0] /= 1048576.0;
#else
    REAL(ans)[0] = NA_REAL;
#endif
    UNPROTECT(1);
    return ans;
}

SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP path = R_NilValue, ans;
    const wchar_t *dll;
    DWORD dwVerInfoSize;
    DWORD dwVerHnd;

    checkArity(op, args);
    path = CAR(args);
    if(!isString(path) || LENGTH(path) != 1)
	errorcall(call, _("invalid '%s' argument"), "path");
    dll = filenameToWchar(STRING_ELT(path, 0), FALSE);
    dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd);
    PROTECT(ans = allocVector(STRSXP, 2));
    SET_STRING_ELT(ans, 0, mkChar(""));
    SET_STRING_ELT(ans, 1, mkChar(""));
    if (dwVerInfoSize) {
	BOOL  fRet;
	LPSTR lpstrVffInfo;
	LPSTR lszVer = NULL;
	UINT  cchVer = 0;

	lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize);
	if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) {

	    fRet = VerQueryValue(lpstrVffInfo,
				 TEXT("\\StringFileInfo\\040904E4\\FileVersion"),
				 (LPVOID)&lszVer, &cchVer);
	    if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer));

	    fRet = VerQueryValue(lpstrVffInfo,
				 TEXT("\\StringFileInfo\\040904E4\\R Version"),
				 (LPVOID)&lszVer, &cchVer);
	    if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
	    else {
		fRet = VerQueryValue(lpstrVffInfo,
				     TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"),
				     (LPVOID)&lszVer, &cchVer);
		if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
	    }

	} else ans = R_NilValue;
	free(lpstrVffInfo);
    } else ans = R_NilValue;
    UNPROTECT(1);
    return ans;
}



int Rwin_rename(const char *from, const char *to)
{
    return (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
}

int Rwin_wrename(const wchar_t *from, const wchar_t *to)
{
    return (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
}


const char *formatError(DWORD res)
{
    static char buf[1000], *p;
    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
		  NULL, res,
		  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
		  buf, 1000, NULL);
    p = buf+strlen(buf) -1;
    if(*p == '\n') *p = '\0';
    p = buf+strlen(buf) -1;
    if(*p == '\r') *p = '\0';
    p = buf+strlen(buf) -1;
    if(*p == '.') *p = '\0';
    return buf;
}


void R_UTF8fixslash(char *s); /* from main/util.c */
SEXP do_normalizepath(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, paths = CAR(args), el, slash;
    int i, n = LENGTH(paths), res;
    char tmp[MAX_PATH], longpath[MAX_PATH], *tmp2;
    wchar_t wtmp[32768], wlongpath[32768], *wtmp2;
    int mustWork, fslash = 0;

    checkArity(op, args);
    if(!isString(paths))
	errorcall(call, _("'path' must be a character vector"));

    slash = CADR(args);
    if(!isString(slash) || LENGTH(slash) != 1)
	errorcall(call, "'winslash' must be a character string");
    const char *sl = CHAR(STRING_ELT(slash, 0));
    if (strcmp(sl, "/") && strcmp(sl, "\\"))
	errorcall(call, "'winslash' must be '/' or '\\\\'");
    if (strcmp(sl, "/") == 0) fslash = 1;
    
    mustWork = asLogical(CADDR(args));

    PROTECT(ans = allocVector(STRSXP, n));
    for (i = 0; i < n; i++) {
    	int warn = 0;
    	SEXP result;
	el = STRING_ELT(paths, i);
	result = el;
	if(getCharCE(el) == CE_UTF8) {
	    if ((res = GetFullPathNameW(filenameToWchar(el, FALSE), 32768, 
					wtmp, &wtmp2)) && res <= 32768) {
		if ((res = GetLongPathNameW(wtmp, wlongpath, 32768))
		    && res <= 32768) {
	    	    wcstoutf8(longpath, wlongpath, wcslen(wlongpath)+1);
		    if(fslash) R_UTF8fixslash(longpath);
	    	    result = mkCharCE(longpath, CE_UTF8);
		} else if(mustWork == 1) {
		    errorcall(call, "path[%d]=\"%s\": %s", i+1, 
			      translateChar(el), 
			      formatError(GetLastError()));	
	    	} else {
	    	    wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
		    if(fslash) R_UTF8fixslash(tmp);
	    	    result = mkCharCE(tmp, CE_UTF8);
	    	    warn = 1;
	    	}
	    } else if(mustWork == 1) {
		errorcall(call, "path[%d]=\"%s\": %s", i+1, 
			  translateChar(el), 
			  formatError(GetLastError()));	
	    } else {
		if (fslash) {
		    strcpy(tmp, translateCharUTF8(el));
		    R_UTF8fixslash(tmp);
	    	    result = mkCharCE(tmp, CE_UTF8);
		}
	    	warn = 1;
	    }
	    if (warn && (mustWork == NA_LOGICAL))
	    	warningcall(call, "path[%d]=\"%ls\": %s", i+1, 
			    filenameToWchar(el,FALSE), 
			    formatError(GetLastError()));
	} else {
	    if ((res = GetFullPathName(translateChar(el), MAX_PATH, tmp, &tmp2)) 
		&& res <= MAX_PATH) {
	    	if ((res = GetLongPathName(tmp, longpath, MAX_PATH))
		    && res <= MAX_PATH) {
		    if(fslash) R_fixslash(longpath);
	    	    result = mkChar(longpath);
		} else if(mustWork == 1) {
		    errorcall(call, "path[%d]=\"%s\": %s", i+1, 
			      translateChar(el), 
			      formatError(GetLastError()));	
	    	} else {
		    if(fslash) R_fixslash(tmp);
	    	    result = mkChar(tmp);
	    	    warn = 1;
	    	}
	    } else if(mustWork == 1) {
		errorcall(call, "path[%d]=\"%s\": %s", i+1, 
			  translateChar(el), 
			  formatError(GetLastError()));	
	    } else {
		if (fslash) {
		    strcpy(tmp, translateChar(el));
		    R_fixslash(tmp);
		    result = mkChar(tmp);
		}
	    	warn = 1;
	    }
	    if (warn && (mustWork == NA_LOGICAL))
		warningcall(call, "path[%d]=\"%s\": %s", i+1, 
			    translateChar(el), 
			    formatError(GetLastError()));	
	}
	SET_STRING_ELT(ans, i, result);
    }
    UNPROTECT(1);
    return ans;
}
Exemple #16
0
SEXP tiers(SEXP nodes, SEXP debug) {

int i = 0, j = 0, k = 0, narcs = 0, nnodes = 0, ntiers = LENGTH(nodes);
int *tier_size = NULL, *debuglevel = LOGICAL(debug), tier_start = 0, cur = 0;
SEXP flattened, blacklist, temp;

  /* allocate the counters for tiers' sizes.*/
  tier_size = alloc1dcont(ntiers);

  if (!isString(nodes)) {

    /* "node" is a list, each tier is an element. */
    for (i = ntiers - 1; i >= 0; i--) {

      temp = VECTOR_ELT(nodes, i);
      tier_size[i] = LENGTH(temp);
      nnodes += tier_size[i];
      narcs += (nnodes - tier_size[i]) * tier_size[i];

    }/*FOR*/

    /* flatten the tiers to keep manipulation later on simple. */
    PROTECT(flattened = allocVector(STRSXP, nnodes));

    for (i = 0, k = 0; i < ntiers; i++) {

      temp = VECTOR_ELT(nodes, i);

      for (j = 0; j < tier_size[i]; j++)
        SET_STRING_ELT(flattened, k++, STRING_ELT(temp, j));

    }/*FOR*/

  }/*THEN*/
  else {

    /* "node" is a character vector, which means that each node is in its own tier
     * and that there is no need to flatted it. */
    flattened = nodes;
    nnodes = LENGTH(nodes);
    for (i = 0; i < ntiers; i++)
      tier_size[i] = 1;

    /* the blacklist is the one resulting from a complete node ordering. */
    narcs = ntiers * (ntiers - 1) / 2;

  }/*ELSE*/

  /* allocate the return value. */
  PROTECT(blacklist = allocMatrix(STRSXP, narcs, 2));

  for (k = 0, i = 0; k < nnodes; k++) {

    temp = STRING_ELT(flattened, k);

    if (*debuglevel > 0)
      Rprintf("* current node is %s in tier %d.\n", CHAR(temp), i + 1);

    for (j = tier_start + tier_size[i]; j < nnodes; j++) {

      if (*debuglevel)
        Rprintf("  > blacklisting %s -> %s\n", CHAR(STRING_ELT(flattened, j)), CHAR(temp));

      SET_STRING_ELT(blacklist, cur, STRING_ELT(flattened, j));
      SET_STRING_ELT(blacklist, cur + narcs, temp);
      cur++;

    }/*FOR*/

    if (k >= tier_start + tier_size[i] - 1)
      tier_start += tier_size[i++];

    if (i == ntiers)
      break;

  }

  /* allocate, initialize and set the column names. */
  finalize_arcs(blacklist);

  if (!isString(nodes))
    UNPROTECT(2);
  else
    UNPROTECT(1);

  return blacklist;

}/*TIERS*/
Exemple #17
0
/**
 * Commit
 *
 * @param repo S4 class git_repository
 * @param message The message for the commit
 * @param author S4 class git_signature
 * @param committer S4 class git_signature
 * @return S4 class git_commit
 */
SEXP git2r_commit(
    SEXP repo,
    SEXP message,
    SEXP author,
    SEXP committer)
{
    int err;
    SEXP result = R_NilValue;
    git_signature *c_author = NULL;
    git_signature *c_committer = NULL;
    git_index *index = NULL;
    git_oid oid;
    git_repository *repository = NULL;
    git_commit *commit = NULL;

    if (git2r_arg_check_string(message))
        git2r_error(git2r_err_string_arg, __func__, "message");
    if (git2r_arg_check_signature(author))
        git2r_error(git2r_err_signature_arg, __func__, "author");
    if (git2r_arg_check_signature(committer))
        git2r_error(git2r_err_signature_arg, __func__, "committer");

    repository = git2r_repository_open(repo);
    if (!repository)
        git2r_error(git2r_err_invalid_repository, __func__, NULL);

    err = git2r_signature_from_arg(&c_author, author);
    if (GIT_OK != err)
        goto cleanup;

    err = git2r_signature_from_arg(&c_committer, committer);
    if (GIT_OK != err)
        goto cleanup;

    err = git2r_any_changes_in_index(repository);
    if (GIT_OK != err)
        goto cleanup;

    err = git_repository_index(&index, repository);
    if (GIT_OK != err)
        goto cleanup;

    err = git2r_commit_create(
        &oid,
        repository,
        index,
        CHAR(STRING_ELT(message, 0)),
        c_author,
        c_committer);
    if (GIT_OK != err)
        goto cleanup;

    err = git_commit_lookup(&commit, repository, &oid);
    if (GIT_OK != err)
        goto cleanup;

    PROTECT(result = NEW_OBJECT(MAKE_CLASS("git_commit")));
    git2r_commit_init(commit, repo, result);

cleanup:
    if (c_author)
        git_signature_free(c_author);

    if (c_committer)
        git_signature_free(c_committer);

    if (index)
        git_index_free(index);

    if (repository)
        git_repository_free(repository);

    if (commit)
        git_commit_free(commit);

    if (R_NilValue != result)
        UNPROTECT(1);

    if (GIT_OK != err)
        git2r_error(git2r_err_from_libgit2, __func__, giterr_last()->message);

    return result;
}
Exemple #18
0
// Coordinate descent for poisson models
SEXP cdfit_poisson(SEXP X_, SEXP y_, SEXP penalty_, SEXP lambda, SEXP eps_, SEXP max_iter_, SEXP gamma_, SEXP multiplier, SEXP alpha_, SEXP dfmax_, SEXP user_, SEXP warn_) {

  // Declarations
  int n = length(y_);
  int p = length(X_)/n;
  int L = length(lambda);
  SEXP res, beta0, beta, Dev, iter;
  PROTECT(beta0 = allocVector(REALSXP, L));
  double *b0 = REAL(beta0);
  for (int i=0; i<L; i++) b0[i] = 0;
  PROTECT(beta = allocVector(REALSXP, L*p));
  double *b = REAL(beta);
  for (int j=0; j<(L*p); j++) b[j] = 0;
  PROTECT(Dev = allocVector(REALSXP, L));
  PROTECT(iter = allocVector(INTSXP, L));
  for (int i=0; i<L; i++) INTEGER(iter)[i] = 0;
  double *a = Calloc(p, double);    // Beta from previous iteration
  for (int j=0; j<p; j++) a[j] = 0;
  double a0 = 0;                    // Beta0 from previous iteration
  double *X = REAL(X_);
  double *y = REAL(y_);
  const char *penalty = CHAR(STRING_ELT(penalty_, 0));
  double *lam = REAL(lambda);
  double eps = REAL(eps_)[0];
  int max_iter = INTEGER(max_iter_)[0];
  double gamma = REAL(gamma_)[0];
  double *m = REAL(multiplier);
  double alpha = REAL(alpha_)[0];
  int dfmax = INTEGER(dfmax_)[0];
  int user = INTEGER(user_)[0];
  int warn = INTEGER(warn_)[0];
  double *r = Calloc(n, double);
  double *w = Calloc(n, double);
  double *s = Calloc(n, double);
  double *z = Calloc(p, double);
  double *eta = Calloc(n, double);
  int *e1 = Calloc(p, int);
  for (int j=0; j<p; j++) e1[j] = 0;
  int *e2 = Calloc(p, int);
  for (int j=0; j<p; j++) e2[j] = 0;
  double xwr, xwx, mu, u, v, cutoff, l1, l2, shift, si;
  int lstart;

  // Initialization
  double ybar = sum(y, n)/n;
  a0 = b0[0] = log(ybar);
  double nullDev = 0;
  for (int i=0;i<n;i++) if (y[i]!=0) nullDev += y[i]*log(y[i]/ybar);
  for (int i=0; i<n; i++) s[i] = y[i] - ybar;
  for (int i=0; i<n; i++) eta[i] = a0;
  for (int j=0; j<p; j++) z[j] = crossprod(X, s, n, j)/n;

  // If lam[0]=lam_max, skip lam[0] -- closed form sol'n available
  if (user) {
    lstart = 0;
  } else {
    lstart = 1;
    REAL(Dev)[0] = nullDev;
  }

  // Path
  for (int l=lstart; l<L; l++) {
    R_CheckUserInterrupt();
    if (l != 0) {
      // Assign a, a0
      a0 = b0[l-1];
      for (int j=0; j<p; j++) a[j] = b[(l-1)*p+j];

      // Check dfmax
      int nv = 0;
      for (int j=0; j<p; j++) {
	if (a[j] != 0) nv++;
      }
      if (nv > dfmax) {
	for (int ll=l; ll<L; ll++) INTEGER(iter)[ll] = NA_INTEGER;
	res = cleanupP(s, w, a, r, e1, e2, z, eta, beta0, beta, Dev, iter);
	return(res);
      }

      // Determine eligible set
      if (strcmp(penalty, "lasso")==0) cutoff = 2*lam[l] - lam[l-1];
      if (strcmp(penalty, "MCP")==0) cutoff = lam[l] + gamma/(gamma-1)*(lam[l] - lam[l-1]);
      if (strcmp(penalty, "SCAD")==0) cutoff = lam[l] + gamma/(gamma-2)*(lam[l] - lam[l-1]);
      for (int j=0; j<p; j++) if (fabs(z[j]) > (cutoff * alpha * m[j])) e2[j] = 1;
    } else {

      // Determine eligible set
      double lmax = 0;
      for (int j=0; j<p; j++) if (fabs(z[j]) > lmax) lmax = fabs(z[j]);
      if (strcmp(penalty, "lasso")==0) cutoff = 2*lam[l] - lmax;
      if (strcmp(penalty, "MCP")==0) cutoff = lam[l] + gamma/(gamma-1)*(lam[l] - lmax);
      if (strcmp(penalty, "SCAD")==0) cutoff = lam[l] + gamma/(gamma-2)*(lam[l] - lmax);
      for (int j=0; j<p; j++) if (fabs(z[j]) > (cutoff * alpha * m[j])) e2[j] = 1;
    }

    while (INTEGER(iter)[l] < max_iter) {
      while (INTEGER(iter)[l] < max_iter) {
	while (INTEGER(iter)[l] < max_iter) {
	  INTEGER(iter)[l]++;
	  REAL(Dev)[l] = 0;
          double maxChange = 0;
	  for (int i=0;i<n;i++) {
	    mu = exp(eta[i]);
	    w[i] = mu;
	    s[i] = y[i] - mu;
	    r[i] = s[i]/w[i];
	    if (y[i]!=0) REAL(Dev)[l] += y[i]*log(y[i]/mu);
	  }
	  if (REAL(Dev)[l]/nullDev < .01) {
	    if (warn) warning("Model saturated; exiting...");
	    for (int ll=l; ll<L; ll++) INTEGER(iter)[ll] = NA_INTEGER;
	    res = cleanupP(s, w, a, r, e1, e2, z, eta, beta0, beta, Dev, iter);
	    return(res);
	  }

	  // Intercept
	  xwr = crossprod(w, r, n, 0);
	  xwx = sum(w, n);
	  b0[l] = xwr/xwx + a0;
	  for (int i=0; i<n; i++) {
	    si = b0[l] - a0;
	    r[i] -= si;
	    eta[i] += si;
	  }

	  // Covariates
	  for (int j=0; j<p; j++) {
	    if (e1[j]) {

	      // Calculate u, v
	      xwr = wcrossprod(X, r, w, n, j);
	      xwx = wsqsum(X, w, n, j);
	      u = xwr/n + (xwx/n)*a[j];
	      v = xwx/n;

	      // Update b_j
	      l1 = lam[l] * m[j] * alpha;
	      l2 = lam[l] * m[j] * (1-alpha);
	      if (strcmp(penalty,"MCP")==0) b[l*p+j] = MCP(u, l1, l2, gamma, v);
	      if (strcmp(penalty,"SCAD")==0) b[l*p+j] = SCAD(u, l1, l2, gamma, v);
	      if (strcmp(penalty,"lasso")==0) b[l*p+j] = lasso(u, l1, l2, v);

	      // Update r
	      shift = b[l*p+j] - a[j];
	      if (shift !=0) {
		for (int i=0;i<n;i++) {
		  si = shift*X[j*n+i];
		  r[i] -= si;
		  eta[i] += si;
		}
                if (fabs(shift)*v > maxChange) maxChange = fabs(shift)*v;
	      }
	    }
	  }

	  // Check for convergence
	  a0 = b0[l];
	  for (int j=0; j<p; j++) a[j] = b[l*p+j];
          if (maxChange < eps) break;
	}

	// Scan for violations in strong set
	int violations = 0;
	for (int j=0; j<p; j++) {
	  if (e1[j]==0 & e2[j]==1) {
	    z[j] = crossprod(X, s, n, j)/n;
	    l1 = lam[l] * m[j] * alpha;
	    if (fabs(z[j]) > l1) {
	      e1[j] = e2[j] = 1;
	      violations++;
	    }
	  }
	}
	if (violations==0) break;
      }

      // Scan for violations in rest
      int violations = 0;
      for (int j=0; j<p; j++) {
	if (e2[j]==0) {
	  z[j] = crossprod(X, s, n, j)/n;
	  l1 = lam[l] * m[j] * alpha;
	  if (fabs(z[j]) > l1) {
	    e1[j] = e2[j] = 1;
	    violations++;
	  }
	}
      }
      if (violations==0) break;
    }
  }
  res = cleanupP(s, w, a, r, e1, e2, z, eta, beta0, beta, Dev, iter);
  return(res);
}
Exemple #19
0
SEXP attribute_hidden do_sprintf(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
    int i, nargs, cnt, v, thislen, nfmt, nprotect = 0;
    /* fmt2 is a copy of fmt with '*' expanded.
       bit will hold numeric formats and %<w>s, so be quite small. */
    char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],
	*outputString;
    const char *formatString;
    size_t n, cur, chunk;

    SEXP format, _this, a[MAXNARGS], ans /* -Wall */ = R_NilValue;
    int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0;
    static R_StringBuffer outbuff = {nullptr, 0, MAXELTSIZE};
    Rboolean has_star, use_UTF8;

#define _my_sprintf(_X_)						\
    {									\
	int nc = snprintf(bit, MAXLINE+1, fmtp, _X_);			\
	if (nc > MAXLINE)						\
	    error(_("required resulting string length %d is greater than maximal %d"), \
		  nc, MAXLINE);						\
    }

    nargs = num_args;
    /* grab the format string */
    format = num_args ? args[0] : nullptr;
    if (!isString(format))
	error(_("'fmt' is not a character vector"));
    nfmt = length(format);
    if (nfmt == 0) return allocVector(STRSXP, 0);
    args = (args + 1); nargs--;
    if(nargs >= MAXNARGS)
	error(_("only %d arguments are allowed"), MAXNARGS);

    /* record the args for possible coercion and later re-ordering */
    for(i = 0; i < nargs; i++, args = (args + 1)) {
	SEXPTYPE t_ai;
	a[i] = args[0];
	if((t_ai = TYPEOF(a[i])) == LANGSXP || t_ai == SYMSXP) /* << maybe add more .. */
	    error(_("invalid type of argument[%d]: '%s'"),
		  i+1, CHAR(type2str(t_ai)));
	lens[i] = length(a[i]);
	if(lens[i] == 0) return allocVector(STRSXP, 0);
    }

#define CHECK_maxlen							\
    maxlen = nfmt;							\
    for(i = 0; i < nargs; i++)						\
	if(maxlen < lens[i]) maxlen = lens[i];				\
    if(maxlen % nfmt)							\
	error(_("arguments cannot be recycled to the same length"));	\
    for(i = 0; i < nargs; i++)						\
	if(maxlen % lens[i])						\
	    error(_("arguments cannot be recycled to the same length"))

    CHECK_maxlen;

    outputString = CXXRCONSTRUCT(static_cast<char*>, R_AllocStringBuffer(0, &outbuff));

    /* We do the format analysis a row at a time */
    for(ns = 0; ns < maxlen; ns++) {
	outputString[0] = '\0';
	use_UTF8 = CXXRCONSTRUCT(Rboolean, getCharCE(STRING_ELT(format, ns % nfmt)) == CE_UTF8);
	if (!use_UTF8) {
	    for(i = 0; i < nargs; i++) {
		if (!isString(a[i])) continue;
		if (getCharCE(STRING_ELT(a[i], ns % lens[i])) == CE_UTF8) {
		    use_UTF8 = TRUE; break;
		}
	    }
	}

	formatString = TRANSLATE_CHAR(format, ns % nfmt);
	n = strlen(formatString);
	if (n > MAXLINE)
	    error(_("'fmt' length exceeds maximal format length %d"), MAXLINE);
	/* process the format string */
	for (cur = 0, cnt = 0; cur < n; cur += chunk) {
	    const char *curFormat = formatString + cur, *ss;
	    char *starc;
	    ss = nullptr;
	    if (formatString[cur] == '%') { /* handle special format command */

		if (cur < n - 1 && formatString[cur + 1] == '%') {
		    /* take care of %% in the format */
		    chunk = 2;
		    strcpy(bit, "%");
		}
		else {
		    /* recognise selected types from Table B-1 of K&R */
		    /* NB: we deal with "%%" in branch above. */
		    /* This is MBCS-OK, as we are in a format spec */
		    chunk = strcspn(curFormat + 1, "diosfeEgGxXaA") + 2;
		    if (cur + chunk > n)
			error(_("unrecognised format specification '%s'"), curFormat);

		    strncpy(fmt, curFormat, chunk);
		    fmt[chunk] = '\0';

		    nthis = -1;
		    /* now look for %n$ or %nn$ form */
		    if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') {
			v = fmt[1] - '0';
			if(fmt[2] == '$') {
			    if(v > nargs)
				error(_("reference to non-existent argument %d"), v);
			    nthis = v-1;
			    memmove(fmt+1, fmt+3, strlen(fmt)-2);
			} else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') {
			    v = 10*v + fmt[2] - '0';
			    if(v > nargs)
				error(_("reference to non-existent argument %d"), v);
			    nthis = v-1;
			    memmove(fmt+1, fmt+4, strlen(fmt)-3);
			}
		    }

		    starc = Rf_strchr(fmt, '*');
		    if (starc) { /* handle  *  format if present */
			nstar = -1;
			if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') {
			    v = starc[1] - '0';
			    if(starc[2] == '$') {
				if(v > nargs)
				    error(_("reference to non-existent argument %d"), v);
				nstar = v-1;
				memmove(starc+1, starc+3, strlen(starc)-2);
			    } else if(starc[2] >= '0' && starc[2] <= '9'
				      && starc[3] == '$') {
				v = 10*v + starc[2] - '0';
				if(v > nargs)
				    error(_("reference to non-existent argument %d"), v);
				nstar = v-1;
				memmove(starc+1, starc+4, strlen(starc)-3);
			    }
			}

			if(nstar < 0) {
			    if (cnt >= nargs) error(_("too few arguments"));
			    nstar = cnt++;
			}

			if (Rf_strchr(starc+1, '*'))
			    error(_("at most one asterisk '*' is supported in each conversion specification"));

			_this = a[nstar];
			if(ns == 0 && TYPEOF(_this) == REALSXP) {
			    _this = coerceVector(_this, INTSXP);
			    PROTECT(a[nstar] = _this);
			    nprotect++;
			}
			if(TYPEOF(_this) != INTSXP || LENGTH(_this)<1 ||
			   INTEGER(_this)[ns % LENGTH(_this)] == NA_INTEGER)
			    error(_("argument for '*' conversion specification must be a number"));
			star_arg = INTEGER(_this)[ns % LENGTH(_this)];
			has_star = TRUE;
		    }
		    else
			has_star = FALSE;

		    if (fmt[strlen(fmt) - 1] == '%') {
			/* handle % with formatting options */
			if (has_star)
			    snprintf(bit, MAXLINE+1, fmt, star_arg);
			else
			    strcpy(bit, fmt);
			/* was sprintf(..)  for which some compiler warn */
		    } else {
			Rboolean did_this = FALSE;
			if(nthis < 0) {
			    if (cnt >= nargs) error(_("too few arguments"));
			    nthis = cnt++;
			}
			_this = a[nthis];
			if (has_star) {
			    size_t nf; char *p, *q = fmt2;
			    for (p = fmt; *p; p++)
				if (*p == '*') q += sprintf(q, "%d", star_arg);
				else *q++ = *p;
			    *q = '\0';
			    nf = strlen(fmt2);
			    if (nf > MAXLINE)
				error(_("'fmt' length exceeds maximal format length %d"),
				      MAXLINE);
			    fmtp = fmt2;
			} else fmtp = fmt;

#define CHECK_this_length						\
			PROTECT(_this);					\
			thislen = length(_this);			\
			if(thislen == 0)				\
			    error(_("coercion has changed vector length to 0"))

			/* Now let us see if some minimal coercion
			   would be sensible, but only do so once, for ns = 0: */
			if(ns == 0) {
			    SEXP tmp; Rboolean do_check;
			    switch(*findspec(fmtp)) {
			    case 'd':
			    case 'i':
			    case 'o':
			    case 'x':
			    case 'X':
				if(TYPEOF(_this) == REALSXP) {
				    double r = REAL(_this)[0];
				    if(double(int( r)) == r)
					_this = coerceVector(_this, INTSXP);
				    PROTECT(a[nthis] = _this);
				    nprotect++;
				}
				break;
			    case 'a':
			    case 'A':
			    case 'e':
			    case 'f':
			    case 'g':
			    case 'E':
			    case 'G':
				if(TYPEOF(_this) != REALSXP &&
				   /* no automatic as.double(<string>) : */
				   TYPEOF(_this) != STRSXP) {
				    PROTECT(tmp = lang2(install("as.double"), _this));
#define COERCE_THIS_TO_A						\
				    _this = eval(tmp, env);		\
				    UNPROTECT(1);			\
				    PROTECT(a[nthis] = _this);		\
				    nprotect++;				\
				    did_this = TRUE;			\
				    CHECK_this_length;			\
				    do_check = (CXXRCONSTRUCT(Rboolean, lens[nthis] == maxlen)); \
				    lens[nthis] = thislen; /* may have changed! */ \
				    if(do_check && thislen < maxlen) {	\
					CHECK_maxlen;			\
				    }

				    COERCE_THIS_TO_A
				}
				break;
			    case 's':
				if(TYPEOF(_this) != STRSXP) {
				    /* as.character method might call sprintf() */
				    size_t nc = strlen(outputString);
				    char *z = Calloc(nc+1, char);
				    strcpy(z, outputString);
				    PROTECT(tmp = lang2(install("as.character"), _this));

				    COERCE_THIS_TO_A
				    strcpy(outputString, z);
				    Free(z);
				}
				break;
			    default:
				break;
			    }
			} /* ns == 0 (first-time only) */

			if(!did_this)
			    CHECK_this_length;

			switch(TYPEOF(_this)) {
			case LGLSXP:
			    {
				int x = LOGICAL(_this)[ns % thislen];
				if (checkfmt(fmtp, "di"))
				    error(_("invalid format '%s'; %s"), fmtp,
					  _("use format %d or %i for logical objects"));
				if (x == NA_LOGICAL) {
				    fmtp[strlen(fmtp)-1] = 's';
				    _my_sprintf("NA")
				} else {
				    _my_sprintf(x)
				}
				break;
			    }
			case INTSXP:
			    {
				int x = INTEGER(_this)[ns % thislen];
				if (checkfmt(fmtp, "dioxX"))
				    error(_("invalid format '%s'; %s"), fmtp,
					  _("use format %d, %i, %o, %x or %X for integer objects"));
				if (x == NA_INTEGER) {
				    fmtp[strlen(fmtp)-1] = 's';
				    _my_sprintf("NA")
				} else {
				    _my_sprintf(x)
				}
				break;
			    }
Exemple #20
0
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int   i, rc;
    ParseStatus status;
    SEXP  x, fn, envir, ti, ed, t;
    char *filename, *editcmd, *vmaxsave, *cmd;
    FILE *fp;
#ifdef Win32
    char *title;
#endif

	checkArity(op, args);

    vmaxsave = vmaxget();

    x = CAR(args); args = CDR(args);
    if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
    else envir = R_NilValue;
    PROTECT(envir);

    fn = CAR(args); args = CDR(args);
    if (!isString(fn))
	error(_("invalid argument to edit()"));

    if (LENGTH(STRING_ELT(fn, 0)) > 0) {
	filename = R_alloc(strlen(CHAR(STRING_ELT(fn, 0))), sizeof(char));
	strcpy(filename, CHAR(STRING_ELT(fn, 0)));
    }
    else filename = DefaultFileName;

    if (x != R_NilValue) {

	if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
	    errorcall(call, _("unable to open file"));
	if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
	if (TYPEOF(x) != CLOSXP || isNull(t = getAttrib(x, R_SourceSymbol)))
	    t = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */
	for (i = 0; i < LENGTH(t); i++)
	    fprintf(fp, "%s\n", CHAR(STRING_ELT(t, i)));
	fclose(fp);
    }
    ti = CAR(args); args = CDR(args);
    ed = CAR(args);
    if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
    cmd = CHAR(STRING_ELT(ed, 0));
    if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
    editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
    if (!strcmp(cmd,"internal")) {
	if (!isString(ti))
	    error(_("'title' must be a string"));
	if (LENGTH(STRING_ELT(ti, 0)) > 0) {
	    title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
	    strcpy(title, CHAR(STRING_ELT(ti, 0)));
	} else {
	    title = R_alloc(strlen(filename)+1, sizeof(char));
	    strcpy(title, filename);
	}
	Rgui_Edit(filename, title, 1);
    }
    else {
	/* Quote path if necessary */
	if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
	    sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
	else
	    sprintf(editcmd, "%s \"%s\"", cmd, filename);
	rc = runcmd(editcmd, 1, 1, "");
	if (rc == NOLAUNCH)
	    errorcall(call, _("unable to run editor '%s'"), cmd);
	if (rc != 0)
	    warningcall(call, _("editor ran but returned error status"));
    }
#else
    if (ptr_R_EditFile)
        rc = ptr_R_EditFile(filename);
    else {
        sprintf(editcmd, "%s %s", cmd, filename);
        rc = R_system(editcmd);
    }
    if (rc != 0)
	errorcall(call, _("problem with running editor %s"), cmd);
#endif

    if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
	errorcall(call, _("unable to open file to read"));
    R_ParseCnt = 0;
    x = PROTECT(R_ParseFile(fp, -1, &status));
    fclose(fp);
    if (status != PARSE_OK)
	errorcall(call,
		  _("an error occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseError);
    R_ResetConsole();
    {   /* can't just eval(x) here */
	int j, n;
	SEXP tmp = R_NilValue;

	n = LENGTH(x);
	for (j = 0 ; j < n ; j++)
	    tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
	x = tmp;
    }
    if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
	SET_CLOENV(x, envir);
    UNPROTECT(2);
    vmaxset(vmaxsave);
    return (x);
}
Exemple #21
0
/* conditional independence tests. */
SEXP ctest(SEXP x, SEXP y, SEXP sx, SEXP data, SEXP test, SEXP B, SEXP alpha,
    SEXP learning) {

int ntests = length(x), nobs = 0;
double *pvalue = NULL, statistic = 0, df = NA_REAL;
const char *t = CHAR(STRING_ELT(test, 0));
test_e test_type = test_label(t);
SEXP xx, yy, zz, result;

  /* allocate the return value, which the same length as x. */
  PROTECT(result = allocVector(REALSXP, ntests));
  setAttrib(result, R_NamesSymbol, x);
  pvalue = REAL(result);
  /* set all elements to zero. */
  memset(pvalue, '\0', ntests * sizeof(double));

  /* extract the variables from the data. */
  PROTECT(xx = c_dataframe_column(data, x, FALSE, FALSE));
  PROTECT(yy = c_dataframe_column(data, y, TRUE, FALSE));
  PROTECT(zz = c_dataframe_column(data, sx, FALSE, FALSE));
  nobs = length(yy);

  if (IS_DISCRETE_ASYMPTOTIC_TEST(test_type)) {

    /* parametric tests for discrete variables. */
    statistic = ct_discrete(xx, yy, zz, nobs, ntests, pvalue, &df, test_type);

  }/*THEN*/
  else if ((test_type == COR) || (test_type == ZF) || (test_type == MI_G) ||
           (test_type == MI_G_SH)) {

    /* parametric tests for Gaussian variables. */
    statistic = ct_gaustests(xx, yy, zz, nobs, ntests, pvalue, &df, test_type);

  }/*THEN*/
  else if (test_type == MI_CG) {

    /* conditional linear Gaussian mutual information test. */
    statistic = ct_micg(xx, yy, zz, nobs, ntests, pvalue, &df);

  }/*THEN*/
  else if (IS_DISCRETE_PERMUTATION_TEST(test_type)) {

    statistic = ct_dperm(xx, yy, zz, nobs, ntests, pvalue, &df, test_type, INT(B),
                  IS_SMC(test_type) ? NUM(alpha) : 1);

  }/*THEN*/
  else if (IS_CONTINUOUS_PERMUTATION_TEST(test_type)) {

    statistic = ct_gperm(xx, yy, zz, nobs, ntests, pvalue, &df, test_type, INT(B),
                  IS_SMC(test_type) ? NUM(alpha) : 1);

  }/*THEN*/

  UNPROTECT(4);

  /* catch-all for unknown tests (after deallocating memory.) */
  if (test_type == ENOTEST)
    error("unknown test statstic '%s'.", t);

  /* increase the test counter. */
  test_counter += ntests;

  if (isTRUE(learning))
    return result;
  else
    return c_create_htest(statistic, test, pvalue[ntests - 1], df, B);

}/*CTEST*/
Exemple #22
0
/* convert an arc set to an edge list. */
SEXP arcs2elist(SEXP arcs, SEXP nodes, SEXP id, SEXP sublist) {

int i = 0, j = 0, k = 0, nnodes = LENGTH(nodes), narcs = LENGTH(arcs)/2;
int *e = NULL, *coords = NULL, *children = NULL;
int *convert = LOGICAL(id), *sub = LOGICAL(sublist);
SEXP try, elist, edges, temp, temp_name = R_NilValue;

  /* allocate the return value. */
  PROTECT(elist = allocVector(VECSXP, nnodes));
  /* set the node names. */
  setAttrib(elist, R_NamesSymbol, nodes);

  if (*sub > 0) {

    /* allocate and initialize the subset name. */
    PROTECT(temp_name = allocVector(STRSXP, 1));
    SET_STRING_ELT(temp_name, 0, mkChar("edges"));

  }/*THEN*/

  /* allocate the scratch space to keep track of the children of each node. */
  children = alloc1dcont(nnodes);

  /* match the node labels in the arc set. */
  PROTECT(try = match(nodes, arcs, 0));
  coords = INTEGER(try);

  for (i = 0; i < narcs; i++) {

    children[coords[i] - 1]++;

  }/*FOR*/

  for (i = 0; i < nnodes; i++) {

    /* allocate and set up the edge array. */
    if (*convert > 0) {

      PROTECT(edges = allocVector(INTSXP, children[i]));
      e = INTEGER(edges);

    }/*THEN*/
    else {

      PROTECT(edges = allocVector(STRSXP, children[i]));

    }/*ELSE*/

    /* copy the coordinates of the adjacent nodes. */
    for (j = 0, k = 0; j < narcs; j++) {

      if (coords[j] != i + 1)
        continue;

      if (*convert > 0)
        e[k++] = coords[narcs + j];
      else
        SET_STRING_ELT(edges, k++, STRING_ELT(arcs, narcs + j));

      if (k == children[i])
        break;

    }/*FOR*/

    if (*sub > 0) {

      /* allocate and set up the "edge" sublist for graphNEL. */
      PROTECT(temp = allocVector(VECSXP, 1));
      setAttrib(temp, R_NamesSymbol, temp_name);
      SET_VECTOR_ELT(temp, 0, edges);
      SET_VECTOR_ELT(elist, i, temp);
      UNPROTECT(1);

    }/*THEN*/
    else {

      SET_VECTOR_ELT(elist, i, edges);

    }/*ELSE*/

    UNPROTECT(1);

  }/*FOR*/

  if (*sub > 0)
    UNPROTECT(3);
  else
    UNPROTECT(2);

  return elist;

}/*ARCS2ELIST*/
Exemple #23
0
SEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y)
{
    SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames;
    int nx, ny, xarray, yarray, xts, yts;
    Rboolean mismatch = FALSE, iS;
    PROTECT_INDEX xpi, ypi;

    PROTECT_WITH_INDEX(x, &xpi);
    PROTECT_WITH_INDEX(y, &ypi);
    nx = length(x);
    ny = length(y);

    /* pre-test to handle the most common case quickly.
       Used to skip warning too ....
     */
    if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue &&
	TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP &&
	LENGTH(x) > 0 && LENGTH(y) > 0) {
	SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
	if (nx > 0 && ny > 0)
	    mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
	if (mismatch) {
	    PROTECT(ans);
	    warningcall(call, _("longer object length is not a multiple of shorter object length"));
	    UNPROTECT(1);
	}
	UNPROTECT(2);
	return ans;
    }

    /* That symbols and calls were allowed was undocumented prior to
       R 2.5.0.  We deparse them as deparse() would, minus attributes */
    if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) {
	SEXP tmp = allocVector(STRSXP, 1);
	PROTECT(tmp);
	SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) :
		       STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0));
	REPROTECT(x = tmp, xpi);
	UNPROTECT(1);
    }
    if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) {
	SEXP tmp = allocVector(STRSXP, 1);
	PROTECT(tmp);
	SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) :
		       STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0));
	REPROTECT(y = tmp, ypi);
	UNPROTECT(1);
    }

    if (!isVector(x) || !isVector(y)) {
	if (isNull(x) || isNull(y)) {
	    UNPROTECT(2);
	    return allocVector(LGLSXP,0);
	}
	errorcall(call,
		  _("comparison (%d) is possible only for atomic and list types"),
		  PRIMVAL(op));
    }

    if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP)
	errorcall(call, _("comparison is not allowed for expressions"));

    /* ELSE :  x and y are both atomic or list */

    if (LENGTH(x) <= 0 || LENGTH(y) <= 0) {
	UNPROTECT(2);
	return allocVector(LGLSXP,0);
    }

    mismatch = FALSE;
    xarray = isArray(x);
    yarray = isArray(y);
    xts = isTs(x);
    yts = isTs(y);
    if (nx > 0 && ny > 0)
	mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;

    if (xarray || yarray) {
	if (xarray && yarray) {
	    if (!conformable(x, y))
		errorcall(call, _("non-conformable arrays"));
	    PROTECT(dims = getAttrib(x, R_DimSymbol));
	}
	else if (xarray) {
	    PROTECT(dims = getAttrib(x, R_DimSymbol));
	}
	else /*(yarray)*/ {
	    PROTECT(dims = getAttrib(y, R_DimSymbol));
	}
	PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
	PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
    }
    else {
	PROTECT(dims = R_NilValue);
	PROTECT(xnames = getAttrib(x, R_NamesSymbol));
	PROTECT(ynames = getAttrib(y, R_NamesSymbol));
    }
    if (xts || yts) {
	if (xts && yts) {
	    if (!tsConform(x, y))
		errorcall(call, _("non-conformable time series"));
	    PROTECT(tsp = getAttrib(x, R_TspSymbol));
	    PROTECT(klass = getAttrib(x, R_ClassSymbol));
	}
	else if (xts) {
	    if (length(x) < length(y))
		ErrorMessage(call, ERROR_TSVEC_MISMATCH);
	    PROTECT(tsp = getAttrib(x, R_TspSymbol));
	    PROTECT(klass = getAttrib(x, R_ClassSymbol));
	}
	else /*(yts)*/ {
	    if (length(y) < length(x))
		ErrorMessage(call, ERROR_TSVEC_MISMATCH);
	    PROTECT(tsp = getAttrib(y, R_TspSymbol));
	    PROTECT(klass = getAttrib(y, R_ClassSymbol));
	}
    }
    if (mismatch)
	warningcall(call, _("longer object length is not a multiple of shorter object length"));

    if (isString(x) || isString(y)) {
	REPROTECT(x = coerceVector(x, STRSXP), xpi);
	REPROTECT(y = coerceVector(y, STRSXP), ypi);
	x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    }
    else if (isComplex(x) || isComplex(y)) {
	REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
	REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
	x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
    }
    else if (isReal(x) || isReal(y)) {
	REPROTECT(x = coerceVector(x, REALSXP), xpi);
	REPROTECT(y = coerceVector(y, REALSXP), ypi);
	x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    }
    else if (isInteger(x) || isInteger(y)) {
	REPROTECT(x = coerceVector(x, INTSXP), xpi);
	REPROTECT(y = coerceVector(y, INTSXP), ypi);
	x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    }
    else if (isLogical(x) || isLogical(y)) {
	REPROTECT(x = coerceVector(x, LGLSXP), xpi);
	REPROTECT(y = coerceVector(y, LGLSXP), ypi);
	x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    }
    else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
	REPROTECT(x = coerceVector(x, RAWSXP), xpi);
	REPROTECT(y = coerceVector(y, RAWSXP), ypi);
	x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    } else errorcall(call, _("comparison of these types is not implemented"));


    PROTECT(x);
    if (dims != R_NilValue) {
	setAttrib(x, R_DimSymbol, dims);
	if (xnames != R_NilValue)
	    setAttrib(x, R_DimNamesSymbol, xnames);
	else if (ynames != R_NilValue)
	    setAttrib(x, R_DimNamesSymbol, ynames);
    }
    else {
	if (length(x) == length(xnames))
	    setAttrib(x, R_NamesSymbol, xnames);
	else if (length(x) == length(ynames))
	    setAttrib(x, R_NamesSymbol, ynames);
    }
    if (xts || yts) {
	setAttrib(x, R_TspSymbol, tsp);
	setAttrib(x, R_ClassSymbol, klass);
	UNPROTECT(2);
    }

    UNPROTECT(6);
    return x;
}
Exemple #24
0
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call)
{
    /* ExtractSubset is currently copied/inspired by subset.c from GNU-R
       This is slated to be reimplemented using the previous method
       in xts to get the correct dimnames
    */
    int i, ii, n, nx, mode;
    SEXP tmp, tmp2;
    mode = TYPEOF(x);
    n = LENGTH(indx); 
    nx = length(x);
    tmp = result;
    
    /*if (x == R_NilValue)*/
    if (isNull(x))
    return x;
    
    for (i = 0; i < n; i++) {
    ii = INTEGER(indx)[i];
    if (ii != NA_INTEGER)
        ii--;
    switch (mode) {
    case LGLSXP:
        if (0 <= ii && ii < nx && ii != NA_LOGICAL)
        LOGICAL(result)[i] = LOGICAL(x)[ii];
        else
        LOGICAL(result)[i] = NA_LOGICAL;
        break;
    case INTSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        INTEGER(result)[i] = INTEGER(x)[ii];
        else
        INTEGER(result)[i] = NA_INTEGER;
        break;
    case REALSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        REAL(result)[i] = REAL(x)[ii];
        else
        REAL(result)[i] = NA_REAL;
        break;
    case CPLXSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
        COMPLEX(result)[i] = COMPLEX(x)[ii];
        }
        else {
        COMPLEX(result)[i].r = NA_REAL;
        COMPLEX(result)[i].i = NA_REAL;
        }
        break;
    case STRSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        SET_STRING_ELT(result, i, STRING_ELT(x, ii));
        else
        SET_STRING_ELT(result, i, NA_STRING);
        break;
    case VECSXP:
    case EXPRSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
        else
        SET_VECTOR_ELT(result, i, R_NilValue);
        break;
    case LISTSXP:
        /* cannot happen: pairlists are coerced to lists */
    case LANGSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
        tmp2 = nthcdr(x, ii);
        SETCAR(tmp, CAR(tmp2));
        SET_TAG(tmp, TAG(tmp2));
        }
        else
        SETCAR(tmp, R_NilValue);
        tmp = CDR(tmp);
        break;
    case RAWSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        RAW(result)[i] = RAW(x)[ii];
        else
        RAW(result)[i] = (Rbyte) 0;
        break;
    default:
        error("error in subset\n");
        break;
    }
    }
    return result;
}
Exemple #25
0
/* do the two objects compute as identical?
   Also used in unique.c */
Rboolean
R_compute_identical(SEXP x, SEXP y, int flags)
{
    SEXP ax, ay, atrx, atry;
    if(x == y) /* same pointer */
	return TRUE;
    if(TYPEOF(x) != TYPEOF(y))
	return FALSE;
    if(OBJECT(x) != OBJECT(y))
	return FALSE;

    /* Skip attribute checks for CHARSXP
       -- such attributes are used for the cache.  */
    if(TYPEOF(x) == CHARSXP)
    {
	/* This matches NAs */
	return Seql(x, y);
    }

    ax = ATTRIB(x); ay = ATTRIB(y);
    if (!ATTR_AS_SET) {
	if(!R_compute_identical(ax, ay, flags)) return FALSE;
    }
    /* Attributes are special: they should be tagged pairlists.  We
       don't test them if they are not, and we do not test the order
       if they are.

       This code is not very efficient, but then neither is using
       pairlists for attributes.  If long attribute lists become more
       common (and they are used for S4 slots) we should store them in
       a hash table.
    */
    else if(ax != R_NilValue || ay != R_NilValue) {
	if(ax == R_NilValue || ay == R_NilValue)
	    return FALSE;
	if(TYPEOF(ax) != LISTSXP || TYPEOF(ay) != LISTSXP) {
	    warning(_("ignoring non-pairlist attributes"));
	} else {
	    SEXP elx, ely;
	    if(length(ax) != length(ay)) return FALSE;
	    /* They are the same length and should have
	       unique non-empty non-NA tags */
	    for(elx = ax; elx != R_NilValue; elx = CDR(elx)) {
		const char *tx = CHAR(PRINTNAME(TAG(elx)));
		for(ely = ay; ely != R_NilValue; ely = CDR(ely))
		    if(streql(tx, CHAR(PRINTNAME(TAG(ely))))) {
			/* We need to treat row.names specially here */
			if(streql(tx, "row.names")) {
			    PROTECT(atrx = getAttrib(x, R_RowNamesSymbol));
			    PROTECT(atry = getAttrib(y, R_RowNamesSymbol));
			    if(!R_compute_identical(atrx, atry, flags)) {
				UNPROTECT(2);
				return FALSE;
			    } else
				UNPROTECT(2);
			} else
			    if(!R_compute_identical(CAR(elx), CAR(ely), flags))
				return FALSE;
			break;
		    }
		if(ely == R_NilValue) return FALSE;
	    }
	}
    }
    switch (TYPEOF(x)) {
    case NILSXP:
	return TRUE;
    case LGLSXP:
	if (length(x) != length(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)LOGICAL(x), (void *)LOGICAL(y),
		      length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
    case INTSXP:
	if (length(x) != length(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)INTEGER(x), (void *)INTEGER(y),
		      length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
    case REALSXP:
    {
	int n = length(x);
	if(n != length(y)) return FALSE;
	else {
	    double *xp = REAL(x), *yp = REAL(y);
	    int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
	    for(i = 0; i < n; i++)
		if(neWithNaN(xp[i], yp[i], ne_strict)) return FALSE;
	}
	return TRUE;
    }
    case CPLXSXP:
    {
	int n = length(x);
	if(n != length(y)) return FALSE;
	else {
	    Rcomplex *xp = COMPLEX(x), *yp = COMPLEX(y);
	    int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
	    for(i = 0; i < n; i++)
		if(neWithNaN(xp[i].r, yp[i].r, ne_strict) ||
		   neWithNaN(xp[i].i, yp[i].i, ne_strict))
		    return FALSE;
	}
	return TRUE;
    }
    case STRSXP:
    {
	int i, n = length(x);
	if(n != length(y)) return FALSE;
	for(i = 0; i < n; i++) {
	    /* This special-casing for NAs is not needed */
	    Rboolean na1 = (STRING_ELT(x, i) == NA_STRING),
		na2 = (STRING_ELT(y, i) == NA_STRING);
	    if(na1 ^ na2) return FALSE;
	    if(na1 && na2) continue;
	    if (! Seql(STRING_ELT(x, i), STRING_ELT(y, i))) return FALSE;
	}
	return TRUE;
    }
    case CHARSXP: /* Probably unreachable, but better safe than sorry... */
    {
	/* This matches NAs */
	return Seql(x, y);
    }
    case VECSXP:
    case EXPRSXP:
    {
	int i, n = length(x);
	if(n != length(y)) return FALSE;
	for(i = 0; i < n; i++)
	    if(!R_compute_identical(VECTOR_ELT(x, i),VECTOR_ELT(y, i), flags))
		return FALSE;
	return TRUE;
    }
    case LANGSXP:
    case LISTSXP:
    {
	while (x != R_NilValue) {
	    if(y == R_NilValue)
		return FALSE;
	    if(!R_compute_identical(CAR(x), CAR(y), flags))
		return FALSE;
	    if(!R_compute_identical(PRINTNAME(TAG(x)), PRINTNAME(TAG(y)), flags))
		return FALSE;
	    x = CDR(x);
	    y = CDR(y);
	}
	return(y == R_NilValue);
    }
    case CLOSXP:
	return(R_compute_identical(FORMALS(x), FORMALS(y), flags) &&
	       R_compute_identical(BODY_EXPR(x), BODY_EXPR(y), flags) &&
	       (CLOENV(x) == CLOENV(y) ? TRUE : FALSE) &&
	       (IGNORE_BYTECODE || R_compute_identical(BODY(x), BODY(y), flags))
	       );
    case SPECIALSXP:
    case BUILTINSXP:
	return(PRIMOFFSET(x) == PRIMOFFSET(y) ? TRUE : FALSE);
    case ENVSXP:
    case SYMSXP:
    case WEAKREFSXP:
    case BCODESXP: /**** is this the best approach? */
	return(x == y ? TRUE : FALSE);
    case EXTPTRSXP:
	return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);
    case RAWSXP:
	if (length(x) != length(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)RAW(x), (void *)RAW(y),
		      length(x) * sizeof(Rbyte)) == 0 ? TRUE : FALSE;

/*  case PROMSXP: args are evaluated, so will not be seen */
	/* test for equality of the substituted expression -- or should
	   we require both expression and environment to be identical? */
	/*#define PREXPR(x)	((x)->u.promsxp.expr)
	  #define PRENV(x)	((x)->u.promsxp.env)
	  return(R_compute_identical(subsititute(PREXPR(x), PRENV(x),
	                             flags),
	  subsititute(PREXPR(y), PRENV(y))));*/
    case S4SXP:
	/* attributes already tested, so all slots identical */
	return TRUE;
    default:
	/* these are all supposed to be types that represent constant
	   entities, so no further testing required ?? */
	printf("Unknown Type: %s (%x)\n", type2char(TYPEOF(x)), TYPEOF(x));
	return TRUE;
    }
}
Exemple #26
0
SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) {
  SEXP result;
  int i, j, nr, nc, nrs, ncs;
  int P=0;

  SEXP Dim = getAttrib(x, R_DimSymbol);
  nrs = nrows(x);ncs = ncols(x);
  nr = length(sr); nc = length(sc);

  SEXP oindex, nindex;
  oindex = getAttrib(x, install("index"));
  PROTECT(nindex = allocVector(TYPEOF(oindex), nr)); P++;
  PROTECT(result = allocVector(TYPEOF(x), nr*nc)); P++;
  j = 0;

  double *real_nindex=NULL, *real_oindex, *real_result=NULL, *real_x=NULL; 
  int *int_nindex=NULL, *int_oindex, *int_result=NULL, *int_x=NULL; 
  int *int_sr=NULL, *int_sc=NULL;
  int_sr = INTEGER(sr);
  int_sc = INTEGER(sc);

  copyAttributes(x, result);

  if(TYPEOF(x)==LGLSXP) {
    int_x = LOGICAL(x); 
    int_result = LOGICAL(result); 
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);
    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  /* branch into INTSXP and REALSXP, as these are most
     common/important types for time series data 
  */
  if(TYPEOF(x)==INTSXP) {
    int_x = INTEGER(x); 
    int_result = INTEGER(result); 
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    /* loop through remaining columns */
    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==REALSXP) {
    real_x = REAL(x);
    real_result = REAL(result);
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==CPLXSXP) {
    /*
    real_x = REAL(x);
    real_result = REAL(result);
    */
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==STRSXP) {
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    }
  } else
  if(TYPEOF(x)==RAWSXP) {
    /*
    real_x = REAL(x);
    real_result = REAL(result);
    */
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  }


  if(!isNull(Dim) && nr >= 0 && nc >= 0) {
  SEXP dim;
  PROTECT(dim = allocVector(INTSXP,2));P++;
  INTEGER(dim)[0] = nr;
  INTEGER(dim)[1] = nc;
  setAttrib(result, R_DimSymbol, dim);

   if (nr >= 0 && nc >= 0) {
    SEXP dimnames, dimnamesnames, newdimnames;
    dimnames = getAttrib(x, R_DimNamesSymbol);
    dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
    if (!isNull(dimnames)) {
        PROTECT(newdimnames = allocVector(VECSXP, 2));
        if (TYPEOF(dimnames) == VECSXP) {
          SET_VECTOR_ELT(newdimnames, 0,
            ExtractSubset(VECTOR_ELT(dimnames, 0),
                  allocVector(STRSXP, nr), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            ExtractSubset(VECTOR_ELT(dimnames, 1),
                  allocVector(STRSXP, nc), sc));
        }
        else {
          SET_VECTOR_ELT(newdimnames, 0,
            ExtractSubset(CAR(dimnames),
                  allocVector(STRSXP, nr), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            ExtractSubset(CADR(dimnames),
                  allocVector(STRSXP, nc), sc));
        }
        setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
        setAttrib(result, R_DimNamesSymbol, newdimnames);
        UNPROTECT(1);
    }
    }

  }
  setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
  if(nc == 1 && LOGICAL(drop)[0])
    setAttrib(result, R_DimSymbol, R_NilValue);


  UNPROTECT(P);
  return result;
}
void bmerge_r(int xlowIn, int xuppIn, int ilowIn, int iuppIn, int col, int lowmax, int uppmax)
// col is >0 and <=ncol-1 if this range of [xlow,xupp] and [ilow,iupp] match up to but not including that column
// lowmax=1 if xlowIn is the lower bound of this group (needed for roll)
// uppmax=1 if xuppIn is the upper bound of this group (needed for roll)
{
    int xlow=xlowIn, xupp=xuppIn, ilow=ilowIn, iupp=iuppIn, j, k, ir, lir, tmp;
    ir = lir = ilow + (iupp-ilow)/2;           // lir = logical i row.
    if (o) ir = o[lir]-1;                      // ir = the actual i row if i were ordered

    ic = VECTOR_ELT(i,icols[col]-1);  // ic = i column
    xc = VECTOR_ELT(x,xcols[col]-1);  // xc = x column
    // it was checked in bmerge() that the types are equal

    switch (TYPEOF(xc)) {
    case LGLSXP :
    case INTSXP :   // including factors
        ival.i = INTEGER(ic)[ir];
        while(xlow < xupp-1) {
            mid = xlow + (xupp-xlow)/2;   // Same as (xlow+xupp)/2 but without risk of overflow
            xval.i = INTEGER(xc)[mid];
            if (xval.i<ival.i) {          // relies on NA_INTEGER == INT_MIN, tested in init.c
                xlow=mid;
            } else if (xval.i>ival.i) {   // TO DO: is *(&xlow, &xupp)[0|1]=mid more efficient than branch?
                xupp=mid;
            } else { // xval.i == ival.i  including NA_INTEGER==NA_INTEGER
                // branch mid to find start and end of this group in this column
                // TO DO?: not if mult=first|last and col<ncol-1
                tmplow = mid;
                tmpupp = mid;
                while(tmplow<xupp-1) {
                    mid = tmplow + (xupp-tmplow)/2;
                    xval.i = INTEGER(xc)[mid];
                    if (xval.i == ival.i) tmplow=mid;
                    else xupp=mid;
                }
                while(xlow<tmpupp-1) {
                    mid = xlow + (tmpupp-xlow)/2;
                    xval.i = INTEGER(xc)[mid];
                    if (xval.i == ival.i) tmpupp=mid;
                    else xlow=mid;
                }
                // xlow and xupp now surround the group in xc, we only need this range for the next column
                break;
            }
        }
        tmplow = lir;
        tmpupp = lir;
        while(tmplow<iupp-1) {   // TO DO: could double up from lir rather than halving from iupp
            mid = tmplow + (iupp-tmplow)/2;
            xval.i = INTEGER(ic)[ o ? o[mid]-1 : mid ];   // reuse xval to search in i
            if (xval.i == ival.i) tmplow=mid;
            else iupp=mid;
        }
        while(ilow<tmpupp-1) {
            mid = ilow + (tmpupp-ilow)/2;
            xval.i = INTEGER(ic)[ o ? o[mid]-1 : mid ];
            if (xval.i == ival.i) tmpupp=mid;
            else ilow=mid;
        }
        // ilow and iupp now surround the group in ic, too
        break;
    case STRSXP :
        ival.s = STRING_ELT(ic,ir);
        while(xlow < xupp-1) {
            mid = xlow + (xupp-xlow)/2;
            xval.s = STRING_ELT(xc,mid);
            if (enc_warn && (ENC_KNOWN(ival.s) || ENC_KNOWN(xval.s))) {
                // The || is only done here to avoid the warning message being repeating in this code.
                warning("A known encoding (latin1 or UTF-8) was detected in a join column. data.table compares the bytes currently, so doesn't support *mixed* encodings well; i.e., using both latin1 and UTF-8, or if any unknown encodings are non-ascii and some of those are marked known and others not. But if either latin1 or UTF-8 is used exclusively, and all unknown encodings are ascii, then the result should be ok. In future we will check for you and avoid this warning if everything is ok. The tricky part is doing this without impacting performance for ascii-only cases.");
                // TO DO: check and warn in forder whether any strings are non-ascii (>127) but unknown encoding
                //        check in forder whether both latin1 and UTF-8 have been used
                //        See bugs #5159 and #5266 and related #5295 to revisit
                enc_warn = FALSE;  // just warn once
            }
            tmp = StrCmp(xval.s, ival.s);  // uses pointer equality first, NA_STRING are allowed and joined to, then uses strcmp on CHAR().
            if (tmp == 0) {                // TO DO: deal with mixed encodings and locale optionally
                tmplow = mid;
                tmpupp = mid;
                while(tmplow<xupp-1) {
                    mid = tmplow + (xupp-tmplow)/2;
                    xval.s = STRING_ELT(xc,mid);
                    if (ival.s == xval.s) tmplow=mid;
                    else xupp=mid;  // the == here assumes (within this column) no mixing of latin1 and UTF-8, and no unknown non-ascii
                }                                                     // TO DO: add checks to forder, see above.
                while(xlow<tmpupp-1) {
                    mid = xlow + (tmpupp-xlow)/2;
                    xval.s = STRING_ELT(xc,mid);
                    if (ival.s == xval.s) tmpupp=mid;
                    else xlow=mid;  // see above re ==
                }
                break;
            } else if (tmp < 0) {
                xlow=mid;
            } else {
                xupp=mid;
            }
        }
        tmplow = lir;
        tmpupp = lir;
        while(tmplow<iupp-1) {
            mid = tmplow + (iupp-tmplow)/2;
            xval.s = STRING_ELT(ic, o ? o[mid]-1 : mid);
            if (xval.s == ival.s) tmplow=mid;
            else iupp=mid;   // see above re ==
        }
        while(ilow<tmpupp-1) {
            mid = ilow + (tmpupp-ilow)/2;
            xval.s = STRING_ELT(ic, o ? o[mid]-1 : mid);
            if (xval.s == ival.s) tmpupp=mid;
            else ilow=mid;   // see above re ==
        }
        break;
    case REALSXP :
        class = getAttrib(xc, R_ClassSymbol);
        twiddle = (isString(class) && STRING_ELT(class, 0)==char_integer64) ? &i64twiddle : &dtwiddle;
        ival.ll = twiddle(DATAPTR(ic), ir, 1);
        while(xlow < xupp-1) {
            mid = xlow + (xupp-xlow)/2;
            xval.ll = twiddle(DATAPTR(xc), mid, 1);
            if (xval.ll<ival.ll) {
                xlow=mid;
            } else if (xval.ll>ival.ll) {
                xupp=mid;
            } else { // xval.ll == ival.ll)
                tmplow = mid;
                tmpupp = mid;
                while(tmplow<xupp-1) {
                    mid = tmplow + (xupp-tmplow)/2;
                    xval.ll = twiddle(DATAPTR(xc), mid, 1);
                    if (xval.ll == ival.ll) tmplow=mid;
                    else xupp=mid;
                }
                while(xlow<tmpupp-1) {
                    mid = xlow + (tmpupp-xlow)/2;
                    xval.ll = twiddle(DATAPTR(xc), mid, 1);
                    if (xval.ll == ival.ll) tmpupp=mid;
                    else xlow=mid;
                }
                break;
            }
        }
        tmplow = lir;
        tmpupp = lir;
        while(tmplow<iupp-1) {
            mid = tmplow + (iupp-tmplow)/2;
            xval.ll = twiddle(DATAPTR(ic), o ? o[mid]-1 : mid, 1 );
            if (xval.ll == ival.ll) tmplow=mid;
            else iupp=mid;
        }
        while(ilow<tmpupp-1) {
            mid = ilow + (tmpupp-ilow)/2;
            xval.ll = twiddle(DATAPTR(ic), o ? o[mid]-1 : mid, 1 );
            if (xval.ll == ival.ll) tmpupp=mid;
            else ilow=mid;
        }
        break;
    default:
        error("Type '%s' not supported as key column", type2char(TYPEOF(xc)));
    }

    if (xlow<xupp-1) {      // if value found, low and upp surround it, unlike standard binary search where low falls on it
        if (col<ncol-1) bmerge_r(xlow, xupp, ilow, iupp, col+1, 1, 1);  // final two 1's are lowmax and uppmax
        else {
            int len = xupp-xlow-1;
            if (len>1) allLen1[0] = FALSE;
            for (j=ilow+1; j<iupp; j++) {   // usually iterates once only for j=ir
                if (o) k=o[j]-1;
                else k=j;
                retFirst[k] = xlow+2;       // extra +1 for 1-based indexing at R level
                retLength[k]= len;
            }
        }
    }
    else if (roll!=0.0 && col==ncol-1) {
        // runs once per i row (not each search test), so not hugely time critical
        if (xlow != xupp-1 || xlow<xlowIn || xupp>xuppIn) error("Internal error: xlow!=xupp-1 || xlow<xlowIn || xupp>xuppIn");
        if (nearest) {   // value of roll ignored currently when nearest
            if ( (!lowmax || xlow>xlowIn) && (!uppmax || xupp<xuppIn) ) {
                if (  ( TYPEOF(ic)==REALSXP && REAL(ic)[ir]-REAL(xc)[xlow] <= REAL(xc)[xupp]-REAL(ic)[ir] )
                        || ( TYPEOF(ic)<=INTSXP && INTEGER(ic)[ir]-INTEGER(xc)[xlow] <= INTEGER(xc)[xupp]-INTEGER(ic)[ir] )) {
                    retFirst[ir] = xlow+1;
                    retLength[ir] = 1;
                } else {
                    retFirst[ir] = xupp+1;
                    retLength[ir] = 1;
                }
            } else if (uppmax && xupp==xuppIn && rollends[1]) {
                retFirst[ir] = xlow+1;
                retLength[ir] = 1;
            } else if (lowmax && xlow==xlowIn && rollends[0]) {
                retFirst[ir] = xupp+1;
                retLength[ir] = 1;
            }
        } else {
            if ( (   (roll>0.0 && (!lowmax || xlow>xlowIn) && (xupp<xuppIn || !uppmax || rollends[1]))
                     || (roll<0.0 && xupp==xuppIn && uppmax && rollends[1]) )
                    && (   (TYPEOF(ic)==REALSXP && REAL(ic)[ir]-REAL(xc)[xlow]-rollabs<1e-6)
                           || (TYPEOF(ic)<=INTSXP && (double)(INTEGER(ic)[ir]-INTEGER(xc)[xlow])-rollabs<1e-6 )
                           || (TYPEOF(ic)==STRSXP)   )) {
                retFirst[ir] = xlow+1;
                retLength[ir] = 1;
            } else if
            (  (  (roll<0.0 && (!uppmax || xupp<xuppIn) && (xlow>xlowIn || !lowmax || rollends[0]))
                    || (roll>0.0 && xlow==xlowIn && lowmax && rollends[0]) )
                    && (   (TYPEOF(ic)==REALSXP && REAL(xc)[xupp]-REAL(ic)[ir]-rollabs<1e-6)
                           || (TYPEOF(ic)<=INTSXP && (double)(INTEGER(xc)[xupp]-INTEGER(ic)[ir])-rollabs<1e-6 )
                           || (TYPEOF(ic)==STRSXP)   )) {
                retFirst[ir] = xupp+1;   // == xlow+2
                retLength[ir] = 1;
            }
        }
        if (iupp-ilow > 2 && retFirst[ir]!=NA_INTEGER) {  // >=2 equal values in the last column being rolling to the same point.
            for (j=ilow+1; j<iupp; j++) {                 // will rewrite retFirst[ir] to itself, but that's ok
                if (o) k=o[j]-1;
                else k=j;
                retFirst[k] = retFirst[ir];
                retLength[k]= retLength[ir];
            }
        }
    }
    if (ilow>ilowIn && (xlow>xlowIn || (roll!=0.0 && col==ncol-1)))
        bmerge_r(xlowIn, xlow+1, ilowIn, ilow+1, col, lowmax, uppmax && xlow+1==xuppIn);
    if (iupp<iuppIn && (xupp<xuppIn || (roll!=0.0 && col==ncol-1)))
        bmerge_r(xupp-1, xuppIn, iupp-1, iuppIn, col, lowmax && xupp-1==xlowIn, uppmax);
}
Exemple #28
0
/* base::Sys.info */
SEXP do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, ansnames;
    OSVERSIONINFOEX osvi;
    char ver[256], buf[1000];
    wchar_t name[MAX_COMPUTERNAME_LENGTH + 1], user[UNLEN+1];
    DWORD namelen = MAX_COMPUTERNAME_LENGTH + 1, userlen = UNLEN+1;

    checkArity(op, args);
    PROTECT(ans = allocVector(STRSXP, 8));
    osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX);
    if(!GetVersionEx((OSVERSIONINFO *)&osvi))
	error(_("unsupported version of Windows"));

    SET_STRING_ELT(ans, 0, mkChar("Windows"));

    /* Here for unknown future versions */
    snprintf(ver, 256, "%d.%d", 
	     (int)osvi.dwMajorVersion, (int)osvi.dwMinorVersion);

    if((int)osvi.dwMajorVersion >= 5) {
	PGNSI pGNSI;
	SYSTEM_INFO si;
	if(osvi.dwMajorVersion == 6) {
	    if(osvi.wProductType == VER_NT_WORKSTATION) {
		if(osvi.dwMinorVersion == 0)
		    strcpy(ver, "Vista");
		else strcpy(ver, "7");
	    } else
		strcpy(ver, "Server 2008");
	}
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 0)
	    strcpy(ver, "2000");
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 1)
	    strcpy(ver, "XP");
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 2) {
	    if(osvi.wProductType == VER_NT_WORKSTATION)
		strcpy(ver, "XP Professional");
	    else strcpy(ver, "Server 2003");
	}
	/* GetNativeSystemInfo is XP or later */
	pGNSI = (PGNSI)
	    GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
			   "GetNativeSystemInfo");
	if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
	if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
	    strcat(ver, " x64");
    }
    SET_STRING_ELT(ans, 1, mkChar(ver));

    if((int)osvi.dwMajorVersion >= 5) {
	if(osvi.wServicePackMajor > 0)
	    snprintf(ver, 256, "build %d, Service Pack %d",
		     LOWORD(osvi.dwBuildNumber),
		     (int) osvi.wServicePackMajor);
	else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
    } else
	snprintf(ver, 256, "build %d, %s",
		 LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
    SET_STRING_ELT(ans, 2, mkChar(ver));
    GetComputerNameW(name, &namelen);
    wcstoutf8(buf, name, 1000);
    SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
#ifdef WIN64
    SET_STRING_ELT(ans, 4, mkChar("x86-64"));
#else
    SET_STRING_ELT(ans, 4, mkChar("x86"));
#endif
    GetUserNameW(user, &userlen);
    wcstoutf8(buf, user, 1000);
    SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8));
    SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
    SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
    PROTECT(ansnames = allocVector(STRSXP, 8));
    SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
    SET_STRING_ELT(ansnames, 1, mkChar("release"));
    SET_STRING_ELT(ansnames, 2, mkChar("version"));
    SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
    SET_STRING_ELT(ansnames, 4, mkChar("machine"));
    SET_STRING_ELT(ansnames, 5, mkChar("login"));
    SET_STRING_ELT(ansnames, 6, mkChar("user"));
    SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
    setAttrib(ans, R_NamesSymbol, ansnames);
    UNPROTECT(2);
    return ans;
}
/* complete.cases(.) */
SEXP compcases(SEXP args)
{
    SEXP s, t, u, rval;
    int i, len;

    args = CDR(args);

    len = -1;

    for (s = args; s != R_NilValue; s = CDR(s)) {
	if (isList(CAR(s))) {
	    for (t = CAR(s); t != R_NilValue; t = CDR(t))
		if (isMatrix(CAR(t))) {
		    u = getAttrib(CAR(t), R_DimSymbol);
		    if (len < 0)
			len = INTEGER(u)[0];
		    else if (len != INTEGER(u)[0])
			goto bad;
		}
		else if (isVector(CAR(t))) {
		    if (len < 0)
			len = LENGTH(CAR(t));
		    else if (len != LENGTH(CAR(t)))
			goto bad;
		}
		else
		    error(R_MSG_type, type2char(TYPEOF(CAR(t))));
	}
	/* FIXME : Need to be careful with the use of isVector() */
	/* since this includes lists and expressions. */
	else if (isNewList(CAR(s))) {
	    int it, nt;
	    t = CAR(s);
	    nt = length(t);
	    /* 0-column data frames are a special case */
	    if(nt) {
		for (it = 0 ; it < nt ; it++) {
		    if (isMatrix(VECTOR_ELT(t, it))) {
			u = getAttrib(VECTOR_ELT(t, it), R_DimSymbol);
			if (len < 0)
			    len = INTEGER(u)[0];
			else if (len != INTEGER(u)[0])
			    goto bad;
		    }
		    else if (isVector(VECTOR_ELT(t, it))) {
			if (len < 0)
			    len = LENGTH(VECTOR_ELT(t, it));
			else if (len != LENGTH(VECTOR_ELT(t, it)))
			    goto bad;
		    }
		    else
			error(R_MSG_type, "unknown");
		}
	    } else {
		u = getAttrib(t, R_RowNamesSymbol);
		if (!isNull(u)) {
		    if (len < 0)
			len = LENGTH(u);
		    else if (len != INTEGER(u)[0])
			goto bad;
		}
	    }
	}
	else if (isMatrix(CAR(s))) {
	    u = getAttrib(CAR(s), R_DimSymbol);
	    if (len < 0)
		len = INTEGER(u)[0];
	    else if (len != INTEGER(u)[0])
		goto bad;
	}
	else if (isVector(CAR(s))) {
	    if (len < 0)
		len = LENGTH(CAR(s));
	    else if (len != LENGTH(CAR(s)))
		goto bad;
	}
	else
	    error(R_MSG_type, type2char(TYPEOF(CAR(s))));
    }

    if (len < 0)
	error(_("no input has determined the number of cases"));
    PROTECT(rval = allocVector(LGLSXP, len));
    for (i = 0; i < len; i++) INTEGER(rval)[i] = 1;
    /* FIXME : there is a lot of shared code here for vectors. */
    /* It should be abstracted out and optimized. */
    for (s = args; s != R_NilValue; s = CDR(s)) {
	if (isList(CAR(s))) {
	    /* Now we only need to worry about vectors */
	    /* since we use mod to handle arrays. */
	    /* FIXME : using mod like this causes */
	    /* a potential performance hit. */
	    for (t = CAR(s); t != R_NilValue; t = CDR(t)) {
		u = CAR(t);
		for (i = 0; i < LENGTH(u); i++) {
		    switch (TYPEOF(u)) {
		    case INTSXP:
		    case LGLSXP:
			if (INTEGER(u)[i] == NA_INTEGER)
			    INTEGER(rval)[i % len] = 0;
			break;
		    case REALSXP:
			if (ISNAN(REAL(u)[i]))
			    INTEGER(rval)[i % len] = 0;
			break;
		    case CPLXSXP:
			if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
			    INTEGER(rval)[i % len] = 0;
			break;
		    case STRSXP:
			if (STRING_ELT(u, i) == NA_STRING)
			    INTEGER(rval)[i % len] = 0;
			break;
		    default:
			UNPROTECT(1);
			error(R_MSG_type, type2char(TYPEOF(u)));
		    }
		}
	    }
	}
	if (isNewList(CAR(s))) {
	    int it, nt;
	    t = CAR(s);
	    nt = length(t);
	    for (it = 0 ; it < nt ; it++) {
		u = VECTOR_ELT(t, it);
		for (i = 0; i < LENGTH(u); i++) {
		    switch (TYPEOF(u)) {
		    case INTSXP:
		    case LGLSXP:
			if (INTEGER(u)[i] == NA_INTEGER)
			    INTEGER(rval)[i % len] = 0;
			break;
		    case REALSXP:
			if (ISNAN(REAL(u)[i]))
			    INTEGER(rval)[i % len] = 0;
			break;
		    case CPLXSXP:
			if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
			    INTEGER(rval)[i % len] = 0;
			break;
		    case STRSXP:
			if (STRING_ELT(u, i) == NA_STRING)
			    INTEGER(rval)[i % len] = 0;
			break;
		    default:
			UNPROTECT(1);
			error(R_MSG_type, type2char(TYPEOF(u)));
		    }
		}
	    }
	}
	else {
	    for (i = 0; i < LENGTH(CAR(s)); i++) {
		u = CAR(s);
		switch (TYPEOF(u)) {
		case INTSXP:
		case LGLSXP:
		    if (INTEGER(u)[i] == NA_INTEGER)
			INTEGER(rval)[i % len] = 0;
		    break;
		case REALSXP:
		    if (ISNAN(REAL(u)[i]))
			INTEGER(rval)[i % len] = 0;
		    break;
		case CPLXSXP:
		    if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
			INTEGER(rval)[i % len] = 0;
		    break;
		case STRSXP:
		    if (STRING_ELT(u, i) == NA_STRING)
			INTEGER(rval)[i % len] = 0;
		    break;
		default:
		    UNPROTECT(1);
		    error(R_MSG_type, type2char(TYPEOF(u)));
		}
	    }
	}
    }
    UNPROTECT(1);
    return rval;

 bad:
    error(_("not all arguments have the same length"));
    return R_NilValue; /* -Wall */
}
Exemple #30
0
SEXP attribute_hidden
do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);

    SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args);
    int m, zero = 0;
    R_xlen_t *lengths, *counters, longest = 0;

    m = length(varyingArgs);
    SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
    Rboolean named = CXXRCONSTRUCT(Rboolean, vnames != R_NilValue);

    lengths = static_cast<R_xlen_t *>(  CXXR_alloc(m, sizeof(R_xlen_t)));
    for (int i = 0; i < m; i++) {
	SEXP tmp1 = VECTOR_ELT(varyingArgs, i);
	lengths[i] = xlength(tmp1);
	if (isObject(tmp1)) { // possibly dispatch on length()
	    /* Cache the .Primitive: unclear caching is worthwhile. */
	    static SEXP length_op = NULL;
	    if (length_op == NULL) length_op = R_Primitive("length");
	    // DispatchOrEval() needs 'args' to be a pairlist
	    SEXP ans, tmp2 = PROTECT(list1(tmp1));
	    if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1))
		lengths[i] = R_xlen_t( (TYPEOF(ans) == REALSXP ?
					REAL(ans)[0] : asInteger(ans)));
	    UNPROTECT(1);
	}
	if (lengths[i] == 0) zero++;
	if (lengths[i] > longest) longest = lengths[i];
    }
    if (zero && longest)
	error(_("zero-length inputs cannot be mixed with those of non-zero length"));

    counters = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t)));
    memset(counters, 0, m * sizeof(R_xlen_t));

    SEXP mindex = PROTECT(allocVector(VECSXP, m));
    SEXP nindex = PROTECT(allocVector(VECSXP, m));

    /* build a call like
       f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
    */

    SEXP fcall = R_NilValue; // -Wall
    if (constantArgs == R_NilValue)
	;
    else if (isVectorList(constantArgs))
	fcall = VectorToPairList(constantArgs);
    else
	error(_("argument 'MoreArgs' of 'mapply' is not a list"));
    PROTECT_INDEX fi;
    PROTECT_WITH_INDEX(fcall, &fi);

    Rboolean realIndx = CXXRCONSTRUCT(Rboolean, longest > INT_MAX);
    SEXP Dots = install("dots");
    for (int j = m - 1; j >= 0; j--) {
	SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
	SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1));
	SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j)));
	SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j)));
	REPROTECT(fcall = CONS(tmp2, fcall), fi);
	UNPROTECT(2);
	if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
	    SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j)));
    }

    REPROTECT(fcall = LCONS(f, fcall), fi);

    SEXP ans = PROTECT(allocVector(VECSXP, longest));

    for (int i = 0; i < longest; i++) {
	for (int j = 0; j < m; j++) {
	    counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
	    if (realIndx)
		REAL(VECTOR_ELT(nindex, j))[0] = double( counters[j]);
	    else
		INTEGER(VECTOR_ELT(nindex, j))[0] = int( counters[j]);
	}
	SEXP tmp = eval(fcall, rho);
	if (NAMED(tmp))
	    tmp = duplicate(tmp);
	SET_VECTOR_ELT(ans, i, tmp);
    }

    for (int j = 0; j < m; j++)
	if (counters[j] != lengths[j])
	    warning(_("longer argument not a multiple of length of shorter"));

    UNPROTECT(5);
    return ans;
}