示例#1
0
void getDrivesForArray(const std::string& arrayName,
                       MDInterface& md,
                       QueryData& data) {
  std::string path(md.getPathByDevName(arrayName));
  if (path.empty()) {
    LOG(ERROR) << "Could not get file path for " << arrayName;
    return;
  }

  mdu_array_info_t array;
  if (!md.getArrayInfo(path, array)) {
    return;
  }

  /* Create a vector of with all expected slot positions.  As we work through
   * the RAID disks, we remove discovered slots */
  std::vector<size_t> missingSlots(array.raid_disks);
  std::iota(missingSlots.begin(), missingSlots.end(), 0);

  /* Keep track of index in QueryData that have removed slots since we can't
   * make safe assumptions about it's original slot position if disk_number >=
   * total_disk and we're unable to deteremine total number of missing slots
   * until we walk thru all MD_SB_DISKS */
  std::vector<size_t> removedSlots;

  size_t qdPos = data.size();
  for (size_t i = 0; i < MD_SB_DISKS; i++) {
    mdu_disk_info_t disk;
    disk.number = i;
    if (!md.getDiskInfo(path, disk)) {
      continue;
    }

    if (disk.major > 0) {
      Row r;
      r["md_device_name"] = arrayName;
      r["drive_name"] = md.getDevName(disk.major, disk.minor);
      r["state"] = getDiskStateStr(disk.state);

      if (disk.raid_disk >= 0) {
        r["slot"] = INTEGER(disk.raid_disk);
        missingSlots.erase(
            std::remove(
                missingSlots.begin(), missingSlots.end(), disk.raid_disk),
            missingSlots.end());

        /* We assume that if the disk number is less than the total disk count
         * of the array, then it assumes its original slot position;  If the
         * number is greater than the disk count, then it's not safe to make
         * that assumption. We do this check here b/c if a recovery is targeted
         * for the same slot, we potentially miss identifying the original slot
         * position of the bad disk. */
      } else if (disk.raid_disk < 0 && disk.number < array.raid_disks) {
        r["slot"] = std::to_string(disk.number);
        missingSlots.erase(
            std::remove(missingSlots.begin(), missingSlots.end(), disk.number),
            missingSlots.end());

        /* Mark QueryData position as a removedSlot to handle later*/
      } else {
        removedSlots.push_back(qdPos);
      }

      qdPos++;
      data.push_back(r);
    }
  }

  /* Handle all missing slots.  See `scattered_faulty_and_removed` unit test in
   * `./tests/md_tables_tests.cpp`*/
  for (const auto& slot : missingSlots) {
    if (!removedSlots.empty()) {
      data[removedSlots[0]]["slot"] = INTEGER(slot);
      removedSlots.erase(removedSlots.begin());

    } else {
      Row r;
      r["md_device_name"] = arrayName;
      r["drive_name"] = "unknown";
      r["state"] = "removed";
      r["slot"] = std::to_string(slot);
      data.push_back(r);
    }
  }
}
示例#2
0
int * AllocProtectInt(int n){

  SEXP x = R_NilValue;
  PROTECT(x = NEW_INTEGER(n));
  return( INTEGER(x) );
}
示例#3
0
文件: agmart3.c 项目: cran/survival
SEXP agmart3(SEXP surv2, SEXP score2, SEXP weight2, SEXP strata2,
	     SEXP sortx, SEXP method2) {

    int k, ksave;
    int p, istrat, indx2;
    double deaths, denom, e_denom;
    double hazard, e_hazard, cumhaz;
    double temp, time;
    double wtsum;
    int n, person;
 
    /* pointers to the input data */
    double *start, *stop, *event;
    double *weight, *score;
    int    *sort1, *sort2, *strata;

    int method;  /* integer version of input */

    /* output */
    SEXP resid2;
    double *resid;

    n = nrows(surv2);
    method = asInteger(method2);
    start = REAL(surv2);
    stop  = start +n;
    event = stop +n;
    weight= REAL(weight2);
    score = REAL(score2);
    sort1 = INTEGER(sortx);
    sort2 = sort1 + n;
    strata= INTEGER(strata2);

    PROTECT(resid2 = allocVector(REALSXP, n));
    resid = REAL(resid2);

    /*
    **  'person' walks through the the data from 1 to n,
    **     sort1[0] points to the largest stop time, sort1[1] the next, ...
    **  'time' is a scratch variable holding the time of current interest
    **  'indx2' walks through the start times.  It will be smaller than 
    **    'person': if person=27 that means that 27 subjects have stop >=time,
    **    and are thus potential members of the risk set.  If 'indx2' =9,
    **    that means that 9 subjects have start >=time and thus are NOT part
    **    of the risk set.  (stop > start for each subject guarrantees that
    **    the 9 are a subset of the 27). 
    **  Basic algorithm: move 'person' forward, adding the new subject into
    **    the risk set.  If this is a new, unique death time, take selected
    **    old obs out of the sums, add in obs tied at this time, then update
    **    the cumulative hazard. Everything resets at the end of a stratum.
    **  The sort order is from large time to small, so we encounter a subject's
    **    ending time first, then their start time.
    **  The martingale residual for a subject is 
    **     status - (cumhaz at end of their interval - cumhaz at start)*score
    */
    istrat=0;
    indx2 =0;
    denom =0;
    cumhaz =0;
    for (person=0; person <n; ) {
	p = sort1[person];
	if (event[p] ==0) { /* censored */
	    denom += score[p] * weight[p];
	    resid[p] = cumhaz * score[p];
	    person++;
	} else {
	    time = stop[p]; /* found a new, unique death time */
	    /* 
	    ** Remove those subjects whose start time is to the right
	    **  from the risk set, and finish computation of their residual
	    */
	    for (;  indx2 <strata[istrat]; indx2++) {
		p = sort2[indx2];
		if (start[p] < time) break;
		denom -= score[p] * weight[p];
		resid[p] -= cumhaz * score[p];
	    }

	    /*
	    **	Add up over this death time, for all subjects
	    */
	    deaths =0;
	    e_denom =0;
	    wtsum =0;
	    for (k=person; k<strata[istrat]; k++) {
		p = sort1[k];
		if (stop[p]  < time) break;  /* only tied times */ 
		denom += score[p] * weight[p];
		if (event[p] ==1) {
		    deaths ++;
		    e_denom += score[p] * weight[p];
		    wtsum += weight[p];
		}
	    }
	    ksave = k;
	    
	    /* compute the increment in hazard 
	    ** hazard = usual increment
	    ** e_hazard = efron increment, for tied deaths only
	    */
	    if (method==0 || deaths==1) { /* Breslow */
		hazard = wtsum/denom;
		e_hazard = hazard;
	    }
	    else { /* Efron */
		hazard =0;
		e_hazard =0;  /* hazard experienced by a tied death */
		wtsum /= deaths;   
		for (k=0; k <deaths; k++) {
		    temp = k/deaths;
		    hazard += wtsum/(denom - temp*e_denom);
		    e_hazard += wtsum * (1-temp)/(denom - temp*e_denom);
		}
	    }

	    /* Give initial value to all intervals ending at this time
            ** If tied censors are sorted before deaths (which at least some
	    **  callers of this routine do), then the else below will never
	    **  occur.
            */
	    temp = cumhaz + (hazard -e_hazard);
	    for (; person < ksave; person++) {
		p = sort1[person];
		if (event[p] ==1) resid[p] = 1 + temp*score[p];
		else resid[p] = cumhaz * score[p];
		}
	    cumhaz += hazard;
	}

	/* clean up at the end of a strata */
	if (person == strata[istrat]) {
	    for (; indx2<strata[istrat]; indx2++) {
		p = sort2[indx2];
		resid[p] -= cumhaz * score[p];
	    }
	    cumhaz =0;
	    denom = 0;
	    istrat++;
	}
    }
    UNPROTECT(1);
    return(resid2);
}
SEXP gbm_pred
(
   SEXP radX,        // the data matrix
   SEXP rcRows,      // number of rows
   SEXP rcCols,      // number of columns
   SEXP rcTrees,     // number of trees, may be a vector
   SEXP rdInitF,     // the initial value
   SEXP rTrees,      // the list of trees
   SEXP rCSplits,    // the list of categorical splits
   SEXP raiVarType,  // indicator of continuous/nominal
   SEXP riSingleTree // boolean whether to return only results for one tree
)
{
   unsigned long hr = 0;
   int iTree = 0;
   int iObs = 0;
   int cRows = INTEGER(rcRows)[0];
   int cPredIterations = LENGTH(rcTrees);
   int iPredIteration = 0;
   int cTrees = 0;

   SEXP rThisTree = NULL;
   int *aiSplitVar = NULL;
   double *adSplitCode = NULL;
   int *aiLeftNode = NULL;
   int *aiRightNode = NULL;
   int *aiMissingNode = NULL;
   int iCurrentNode = 0;
   double dX = 0.0;
   int iCatSplitIndicator = 0;
   bool fSingleTree = (INTEGER(riSingleTree)[0]==1);

   SEXP radPredF = NULL;

   // allocate the predictions to return
   PROTECT(radPredF = allocVector(REALSXP, cRows*cPredIterations));
   if(radPredF == NULL)
   {
      hr = GBM_OUTOFMEMORY;
      goto Error;
   }

   // initialize the predicted values
   if(!fSingleTree)
   {
      // initialize with the intercept for only the smallest rcTrees
      for(iObs=0; iObs<cRows; iObs++)
      {
         REAL(radPredF)[iObs] = REAL(rdInitF)[0];
      }
   }
   else
   {
      for(iObs=0; iObs<cRows*cPredIterations; iObs++)
      {
         REAL(radPredF)[iObs] = 0.0;
      }
   }

   iTree = 0;
   for(iPredIteration=0; iPredIteration<LENGTH(rcTrees); iPredIteration++)
   {
      cTrees = INTEGER(rcTrees)[iPredIteration];
      if(fSingleTree) iTree=cTrees-1;
      if(!fSingleTree && (iPredIteration>0))
      {
         // copy over from the last rcTrees
         for(iObs=0; iObs<cRows; iObs++)
         {
            REAL(radPredF)[cRows*iPredIteration+iObs] =
               REAL(radPredF)[cRows*(iPredIteration-1)+iObs];
         }
      }
      while(iTree<cTrees)
      {
         rThisTree     = VECTOR_ELT(rTrees,iTree);
         // these relate to columns returned by pretty.gbm.tree()
         aiSplitVar    = INTEGER(VECTOR_ELT(rThisTree,0));
         adSplitCode   = REAL   (VECTOR_ELT(rThisTree,1));
         aiLeftNode    = INTEGER(VECTOR_ELT(rThisTree,2));
         aiRightNode   = INTEGER(VECTOR_ELT(rThisTree,3));
         aiMissingNode = INTEGER(VECTOR_ELT(rThisTree,4));
         for(iObs=0; iObs<cRows; iObs++)
         {
            iCurrentNode = 0;
            while(aiSplitVar[iCurrentNode] != -1)
            {
               dX = REAL(radX)[aiSplitVar[iCurrentNode]*cRows + iObs];
               // missing?
               if(ISNA(dX))
               {
                  iCurrentNode = aiMissingNode[iCurrentNode];
               }
               // continuous?
               else if(INTEGER(raiVarType)[aiSplitVar[iCurrentNode]] == 0)
               {
                  if(dX < adSplitCode[iCurrentNode])
                  {
                        iCurrentNode = aiLeftNode[iCurrentNode];
                  }
                  else
                  {
                        iCurrentNode = aiRightNode[iCurrentNode];
                  }
               }
               else // categorical
               {
                  iCatSplitIndicator = INTEGER(
                        VECTOR_ELT(rCSplits,
                                 (int)adSplitCode[iCurrentNode]))[(int)dX];
                  if(iCatSplitIndicator==-1)
                  {
                        iCurrentNode = aiLeftNode[iCurrentNode];
                  }
                  else if(iCatSplitIndicator==1)
                  {
                        iCurrentNode = aiRightNode[iCurrentNode];
                  }
                  else // categorical level not present in training
                  {
                        iCurrentNode = aiMissingNode[iCurrentNode];
                  }
               }
            }
            REAL(radPredF)[cRows*iPredIteration+iObs] += 
               adSplitCode[iCurrentNode]; // add the prediction
         } // iObs
         iTree++;
      } // iTree
    } // iPredIteration
    
Cleanup:
    UNPROTECT(1); // radPredF
    return radPredF;
Error:
    goto Cleanup;
}
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;
}
示例#6
0
文件: MBAPoints.cpp 项目: cran/MBA
  SEXP MBAPoints(SEXP xyz, SEXP xyzEst, SEXP m, SEXP n, SEXP h, SEXP extend, SEXP verbose) {

    int i,j;
    int nProtect = 0;
    SEXP xyzPts, Z;

    //get the surface points
    PROTECT(xyzPts = getAttrib(xyz, R_DimSymbol)); nProtect++;      
    int nPts = INTEGER(xyzPts)[0];

    typedef std::vector<double> dVec;
    boost::shared_ptr<dVec> x_arr(new std::vector<double>);
    boost::shared_ptr<dVec> y_arr(new std::vector<double>);
    boost::shared_ptr<dVec> z_arr(new std::vector<double>);

    for(i = 0; i < nPts; i++){
      x_arr->push_back(REAL(xyz)[i]);
      y_arr->push_back(REAL(xyz)[nPts+i]);
      z_arr->push_back(REAL(xyz)[2*nPts+i]);
    }

    double maxXSurf = *std::max_element((*x_arr).begin(), (*x_arr).end());
    double minXSurf = *std::min_element((*x_arr).begin(), (*x_arr).end());
    double maxYSurf = *std::max_element((*y_arr).begin(), (*y_arr).end());
    double minYSurf = *std::min_element((*y_arr).begin(), (*y_arr).end());

    //get the points
    xyzPts = getAttrib(xyzEst, R_DimSymbol);      
    int nEstPts = INTEGER(xyzPts)[0];

    double maxXPt = REAL(xyzEst)[0];
    double minXPt = REAL(xyzEst)[0];
    double maxYPt = REAL(xyzEst)[nEstPts];
    double minYPt = REAL(xyzEst)[nEstPts];

    for(i = 0; i < nEstPts; i++){
      if(REAL(xyzEst)[i] > maxXPt) maxXPt = REAL(xyzEst)[i];
      if(REAL(xyzEst)[i] < minXPt) minXPt = REAL(xyzEst)[i];
      if(REAL(xyzEst)[nEstPts+i] > maxYPt) maxYPt = REAL(xyzEst)[nEstPts+i];
      if(REAL(xyzEst)[nEstPts+i] < minYPt) minYPt = REAL(xyzEst)[nEstPts+i];
    }

    std::string extendDirection = "";
    if(INTEGER(extend)[0]){
      if(maxXSurf < maxXPt){
	maxXSurf = maxXPt;
	extendDirection="+x ";
      }
      if(minXSurf > minXPt){
	minXSurf = minXPt;
	extendDirection+="-x ";
      }
      if(maxYSurf < maxYPt){
	maxYSurf = maxYPt;
	extendDirection+="+y ";
      }
      if(minYSurf > minYPt){ 
	minYSurf = minYPt;
	extendDirection+="-y ";
      }
    }

    //init
    MBA mba(x_arr, y_arr, z_arr);
    
    mba.setDomain(minXSurf, minYSurf, maxXSurf, maxYSurf);

    mba.MBAalg(INTEGER(m)[0], INTEGER(n)[0], INTEGER(h)[0]);

    //retrieve the spline surface and evaluate
    UCBspl::SplineSurface surface = mba.getSplineSurface(); 

    double umin, vmin, umax, vmax;
    surface.getDomain(umin, vmin, umax, vmax);
    
    PROTECT(Z = allocVector(REALSXP, nEstPts)); nProtect++;
    
    int ptsOutSide = 0;
    for (i = 0; i < nEstPts; i++){
      if(REAL(xyzEst)[i] < umin || REAL(xyzEst)[i] > umax ||
	 REAL(xyzEst)[nEstPts+i] < vmin || REAL(xyzEst)[nEstPts+i] > vmax){
	REAL(Z)[i] = NA_REAL;
	ptsOutSide++;
      }else{ 
	REAL(Z)[i] = surface.f(REAL(xyzEst)[i], REAL(xyzEst)[nEstPts+i]);
      }
    }

    if(INTEGER(verbose)[0]){
      if(extendDirection != "")
	warning("domain extended in the %sdirection(s)\n", extendDirection.c_str());
      
      if(ptsOutSide)
	warning("%i point(s) fell outside the domain and were set to NA\n", ptsOutSide);
    }

    //clean-up
    mba.cleanup(2);

    //just to be sure
    x_arr.reset();
    y_arr.reset();
    z_arr.reset();

    UNPROTECT(nProtect);
    return(Z);
  }
示例#7
0
文件: scan.c 项目: Maxsl/r-source
static void extractItem(char *buffer, SEXP ans, int i, LocalData *d)
{
    char *endp;
    switch(TYPEOF(ans)) {
    case NILSXP:
	break;
    case LGLSXP:
	if (isNAstring(buffer, 0, d))
	    LOGICAL(ans)[i] = NA_INTEGER;
	else {
	    int tr = StringTrue(buffer), fa = StringFalse(buffer);
	    if(tr || fa) LOGICAL(ans)[i] = tr;
	    else expected("a logical", buffer, d);
	}
	break;
    case INTSXP:
	if (isNAstring(buffer, 0, d))
	    INTEGER(ans)[i] = NA_INTEGER;
	else {
	    INTEGER(ans)[i] = Strtoi(buffer, 10);
	    if (INTEGER(ans)[i] == NA_INTEGER)
		expected("an integer", buffer, d);
	}
	break;
    case REALSXP:
	if (isNAstring(buffer, 0, d))
	    REAL(ans)[i] = NA_REAL;
	else {
	    REAL(ans)[i] = Strtod(buffer, &endp, TRUE, d);
	    if (!isBlankString(endp))
		expected("a real", buffer, d);
	}
	break;
    case CPLXSXP:
	if (isNAstring(buffer, 0, d))
	    COMPLEX(ans)[i].r = COMPLEX(ans)[i].i = NA_REAL;
	else {
	    COMPLEX(ans)[i] = strtoc(buffer, &endp, TRUE, d);
	    if (!isBlankString(endp))
		expected("a complex", buffer, d);
	}
	break;
    case STRSXP:
	if (isNAstring(buffer, 1, d))
	    SET_STRING_ELT(ans, i, NA_STRING);
	else
	    SET_STRING_ELT(ans, i, insertString(buffer, d));
	break;
    case RAWSXP:
	if (isNAstring(buffer, 0, d))
	    RAW(ans)[i] = 0;
	else {
	    RAW(ans)[i] = strtoraw(buffer, &endp);
	    if (!isBlankString(endp))
		expected("a raw", buffer, d);
	}
	break;
    default:
	UNIMPLEMENTED_TYPE("extractItem", ans);
    }
}
示例#8
0
SEXP R_plmd_model(SEXP Y, SEXP PsiCode, SEXP PsiK, SEXP Groups, SEXP Ngroups){


  SEXP R_return_value;
  SEXP R_weights;
  SEXP R_residuals;
  SEXP R_beta;
  SEXP R_SE;
  SEXP R_was_split;
  
  SEXP R_return_value_names;

  SEXP dim1;

  double *beta;
  double *residuals;
  double *weights;
  double *se;
  
  int *was_split;
  int *groups;

  double residSE;

  double *Ymat;

  double *X; /* Needed for SE */
  int X_cols, X_rows;


  int rows;
  int cols;

  int ngroups;
  
  int howmany_split =0;

  int i;
  
  PROTECT(dim1 = getAttrib(Y,R_DimSymbol));
  rows = INTEGER(dim1)[0];
  cols = INTEGER(dim1)[1];
  UNPROTECT(1);

  PROTECT(R_return_value = allocVector(VECSXP,5));
  
  /*
    Don't allocate R_beta/R_SE straight away, we won't know how much space
    these will actually need until finishing the PLM-d fitting procedure. 
    Instead we will just allocate those for which we currently know the size
  */
  
  
  PROTECT(R_weights = allocMatrix(REALSXP,rows,cols));
  PROTECT(R_residuals = allocMatrix(REALSXP,rows,cols));
  PROTECT(R_was_split = allocVector(INTSXP,rows));

  
  /* 0 - beta   (added below)
     1 - weights
     2 - residuals
     3 - standard errors  (added below)
     4 - R_was_split
  */
  SET_VECTOR_ELT(R_return_value,1,R_weights);
  SET_VECTOR_ELT(R_return_value,2,R_residuals);
  SET_VECTOR_ELT(R_return_value,4,R_was_split);



  UNPROTECT(3);

  residuals = NUMERIC_POINTER(R_residuals);
  weights = NUMERIC_POINTER(R_weights);
  was_split = INTEGER_POINTER(R_was_split);
  
  groups = INTEGER_POINTER(Groups);

  ngroups = INTEGER(Ngroups)[0];

  Ymat = NUMERIC_POINTER(Y);
  
  beta = Calloc(cols + rows*ngroups -1, double);   
  se = Calloc(cols + rows*ngroups -1, double);

  plmd_fit(Ymat, rows, cols, ngroups, groups, was_split, beta, residuals, weights, PsiFunc(asInteger(PsiCode)),asReal(PsiK), 20);


  for (i = 0; i < rows; i++){
    howmany_split+=was_split[i];
  }
  
  if (howmany_split > 0){
    PROTECT(R_beta = allocVector(REALSXP,rows + cols + howmany_split*(ngroups-1)));
    PROTECT(R_SE = allocVector(REALSXP,rows + cols + howmany_split*(ngroups-1)));
    
    X = plmd_get_design_matrix(rows, cols, ngroups, groups,was_split,&X_rows,&X_cols);


    rlm_compute_se(X,Ymat, X_rows, X_cols, beta, residuals, weights, se,(double *)NULL, &residSE, 2, PsiFunc(asInteger(PsiCode)),asReal(PsiK));
    Free(X);


    for (i = cols; i <  rows + cols + howmany_split*(ngroups-1) - 1; i++)
      beta[rows + cols + howmany_split*(ngroups-1) -1]-=beta[i];
    
    for (i = 0; i < rows + cols + howmany_split*(ngroups-1) ; i++){
      NUMERIC_POINTER(R_beta)[i] = beta[i];
      NUMERIC_POINTER(R_SE)[i] = se[i];
    }


  } else {
    /* Note use 2 rather than 4  for SE method */
    rlm_compute_se_anova(Ymat, rows, cols, beta, residuals, weights,se, (double *)
			 NULL, &residSE, 2, PsiFunc(asInteger(PsiCode)),asReal(PsiK));

    beta[rows+cols -1] = 0.0;
    se[rows+cols -1] = 0.0;


    for (i = cols; i < rows + cols -1; i++)
      beta[rows+cols -1]-=beta[i];
    
    PROTECT(R_beta = allocVector(REALSXP,rows+cols));
    PROTECT(R_SE = allocVector(REALSXP,rows+cols));
    
    for (i = 0; i < rows + cols; i++){
      NUMERIC_POINTER(R_beta)[i] = beta[i];
      NUMERIC_POINTER(R_SE)[i] = se[i];
    }


  }

  Free(beta);
  Free(se);

  SET_VECTOR_ELT(R_return_value,0,R_beta);
  SET_VECTOR_ELT(R_return_value,3,R_SE);
  UNPROTECT(2);
  
  PROTECT(R_return_value_names= allocVector(STRSXP,5));
  SET_VECTOR_ELT(R_return_value_names,0,mkChar("Estimates"));
  SET_VECTOR_ELT(R_return_value_names,1,mkChar("Weights"));
  SET_VECTOR_ELT(R_return_value_names,2,mkChar("Residuals"));
  SET_VECTOR_ELT(R_return_value_names,3,mkChar("StdErrors"));
  SET_VECTOR_ELT(R_return_value_names,4,mkChar("WasSplit"));
  setAttrib(R_return_value, R_NamesSymbol,R_return_value_names);
  UNPROTECT(2);
  return R_return_value;

}
示例#9
0
文件: layout.c 项目: Bgods/r-source
int layoutNRow(SEXP l) {
    return INTEGER(VECTOR_ELT(l, LAYOUT_NROW))[0];
}
示例#10
0
//EXPORT int JpmcdsCdsoneUpfrontCharge(cdsone.c)
SEXP calcUpfrontTest
(SEXP baseDate_input,  /* (I) Value date  for zero curve       */
 SEXP types, /* "MMMMMSSSSSSSSS"*/
 SEXP rates, /* rates[14] = {1e-9, 1e-9, 1e-9, 1e-9, 1e-9, 1e-9, 1e-9,
		1e-9, 1e-9, 1e-9, 1e-9, 1e-9, 1e-9, 1e-9};/\* (I)
		Array of swap rates *\/ */
 SEXP expiries,
 SEXP mmDCC,          /* (I) DCC of MM instruments            */

 SEXP fixedSwapFreq,   /* (I) Fixed leg freqency/interval               */
 SEXP floatSwapFreq,   /* (I) Floating leg freqency/interval            */
 SEXP fixedSwapDCC,    /* (I) DCC of fixed leg                 */
 SEXP floatSwapDCC,    /* (I) DCC of floating leg              */
 SEXP badDayConvZC, //'M'  badDayConv for zero curve
 SEXP holidays,//'None'

 // input for upfront charge calculation
 SEXP todayDate_input, /*today: T (Where T = trade date)*/
 SEXP valueDate_input, /* value date: T+3 Business Days*/
 SEXP benchmarkDate_input,/* start date of benchmark CDS for internal
				     ** clean spread bootstrapping;
				     ** accrual Begin Date  */
 SEXP startDate_input,/* Accrual Begin Date */
 SEXP endDate_input,/*  Maturity (Fixed) */
 SEXP stepinDate_input,  /* T + 1*/
 
 SEXP dccCDS, 			/* accruedDcc */
 SEXP ivlCDS,
 SEXP stubCDS,
 SEXP badDayConvCDS,
 SEXP calendar,

 SEXP parSpread,
 SEXP couponRate,
 SEXP recoveryRate,
 SEXP isPriceClean_input,
 SEXP payAccruedOnDefault_input,
 SEXP notional) 

{
  //  static char routine[] = "JpmcdsCdsoneUpfrontCharge";

  // my vars
  int n;
  TDate baseDate, today, benchmarkDate, startDate, endDate, stepinDate,valueDate;
  int isPriceClean, payAccruedOnDefault;
  SEXP upfrontPayment;
  TCurve *discCurve = NULL;
  char* pt_types;
  char* pt_holidays;
  char* pt_mmDCC;
  char* pt_fixedSwapDCC;
  char* pt_floatSwapDCC;
  char* pt_fixedSwapFreq;
  char* pt_floatSwapFreq;
  char* pt_dccCDS;
  char* pt_ivlCDS;
  char* pt_stubCDS;
  char* pt_calendar;
  char* pt_badDayConvCDS;

  // new
  char *pt_badDayConvZC;
  double parSpread_for_upf, couponRate_for_upf, recoveryRate_for_upf, notional_for_upf;
  
  // function to consolidate R input to TDate
  baseDate_input = coerceVector(baseDate_input,INTSXP);
  baseDate = JpmcdsDate((long)INTEGER(baseDate_input)[0], 
			(long)INTEGER(baseDate_input)[1], 
			(long)INTEGER(baseDate_input)[2]);

  todayDate_input = coerceVector(todayDate_input,INTSXP);
  today = JpmcdsDate((long)INTEGER(todayDate_input)[0], 
		     (long)INTEGER(todayDate_input)[1], 
		     (long)INTEGER(todayDate_input)[2]);

  valueDate_input = coerceVector(valueDate_input,INTSXP);
  valueDate = JpmcdsDate((long)INTEGER(valueDate_input)[0], 
			 (long)INTEGER(valueDate_input)[1], 
			 (long)INTEGER(valueDate_input)[2]);

  benchmarkDate_input = coerceVector(benchmarkDate_input,INTSXP);
  benchmarkDate = JpmcdsDate((long)INTEGER(benchmarkDate_input)[0], 
			     (long)INTEGER(benchmarkDate_input)[1],
			     (long)INTEGER(benchmarkDate_input)[2]);

  startDate_input = coerceVector(startDate_input,INTSXP);
  startDate = JpmcdsDate((long)INTEGER(startDate_input)[0], 
			 (long)INTEGER(startDate_input)[1], 
			 (long)INTEGER(startDate_input)[2]);

  endDate_input = coerceVector(endDate_input,INTSXP);
  endDate = JpmcdsDate((long)INTEGER(endDate_input)[0],
		       (long)INTEGER(endDate_input)[1],
		       (long)INTEGER(endDate_input)[2]);

  stepinDate_input = coerceVector(stepinDate_input,INTSXP);
  stepinDate = JpmcdsDate((long)INTEGER(stepinDate_input)[0],
		       (long)INTEGER(stepinDate_input)[1],
		       (long)INTEGER(stepinDate_input)[2]);

  types = coerceVector(types, STRSXP);
  pt_types = (char *) CHAR(STRING_ELT(types,0));
  holidays = coerceVector(holidays, STRSXP);
  pt_holidays =  (char *) CHAR(STRING_ELT(holidays, 0));
  
  n = strlen(CHAR(STRING_ELT(types, 0))); // for zerocurve
  rates = coerceVector(rates,REALSXP);

  mmDCC = coerceVector(mmDCC, STRSXP);
  pt_mmDCC = (char *) CHAR(STRING_ELT(mmDCC,0));

  fixedSwapFreq = coerceVector(fixedSwapFreq, STRSXP);
  pt_fixedSwapFreq = (char *) CHAR(STRING_ELT(fixedSwapFreq,0));

  floatSwapFreq = coerceVector(floatSwapFreq, STRSXP);
  pt_floatSwapFreq = (char *) CHAR(STRING_ELT(floatSwapFreq,0));

  fixedSwapDCC = coerceVector(fixedSwapDCC, STRSXP);
  pt_fixedSwapDCC = (char *) CHAR(STRING_ELT(fixedSwapDCC,0));

  floatSwapDCC = coerceVector(floatSwapDCC, STRSXP);
  pt_floatSwapDCC = (char *) CHAR(STRING_ELT(floatSwapDCC,0));

  calendar = coerceVector(calendar, STRSXP);
  pt_calendar = (char *) CHAR(STRING_ELT(calendar,0));

  parSpread_for_upf = *REAL(parSpread);
  couponRate_for_upf = *REAL(couponRate);
  recoveryRate_for_upf = *REAL(recoveryRate);
  isPriceClean = *INTEGER(isPriceClean_input);
  payAccruedOnDefault = *INTEGER(payAccruedOnDefault_input);
  notional_for_upf = *REAL(notional);

  badDayConvZC = coerceVector(badDayConvZC, STRSXP);
  pt_badDayConvZC = (char *) CHAR(STRING_ELT(badDayConvZC,0));

  badDayConvCDS = coerceVector(badDayConvCDS, STRSXP);
  pt_badDayConvCDS = (char *) CHAR(STRING_ELT(badDayConvCDS,0));

  TDateInterval fixedSwapIvl_curve;
  TDateInterval floatSwapIvl_curve;
  long          fixedSwapDCC_curve;
  long          floatSwapDCC_curve;
  double        fixedSwapFreq_curve;
  double        floatSwapFreq_curve;

  long mmDCC_zc_main;
  static char  *routine_zc_main = "BuildExampleZeroCurve";

  if (JpmcdsStringToDayCountConv(pt_mmDCC, &mmDCC_zc_main) != SUCCESS)
    goto done;
  
  if (JpmcdsStringToDayCountConv(pt_fixedSwapDCC, &fixedSwapDCC_curve) != SUCCESS)
    goto done;
  if (JpmcdsStringToDayCountConv(pt_floatSwapDCC, &floatSwapDCC_curve) != SUCCESS)
    goto done;
  
  if (JpmcdsStringToDateInterval(pt_fixedSwapFreq, routine_zc_main, &fixedSwapIvl_curve) != SUCCESS)
    goto done;
  if (JpmcdsStringToDateInterval(pt_floatSwapFreq, routine_zc_main, &floatSwapIvl_curve) != SUCCESS)
    goto done;
  
  if (JpmcdsDateIntervalToFreq(&fixedSwapIvl_curve, &fixedSwapFreq_curve) != SUCCESS)
    goto done;
  if (JpmcdsDateIntervalToFreq(&floatSwapIvl_curve, &floatSwapFreq_curve) != SUCCESS)
    goto done;
  
  expiries = coerceVector(expiries, VECSXP);

  TDate *dates_main;// = NULL;
  dates_main = NEW_ARRAY1(TDate, n);
  int i;
  for (i = 0; i < n; i++)
    {
      TDateInterval tmp;
      if (JpmcdsStringToDateInterval(strdup(CHAR(asChar(VECTOR_ELT(expiries, i)))), routine_zc_main, &tmp) != SUCCESS)

	{
            JpmcdsErrMsg ("%s: invalid interval for element[%d].\n", routine_zc_main, i);
            goto done;
        }
      
      if (JpmcdsDateFwdThenAdjust(baseDate, &tmp, JPMCDS_BAD_DAY_NONE, "None", dates_main+i) != SUCCESS)
      {
          JpmcdsErrMsg ("%s: invalid interval for element[%d].\n", routine_zc_main, i);
          goto done;
      }
    }

    discCurve = JpmcdsBuildIRZeroCurve(baseDate,
				       pt_types,
				       dates_main,
				       REAL(rates),
				       (long)n,
				       (long) mmDCC_zc_main,
				       (long) fixedSwapFreq_curve,
				       (long) floatSwapFreq_curve,
				       fixedSwapDCC_curve,
				       floatSwapDCC_curve,
				       (char) *pt_badDayConvZC,
				       pt_holidays);
    
    if (discCurve == NULL) JpmcdsErrMsg("IR curve not available ... \n");

    dccCDS = coerceVector(dccCDS, STRSXP);
    pt_dccCDS = (char *) CHAR(STRING_ELT(dccCDS,0));

    ivlCDS = coerceVector(ivlCDS, STRSXP);
    pt_ivlCDS = (char *) CHAR(STRING_ELT(ivlCDS,0));

    stubCDS = coerceVector(stubCDS, STRSXP);
    pt_stubCDS = (char *) CHAR(STRING_ELT(stubCDS,0));

    static char *routine = "CalcUpfrontCharge";
    TDateInterval ivl;
    TStubMethod stub;
    long dcc;

    if (JpmcdsStringToDayCountConv(pt_dccCDS, &dcc) != SUCCESS)
        goto done;
    
    if (JpmcdsStringToDateInterval(pt_ivlCDS, routine, &ivl) != SUCCESS)
        goto done;

    if (JpmcdsStringToStubMethod(pt_stubCDS, &stub) != SUCCESS)
        goto done;

    double result = -1.0;

    PROTECT(upfrontPayment = allocVector(REALSXP, 1));
    if (JpmcdsCdsoneUpfrontCharge(today,
				  valueDate,
				  benchmarkDate,
				  stepinDate,
				  startDate,
				  endDate,
				  couponRate_for_upf / 10000.0,
				  payAccruedOnDefault, //TRUE,
				  &ivl,
				  &stub, 
				  dcc,
				  (char) *pt_badDayConvCDS,
				  pt_calendar,
				  discCurve,
				  parSpread_for_upf/10000.0, 
				  recoveryRate_for_upf,
				  isPriceClean,
				  &result) != SUCCESS) 
      goto done;
 done:
    REAL(upfrontPayment)[0] = result * notional_for_upf;
    UNPROTECT(1);
    FREE(dates_main);
    return upfrontPayment;
}
示例#11
0
SEXP glm_mcmcbas(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights, 
		 SEXP Rprobinit, SEXP Rmodeldim, 
		 SEXP modelprior, SEXP betaprior, SEXP Rbestmodel,SEXP plocal, 
		 SEXP BURNIN_Iterations,
		 SEXP family, SEXP Rcontrol,
		 SEXP Rupdate, SEXP Rlaplace) 
{
	int nProtected = 0;
	int nModels=LENGTH(Rmodeldim);

	SEXP ANS = PROTECT(allocVector(VECSXP, 17)); ++nProtected;
	SEXP ANS_names = PROTECT(allocVector(STRSXP, 17)); ++nProtected;
	SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
	SEXP MCMCprobs= PROTECT(duplicate(Rprobinit)); ++nProtected;
	SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
	SEXP modeldim =  PROTECT(duplicate(Rmodeldim)); ++nProtected;
	SEXP counts =  PROTECT(duplicate(Rmodeldim)); ++nProtected;
	SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
	SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
	SEXP deviance = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	SEXP Q = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	SEXP Rintercept = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
	
	SEXP NumUnique = PROTECT(allocVector(INTSXP, 1)); ++nProtected;

	double *probs, MH=0.0, prior_m=1.0,shrinkage_m, logmargy, postold, postnew;
	int i, m, n, pmodel_old, *bestmodel;
	int mcurrent, n_sure;
	
	glmstptr *glmfamily;
	glmfamily = make_glmfamily_structure(family);

	betapriorptr *betapriorfamily;
	betapriorfamily = make_betaprior_structure(betaprior, family);


	//get dimsensions of all variables 
	int p = INTEGER(getAttrib(X,R_DimSymbol))[1];
	int k = LENGTH(modelprobs);
	int update = INTEGER(Rupdate)[0];
	double eps = DBL_EPSILON;

	struct Var *vars = (struct Var *) R_alloc(p, sizeof(struct Var)); // Info about the model variables. 
	probs =  REAL(Rprobs);
	n = sortvars(vars, probs, p); 
	for (i =n; i <p; i++) REAL(MCMCprobs)[vars[i].index] = probs[vars[i].index];
	for (i =0; i <n; i++) REAL(MCMCprobs)[vars[i].index] = 0.0;

	// fill in the sure things 
	int *model = ivecalloc(p);
	for (i = n, n_sure = 0; i < p; i++)  {
		model[vars[i].index] = (int) vars[i].prob;
		if (model[vars[i].index] == 1) ++n_sure;
	}

	GetRNGstate();

	NODEPTR tree, branch;
	tree = make_node(-1.0);
	//  Rprintf("For m=0, Initialize Tree with initial Model\n");  

	m = 0;
	bestmodel = INTEGER(Rbestmodel);
	INTEGER(modeldim)[m] = n_sure;

	// Rprintf("Create Tree\n"); 
	branch = tree;
	CreateTree(branch, vars, bestmodel, model, n, m, modeldim);
	int pmodel = INTEGER(modeldim)[m];
	SEXP Rmodel_m =	PROTECT(allocVector(INTSXP,pmodel));
	GetModel_m(Rmodel_m, model, p);
	//evaluate logmargy and shrinkage
	SEXP glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
					    glmfamily, Rcontrol, Rlaplace,
					    betapriorfamily));	
	prior_m  = compute_prior_probs(model,pmodel,p, modelprior);

	logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
	shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),	
						  "shrinkage"))[0];
	SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
	SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2,
		  Q, Rintercept, m);
	UNPROTECT(2);

	int nUnique=0, newmodel=0;
	double *real_model = vecalloc(n);
	int *modelold = ivecalloc(p);
	int old_loc = 0;
	int new_loc;
	pmodel_old = pmodel;
	nUnique=1;
	INTEGER(counts)[0] = 0;
	postold =  REAL(logmarg)[m] + log(REAL(priorprobs)[m]);
	memcpy(modelold, model, sizeof(int)*p);
	m = 0;
	int *varin= ivecalloc(p);
	int *varout= ivecalloc(p);
	double problocal = REAL(plocal)[0];
	while (nUnique < k && m < INTEGER(BURNIN_Iterations)[0]) {
		memcpy(model, modelold, sizeof(int)*p);
		pmodel =  n_sure;

		MH = GetNextModelCandidate(pmodel_old, n, n_sure, model, vars, problocal, varin, varout);

		branch = tree;
		newmodel= 0;
		for (i = 0; i< n; i++) {
			int bit =  model[vars[i].index];
			if (bit == 1) {
				if (branch->one != NULL) branch = branch->one;
				else newmodel = 1;
			} else {
				if (branch->zero != NULL)  branch = branch->zero;
				else newmodel = 1;
			} 
			pmodel  += bit;
		}

		if (pmodel  == n_sure || pmodel == n + n_sure) {
			MH = 1.0/(1.0 - problocal);
		}
		if (newmodel == 1) {
		  new_loc = nUnique;
		  PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
		  GetModel_m(Rmodel_m, model, p);

		  glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
						 glmfamily, Rcontrol, Rlaplace,
						 betapriorfamily));	
		  prior_m = compute_prior_probs(model,pmodel,p, modelprior);

		  logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
		  shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),	
						  "shrinkage"))[0];
		  postnew = logmargy + log(prior_m);
		}
		else {
		  new_loc = branch->where;
		  postnew =  REAL(logmarg)[new_loc] + log(REAL(priorprobs)[new_loc]);      
		} 

		MH *= exp(postnew - postold);
		//    Rprintf("MH new %lf old %lf\n", postnew, postold);
		if (unif_rand() < MH) {
		  if (newmodel == 1)  {
		    new_loc = nUnique;
		    insert_model_tree(tree, vars, n, model, nUnique);
		    INTEGER(modeldim)[nUnique] = pmodel;
		    //Rprintf("model %d: %d variables\n", m, pmodel);
		    
		    SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, nUnique);
		    SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2, Q, Rintercept, nUnique);
		    UNPROTECT(2);	
		    ++nUnique; 
		  }
		  old_loc = new_loc;
		  postold = postnew;
		  pmodel_old = pmodel;
		  memcpy(modelold, model, sizeof(int)*p);
		} else  {
		  if (newmodel == 1) UNPROTECT(2);
		}
		INTEGER(counts)[old_loc] += 1;
		for (i = 0; i < n; i++) {
		  // store in opposite order so nth variable is first 
		  real_model[n-1-i] = (double) modelold[vars[i].index];
		  REAL(MCMCprobs)[vars[i].index] += (double) modelold[vars[i].index];
		}	
		m++;
	}

	for (i = 0; i < n; i++) {
		REAL(MCMCprobs)[vars[i].index] /= (double) m;
	}

	// Compute marginal probabilities  
	mcurrent = nUnique;
	//	Rprintf("NumUnique Models Accepted %d \n", nUnique);
	compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
	compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);        

	//  Now sample W/O Replacement  
	INTEGER(NumUnique)[0] = nUnique;
	
	if (nUnique < k) {
		int *modelwork= ivecalloc(p);
		double *pigamma = vecalloc(p);
		update_probs(probs, vars, mcurrent, k, p);
		update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);     
		for (m = nUnique;  m < k; m++) {
			for (i = n; i < p; i++)  {
				INTEGER(modeldim)[m]  +=  model[vars[i].index];
			}

			branch = tree;
			GetNextModel_swop(branch, vars, model, n, m, pigamma, problocal, modeldim, bestmodel);

			/* Now subtract off the visited probability mass. */
	branch=tree;
	Substract_visited_probability_mass(branch, vars, model, n, m, pigamma,eps);

			/* Now get model specific calculations */
	pmodel = INTEGER(modeldim)[m];
	PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
	GetModel_m(Rmodel_m, model, p);

	glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
				       glmfamily, Rcontrol, Rlaplace,
				       betapriorfamily));	
	prior_m = compute_prior_probs(model,pmodel,p, modelprior);
	logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
	shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),	
						  "shrinkage"))[0];
	SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
	SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2, Q, Rintercept, m);
	UNPROTECT(2);

	REAL(sampleprobs)[m] = pigamma[0];  


			//update marginal inclusion probs
	if (m > 1) {
	  double mod; 
	  double rem = modf((double) m/(double) update, &mod);
	  if (rem  == 0.0) {
	    int mcurrent = m;
	    compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
	    compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);        
	    if (update_probs(probs, vars, mcurrent, k, p) == 1) {
	      //	      Rprintf("Updating Model Tree %d \n", m);
	      update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);     
	    }
	  }
	}  
		}
	}

	compute_modelprobs(modelprobs, logmarg, priorprobs,k);
	compute_margprobs(modelspace, modeldim, modelprobs, probs, k, p);  

	INTEGER(NumUnique)[0] = nUnique;
	SET_VECTOR_ELT(ANS, 0, Rprobs);
	SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));

	SET_VECTOR_ELT(ANS, 1, modelspace);
	SET_STRING_ELT(ANS_names, 1, mkChar("which"));

	SET_VECTOR_ELT(ANS, 2, logmarg);
	SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));

	SET_VECTOR_ELT(ANS, 3, modelprobs);
	SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));

	SET_VECTOR_ELT(ANS, 4, priorprobs);
	SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));

	SET_VECTOR_ELT(ANS, 5, sampleprobs);
	SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));

	SET_VECTOR_ELT(ANS, 6, deviance);
	SET_STRING_ELT(ANS_names, 6, mkChar("deviance"));

	SET_VECTOR_ELT(ANS, 7, beta);
	SET_STRING_ELT(ANS_names, 7, mkChar("mle"));

	SET_VECTOR_ELT(ANS, 8, se);
	SET_STRING_ELT(ANS_names, 8, mkChar("mle.se"));

	SET_VECTOR_ELT(ANS, 9, shrinkage);
	SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));

	SET_VECTOR_ELT(ANS, 10, modeldim);
	SET_STRING_ELT(ANS_names, 10, mkChar("size"));

	SET_VECTOR_ELT(ANS, 11, R2);
	SET_STRING_ELT(ANS_names, 11, mkChar("R2"));

	SET_VECTOR_ELT(ANS, 12, counts);
	SET_STRING_ELT(ANS_names, 12, mkChar("freq"));

	SET_VECTOR_ELT(ANS, 13, MCMCprobs);
	SET_STRING_ELT(ANS_names, 13, mkChar("probs.MCMC"));

	SET_VECTOR_ELT(ANS, 14, NumUnique);
	SET_STRING_ELT(ANS_names, 14, mkChar("n.Unique"));

	SET_VECTOR_ELT(ANS, 15, Q);
	SET_STRING_ELT(ANS_names, 15, mkChar("Q"));

	SET_VECTOR_ELT(ANS, 16, Rintercept);
	SET_STRING_ELT(ANS_names, 16, mkChar("intercept"));

	
	setAttrib(ANS, R_NamesSymbol, ANS_names);
	
	PutRNGstate();
	UNPROTECT(nProtected);
	return(ANS);  
}
示例#12
0
文件: BATCHgdwm.c 项目: cran/AMORE
SEXP BATCHgdwm_loop_MLPnet (SEXP origNet, SEXP Ptrans, SEXP Ttrans, SEXP nepochs, SEXP rho, SEXP thread_number ) {
   //The only difference between wm and without it is the weight update (and the place the values are stored, one is batchgd the other is batchgdwm)
   SEXP net;
   SEXP R_fcall, args, arg1, arg2, arg3;

   PROTECT(net=duplicate(origNet));
   int* Ptransdim = INTEGER(coerceVector(getAttrib(Ptrans, R_DimSymbol), INTSXP));
   int* Ttransdim = INTEGER(coerceVector(getAttrib(Ttrans, R_DimSymbol), INTSXP));
   int n_epochs  = INTEGER(nepochs)[0];
   struct AMOREnet* ptnet = copynet_RC(net);
   struct AMOREneuron** neurons = ptnet->neurons;

   /////////////////////////////////////////////////////////////////////////
   //Convert input and target to double only once (and instead of copying it every time, just change the pointers)
   //Different rows for easy switching pointers
   double*  input_data  = REAL(Ptrans);
   double*  target_data = REAL(Ttrans);
   double** inputs  = (double**) R_alloc(Ptransdim[1],sizeof(double*)); //This is an 'Index'
   double** targets = (double**) R_alloc(Ptransdim[1],sizeof(double*)); //This is an 'Index'

   for (int fila=0; fila < Ptransdim[1]; fila++) {
      inputs[fila]  = &input_data [fila*Ptransdim[0]];
      targets[fila] = &target_data[fila*Ttransdim[0]];
   }
   /////////////////////////////////////////////////////////////////////////

   /////////////////////////////////////////////////////////////////////////
   // Thread number calculation
   int n_threads = 1;
#ifdef _OPENMP
   {
      int max_threads = omp_get_max_threads();
      int given_threads = 0;

      if (isInteger(thread_number))
        given_threads = INTEGER(thread_number)[0];
      else if (isNumeric(thread_number))
        given_threads = floor(REAL(thread_number)[0]);

      if (given_threads <1) //I HAVE THE POWER TO SCHEDULE!
        if(max_threads  >1)
          n_threads = max_threads-1; //Leave a CPU free
        else
          n_threads = 1;
      else if (given_threads > max_threads)
        n_threads = max_threads;
      else
        n_threads = given_threads;

      if (neurons[0]->actf == CUSTOM_ACTF) //OMP + R custom functions = bad idea
        n_threads = 1;
      else if ((ptnet->deltaE.name != LMLS_NAME) && (ptnet->deltaE.name != LMS_NAME))
        n_threads = 1;

      //printf("Using %i threads from a max of %i.\n",n_threads ,max_threads);
   }
#endif
   /////////////////////////////////////////////////////////////////////////

   /////////////////////////////////////////////////////////////////////////
   //Contribution (who is to blame) : Parallelization done by Jose Maria
   //Memory allocation for running different threads in parallel:
   // Each thread will have his own pool of memory to handle the two kinds of temp vars:
   //   Vars used only inside the forwards/backwards (v0, v1 and method_delta)
   //     These vars will be initialized and read only by each thread
   //   Vars that hold the information on how much the weights and the bias should change 
   //     These vars will be initialized by each thread, then accumulated and read by the master thread when the batch is finished
   int n_neurons = ptnet->last_neuron+1;
   //Temp values, internal in each iteration
   double **  v0s                 = (double** ) R_alloc(n_threads,sizeof(double* )); //This is an 'Index'
   double **  v1s                 = (double** ) R_alloc(n_threads,sizeof(double* )); //This is an 'Index'
   double **  method_deltas       = (double** ) R_alloc(n_threads,sizeof(double* )); //This is an 'Index'
   //Accumulated values
   double **  method_deltas_bias  = (double** ) R_alloc(n_threads,sizeof(double* )); //This is an 'Index'
   double *** method_sums_delta_x = (double***) R_alloc(n_threads,sizeof(double**)); //This is an 'Index'

   for(int id_thread=0; id_thread<n_threads;id_thread++){
      double* chunk = (double*) R_alloc(4*n_neurons,sizeof(double)); //Actual chunk of memory for each thread, trying to avoid R_alloc calls
      //Advantages: Good proximity reference in cache for values of the same thread, and since it has at least 2 neurons
      // (Who would have a NNetwork with less than 2 neurons?), chunks are larger than 64 bytes (i7 L2 cache block size?)
      v0s               [id_thread] =  chunk             ;  
      v1s               [id_thread] = &chunk[  n_neurons];
      method_deltas     [id_thread] = &chunk[2*n_neurons];
      method_deltas_bias[id_thread] = &chunk[3*n_neurons];
      
      method_sums_delta_x[id_thread] = (double**) R_alloc(n_neurons,sizeof(double*)); //This is an 'Index'
      for(int i=0; i<n_neurons; i++) //Different weigth number for each layer, TODO: R_alloc each layer instead of each neuron
         method_sums_delta_x[id_thread][i] = (double*) R_alloc(neurons[i]->last_input_link+1,sizeof(double));
   }
   /////////////////////////////////////////////////////////////////////////

   /////////////////////////////////////////////////////////////////////////
   //Consistency (leave pnet as if the function had worked with their values instead of external ones)
   // R_alloc should handle freeing the memory, so it's not needed to free the previously allocated memory to avoid memory leaks
   // Changing pointer instead of copying data
   ptnet->input  = inputs[Ptransdim[1]-1];
   ptnet->target = targets[Ptransdim[1]-1];
   /////////////////////////////////////////////////////////////////////////
   
   /////////////////////////////////////////////////////////////////////////
   // Dividing learning rate and momentum by the number of samples in the training batch
   // Using local temp memory because of cache (proximity references) and direct access to memory and avoiding modification of header file
   // Using R_alloc for R to manage the memory
   double * neuron_learning_rate = (double*) R_alloc(n_neurons,sizeof(double));
   double * neuron_momentum      = (double*) R_alloc(n_neurons,sizeof(double));
   for(int i=0; i<n_neurons; i++){
      neuron_learning_rate[i] = ptnet->neurons[i]->method_dep_variables.batchgdwm.learning_rate / Ptransdim[1];
      neuron_momentum[i]      = ptnet->neurons[i]->method_dep_variables.batchgdwm.momentum      / Ptransdim[1];
   }
   /////////////////////////////////////////////////////////////////////////

   for (int epoch=0; epoch < n_epochs; epoch++) {
      //Run BATCH in parallel
      #pragma omp parallel num_threads(n_threads)
      {
#ifdef _OPENMP
        int id_thread = omp_get_thread_num();
#else
        int id_thread = 0;
#endif
        //////////////////////////////////////////////////////////////////////////////////////
        //// Using 'private' memory for each thread temp values instead of ptnet's own memory
        //// It's needed for multithreaded execution, in single thread model it's also used (is only modified if not compiled with OMP).
        //////////////////////////////////////////////////////////////////////////////////////
        //Select vars for this thread from the "memory pool":
        //  Used only by each thread:
        double* v0 = v0s[id_thread]; // double[n_neurons] //Using this instead of ptneuron->v0
        double* v1 = v1s[id_thread]; // double[n_neurons] //Using this instead of ptneuron->v1
        double* method_delta      = method_deltas[id_thread]; // double[n_neurons] //Using this instead of ptneuron->ptneuron->method_dep_variables.batchgdwm.delta
#ifdef _OPENMP
        //  Used to update weigths:
        double* method_delta_bias = method_deltas_bias[id_thread]; // double[n_neurons] //Instead of ptneuron->method_dep_variables.batchgdwm.sum_delta_bias
        double** method_sum_delta_x = method_sums_delta_x[id_thread]; // double*[n_neurons] //Instead of ptneuron->method_dep_variables.batchgdwm.sum_delta_x
        
        //Initialize vars that handle comm between batch execution and weight update
        for (int ind_neuron=0; ind_neuron <= ptnet->last_neuron; ind_neuron++){
            method_delta_bias[ind_neuron] = 0.0; //TODO: Should memset be used?
            for (int ind_weight=0; ind_weight <= neurons[ind_neuron]->last_input_link; ind_weight++)
              method_sum_delta_x[ind_neuron][ind_weight] = 0.0; //TODO: Should memset be used?
        }
#endif
        //////////////////////////////////////////////////////////////////////////////////////

        #pragma omp for 
        for (int fila=0; fila < Ptransdim[1]; fila++) {
           // R_alloc should handle freeing the memory, so it's not needed to free the previously allocated memory to avoid memory leaks
           // Also, these are read-only from this point onwards, should not be a problem accessing them on parallel threads 
           // ptnet->input  = inputs[fila];  //Moved into actual access
           // ptnet->target = targets[fila]; //Moved into actual access
           
           /* BEGIN   void batchgd_forward_mlpnet(AMOREnet * ptnet)   */
           for (int ind_neuron=0; ind_neuron <= ptnet->last_neuron ; ind_neuron++ ) {
              struct AMOREneuron * ptneuron = neurons[ind_neuron];
              /* BEGIN batchgd_forward_MLPneuron */
              double a=0.0;
              for (int ind_weight=0; ind_weight <= ptneuron->last_input_link; ind_weight++) {
                 int considered_input = ptneuron->input_links[ind_weight];
                 double x_input = (considered_input < 0 )? inputs[fila][-1-considered_input] :  v0[-1+considered_input];
                 a +=  ptneuron->weights[ind_weight] * x_input;
              }
              a += ptneuron->bias;
              switch (ptneuron->actf) {
                 case TANSIG_ACTF:
                    v0[ind_neuron] =  a_tansig * tanh(a * b_tansig); 
                    v1[ind_neuron] =  b_tansig / a_tansig * (a_tansig - v0[ind_neuron])*(a_tansig + v0[ind_neuron]);
                    break;
                 case SIGMOID_ACTF:
                    v0[ind_neuron] =  1/(1+exp(- a_sigmoid * a)) ; 
                    v1[ind_neuron] =  a_sigmoid * v0[ind_neuron] * ( 1 - v0[ind_neuron] );
                    break;
                 case PURELIN_ACTF:
                    v0[ind_neuron] = a; 
                    v1[ind_neuron] = 1;
                    break;
                 case HARDLIM_ACTF:
                    if (a>=0) {
                       v0[ind_neuron] = 1.0;
                    } else {
                       v0[ind_neuron] = 0.0;
                    }
                    v1[ind_neuron] = NA_REAL;
                    break;
                 case CUSTOM_ACTF:
                    PROTECT(args    = allocVector(REALSXP,1));
                    REAL(args)[0]   = a;
                    PROTECT(R_fcall = lang2(VECTOR_ELT(VECTOR_ELT(NET_NEURONS, ind_neuron), id_F0), args));
                    v0[ind_neuron]  = REAL(eval (R_fcall, rho))[0];
                    PROTECT(args    = allocVector(REALSXP,1));   
                    REAL(args)[0]   = a;
                    PROTECT(R_fcall = lang2(VECTOR_ELT(VECTOR_ELT(NET_NEURONS, ind_neuron), id_F1), args));
                    v1[ind_neuron]  = REAL(eval (R_fcall, rho))[0];
                    UNPROTECT(4);
                    break; 
              }
           /* END batchgd_forward_MLPneuron */
           }
           /* END     void batchgd_forward_mlpnet(AMOREnet * ptnet)   */


           /* BEGIN   void Parcial_batchgd_backwards_MLPnet (AMOREnet * ptnet, SEXP rho) */
           for (int ind_neuron=ptnet->last_neuron; ind_neuron >=0;  ind_neuron-- ) {
              struct AMOREneuron* ptneuron=ptnet->neurons[ind_neuron];
           /**/
              double aux_DELTA = 0.0;
              if (ptneuron->type==TYPE_OUTPUT) {
                 switch(ptnet->deltaE.name) {
                    case LMS_NAME:
                       aux_DELTA = v0[ind_neuron] - targets[fila][-1+ptneuron->output_aims[0]];
                    break;
                    case LMLS_NAME:
                       aux_DELTA = v0[ind_neuron] - targets[fila][-1+ptneuron->output_aims[0]];
                       aux_DELTA = aux_DELTA / (1 + aux_DELTA*aux_DELTA / 2);
                       break;
                    default:   /* if (ptneuron->deltaE.name==TAO_NAME)   de momento tao es como custom*/ 
                      /* ####### OJO FALTA cambiar el TAO  */
                      PROTECT(args  = allocVector(VECSXP,3)     );
                      PROTECT(arg3  = net                       );
                      PROTECT(arg2  = allocVector(REALSXP,1)    );
                      PROTECT(arg1  = allocVector(REALSXP,1)    );
                      REAL(arg1)[0] = v0[ind_neuron];
                      REAL(arg2)[0] =  targets[fila][-1+ptneuron->output_aims[0]];
                      SET_VECTOR_ELT(args, 0, arg1);
                      SET_VECTOR_ELT(args, 1, arg2);
                      SET_VECTOR_ELT(args, 2, arg3);
                      PROTECT(R_fcall = lang2(DELTAE_F, args) );
                      aux_DELTA = REAL(eval (R_fcall, rho))[0];
                      UNPROTECT(5);
                      break;
                 };
              } else {
                 for (int ind_other_neuron=0; ind_other_neuron <= ptneuron->last_output_link ; ind_other_neuron++ ) {
                    struct AMOREneuron* pt_that_neuron = ptneuron->output_links[ind_other_neuron];
                    int that_aim       = -1+ptneuron->output_aims[ind_other_neuron];
                    aux_DELTA     += method_delta[pt_that_neuron->id-1] * pt_that_neuron->weights[that_aim] ;
                 }
              }

              method_delta[ptneuron->id-1] = aux_DELTA * v1[ind_neuron]; //R ids start in 1

              for (int ind_weight = 0; ind_weight <= ptneuron->last_input_link; ind_weight++) {
                 int considered_input = ptneuron->input_links[ind_weight];
                 double x_input = considered_input < 0 ? inputs[fila][-1-considered_input] : v0[-1+considered_input];
#ifdef _OPENMP
                 method_sum_delta_x[ind_neuron][ind_weight] += method_delta[ptneuron->id-1] * x_input ;
              }
              method_delta_bias[ind_neuron] += method_delta[ptneuron->id-1];
           } /*/ End parcial backwards*/
        } /* end bucle fila */
      } //End parallel region

//Up to this point BATCHGD and BATCHGDWM are the same

      //////////////////////////////////////////////////////////////////////////////////////
      //Update ptnet with the values from batch calculations
      for(int id_thread=0; id_thread<n_threads;id_thread++){ //Maybe reduction could be used
        for (int ind_neuron=0; ind_neuron <= ptnet->last_neuron ; ind_neuron++ ) {
          struct AMOREneuron *  ptneuron = neurons[ind_neuron];
          ptneuron->method_dep_variables.batchgdwm.sum_delta_bias +=  method_deltas_bias[id_thread][ind_neuron];
          for (int ind_weight = 0; ind_weight <= ptneuron->last_input_link; ind_weight++) {
            ptneuron->method_dep_variables.batchgdwm.sum_delta_x[ind_weight] += method_sums_delta_x[id_thread][ind_neuron][ind_weight];
          }
        }
      }
      //////////////////////////////////////////////////////////////////////////////////////
#else
                 ptneuron->method_dep_variables.batchgdwm.sum_delta_x[ind_weight] += method_delta[ptneuron->id-1] * x_input ;
              }
              ptneuron->method_dep_variables.batchgdwm.sum_delta_bias += method_delta[ptneuron->id-1];

           } /*/ End parcial backwards*/
示例#13
0
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
 * Purpose: 
 *          
 *          
 *          
 *
 *          
*/
SEXP write_volume(SEXP filename, SEXP nDimensions, 
								SEXP dimLengths, 
								SEXP dimStarts, 
								SEXP dimSteps, 
								SEXP volumeDataType, 
								SEXP volumeRange, 
								SEXP hSlab) {

	mihandle_t			minc_volume;
	midimhandle_t		dim[MI2_MAX_VAR_DIMS];
	mivolumeprops_t		volume_properties;
	
	int				result;
	int				ndx;
	int				no_dimensions;
	int				dim_lengths[MI2_MAX_VAR_DIMS];
	double			dim_starts[MI2_MAX_VAR_DIMS];
	double			dim_steps[MI2_MAX_VAR_DIMS];
	double			volume_range_min, volume_range_max;
	int				volume_data_type;
	
	// pointer to the volume data
	double			*hSlab_p;
	misize_t	hSlab_start[MI2_MAX_VAR_DIMS];
	misize_t	hSlab_count[MI2_MAX_VAR_DIMS];


	// start ...
	if ( R_DEBUG_mincIO ) Rprintf("write_volume: start ...\n");

	/* init number of dimensions and their respective sizes
	  ... yes, I could get this myself, but it's best set in the calling R code */
	no_dimensions = INTEGER(nDimensions)[0];
	volume_data_type = INTEGER(volumeDataType)[0];
	volume_range_min = REAL(volumeRange)[0];
	volume_range_max = REAL(volumeRange)[1];
	
	// init volume data pointer
	hSlab_p = REAL(hSlab);
	
	
	// init lenghts, steps, and starts
	for (ndx=0; ndx < no_dimensions; ++ndx) {
		dim_lengths[ndx]  = INTEGER(dimLengths)[ndx];
		hSlab_count[ndx]  = INTEGER(dimLengths)[ndx];
		dim_starts[ndx]  = REAL(dimStarts)[ndx];
		dim_steps[ndx]  = REAL(dimSteps)[ndx];
	}


	// set the properties for the new output volume
	// ... no compression, no chunking, no multi-resolution, ... nothin fancy
	result = minew_volume_props(&volume_properties);
	if (result != MI_NOERROR) {
		error("write_volume:minew_volume_props: Error setting output volume properties: %s.\n", CHAR(STRING_ELT(filename, 0)));
	}
	result = miset_props_compression_type(volume_properties, MI_COMPRESS_NONE);
	if (result != MI_NOERROR) {
		error("write_volume:miset_props_compression_type: Error setting output volume properties: %s.\n", CHAR(STRING_ELT(filename, 0)));
	}
	result = miset_props_multi_resolution(volume_properties, FALSE, 1);
	if (result != MI_NOERROR) {
		error("write_volume:miset_props_multi_resolution: Error setting output volume properties: %s.\n", CHAR(STRING_ELT(filename, 0)));
	}

	/*	create the 3 output dimensions in the order Z, Y, X, as the volume
		is stored in this order */
	// z-dim
	result = micreate_dimension("zspace", 
								MI_DIMCLASS_SPATIAL,
								MI_DIMATTR_REGULARLY_SAMPLED, 
								dim_lengths[0],
								&dim[0]);
	//
	if (result != MI_NOERROR) {
		error("write_volume: Error initializing the dimension struct for %s dimension.\n", "zspace");
	}
	
	// y-dim
	result = micreate_dimension("yspace", 
								MI_DIMCLASS_SPATIAL,
								MI_DIMATTR_REGULARLY_SAMPLED, 
								dim_lengths[1],
								&dim[1]);
	//
	if (result != MI_NOERROR) {
		error("write_volume: Error initializing the dimension struct for %s dimension.\n", "yspace");
	}
	
	// x-dim
	result = micreate_dimension("xspace", 
								MI_DIMCLASS_SPATIAL,
								MI_DIMATTR_REGULARLY_SAMPLED, 
								dim_lengths[2],
								&dim[2]);
	//
	if (result != MI_NOERROR) {
		error("write_volume: Error initializing the dimension struct for %s dimension.\n", "xspace");
	}


	// set the start values for each dimension
	result = miset_dimension_starts(dim, no_dimensions, dim_starts);
	if (result == MI_ERROR) {
		error("write_volume: Error setting dimension start values.\n");
	}

	// set the step values for each dimension
	result = miset_dimension_separations(dim, no_dimensions, dim_steps);
	if (result == MI_ERROR) {
		error("write_volume: Error setting dimension step values.\n");
	}


	// create the volume structure (no data yet, of course)
	result = micreate_volume(CHAR(STRING_ELT(filename, 0)),
								no_dimensions, 
								dim,
								volume_data_type,
								MI_CLASS_REAL,
								volume_properties,
								&minc_volume);
	//
	if (result != MI_NOERROR) {
		error("write_volume: Error creating output volume structure: %s.\n", CHAR(STRING_ELT(filename, 0)));
	}
		
	// create the path to the image data
	result = micreate_volume_image(minc_volume);
	//
	if (result != MI_NOERROR) {
		error("write_volume: Error writing data to volume %s.\n", CHAR(STRING_ELT(filename, 0)));
	}


	// set valid and real ranges 
	// ... 0xFFFF=65535=16-bits (unsigned)
	miset_volume_valid_range(minc_volume, 0x7FFF, 0);
	miset_volume_range(minc_volume, volume_range_max, volume_range_min);


	// write  hyperslab (entire volume)
	hSlab_start[0] = hSlab_start[1] = hSlab_start[2] = 0;
	if ( R_DEBUG_mincIO ) Rprintf("hSlab_count [0..2] = %d, %d, %d\n", 
		hSlab_count[0], hSlab_count[1], hSlab_count[2]);
			
	result = miset_real_value_hyperslab(minc_volume, MI_TYPE_DOUBLE, 
														hSlab_start,
														hSlab_count,
														hSlab_p);
	if ( result != MI_NOERROR ) {
		error("Error in miset_real_value_hyperslab: %s.\n", CHAR(STRING_ELT(filename, 0)));
	}




	// free resources
        //
        // in the current version of minc (libsrc2/volume.c), these volume properties
        // as well as the dimension handles are already freed by the miclose_volume function.
        //
	//mifree_volume_props(volume_properties);								// free the property list
	//for ( ndx=0; ndx<no_dimensions; ++ndx) {							// free the dimhandles
	//	mifree_dimension_handle(dim[ndx]);
	//}
	// close new volume
	result = miclose_volume(minc_volume);
	if (result != MI_NOERROR) {
		error("write_volume: Error closing newly created volume %s.\n", CHAR(STRING_ELT(filename, 0)));
	}

	// done, return NULL
	if ( R_DEBUG_mincIO ) Rprintf("write_volume: returning ...\n");
	return(R_NilValue);
}
示例#14
0
QueryData genMDDevices(QueryContext& context) {
  QueryData results;
  MDStat mds;
  MD md;
  std::vector<std::string> lines;

  getLines(lines);

  md.parseMDStat(lines, mds);
  for (const auto& device : mds.devices) {
    std::string path(md.getPathByDevName(device.name));
    if (path.empty()) {
      LOG(ERROR) << "Could not get file path for " << device.name;
      return results;
    }

    mdu_array_info_t array;
    if (!md.getArrayInfo(path, array)) {
      return results;
    }

    Row r;
    r["device_name"] = device.name;
    r["status"] = device.status;
    r["raid_level"] = INTEGER(array.level);
    r["size"] = BIGINT(device.usableSize);
    r["chunk_size"] = BIGINT(array.chunk_size);
    r["raid_disks"] = INTEGER(array.raid_disks);
    r["nr_raid_disks"] = INTEGER(array.nr_disks);
    r["working_disks"] = INTEGER(array.working_disks);
    r["active_disks"] = INTEGER(array.active_disks);
    r["failed_disks"] = INTEGER(array.failed_disks);
    r["spare_disks"] = INTEGER(array.spare_disks);

    r["superblock_state"] = getSuperBlkStateStr(array.state);
    r["superblock_version"] = md.getSuperblkVersion(device.name);
    r["superblock_update_time"] = BIGINT(array.utime);

    if (!device.recovery.progress.empty()) {
      r["recovery_progress"] = device.recovery.progress;
      r["recovery_finish"] = device.recovery.finish;
      r["recovery_speed"] = device.recovery.speed;
    }

    if (!device.resync.progress.empty()) {
      r["resync_progress"] = device.resync.progress;
      r["resync_finish"] = device.resync.finish;
      r["resync_speed"] = device.resync.speed;
    }

    if (!device.reshape.progress.empty()) {
      r["reshape_progress"] = device.reshape.progress;
      r["reshape_finish"] = device.reshape.finish;
      r["reshape_speed"] = device.reshape.speed;
    }

    if (!device.checkArray.progress.empty()) {
      r["check_array_progress"] = device.checkArray.progress;
      r["check_array_finish"] = device.checkArray.finish;
      r["check_array_speed"] = device.checkArray.speed;
    }

    if (!device.bitmap.onMem.empty()) {
      r["bitmap_on_mem"] = device.bitmap.onMem;
      r["bitmap_chunk_size"] = device.bitmap.chunkSize;
      r["bitmap_external_file"] = device.bitmap.externalFile;
    }

    r["other"] = device.other;
    r["unused_devices"] = mds.unused;

    results.push_back(r);
  }

  return results;
}
示例#15
0
//extern "C"
SEXP mc_irf_var(SEXP varobj, SEXP nsteps, SEXP draws)
{
  int m, p, dr=INTEGER(draws)[0], ns=INTEGER(nsteps)[0], T, df, i;
  SEXP AR, Y, Bhat, XR, prior, hstar, meanS, output;

  // Get # vars/lags/steps/draws/T/df
  PROTECT(AR = listElt(varobj, "ar.coefs"));
  PROTECT(Y = listElt(varobj, "Y"));
  m = INTEGER(getAttrib(AR, R_DimSymbol))[0]; //#vars
  p = INTEGER(getAttrib(AR, R_DimSymbol))[2]; //#lags
  T = nrows(Y); df = T - m*p - m - 1;
  UNPROTECT(2);

  // Put coefficients from varobj$Bhat in Bcoefs vector (m^2*p, 1)
  PROTECT(Bhat = coerceVector(listElt(varobj, "Bhat"), REALSXP));
  Matrix bcoefs = R2Cmat(Bhat, m*p, m);
  bcoefs = bcoefs.AsColumn();
  UNPROTECT(1);

  // Define X(T x m*p) subset of varobj$X and XXinv as solve(X'X)
  PROTECT(XR = coerceVector(listElt(varobj,"X"),REALSXP));
  Matrix X = R2Cmat(XR, T, m*p), XXinv;
  UNPROTECT(1);

  // Get the correct moment matrix
  PROTECT(prior = listElt(varobj,"prior"));
  if(!isNull(prior)){
    PROTECT(hstar = coerceVector(listElt(varobj,"hstar"),REALSXP));
    XXinv = R2Cmat(hstar, m*p, m*p).i();
    UNPROTECT(1);
  }
  else { XXinv = (X.t()*X).i(); }
  UNPROTECT(1);

  // Get the transpose of the Cholesky decomp of XXinv
  SymmetricMatrix XXinvSym; XXinvSym << XXinv;
  XXinv = Cholesky(XXinvSym);

  // Cholesky of covariance
  PROTECT(meanS = coerceVector(listElt(varobj,"mean.S"),REALSXP));
  SymmetricMatrix meanSSym; meanSSym << R2Cmat(meanS, m, m);
  Matrix Sigmat = Cholesky(meanSSym);
  UNPROTECT(1);

  // Matricies needed for the loop
  ColumnVector bvec; bvec=0.0;
  Matrix sqrtwish, impulse(dr,m*m*ns); impulse = 0.0;
  SymmetricMatrix sigmadraw; sigmadraw = 0.0;
  IdentityMatrix I(m);

  GetRNGstate();
  // Main Loop
  for (i=1; i<=dr; i++){
    // Wishart/Beta draws
    sigmadraw << Sigmat*(T*rwish(I,df).i())*Sigmat.t();
    sqrtwish = Cholesky(sigmadraw);
    bvec = bcoefs+KP(sqrtwish, XXinv)*rnorms(m*m*p);

    // IRF computation
    impulse.Row(i) = irf_var_from_beta(sqrtwish, bvec, ns).t();
    if (!(i%1000)){ Rprintf("Monte Carlo IRF Iteration = %d\n",i); }
  } // end main loop
  PutRNGstate();

  int dims[]={dr,ns,m*m};
  PROTECT(output = C2R3D(impulse,dims));
  setclass(output,"mc.irf.VAR");
  UNPROTECT(1);
  return output;
}
示例#16
0
文件: layout.c 项目: Bgods/r-source
int layoutNCol(SEXP l) {
    return INTEGER(VECTOR_ELT(l, LAYOUT_NCOL))[0];
}
示例#17
0
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;
}
示例#18
0
文件: layout.c 项目: Bgods/r-source
int layoutRespect(SEXP l) {
    return INTEGER(VECTOR_ELT(l, LAYOUT_VRESPECT))[0];
}
示例#19
0
QueryData genProcesses(QueryContext &context) {
  QueryData results;
  auto pidlist = getProcList();
  auto parent_pid = getParentMap(pidlist);
  int argmax = genMaxArgs();

  for (auto &pid : pidlist) {
    if (!context.constraints["pid"].matches<int>(pid)) {
      // Optimize by not searching when a pid is a constraint.
      continue;
    }

    Row r;
    r["pid"] = INTEGER(pid);
    r["name"] = getProcName(pid);
    r["path"] = getProcPath(pid);
    r["cmdline"] = boost::algorithm::join(getProcArgs(pid, argmax), " ");

    proc_cred cred;
    if (getProcCred(pid, cred)) {
      r["uid"] = BIGINT(cred.real.uid);
      r["gid"] = BIGINT(cred.real.gid);
      r["euid"] = BIGINT(cred.effective.uid);
      r["egid"] = BIGINT(cred.effective.gid);
    }

    const auto parent_it = parent_pid.find(pid);
    if (parent_it != parent_pid.end()) {
      r["parent"] = INTEGER(parent_it->second);
    } else {
      r["parent"] = "-1";
    }

    // if the path of the executable that started the process is available and
    // the path exists on disk, set on_disk to 1.  if the path is not
    // available, set on_disk to -1.  if, and only if, the path of the
    // executable is available and the file does not exist on disk, set on_disk
    // to 0.
    r["on_disk"] = osquery::pathExists(r["path"]).toString();

    // systems usage and time information
    struct rusage_info_v2 rusage_info_data;
    int rusage_status = proc_pid_rusage(
        pid, RUSAGE_INFO_V2, (rusage_info_t *)&rusage_info_data);
    // proc_pid_rusage returns -1 if it was unable to gather information
    if (rusage_status == 0) {
      // size information
      r["wired_size"] = TEXT(rusage_info_data.ri_wired_size);
      r["resident_size"] = TEXT(rusage_info_data.ri_resident_size);
      r["phys_footprint"] = TEXT(rusage_info_data.ri_phys_footprint);

      // time information
      r["user_time"] = TEXT(rusage_info_data.ri_user_time);
      r["system_time"] = TEXT(rusage_info_data.ri_system_time);
      r["start_time"] = TEXT(rusage_info_data.ri_proc_start_abstime);
    }

    // save the results
    results.push_back(r);
  }

  return results;
}
示例#20
0
文件: layout.c 项目: Bgods/r-source
int* layoutRespectMat(SEXP l) {
    return INTEGER(VECTOR_ELT(l, LAYOUT_MRESPECT));
}
示例#21
0
文件: scan.c 项目: Maxsl/r-source
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;
}
示例#22
0
文件: mapply.cpp 项目: csilles/cxxr
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;
}
SEXP gbm_plot
(
    SEXP radX,        // vector or matrix of points to make predictions
    SEXP rcRows,      // number of rows in X
    SEXP rcCols,      // number of columns in X
    SEXP raiWhichVar, // length=cCols, index of which var cols of X are
    SEXP rcTrees,     // number of trees to use
    SEXP rdInitF,     // initial value
    SEXP rTrees,      // tree list object
    SEXP rCSplits,    // categorical split list object
    SEXP raiVarType   // vector of variable types
)
{
    unsigned long hr = 0;
    int i = 0;
    int iTree = 0;
    int iObs = 0;
    int cRows = INTEGER(rcRows)[0];
    int cCols = INTEGER(rcCols)[0];
    int cTrees = INTEGER(rcTrees)[0];

    SEXP rThisTree = NULL;
    int *aiSplitVar = NULL;
    double *adSplitCode = NULL;
    int *aiLeftNode = NULL;
    int *aiRightNode = NULL;
    int *aiMissingNode = NULL;
    double *adW = NULL;
    int iCurrentNode = 0;
    double dCurrentW = 0.0;
    double dX = 0.0;
    int iCatSplitIndicator = 0;

    SEXP radPredF = NULL;
    int aiNodeStack[40];
    double adWeightStack[40];
    int cStackNodes = 0;
    int iPredVar = 0;

    // allocate the predictions to return
    PROTECT(radPredF = allocVector(REALSXP, cRows));
    if(radPredF == NULL)
    {
        hr = GBM_OUTOFMEMORY;
        goto Error;
    }
    for(iObs=0; iObs<cRows; iObs++)
    {
        REAL(radPredF)[iObs] = REAL(rdInitF)[0];
    }
    for(iTree=0; iTree<cTrees; iTree++)
    {
        rThisTree     = VECTOR_ELT(rTrees,iTree);
        aiSplitVar    = INTEGER(VECTOR_ELT(rThisTree,0));
        adSplitCode   = REAL   (VECTOR_ELT(rThisTree,1));
        aiLeftNode    = INTEGER(VECTOR_ELT(rThisTree,2));
        aiRightNode   = INTEGER(VECTOR_ELT(rThisTree,3));
        aiMissingNode = INTEGER(VECTOR_ELT(rThisTree,4));
        adW           = REAL   (VECTOR_ELT(rThisTree,6));
        for(iObs=0; iObs<cRows; iObs++)
        {
            aiNodeStack[0] = 0;
            adWeightStack[0] = 1.0;
            cStackNodes = 1;
            while(cStackNodes > 0)
            {
                cStackNodes--;
                iCurrentNode = aiNodeStack[cStackNodes];

                if(aiSplitVar[iCurrentNode] == -1) // terminal node
                {
                    REAL(radPredF)[iObs] += 
                        adWeightStack[cStackNodes]*adSplitCode[iCurrentNode];
                }
                else // non-terminal node
                {
                    // which split variable am I interested in it?
                    iPredVar = -1;
                    for(i=0; (iPredVar == -1) && (i < cCols); i++)
                    {
                        if(INTEGER(raiWhichVar)[i] == aiSplitVar[iCurrentNode])
                        {
                            iPredVar = i; // split is on one that interests me
                        }
                    }

                    if(iPredVar != -1)
                    {
                        dX = REAL(radX)[iPredVar*cRows + iObs];
                        // continuous?
                        if(INTEGER(raiVarType)[aiSplitVar[iCurrentNode]] == 0)
                        {
                            if(dX < adSplitCode[iCurrentNode])
                            {
                                aiNodeStack[cStackNodes] = aiLeftNode[iCurrentNode];
                                cStackNodes++;
                            }
                            else
                            {
                                aiNodeStack[cStackNodes] = aiRightNode[iCurrentNode];
                                cStackNodes++;
                            }
                        }
                        else // categorical
                        {
                            iCatSplitIndicator = INTEGER(
                                VECTOR_ELT(rCSplits,
                                           (int)adSplitCode[iCurrentNode]))[(int)dX];
                            if(iCatSplitIndicator==-1)
                            {
                                aiNodeStack[cStackNodes] = aiLeftNode[iCurrentNode];
                                cStackNodes++;
                            }
                            else if(iCatSplitIndicator==1)
                            {
                                aiNodeStack[cStackNodes] = aiRightNode[iCurrentNode];
                                cStackNodes++;
                            }
                            else // handle unused level
                            {
                                iCurrentNode = aiMissingNode[iCurrentNode];
                            }
                        }
                    } // iPredVar != -1
                    else // not interested in this split, average left and right 
                    {
                        aiNodeStack[cStackNodes] = aiRightNode[iCurrentNode];
                        dCurrentW = adWeightStack[cStackNodes];
                        adWeightStack[cStackNodes] = dCurrentW *
                            adW[aiRightNode[iCurrentNode]]/
                            (adW[aiLeftNode[iCurrentNode]]+
                             adW[aiRightNode[iCurrentNode]]);
                        cStackNodes++;
                        aiNodeStack[cStackNodes] = aiLeftNode[iCurrentNode];
                        adWeightStack[cStackNodes] = 
                            dCurrentW-adWeightStack[cStackNodes-1];
                        cStackNodes++;
                    }
                } // non-terminal node
            } // while(cStackNodes > 0)
        } // iObs
    } // iTree

Cleanup:
    UNPROTECT(1); // radPredF
    return radPredF;
Error:
    goto Cleanup;
} // gbm_plot
示例#24
0
// adapted from https://github.com/armgong/RJulia/blob/master/src/R_Julia.c
SEXP jr_array(jl_value_t *tt)
{
    SEXP ans = R_NilValue;
    //get Julia dims and set R array Dims
    int len = jl_array_len(tt);
    if (len == 0)
        return ans;

    jl_datatype_t *ty = jl_array_eltype(tt);
    int ndims = jl_array_ndims(tt);
    SEXP dims;
    PROTECT(dims = Rf_allocVector(INTSXP, ndims));
    for (size_t i = 0; i < ndims; i++)
        INTEGER(dims)[i] = jl_array_dim(tt, i);
    UNPROTECT(1);

    // again, float64, int32 and int64 are most common
    if (ty == jl_float64_type)
    {
            double *p = (double *) jl_array_data(tt);
            PROTECT(ans = Rf_allocArray(REALSXP, dims));
            for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
            UNPROTECT(1);;
    }
    else if (ty == jl_int32_type)
    {
         int32_t *p = (int32_t *) jl_array_data(tt);
         PROTECT(ans = Rf_allocArray(INTSXP, dims));
         for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
         UNPROTECT(1);
    }
    else if (ty == jl_int64_type)
    {
        int is_int32 = 1;
        int64_t *p = (int64_t *) jl_array_data(tt);
        for (size_t i=0;i<len;i++)
        {
            if (p[i]>INT32_MAX || p[i]<INT32_MIN)
            {
                is_int32 = 0;
                break;
            }
        }
        if (is_int32)
        {
            PROTECT(ans = Rf_allocArray(INTSXP, dims));
            for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
            UNPROTECT(1);
        }
        else
        {
            PROTECT(ans = Rf_allocArray(REALSXP, dims));
            for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
            UNPROTECT(1);
        }
    }
    else if (ty == jl_bool_type)
    {
        bool *p = (bool *) jl_array_data(tt);
        PROTECT(ans = Rf_allocArray(LGLSXP, dims));
        for (size_t i = 0; i < len; i++)
           LOGICAL(ans)[i] = p[i];
        UNPROTECT(1);
    }
    else if (ty == jl_int8_type)
    {
        int8_t *p = (int8_t *) jl_array_data(tt);
        PROTECT(ans = Rf_allocArray(INTSXP, dims));
        for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
        UNPROTECT(1);
    }
    else if (ty == jl_uint8_type)
    {
        uint8_t *p = (uint8_t *) jl_array_data(tt);
        PROTECT(ans = Rf_allocArray(INTSXP, dims));
        for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
        UNPROTECT(1);
    }
    else if (ty == jl_int16_type)
    {
        int16_t *p = (int16_t *) jl_array_data(tt);
        PROTECT(ans = Rf_allocArray(INTSXP, dims));
        for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
        UNPROTECT(1);
    }
    else if (ty == jl_uint16_type)
    {
        uint16_t *p = (uint16_t *) jl_array_data(tt);
        PROTECT(ans = Rf_allocArray(INTSXP, dims));
        for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
        UNPROTECT(1);
    }
    else if (ty == jl_uint32_type)
    {
        int is_int32 = 1;
        uint32_t *p = (uint32_t *) jl_array_data(tt);
        for (size_t i=0;i<len;i++)
        {
            if (p[i]>INT32_MAX || p[i]<INT32_MIN)
            {
                is_int32 = 0;
                break;
            }
        }
        if (is_int32)
        {
            PROTECT(ans = Rf_allocArray(INTSXP, dims));
            for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
            UNPROTECT(1);
        }
        else
        {
            PROTECT(ans = Rf_allocArray(REALSXP, dims));
            for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
            UNPROTECT(1);
        }
    }
    else if (ty == jl_uint64_type)
    {
        int is_int32 = 1;
        uint64_t *p = (uint64_t *) jl_array_data(tt);
        for (size_t i=0;i<len;i++)
        {
            if (p[i]>INT32_MAX || p[i]<INT32_MIN)
            {
                is_int32 = 0;
                break;
            }
        }
        if (is_int32)
        {
            PROTECT(ans = Rf_allocArray(INTSXP, dims));
            for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
            UNPROTECT(1);
        }
        else
        {
          PROTECT(ans = Rf_allocArray(REALSXP, dims));
          for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
          UNPROTECT(1);
        }
    }
    //double
    else if (ty == jl_float32_type)
    {
        float *p = (float *) jl_array_data(tt);
        PROTECT(ans = Rf_allocArray(REALSXP, dims));
        for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
        UNPROTECT(1);;
    }
    //utf8 string
    else if (ty == jl_utf8_string_type)
    {
        PROTECT(ans = Rf_allocArray(STRSXP, dims));
        for (size_t i = 0; i < len; i++)
           SET_STRING_ELT(ans, i, Rf_mkCharCE(jl_string_data(jl_cellref(tt, i)), CE_UTF8));
       UNPROTECT(1);
    }
    else if (ty == jl_ascii_string_type)
    {
        PROTECT(ans = Rf_allocArray(STRSXP, dims));
        for (size_t i = 0; i < len; i++)
           SET_STRING_ELT(ans, i, Rf_mkChar(jl_string_data(jl_cellref(tt, i))));
       UNPROTECT(1);
    }
    return ans;
}
示例#25
0
SEXP L2L1VitPath(SEXP obsSeq, SEXP lambda2, SEXP lambda1, SEXP retPath, SEXP maxSegs,
				 SEXP segmentVec, SEXP primBds)
{
  int segmented_ret = (segmentVec != R_NilValue) ? 1 : 0;

  int max_segs = GetInt(maxSegs, 0, 0);

  double * all_obs   = REAL(obsSeq);

  int n_obs = LENGTH(obsSeq);
  int n_protect = 0;

  double * back_ptrs     = AllocProtectReal(2*n_obs);  n_protect++;
  int * fused_segs1   = NULL;
  int * fused_segs2   = NULL;

  double *o2 = NULL, *wts2 = NULL, *o3 = NULL, *wts3 = NULL;

  int msg_buf_len = FL_SEGSZ*2*30;
  double * msg_buf = malloc( msg_buf_len*sizeof(double) );

  SEXP ret_sxp;
  PROTECT(ret_sxp = NEW_INTEGER(1)); n_protect++;

  double obs_min = R_PosInf, obs_max = R_NegInf;
  for(int i = 0; i < n_obs; i++){

	  if(R_FINITE(all_obs[i])){
		  if(all_obs[i] < obs_min) obs_min = all_obs[i];
		  if(all_obs[i] > obs_max) obs_max = all_obs[i];
	  }
  }

  double lam1 = GetNumeric(lambda1, 0, 0);

  int n_lam2 = LENGTH(lambda2);
  int n_o = n_obs;
  double * o = all_obs;

  double * wts = NULL;

  double * prim_bds = (primBds == R_NilValue) ? NULL : REAL(primBds);

  for(int lam2i = 0; lam2i < n_lam2; lam2i++){

	  double lam2 = REAL(lambda2)[lam2i];

	  double beta_hat = 0.0;

	  int r1 = L2L1VitFwd(lam2, o, wts,
	                      &msg_buf, &msg_buf_len, max_segs,
						  back_ptrs, NULL, n_o, max_segs, obs_min, obs_max,
						  &beta_hat);

	  if(r1 != 1){
		  INTEGER(ret_sxp)[0] = r1;
		  UNPROTECT(n_protect);
		  return ret_sxp;
	  }

	  int * fs = fused_segs1;

	  int nfsd2 = 0;
	  if(o2 == NULL || segmented_ret){
		  //We haven't allocated the buffers for the
		  //fused observations yet
		  nfsd2 = L2L1GetNFused(beta_hat, n_o, back_ptrs);

		  o2 = AllocProtectReal(nfsd2);  n_protect++;
		  wts2 = AllocProtectReal(nfsd2);  n_protect++;

		  fused_segs1 = AllocProtectInt(2*(nfsd2+1));  n_protect++;
		  fused_segs2 = AllocProtectInt(2*(nfsd2+1));  n_protect++;
	  }

	  double * fit_v = NULL;

	  if(segmented_ret){
		  SEXP tmp_sxp;
		  PROTECT(tmp_sxp = NEW_NUMERIC(nfsd2));
		  SET_VECTOR_ELT(retPath, lam2i, tmp_sxp);
		  UNPROTECT(1);

		  fit_v = REAL(VECTOR_ELT(retPath, lam2i));
	  }else{
		  fit_v = REAL(retPath) + n_obs * lam2i;
	  }

	  int seg_R = (fs) ? fs[0] : (n_obs-1);
	  int seg_L = (fs) ? fs[1] : (n_obs-1);

	  int n_fused2 = 0;
	  fused_segs2[0] = seg_R;

	  if(fs) fs += 2;

	  double bd1 = 0.0, bd2 = 0.0;
	  double beta_hat_shr = beta_hat;

	  if(segmented_ret){
		  fit_v[(nfsd2-1) - n_fused2] = beta_hat_shr;
		  bd1 += fabs(beta_hat_shr);
	  }else{
		  for(int k = seg_L; k <= seg_R; k++){
			  fit_v[k] = beta_hat_shr;
		  }
		  bd1 += fabs(beta_hat_shr) * (double)(1+seg_R - seg_L);
	  }
	  if( !R_FINITE(o[n_o-1]) ){
		  o2[n_fused2] = wts2[n_fused2] = 0;
	  }else if(wts){
		  o2[n_fused2] = o[n_o-1]*wts[n_o-1];
		  wts2[n_fused2] = wts[n_o-1];
	  }else{
		  o2[n_fused2] = o[n_o-1];
		  wts2[n_fused2] = 1.0;
	  }

	  if(n_o == 1){
		  n_fused2 = 1;
		  fused_segs2[0] = n_obs - 1;
		  fused_segs2[1] = 0;

		  o2[0] = o[0] * wts[0];
		  wts2[0] = wts[0];
	  }

	  for(int i = n_o-2; i >= 0; i--){
		  seg_R = (fs) ? fs[0] : i;
		  seg_L = (fs) ? fs[1] : i;

		  double * bp = back_ptrs + (2*(i+1));

		  if(beta_hat > bp[1]){
			  bd2 += fabs(beta_hat - bp[1]);

			  beta_hat = bp[1];
			  beta_hat_shr = beta_hat;

			  fused_segs2[2*n_fused2 + 1] = seg_R+1;
			  n_fused2++;

			  o2[n_fused2] = wts2[n_fused2] = 0.0;
			  fused_segs2[2*n_fused2] = seg_R;


		  }else if(beta_hat < bp[0]){
			  bd2 += fabs(beta_hat - bp[0]);

			  beta_hat = bp[0];
			  beta_hat_shr = beta_hat;

			  fused_segs2[2*n_fused2 + 1] = seg_R+1;
			  n_fused2++;

			  o2[n_fused2] = wts2[n_fused2] = 0.0;
			  fused_segs2[2*n_fused2] = seg_R;
		  }

		  if(R_FINITE(o[i])){
			  if(wts){
				  o2[n_fused2] += o[i]*wts[i];
				  wts2[n_fused2] += wts[i];
			  }else{
				  o2[n_fused2] += o[i];
				  wts2[n_fused2] += 1.0;
			  }
		  }

		  if(segmented_ret){
			  fit_v[(nfsd2-1) - n_fused2] = beta_hat_shr;
		  }else{
			  for(int k = seg_L; k <= seg_R; k++){
				  fit_v[k] = beta_hat_shr;
			  }
		  }
		  bd1 += fabs(beta_hat_shr) * (double)(1+seg_R - seg_L);

		  if(i == 0){
			  fused_segs2[2*n_fused2 + 1] = seg_L;
			  n_fused2++;
		  }

		  if(fs) fs += 2;
	  }
	  if(prim_bds){
		  double * bdv = prim_bds + 2*lam2i;
		  bdv[0] = bd1;
		  bdv[1] = bd2;
	  }
	  // We have stored the fitted parameters.  Now we collapse
	  // observations and fit on the new sequence at the next
	  // iteration

	  obs_min = R_PosInf;
	  obs_max = R_NegInf;

	  if(o3 == NULL){
		  o3 = AllocProtectReal(n_fused2);  n_protect++;
		  wts3 = AllocProtectReal(n_fused2);  n_protect++;
	  }

	  for(int i = 0; i < n_fused2; i++){
		  if( wts2[n_fused2-1-i] > 0.0 ){

			  double z = o2[n_fused2-1-i] / wts2[n_fused2-1-i];
			  if(z < obs_min) obs_min = z;
			  if(z > obs_max) obs_max = z;

			  o3[i] = z;
		  }else{
			  o3[i] = NA_REAL;
		  }
		  wts3[i] = wts2[n_fused2-1-i];
	  }

	  if(n_o == 1){
		  obs_max = obs_min + FL_ENDPT_KNOT_FUDGE;
		  obs_min -= FL_ENDPT_KNOT_FUDGE;
	  }

	  if(segmented_ret){
		  SEXP tmp_sxp, seg_dim;
		  PROTECT(tmp_sxp = NEW_INTEGER(2*nfsd2));

		  PROTECT(seg_dim=NEW_INTEGER(2));
		  INTEGER(seg_dim)[0] = 2;
		  INTEGER(seg_dim)[1] = nfsd2;

		  SET_DIM(tmp_sxp,seg_dim);

		  SET_VECTOR_ELT(segmentVec, lam2i, tmp_sxp);
		  UNPROTECT(2);

		  int * seg_v = INTEGER(VECTOR_ELT(segmentVec, lam2i));
		  for(int k = 0; k < nfsd2; k++){
			  seg_v[1+2*k] = fused_segs2[(nfsd2-1-k)*2]+1;
			  seg_v[2*k] = fused_segs2[1+(nfsd2-1-k)*2]+1;
		  }
	  }

	  o = o3;
	  wts = wts3;

	  fs = fused_segs2;
	  fused_segs2 = fused_segs1;
	  fused_segs1 = fs;

	  n_o = n_fused2;
  }

  free(msg_buf);

  if(segmented_ret){
	  for(int lam2i = 0; lam2i < n_lam2; lam2i++){
		   double * bv = REAL(VECTOR_ELT(retPath, lam2i));
		   int m = LENGTH(VECTOR_ELT(retPath, lam2i));

		   for(int i = 0; i < m; i++){
			   bv[i] = soft_thresh(bv[i], lam1);
		   }
	  }
  }else{
	   double * bv = REAL(retPath);
	   int m = LENGTH(retPath);

	   for(int i = 0; i < m; i++){
		   bv[i] = soft_thresh(bv[i], lam1);
	   }
  }



  INTEGER(ret_sxp)[0]  = 1;
  UNPROTECT(n_protect);
  return ret_sxp;
}
示例#26
0
文件: db.c 项目: rforge/rberkeley
/* {{{ rberkeley_db_stat */
SEXP rberkeley_db_stat (SEXP _dbp, SEXP _txnid, SEXP _flags)
{
  DB *dbp;
  DB_TXN *txnid;
  DBTYPE type;
  u_int32_t flags;

  dbp = R_ExternalPtrAddr(_dbp);
  if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
    error("invalid 'db' handle");
  if(!isNull(_txnid)) {
    txnid = R_ExternalPtrAddr(_txnid);
  } else txnid = NULL;
  flags = (u_int32_t)INTEGER(_flags)[0];

  dbp->get_type(dbp, &type); /* DBTYPE to know structure returned */
  
  SEXP DBstat=NULL, DBstatnames=NULL;
  DB_HASH_STAT *hash=NULL;
  DB_BTREE_STAT  *bt=NULL;
  DB_QUEUE_STAT  *qs=NULL;
  switch(type) {
    case DB_HASH:
      dbp->stat(dbp, txnid, &hash, flags);
      PROTECT(DBstat = allocVector(VECSXP,16));
      PROTECT(DBstatnames = allocVector(STRSXP,16));
      SET_VECTOR_ELT(DBstat,  0, ScalarInteger(hash->hash_magic));
      SET_STRING_ELT(DBstatnames,  0, mkChar("hash_magic"));
      SET_VECTOR_ELT(DBstat,  1, ScalarInteger(hash->hash_version));
      SET_STRING_ELT(DBstatnames,  1, mkChar("hash_version"));
      SET_VECTOR_ELT(DBstat,  2, ScalarInteger(hash->hash_nkeys));
      SET_STRING_ELT(DBstatnames,  2, mkChar("hash_nkeys"));
      SET_VECTOR_ELT(DBstat,  3, ScalarInteger(hash->hash_ndata));
      SET_STRING_ELT(DBstatnames,  3, mkChar("hash_ndata"));
      SET_VECTOR_ELT(DBstat,  4, ScalarInteger(hash->hash_pagecnt));
      SET_STRING_ELT(DBstatnames,  4, mkChar("hash_pagecnt"));
      SET_VECTOR_ELT(DBstat,  5, ScalarInteger(hash->hash_pagesize));
      SET_STRING_ELT(DBstatnames,  5, mkChar("hash_pagesize"));
      SET_VECTOR_ELT(DBstat,  6, ScalarInteger(hash->hash_ffactor));
      SET_STRING_ELT(DBstatnames,  6, mkChar("hash_ffactor"));
      SET_VECTOR_ELT(DBstat,  7, ScalarInteger(hash->hash_buckets));
      SET_STRING_ELT(DBstatnames,  7, mkChar("hash_buckets"));
      SET_VECTOR_ELT(DBstat,  8, ScalarInteger(hash->hash_free));
      SET_STRING_ELT(DBstatnames,  8, mkChar("hash_free"));
      SET_VECTOR_ELT(DBstat,  9, ScalarInteger(hash->hash_bfree));
      SET_STRING_ELT(DBstatnames,  9, mkChar("hash_bfree"));
      SET_VECTOR_ELT(DBstat, 10, ScalarInteger(hash->hash_bigpages));
      SET_STRING_ELT(DBstatnames,  10, mkChar("hash_bigpages"));
      SET_VECTOR_ELT(DBstat, 11, ScalarInteger(hash->hash_big_bfree));
      SET_STRING_ELT(DBstatnames,  11, mkChar("hash_big_bfree"));
      SET_VECTOR_ELT(DBstat, 12, ScalarInteger(hash->hash_overflows));
      SET_STRING_ELT(DBstatnames,  12, mkChar("hash_overflows"));
      SET_VECTOR_ELT(DBstat, 13, ScalarInteger(hash->hash_ovfl_free));
      SET_STRING_ELT(DBstatnames,  13, mkChar("hash_ovfl_free"));
      SET_VECTOR_ELT(DBstat, 14, ScalarInteger(hash->hash_dup));
      SET_STRING_ELT(DBstatnames,  14, mkChar("hash_dup"));
      SET_VECTOR_ELT(DBstat, 15, ScalarInteger(hash->hash_dup_free));
      SET_STRING_ELT(DBstatnames,  15, mkChar("hash_dup_free"));
    case DB_BTREE:
    case DB_RECNO:
      dbp->stat(dbp, txnid, &bt, flags);
      PROTECT(DBstat = allocVector(VECSXP,19));
      PROTECT(DBstatnames = allocVector(STRSXP,19));
      SET_VECTOR_ELT(DBstat,  0, ScalarInteger(bt->bt_magic));
      SET_STRING_ELT(DBstatnames,  0, mkChar("bt_magic"));
      SET_VECTOR_ELT(DBstat,  1, ScalarInteger(bt->bt_version));
      SET_STRING_ELT(DBstatnames,  1, mkChar("bt_version"));
      SET_VECTOR_ELT(DBstat,  2, ScalarInteger(bt->bt_nkeys));
      SET_STRING_ELT(DBstatnames,  2, mkChar("bt_nkeys"));
      SET_VECTOR_ELT(DBstat,  3, ScalarInteger(bt->bt_ndata));
      SET_STRING_ELT(DBstatnames,  3, mkChar("bt_ndata"));
      SET_VECTOR_ELT(DBstat,  4, ScalarInteger(bt->bt_pagecnt));
      SET_STRING_ELT(DBstatnames,  4, mkChar("bt_pagecnt"));
      SET_VECTOR_ELT(DBstat,  5, ScalarInteger(bt->bt_minkey));
      SET_STRING_ELT(DBstatnames,  5, mkChar("bt_minkey"));
      SET_VECTOR_ELT(DBstat,  6, ScalarInteger(bt->bt_re_len));
      SET_STRING_ELT(DBstatnames,  6, mkChar("bt_re_len"));
      SET_VECTOR_ELT(DBstat,  7, ScalarInteger(bt->bt_re_pad));
      SET_STRING_ELT(DBstatnames,  7, mkChar("bt_re_pad"));
      SET_VECTOR_ELT(DBstat,  8, ScalarInteger(bt->bt_levels));
      SET_STRING_ELT(DBstatnames,  8, mkChar("bt_levels"));
      SET_VECTOR_ELT(DBstat,  9, ScalarInteger(bt->bt_int_pg));
      SET_STRING_ELT(DBstatnames,  9, mkChar("bt_int_pg"));
      SET_VECTOR_ELT(DBstat, 10, ScalarInteger(bt->bt_leaf_pg));
      SET_STRING_ELT(DBstatnames,  10, mkChar("bt_leaf_pg"));
      SET_VECTOR_ELT(DBstat, 11, ScalarInteger(bt->bt_dup_pg));
      SET_STRING_ELT(DBstatnames,  11, mkChar("bt_dup_pg"));
      SET_VECTOR_ELT(DBstat, 12, ScalarInteger(bt->bt_over_pg));
      SET_STRING_ELT(DBstatnames,  12, mkChar("bt_over_pg"));
      SET_VECTOR_ELT(DBstat, 13, ScalarInteger(bt->bt_empty_pg));
      SET_STRING_ELT(DBstatnames,  13, mkChar("bt_empty_pg"));
      SET_VECTOR_ELT(DBstat, 14, ScalarInteger(bt->bt_free));
      SET_STRING_ELT(DBstatnames,  14, mkChar("bt_free"));
      SET_VECTOR_ELT(DBstat, 15, ScalarInteger(bt->bt_int_pgfree));
      SET_STRING_ELT(DBstatnames,  15, mkChar("bt_int_pgfree"));
      SET_VECTOR_ELT(DBstat, 16, ScalarInteger(bt->bt_leaf_pgfree));
      SET_STRING_ELT(DBstatnames,  16, mkChar("bt_leaf_pgfree"));
      SET_VECTOR_ELT(DBstat, 17, ScalarInteger(bt->bt_dup_pgfree));
      SET_STRING_ELT(DBstatnames,  17, mkChar("bt_dup_pgfree"));
      SET_VECTOR_ELT(DBstat, 18, ScalarInteger(bt->bt_over_pgfree));
      SET_STRING_ELT(DBstatnames,  18, mkChar("bt_over_pgfree"));
      break;
    case DB_QUEUE:
      dbp->stat(dbp, txnid, &qs, flags);
      PROTECT(DBstat = allocVector(VECSXP,12));
      PROTECT(DBstatnames = allocVector(STRSXP,12));
      SET_VECTOR_ELT(DBstat,  0, ScalarInteger(qs->qs_magic));
      SET_STRING_ELT(DBstatnames,  0, mkChar("qs_magic"));
      SET_VECTOR_ELT(DBstat,  1, ScalarInteger(qs->qs_version));
      SET_STRING_ELT(DBstatnames,  1, mkChar("qs_version"));
      SET_VECTOR_ELT(DBstat,  2, ScalarInteger(qs->qs_nkeys));
      SET_STRING_ELT(DBstatnames,  2, mkChar("qs_nkeys"));
      SET_VECTOR_ELT(DBstat,  3, ScalarInteger(qs->qs_ndata));
      SET_STRING_ELT(DBstatnames,  3, mkChar("qs_ndata"));
      SET_VECTOR_ELT(DBstat,  4, ScalarInteger(qs->qs_pagesize));
      SET_STRING_ELT(DBstatnames,  4, mkChar("qs_pagesize"));
      SET_VECTOR_ELT(DBstat,  5, ScalarInteger(qs->qs_extentsize));
      SET_STRING_ELT(DBstatnames,  5, mkChar("qs_extentsize"));
      SET_VECTOR_ELT(DBstat,  6, ScalarInteger(qs->qs_pages));
      SET_STRING_ELT(DBstatnames,  6, mkChar("qs_pages"));
      SET_VECTOR_ELT(DBstat,  7, ScalarInteger(qs->qs_re_len));
      SET_STRING_ELT(DBstatnames,  7, mkChar("qs_re_len"));
      SET_VECTOR_ELT(DBstat,  8, ScalarInteger(qs->qs_re_pad));
      SET_STRING_ELT(DBstatnames,  8, mkChar("qs_re_pad"));
      SET_VECTOR_ELT(DBstat,  9, ScalarInteger(qs->qs_pgfree));
      SET_STRING_ELT(DBstatnames,  9, mkChar("qs_pgfree"));
      SET_VECTOR_ELT(DBstat, 10, ScalarInteger(qs->qs_first_recno));
      SET_STRING_ELT(DBstatnames,  10, mkChar("qs_first_recno"));
      SET_VECTOR_ELT(DBstat, 11, ScalarInteger(qs->qs_cur_recno));
      SET_STRING_ELT(DBstatnames,  11, mkChar("qs_cur_recno"));
      break;
    case DB_UNKNOWN:
      error("DB_UNKNOWN"); /* FIXME not too sure of correct handling here */
      break;
  }
  setAttrib(DBstat, R_NamesSymbol, DBstatnames); 
  UNPROTECT(2);
  return(DBstat);   
}
示例#27
0
void genControlInfo(int* oid,
                    size_t oid_size,
                    QueryData& results,
                    const std::map<std::string, std::string>& config) {
  Row r;
  if (oid_size == 0) {
    return;
  }

  r["oid"] = stringFromMIB(oid, oid_size);
  // Request the description (the canonical name) for the MIB.
  char response[CTL_MAX_VALUE] = {0};
  size_t response_size = CTL_MAX_VALUE;

  int request[CTL_MAXNAME + 2] = {0, CTL_DEBUG_DESCRIPTION};
  memcpy(request + 2, oid, oid_size * sizeof(int));
  if (sysctl(request, oid_size + 2, response, &response_size, 0, 0) != 0) {
    return;
  }

  r["name"] = std::string(response);
  if (oid[0] > 0 && oid[0] < static_cast<int>(kControlNames.size())) {
    r["subsystem"] = kControlNames[oid[0]];
  }

  // Now request structure type.
  request[1] = CTL_DEBUG_TYPE;
  if (sysctl(request, oid_size + 2, response, &response_size, 0, 0) != 0) {
    // Cannot request MIB type (int, string, struct, etc).
    return;
  }

  size_t oid_type = 0;
  if (response_size > 0) {
    oid_type = ((size_t)response[0] & CTLTYPE);
    if (oid_type < kControlTypes.size()) {
      r["type"] = kControlTypes[((int)response[0])];
    }
  }

  // Finally request MIB value.
  if (oid_type > CTLTYPE_NODE && oid_type < CTLTYPE_OPAQUE) {
    size_t value_size = 0;
    sysctl(oid, oid_size, 0, &value_size, 0, 0);

    if (value_size > CTL_MAX_VALUE) {
      // If the value size is larger than the max value, limit.
      value_size = CTL_MAX_VALUE;
    }

    sysctl(oid, oid_size, response, &value_size, 0, 0);
    if (oid_type == CTLTYPE_INT) {
      unsigned int value;
      memcpy(&value, response, sizeof(int));
      r["current_value"] = INTEGER(value);
    } else if (oid_type == CTLTYPE_STRING) {
      r["current_value"] = std::string(response);
    } else if (oid_type == CTLTYPE_QUAD) {
      unsigned long long value;
      memcpy(&value, response, value_size);
    }
  }

  // If this MIB was set using sysctl.conf add the value.
  if (config.count(r.at("name")) > 0) {
    r["config_value"] = config.at(r["name"]);
  }

  results.push_back(r);
}
示例#28
0
文件: db.c 项目: rforge/rberkeley
/* {{{ rberkeley_db_strerror */
SEXP rberkeley_db_strerror (SEXP _error)
{
  return mkString(db_strerror(INTEGER(_error)[0]));
}
示例#29
0
      }

    aterm = terms[aterm].next;
    }
  while ( aterm != NullTerm );

  printf( "\n" );
  }
#endif


/*  FIT_MSPECFLAT
 *
 *
 */
F77_SUBROUTINE(fit_mspecflat_int)( CHARACTER(spec), INTEGER(nterm),
                                   INTEGER_ARRAY(aterm),
                                   INTEGER_ARRAY(atsign),
                                   INTEGER(status) TRAIL(spec) )
  {
  GENPTR_CHARACTER(spec)
  GENPTR_INTEGER(nterm)
  GENPTR_INTEGER_ARRAY(aterm)
  GENPTR_INTEGER_ARRAY(atsign)
  GENPTR_INTEGER(status)

  int			i;		/* Loop variable */
  LegalToken		lastop;		/* Linking operator between terms */
  char			*mcur,*mspec;		/* Model specification */
  NodeRef		mtree;		/* Parsed model specification */
  int			tlist;		/* Root of expanded expression */
示例#30
0
文件: ijoin.c 项目: 23data/data.table
// TODO: implement 'lookup' for 'gaps' and 'overlaps' arguments
SEXP lookup(SEXP ux, SEXP xlen, SEXP indices, SEXP gaps, SEXP overlaps, SEXP multArg, SEXP typeArg, SEXP verbose) {
    
    SEXP vv, tt, lookup, type_lookup;
    R_len_t i,j,k,*idx,*len1,*len2,xrows=INTEGER(xlen)[0],uxrows=LENGTH(VECTOR_ELT(ux, 0)),uxcols=LENGTH(ux);
    int *from = (int *)INTEGER(VECTOR_ELT(indices, 0));
    int *to   = (int *)INTEGER(VECTOR_ELT(indices, 1));
    clock_t pass1, pass2, pass3, start;
    enum {ALL, FIRST, LAST} mult = ALL;
    enum {ANY, WITHIN, START, END, EQUAL} type = ANY;
    
    if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "all"))  mult = ALL;
    else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "first")) mult = FIRST;
    else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "last")) mult = LAST;
    else error("Internal error: invalid value for 'mult'; this should have been caught before. Please report to datatable-help");

    if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "any"))  type = ANY;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "within")) type = WITHIN;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "start")) type = START;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "end")) type = END;
    else if (!strcmp(CHAR(STRING_ELT(typeArg, 0)), "equal")) type = EQUAL;
    else error("Internal error: invalid value for 'type'; this should have been caught before. Please report to datatable-help");
    
    // For reference: uxcols-1 = type_count, uxcols-2 = count, uxcols-3 = type_lookup, uxcols-4 = lookup
    // first pass: calculate lengths first
    start = clock();
    len1 = (int *)INTEGER(VECTOR_ELT(ux, uxcols-2));
    len2 = (int *)INTEGER(VECTOR_ELT(ux, uxcols-1));
    switch (mult) {
        case FIRST: 
        for (i=0; i<xrows; i++) {
            for (j=from[i]; j<=to[i]; j++) {
                len1[j-1]++;
            }
        }
        if (type != WITHIN) {
            for (i=0; i<uxrows; i++)                      // TODO: this allocation can be avoided if we take care of FIRST/LAST accordingly in 'overlaps'
                if (len1[i]) len2[i] = 1;
        }
        break;
        
        case LAST :
        switch (type) {
            case ANY:
            for (i=0; i<xrows; i++) {
                for (j=from[i]; j<=to[i]; j++) {
                    len1[j-1]++;
                    if (from[i]==j && !len2[j-1]) len2[j-1]++;
                }
            }
            break;
            case START: case END: case EQUAL: case WITHIN:
            for (i=0; i<xrows; i++) {
                for (j=from[i]; j<=to[i]; j++) {
                    len1[j-1]++;
                }
            }
            if (type != WITHIN) {
                for (i=0; i<uxrows; i++)              // TODO: this allocation can be avoided if we take care of FIRST/LAST accordingly in 'overlaps'
                    if (len1[i]) len2[i] = 1;                    
            }
            break;
        }
        break;
        
        case ALL : 
            switch (type) {
                case START: case END:
                for (i=0; i<xrows; i++) {
                    for (j=from[i]; j<=to[i]; j++) {
                        len1[j-1]++; len2[j-1]++;       // alternatively, we could simply do with len2=len1 ?
                    }
                }
                break;
                case EQUAL:
                for (i=0; i<xrows; i++) {
                    len1[from[i]-1]++; len1[to[i]-1]++;
                    len2[from[i]-1]++; len2[to[i]-1]++;
                }
                break;
                case ANY :
                for (i=0; i<xrows; i++) {
                    k = from[i];
                    for (j=from[i]; j<=to[i]; j++) {
                        len1[j-1]++;
                        if (k==j) len2[j-1]++;
                    }
                }
                break;
                case WITHIN :
                for (i=0; i<xrows; i++) {
                    for (j=from[i]; j<=to[i]; j++) {
                        len1[j-1]++;
                    }
                }
                break;
            }
        break;
    }
    pass1 = clock() - start;
    if (LOGICAL(verbose)[0])
        Rprintf("First pass on calculating lengths in lookup ... done in %8.3f seconds\n", 1.0*(pass1)/CLOCKS_PER_SEC);
    // second pass: allocate vectors
    start = clock();
    lookup = VECTOR_ELT(ux, uxcols-4);
    type_lookup = VECTOR_ELT(ux, uxcols-3);
    for (i=0; i<uxrows; i++) {
        vv = allocVector(INTSXP, len1[i]);
        SET_VECTOR_ELT(lookup, i, vv);
        if (type != WITHIN) {
            vv = allocVector(INTSXP, len2[i]);
            SET_VECTOR_ELT(type_lookup, i, vv);
        }
    }
    pass2 = clock() - start;
    if (LOGICAL(verbose)[0])
        Rprintf("Second pass on allocation in lookup ... done in %8.3f seconds\n", 1.0*(pass2)/CLOCKS_PER_SEC);
    // generate lookup
    start = clock();
    idx = Calloc(uxrows, R_len_t); // resets bits, =0
    switch (type) {
        case ANY: case START: case END: case WITHIN:
        for (i=0; i<xrows; i++) {
            for (j=from[i]; j<=to[i]; j++) {
                vv = VECTOR_ELT(lookup, j-1);  // cache misses - memory efficiency? but 'lookups' are tiny - takes 0.036s on A.thaliana GFF for entire process)
                INTEGER(vv)[idx[j-1]++] = i+1;
            }
        }
        break;
        case EQUAL:
        for (i=0; i<xrows; i++) {
            INTEGER(VECTOR_ELT(lookup, from[i]-1))[idx[from[i]-1]++] = i+1;
            INTEGER(VECTOR_ELT(lookup, to[i]-1))[idx[to[i]-1]++] = i+1;
        }
        break;
    }
    Free(idx);
    // generate type_lookup
    if (type != WITHIN) {
        switch (mult) {
            case FIRST :
            for (i=0; i<uxrows; i++) {
                if (!len1[i]) continue;
                vv = VECTOR_ELT(lookup, i);
                tt = VECTOR_ELT(type_lookup, i);
                INTEGER(tt)[0] = INTEGER(vv)[0];
            }
            break;

            case LAST :
            for (i=0; i<uxrows; i++) {
                if (!len1[i]) continue;
                vv = VECTOR_ELT(lookup, i);
                tt = VECTOR_ELT(type_lookup, i);
                INTEGER(tt)[0] = INTEGER(vv)[len1[i]-1];
            }
        
            case ALL :
            switch (type) {
                case START: case END: case EQUAL:
                for (i=0; i<uxrows; i++)
                    SET_VECTOR_ELT(type_lookup, i, VECTOR_ELT(lookup, i));
                break;
            
                case ANY :
                for (i=0; i<uxrows; i++) {
                    vv = VECTOR_ELT(lookup, i);
                    tt = VECTOR_ELT(type_lookup, i);
                    k=0;
                    for (j=len1[i]-len2[i]; j<len1[i]; j++)
                        INTEGER(tt)[k++] = INTEGER(vv)[j];
                }
                break;
            
                case WITHIN :
                // for (i=0; i<uxrows; i++) {
                //     vv = VECTOR_ELT(lookup, i);
                //     tt = VECTOR_ELT(type_lookup, i);
                //     for (j=0; j<len2[i]; j++)
                //         INTEGER(tt)[j] = INTEGER(vv)[j];
                // }
                break;
            }
        break;
        }
    }
    pass3 = clock() - start;
    if (LOGICAL(verbose)[0])
        Rprintf("Final step in generating lookup ... done in %8.3f seconds\n", 1.0*(pass3)/CLOCKS_PER_SEC);    
    return(R_NilValue);
}