예제 #1
1
파일: connect.cpp 프로젝트: cran/excel.link
/* 
 The real invoke mechanism that handles all the details.
*/
SEXP
R_COM_Invoke(SEXP obj, SEXP methodName, SEXP args, WORD callType, WORD doReturn,
             SEXP ids)
{
 IDispatch* disp;
 SEXP ans = R_NilValue;
 int numNamedArgs = 0, *namedArgPositions = NULL, i;
 HRESULT hr;

 // callGC();
 disp = (IDispatch *) getRDCOMReference(obj);

#ifdef ANNOUNCE_COM_CALLS
 fprintf(stderr, "<COM> %s %d %p\n", CHAR(STRING_ELT(methodName, 0)), (int) callType, 
                                     disp);fflush(stderr);
#endif

 DISPID *methodIds;
 const char *pmname = CHAR(STRING_ELT(methodName, 0));
 BSTR *comNames = NULL;

 SEXP names = GET_NAMES(args);
 int numNames = Rf_length(names) + 1;

 SetErrorInfo(0L, NULL);

 methodIds = (DISPID *) S_alloc(numNames, sizeof(DISPID));
 namedArgPositions = (int*) S_alloc(numNames, sizeof(int)); // we may not use all of these, but we allocate them

 if(Rf_length(ids) == 0) {
     comNames = (BSTR*) S_alloc(numNames, sizeof(BSTR));

     comNames[0] = AsBstr(pmname);
     for(i = 0; i < Rf_length(names); i++) {
       const char *str = CHAR(STRING_ELT(names, i));
       if(str && str[0]) {
         comNames[numNamedArgs+1] = AsBstr(str);
         namedArgPositions[numNamedArgs] = i;
         numNamedArgs++;
       }
     }
     numNames = numNamedArgs + 1;

     hr = disp->GetIDsOfNames(IID_NULL, comNames, numNames, LOCALE_USER_DEFAULT, methodIds);

     if(FAILED(hr) || hr == DISP_E_UNKNOWNNAME /* || DISPID mid == DISPID_UNKNOWN */) {
       PROBLEM "Cannot locate %d name(s) %s in COM object (status = %d)", numNamedArgs, pmname, (int) hr
	 ERROR;
     }
 } else {
   for(i = 0; i < Rf_length(ids); i++) {
     methodIds[i] = (MEMBERID) NUMERIC_DATA(ids)[i];
     //XXX What about namedArgPositions here.
   }
 }


 DISPPARAMS params = {NULL, NULL, 0, 0};
 
 if(args != NULL && Rf_length(args) > 0) {

   hr = R_getCOMArgs(args, &params, methodIds, numNamedArgs, namedArgPositions);

   if(FAILED(hr)) {
     clearVariants(&params);
     freeSysStrings(comNames, numNames);
     PROBLEM "Failed in converting arguments to DCOM call"
     ERROR;
   }
   if(callType & DISPATCH_PROPERTYPUT) {
     params.rgdispidNamedArgs = (DISPID*) S_alloc(1, sizeof(DISPID));
     params.rgdispidNamedArgs[0] = DISPID_PROPERTYPUT;
     params.cNamedArgs = 1;
   }
 }

 VARIANT varResult, *res = NULL;

 if(doReturn && callType != DISPATCH_PROPERTYPUT)
   VariantInit(res = &varResult);

 EXCEPINFO exceptionInfo;
 memset(&exceptionInfo, 0, sizeof(exceptionInfo));
 unsigned int nargErr = 100;

#ifdef RDCOM_VERBOSE
 if(params.cNamedArgs) {
   errorLog("# of named arguments to %d: %d\n", (int) methodIds[0], 
                                                (int) params.cNamedArgs);
   for(int p = params.cNamedArgs; p > 0; p--)
     errorLog("%d) id %d, type %d\n", p, 
	                             (int) params.rgdispidNamedArgs[p-1],
                                     (int) V_VT(&(params.rgvarg[p-1])));
 }
#endif

 hr = disp->Invoke(methodIds[0], IID_NULL, LOCALE_USER_DEFAULT, callType, &params, res, &exceptionInfo, &nargErr);
 if(FAILED(hr)) {
   if(hr == DISP_E_MEMBERNOTFOUND) {
     errorLog("Error because member not found %d\n", nargErr);
   }

#ifdef RDCOM_VERBOSE
   errorLog("Error (%d): <in argument %d>, call type = %d, call = \n",  
	   (int) hr, (int)nargErr, (int) callType, pmname);
#endif

    clearVariants(&params);
    freeSysStrings(comNames, numNames);

    if(checkErrorInfo(disp, hr, NULL) != S_OK) {
 fprintf(stderr, "checkErrorInfo %d\n", (int) hr);fflush(stderr);
      COMError(hr);
    }
 }

 if(res) {
   ans = R_convertDCOMObjectToR(&varResult);
   VariantClear(&varResult);
 }
 clearVariants(&params);
 freeSysStrings(comNames, numNames);

#ifdef ANNOUNCE_COM_CALLS
 fprintf(stderr, "</COM>\n", (int) callType);fflush(stderr);
#endif

 return(ans);
}
예제 #2
0
HRESULT
R_getCOMArgs(SEXP args, DISPPARAMS *parms, DISPID *ids, int numNamedArgs, int *namedArgPositions)
{
 HRESULT hr;
 int numArgs = Rf_length(args), i, ctr;
 if(numArgs == 0)
   return(S_OK);

#ifdef RDCOM_VERBOSE
 errorLog("Converting arguments (# %d, # %d named)\n", numArgs, numNamedArgs);
#endif


 parms->rgvarg = (VARIANT *) S_alloc(numArgs, sizeof(VARIANT));
 parms->cArgs = numArgs;

 /* If there are named arguments, then put these at the beginning of the
    rgvarg*/
 if(numNamedArgs > 0) {
   int namedArgCtr = 0;
   VARIANT *var;
   SEXP el;
   SEXP names = GET_NAMES(args);

   parms->rgdispidNamedArgs = (DISPID *) S_alloc(numNamedArgs, sizeof(DISPID));
   parms->cNamedArgs = numNamedArgs;

   for(i = 0, ctr = numArgs-1; i < numArgs ; i++) {
     if(strcmp(CHAR(STRING_ELT(names, i)), "") != 0) {
       var = &(parms->rgvarg[namedArgCtr]);
       parms->rgdispidNamedArgs[namedArgCtr] = ids[namedArgCtr + 1];
#ifdef RDCOM_VERBOSE
       errorLog("Putting named argument %d into %d\n", i+1, namedArgCtr);
       Rf_PrintValue(VECTOR_ELT(args, i));
#endif
       namedArgCtr++;
     } else {
       var = &(parms->rgvarg[ctr]);
       ctr--;       
     }
     el = VECTOR_ELT(args, i);
     VariantInit(var);
     hr = R_convertRObjectToDCOM(el, var);
   }
 } else {

   parms->cNamedArgs = 0;
   parms->rgdispidNamedArgs = NULL;

   for(i = 0, ctr = numArgs-1; i < numArgs; i++, ctr--) {
     SEXP el = VECTOR_ELT(args, i);
     VariantInit(&parms->rgvarg[ctr]);
     hr = R_convertRObjectToDCOM(el, &(parms->rgvarg[ctr]));
   }
 }

 return(S_OK);
}
예제 #3
0
void SimOneNorm_IG(double *shape, double *rate, int *pd, int *pnreps,
                   int *pN, double *es, double *YY)
{
  int i, j, l, d, N, nreps, mxnreps;
  int *lbuff;

  double sig, sigma2, sigma;

  double *xbuff, *Y;

  N = *pN;
  d = *pd;

  mxnreps=0;
  for(l=0;l<N;l++) if(mxnreps < *(pnreps+l)) mxnreps = *(pnreps+l);

  lbuff       = (int   *)S_alloc(        1, sizeof(int));
  xbuff       = (double *)S_alloc(        d, sizeof(double));
  Y           = (double *)S_alloc(mxnreps*d, sizeof(double));

  GetRNGstate();

  /* NOTE:                                                                             */
  /* this block computes the average std dev over genes from the model                 */
  /* it is used for the purposes of assigning mean value to Y's under the alternative  */
  /*                                                                                   */

  sig = pow(*rate/(*shape-1.0), 0.5);

  for(l=0;l<N;l++){  

    /*                                                                                  */
    /* First, simulate sigma2 ~ InvGamma(shape, rate).  This is done                    */
    /* using the result:  if sigma2^(-1) ~ Gamma(shape, rate) then                      */
    /* sigma2 ~ InvGamma(shape, rate).                                                  */

    sigma2 = 1.0/rgamma(*shape, 1.0/(*rate));  

    /*                                                                                   */
    /* sigma2 ~ InvGamma(shape, rate)                                                    */
    /*                                                                                   */
    /* Next, use sigma2 to simulate Y ~ i.i.d. N(0_d, sigma2)                            */

    nreps = *(pnreps+l);
    *lbuff = nreps*d;
    rnormn(lbuff, Y); 

    sigma = pow(sigma2, 0.5);

    for(i=0;i<nreps;i++){
	for(j=0;j<d;j++) *(Y + d*i + j) = *(Y + d*i + j)*(sigma) + *(es + l)*(sig);
    }
    for(i=0;i<(nreps*d);i++) *(YY + mxnreps*d*l + i) = *(Y+i);
  }
  PutRNGstate();

}
예제 #4
0
파일: splridge.c 프로젝트: cran/Rwave
void splridge(int rate, double *y, int n, double *yy)
     
{
  int i,k, x, khi, klo;
  double p,qn,sig,un,*u,yp1,ypn,a,b,h;
  double *y2;
  
  u=(double *)S_alloc(n-1,sizeof(double));
  y2=(double *)S_alloc(n,sizeof(double));
  yp1 = ypn =0;
  
  if (yp1 > 0.99e30)
    y2[0]=u[0]=0.0;
  else {
    y2[0] = -0.5;
    u[0]=(3.0/rate)*((y[1]-y[0])/rate-yp1);
  }
  
  for (i=1;i<=n-2;i++) {
    sig=2.0;
    p=sig*y2[i-1]+2.0;
    y2[i]=(sig-1.0)/p;
    u[i]=(y[i+1]-y[i])/rate - (y[i]-y[i-1])/rate;
    u[i]=(6.0*u[i]/rate/2.0-sig*u[i-1])/p;
  }
  if (ypn > 0.99e30)
    qn=un=0.0;
  else {
    qn=0.5;
    un=(3.0/rate)*(ypn-(y[n-1]-y[n-2])/rate);
  }
  y2[n-1]=(un-qn*u[n-2])/(qn*y2[n-2]+1.0);
  for (k=n-2;k>=0;k--)
    y2[k]=y2[k]*y2[k+1]+u[k];
  
  
  for(x=0;x<n*rate;x++){
    klo=1;
    khi=n;
    
    while (khi-klo > 1) {
      k=(khi+klo) >> 1;
      if (k*rate > x) khi=k;
      else klo=k;
    }
    h=(khi-klo)*rate;
    if (h == 0.0) Rf_error("Impossible interpolation");
    a=(rate*khi-x)/h;
    b=(x-klo*rate)/h;
    *yy=a*y[klo]+b*y[khi]+((a*a*a-a)*y2[klo]+(b*b*b-b)*y2[khi])*(h*h)/6.0;
    yy++;
  }
  
  
}
예제 #5
0
파일: utils.c 프로젝트: Hydrophile/RMySQL
SEXP rmysql_escape_strings(SEXP conHandle, SEXP strings) {
  MYSQL* con = RS_DBI_getConnection(conHandle)->drvConnection;

  int n = length(strings);
  SEXP output = PROTECT(allocVector(STRSXP, n));

  long size = 100;
  char* escaped = S_alloc(size, sizeof(escaped));

  for(int i = 0; i < n; i++){
    const char* string = CHAR(STRING_ELT(strings, i));

    size_t len = strlen(string);
    if (size <= 2 * len + 1) {
      escaped = S_realloc(escaped, (2 * len + 1), size, sizeof(escaped));
      size = 2 * len + 1;
    }

    if (escaped == NULL) {
      UNPROTECT(1);
      error("Could not allocate memory to escape string");
    }

    mysql_real_escape_string(con, escaped, string, len);
    SET_STRING_ELT(output, i, mkChar(escaped));
  }

  UNPROTECT(1);
  return output;
}
예제 #6
0
SEXP readToSlashPorStream(SEXP porStream, SEXP s_n){
  porStreamBuf *b = get_porStreamBuf(porStream);
  int n = asInteger(s_n);
  char *ans = S_alloc(n,1);
  readToSlashPorStream1(b,ans,n);
  return mkString(ans);
}
예제 #7
0
파일: gkernel.c 프로젝트: cran/Rwave
void fastgkernel(double *ker, int *px_min,int *px_max,
	    int *px_inc, int *plng, double *nodes,double *phi_nodes,
	    int *pnb_nodes,double *pscale,double *pb_start,double *pb_end)
{
  double *p2, b_start=*pb_start, b_end=*pb_end, scale=*pscale;
  double phimax, b_lo,b_hi;
  int x,y,b;
  int x_min=*px_min,x_max=*px_max,x_inc=*px_inc,lng=*plng,nb_nodes=*pnb_nodes;
  int i=0,up_bound,gamma_min,lng2;
  double *p_tmp;


  p2 = (double *)S_alloc(nb_nodes,sizeof(double));
  p_tmp=ker; /* mark the first element of ker */

  phimax = scale;
  up_bound = (int)(phimax * sqrt(-2.0 * log(EPS))+1);
  lng2=lng*lng;

  /* Compute second derivative of the ridge for spline interpolation
     ---------------------------------------------------------------*/
  spline(nodes-1,phi_nodes-1,nb_nodes,(double)0,(double)0,p2-1);


  /* Integrate
     --------*/
  for(x=x_min;x<=x_max;x+=x_inc){
/*    fprintf(stderr,"x = %d;  ", x);
    fflush(stderr); */

    /* Evaluate the range of computation of the kernel */
    gamma_min = MAX(x_min,(x-2*up_bound) -(x-x_min-2*up_bound)%x_inc);
/*    fprintf(stderr,"gamma_min = %d; \n ", gamma_min);
    fflush(stderr); */
    ker += (gamma_min-x_min)/x_inc; i = (gamma_min-x_min)/x_inc;

    for(y = gamma_min; y <= x; y+=x_inc){
      
      /* Estimation of integration bounds */
      b_lo = MAX(MAX(x-2*up_bound,y-2*up_bound),b_start); 
      b_hi = MIN(MIN(x+2*up_bound,y+2*up_bound),b_end);

      /* Evaluation of the kernel */
      for(b = (int)b_lo; b<= (int)b_hi;b++){
	*ker += gintegrand(b,x,y,p2-1,nodes,phi_nodes,nb_nodes,scale);
	/* to be checked */
      }
      ker++; i++;
    }
    ker -= (i - lng) ;
  }
  ker = p_tmp;


  /* Finish to fill in the kernel by Hermite symmetry
     -----------------------------------------------*/
  ghermite_sym(ker,lng);

}
예제 #8
0
static BYTE *
convertToRegistry(USER_OBJECT_ val, DWORD *nsize, DWORD targetType, const char *name)
{
  int nprotect = 0;
  
  if(targetType == REG_NONE) {
    PROTECT(val = AS_CHARACTER(val));
    nprotect++;
  }

  BYTE *ans = NULL;
  switch(targetType) {
    case REG_NONE:
    case REG_SZ:
    case REG_EXPAND_SZ:
      {
       char *str; 
       str = CHAR_DEREF(STRING_ELT(val, 0));
       *nsize = strlen(str)+1;
       ans = S_alloc(*nsize, sizeof(DWORD));
       strcpy((char *) ans, str);
      }
      break;
    case REG_DWORD:
      if(TYPEOF(val) == INTSXP) {
        *nsize = sizeof(int);
        ans = S_alloc(1, sizeof(int));
        *ans = INTEGER(val)[0];
      } else if(TYPEOF(val) == REALSXP) {
        *nsize = 1;
        ans = S_alloc(*nsize, sizeof(DWORD));
        *ans = REAL(val)[0];
      }
      break;
    default:
      PROBLEM "Unhandled case (%d) in converting R value (%d) to registry type (convertToRegistry) for key %s",
	(int) targetType, TYPEOF(val), name
      WARN;
  }
  if(nprotect)
    UNPROTECT(nprotect);

  return(ans);
}
예제 #9
0
파일: pfdautils.c 프로젝트: cran/pfda
double* Idiag(int i){
	//pfda_debug_msg("Idiag is depreciated please use resetI with a previously allocated vector.\n");
	double* rtn;
	rtn = (double*)S_alloc(i*i,sizeof(double));
	int j;
	for(j=0;j<i;j++){
		rtn[j*i+j]=1.0;
	}
	return(rtn);
}
예제 #10
0
int
RS_XML(libXMLEventParse)(const char *fileName, RS_XMLParserData *parserData, RS_XML_ContentSourceType asText,
                          int saxVersion)
{
 xmlSAXHandlerPtr xmlParserHandler;
 xmlParserCtxtPtr ctx; 
 int status;

  switch(asText) {
    case RS_XML_TEXT:
      ctx = xmlCreateDocParserCtxt(CHAR_TO_XMLCHAR(fileName));
      break;

    case RS_XML_FILENAME:
      ctx = xmlCreateFileParserCtxt(fileName);
      break;

    case RS_XML_CONNECTION:
      ctx = RS_XML_xmlCreateConnectionParserCtxt((USER_OBJECT_) fileName);

      break;
    default:
      ctx = NULL;
  }


  if(ctx == NULL) {
    PROBLEM "Can't parse %s", fileName
    ERROR;
  }


  xmlParserHandler = (xmlSAXHandlerPtr) S_alloc(sizeof(xmlSAXHandler), 1);
  /* Make certain this is initialized so that we don't have any references  to unwanted routines!  */
  memset(xmlParserHandler, '\0', sizeof(xmlSAXHandler));

  RS_XML(initXMLParserHandler)(xmlParserHandler, saxVersion);

  parserData->ctx = ctx;
  ctx->userData = parserData;
  ctx->sax = xmlParserHandler;

  status = xmlParseDocument(ctx);

  ctx->sax = NULL;
  xmlFreeParserCtxt(ctx);

  return(status);

/*  Free(xmlParserHandler); */
}
예제 #11
0
파일: triangleFixing.c 프로젝트: cran/dtw
/* Only one triangle of the input matrix D is used (but a square
 * matrix is expected) */
void triangle_fixing_l2(
               /* IN+OUT */
	       double *D,		/* input matrix D, output M */
	       int *maxiter_p,		/* maximum iterations */
	       /* IN */
	       const int *n_p,		/* mtrx dimensions, int */
	       const double *kappa_p,	/* tolerance */
	       /* OUT */
	       double *delta_p		/* final sum of changes */
    ) {

    /* For convenience */
    n=*n_p;

    /* Initialize primal and dual */
    double *z = (double*) S_alloc(n*(n-1)*(n-2)/2,sizeof(double));

    *delta_p = 1.0 + *kappa_p;	/* first iteration */

    /* Convergence test */
    while( (*maxiter_p)-- && *delta_p > *kappa_p ) {

	size_t t=0;
	*delta_p=0.0;
	
	/* Foreach triangle inequality */
	for(size_t i=0; i<n; i++) {
	    for(size_t j=i+1; j<n; j++) {
		for(size_t k=j+1; k<n; k++) {
		    *delta_p += fixOneTriangle(D, i,j,k,z+t);
		    t++;
		    *delta_p += fixOneTriangle(D, j,k,i,z+t);
		    t++;
		    *delta_p += fixOneTriangle(D, k,i,j,z+t);
		    t++;
		}
	    }
	}
	/* delta = sum of changes in the e_ij values (?) */
    }

    for(size_t i=0; i<n; i++) {
	 for(size_t j=i+1; j<n; j++)  {
	      D[i*n+j]   =D[ED(i,j)]; /* symmetrize */
	 }
    }
    
    return;
}
예제 #12
0
파일: polint.c 프로젝트: cran/Rwave
void polint(double xa[], double ya[], int n, double x, double *y, double *dy)
{
	int i,m,ns=1;
	double den,dif,dift,ho,hp,w;
	double *c,*d;

	c=(double *)S_alloc(n,sizeof(double))-1;
	d=(double *)S_alloc(n,sizeof(double))-1; 

	dif=fabs(x-xa[1]);
	for (i=1;i<=n;i++) {
		if ( (dift=fabs(x-xa[i])) < dif) {
			ns=i;
			dif=dift;
		}
		c[i]=ya[i];
		d[i]=ya[i];
	}
	*y=ya[ns--];
	for (m=1;m<n;m++) {
		for (i=1;i<=n-m;i++) {
			ho=xa[i]-x;
			hp=xa[i+m]-x;
			w=c[i+1]-d[i];
			if ( (den=ho-hp) == 0.0) {
			  Rprintf("Error in routine polint\n");
			  return;
			  /* exit(1); */
			}
			den=w/den;
			d[i]=hp*den;
			c[i]=ho*den;
		}
		*y += (*dy=(2*ns < (n-m) ? c[ns+1] : d[ns--]));
	}
}
예제 #13
0
/*----------------------------------------------------------------------*/
void regForest(double *x, double *ypred, int *mdim, int *n,
               int *ntree, int *lDaughter, int *rDaughter,
               int *nodestatus, int *nrnodes, double *xsplit,
               double *avnodes, int *mbest, int *treeSize, int *cat,
               int *maxcat, int *keepPred, double *allpred, int *doProx,
               double *proxMat, int *nodes, int *nodex) {
    int i, j, idx1, idx2, *junk;
    double *ytree;

    junk = NULL;
    ytree = (double *) S_alloc(*n, sizeof(double));
    if (*nodes) {
	zeroInt(nodex, *n * *ntree);
    } else {
	zeroInt(nodex, *n);
    }
    if (*doProx) zeroDouble(proxMat, *n * *n);
    if (*keepPred) zeroDouble(allpred, *n * *ntree);
    idx1 = 0;
    idx2 = 0;
    for (i = 0; i < *ntree; ++i) {
	zeroDouble(ytree, *n);
	predictRegTree(x, *n, *mdim, lDaughter + idx1, rDaughter + idx1,
                       nodestatus + idx1, ytree, xsplit + idx1,
                       avnodes + idx1, mbest + idx1, treeSize[i], cat, *maxcat,
                       nodex + idx2);

	for (j = 0; j < *n; ++j) ypred[j] += ytree[j];
	if (*keepPred) {
	    for (j = 0; j < *n; ++j) allpred[j + i * *n] = ytree[j];
	}
	/* if desired, do proximities for this round */
	if (*doProx) computeProximity(proxMat, 0, nodex + idx2, junk,
				      junk, *n);
	idx1 += *nrnodes; /* increment the offset */
	if (*nodes) idx2 += *n;
    }
    for (i = 0; i < *n; ++i) ypred[i] /= *ntree;
    if (*doProx) {
	for (i = 0; i < *n; ++i) {
	    for (j = i + 1; j < *n; ++j) {
                proxMat[i + j * *n] /= *ntree;
		proxMat[j + i * *n] = proxMat[i + j * *n];
	    }
	    proxMat[i + i * *n] = 1.0;
	}
    }
}
예제 #14
0
파일: rf.c 프로젝트: jbleich89/rf_loss
/*
  Modified by A. Liaw 1/10/2003 (Deal with cutoff)
  Re-written in C by A. Liaw 3/08/2004
*/
void oob(int nsample, int nclass, int *jin, int *cl, int *jtr,int *jerr,
	 int *counttr, int *out, double *errtr, int *jest,
	 double *cutoff) {
    int j, n, noob, *noobcl, ntie;
    double qq, smax, smaxtr;

    noobcl  = (int *) S_alloc(nclass, sizeof(int));
    zeroInt(jerr, nsample);
    zeroDouble(errtr, nclass+1);

    noob = 0;
    for (n = 0; n < nsample; ++n) {
	if (out[n]) {
	    noob++;
	    noobcl[cl[n]-1]++;
	    smax = 0.0;
	    smaxtr = 0.0;
	    ntie = 1;
	    for (j = 0; j < nclass; ++j) {
	    	qq = (((double) counttr[j + n*nclass]) / out[n]) / cutoff[j];
	    	if (j+1 != cl[n]) smax = (qq > smax) ? qq : smax;
	    	/* if vote / cutoff is larger than current max, re-set max and
		   	   change predicted class to the current class */
	    	if (qq > smaxtr) {
	    		smaxtr = qq;
	    		jest[n] = j+1;
	    		ntie = 1;
	    	}
	    	/* break tie at random */
	    	if (qq == smaxtr) {
	    		if (unif_rand() < 1.0 / ntie) {
	    			smaxtr = qq;
	    			jest[n] = j+1;
	    		}
	    		ntie++;
	    	}
	    }
	    if (jest[n] != cl[n]) {
		errtr[cl[n]] += 1.0;
		errtr[0] += 1.0;
		jerr[n] = 1;
	    }
	}
    }
    errtr[0] /= noob;
    for (n = 1; n <= nclass; ++n) errtr[n] /= noobcl[n-1];
}
예제 #15
0
char *readPorStream1(porStreamBuf *b, int n) {
#ifdef DEBUG
  Rprintf("\nreadPorStream1");
  Rprintf("\nb = %d",b);
  Rprintf("\nb->buf = %d",b->buf);
  Rprintf("\nbuffer = |%s|",b->buf);
  Rprintf("\nn = %d",n);
#endif
  if(n > HardMaxRead) n = HardMaxRead;
  if(b->pos == 80) fillPorStreamBuf(b);
  char *ans = S_alloc(n+1,1);
  if(b->pos + n <= 80){
    memcpy(ans, b->buf + b->pos, n);
    b->pos += n;
#ifdef DEBUG
    Rprintf("\nans =  %s",ans);
    Rprintf("\nEND readPorStream1");
#endif
    return ans;
  }
  /* else */
  char *tmp = ans;
  int nread;
  if(80 - b->pos > 0){
    nread = 80 - b->pos;
    memcpy(ans,b->buf + b->pos, nread);
    n -= nread;
    tmp += nread;
    b->pos = 0;
    fillPorStreamBuf(b);
  }
  int i, nlines = n/80, remainder = n%80;
  for(i = 0; i < nlines; i++){
    memcpy(tmp,b->buf,80);
    tmp += 80;
    fillPorStreamBuf(b);
  }
  if(remainder > 0)
    memcpy(tmp,b->buf,remainder);
  b->pos = remainder;
#ifdef DEBUG
  Rprintf("\nans =  %s",ans);
  Rprintf("\nEND readPorStream1");
#endif
  return ans;
}
예제 #16
0
/*
 Get the number of dimensions.
 For each of these dimensions, get the lower and upper bound and iterate
 over the elements.
*/
static SEXP
convertArrayToR(const VARIANT *var)
{
  SAFEARRAY *arr;
  SEXP ans;
  UINT dim;

  if(V_ISBYREF(var))
    arr = *V_ARRAYREF(var);
  else
    arr = V_ARRAY(var);

  dim = SafeArrayGetDim(arr);
  long *indices = (long*) S_alloc(dim, sizeof(long)); // new long[dim];
  ans = getArray(arr, dim, dim, indices);

  return(ans);
}
예제 #17
0
BSTR
AsBstr(const char *str)
{
  BSTR ans = NULL;
  if(!str)
    return(NULL);

  int size = strlen(str);
  int wideSize = 2 * size;
  LPOLESTR wstr = (LPWSTR) S_alloc(wideSize, sizeof(OLECHAR)); 
  if(MultiByteToWideChar(CP_ACP, 0, str, size, wstr, wideSize) == 0 && str[0]) {
    PROBLEM "Can't create BSTR for '%s'", str
    ERROR;
  }

  ans = SysAllocStringLen(wstr, size);

  return(ans);
}
예제 #18
0
USER_OBJECT_
R_getRegistryKey(USER_OBJECT_ hkey, USER_OBJECT_ subKey, USER_OBJECT_ isError)
{
  HKEY lkey;
  char *name = NULL;
  BYTE *buf;
  LONG status;
  DWORD bufSize, type;
  USER_OBJECT_ ans = R_NilValue;

  lkey = getOpenRegKey(hkey, subKey);

  if(GET_LENGTH(subKey))
    name = CHAR_DEREF(STRING_ELT(subKey, 1));
  if(!name[0])
    name = NULL;

  if((status = RegQueryValueEx(lkey, name, NULL, NULL, NULL, &bufSize)) != ERROR_SUCCESS) {
    RegCloseKey(lkey);
    if(LOGICAL(isError)[0]) {
      PROBLEM "Can't get key %s", (name ? name : "Default")
      ERROR;
    } else {
      PROTECT(ans = allocVector(STRSXP, 1));
      SET_STRING_ELT(ans, 0, R_NaString);
      UNPROTECT(1);
      return(ans);
    }
  }

  buf = (BYTE *) S_alloc(bufSize, sizeof(BYTE));
  if((status = RegQueryValueEx(lkey, name, NULL, &type, buf, &bufSize)) != ERROR_SUCCESS) {
    RegCloseKey(lkey);
    PROBLEM "Can't get key %s (2nd time)", name
    ERROR;
  }
  ans = convertRegistryValueToS(buf, bufSize, type);
  RegCloseKey(lkey);
  return(ans);
}
예제 #19
0
char *
FromBstr(BSTR str)
{
  char *ptr = NULL;
  DWORD len;

  if(!str)
    return(NULL);

  len = wcslen(str);

  if(len < 1)
    len = 0;

  ptr = (char *) S_alloc(len+1, sizeof(char));
  ptr[len] = '\0';
  if(len > 0) {
    DWORD ok = WideCharToMultiByte(CP_ACP, 0, str, len, ptr, len, NULL, NULL);
    if(ok == 0) 
      ptr = NULL;
  }

  return(ptr);
}
예제 #20
0
파일: cwt_phase.c 프로젝트: cran/Rwave
void Scwt_phase(double *input, double *Oreal, double *Oimage,
  double *f, int *pnboctave, int *pnbvoice, int *pinputsize,
  double *pcenterfrequency)
{
  int nboctave, nbvoice, i, j, inputsize;
  double centerfrequency, a;
  double *Ri2, *Ri1, *Ii1, *Ii2, *Rdi2, *Idi2, *Ii, *Ri;
  double *Odreal, *Odimage;


  centerfrequency = *pcenterfrequency;
  nboctave = *pnboctave;
  nbvoice = *pnbvoice;
  inputsize = *pinputsize;

  /* Memory allocations  -- 
    is the original use of calloc significant?? 
    Using S_alloc to initialize mem, just in case.  note by xian
     ------------------*/
  if(!(Odreal = (double *) S_alloc(inputsize*nbvoice*nboctave, sizeof(double))))
    Rf_error("Memory allocation failed for Ri1 in cwt_phase.c \n");
  if(!(Odimage = (double *) S_alloc(inputsize*nbvoice*nboctave, sizeof(double))))
    Rf_error("Memory allocation failed for Ii1 in cwt_phase.c \n");

  if(!(Ri1 = (double *) S_alloc(inputsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ri1 in cwt_phase.c \n");
  if(!(Ii1 = (double *) S_alloc(inputsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ii1 in cwt_phase.c \n");

  if(!(Ii2 = (double *) S_alloc(inputsize,sizeof(double))))
    Rf_error("Memory allocation failed for Ri2 in cwt_phase.c \n");
  if(!(Ri2 = (double *) S_alloc(inputsize,sizeof(double))))
    Rf_error("Memory allocation failed for Ri2 in cwt_phase.c \n");

  if(!(Idi2 = (double *) S_alloc(inputsize,sizeof(double))))
    Rf_error("Memory allocation failed for Ri2 in cwt_phase.c \n");
  if(!(Rdi2 = (double *) S_alloc(inputsize,sizeof(double))))
    Rf_error("Memory allocation failed for Ri2 in cwt_phase.c \n");

  if(!(Ri = (double *) S_alloc(inputsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ri in cwt_phase.c \n");
  if(!(Ii = (double *) S_alloc(inputsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ii in cwt_phase.c \n");

  for(i = 0; i < inputsize; i++){
    *Ri = (double)(*input);
    Ri++; input++;
  }
  Ri -= inputsize;
  input -= inputsize;
  
  /* Compute fft of the signal
     -------------------------*/
  double_fft(Ri1,Ii1,Ri,Ii,inputsize,-1);   
  
  /* Multiply signal and wavelets in the Fourier space
     -------------------------------------------------*/
  for(i = 1; i <= nboctave; i++) {
    for(j=0; j < nbvoice; j++) {
      a = (double)(pow((double)2,(double)(i+j/((double)nbvoice))));
      morlet_frequencyph(centerfrequency,a,Ri2,Idi2,inputsize); 
      multiply(Ri1,Ii1,Ri2,Ii2,Oreal,Oimage,inputsize);
      multiply(Ri1,Ii1,Rdi2,Idi2,Odreal,Odimage,inputsize);
      double_fft(Oreal,Oimage,Oreal,Oimage,inputsize,1); 
      double_fft(Odreal,Odimage,Odreal,Odimage,inputsize,1); 
      Oreal += inputsize;
      Oimage += inputsize;  
      Odreal += inputsize;
      Odimage += inputsize; 
    }
  }

  Oreal -= inputsize*nbvoice*nboctave;
  Odreal -= inputsize*nbvoice*nboctave;
  Oimage -= inputsize*nbvoice*nboctave;
  Odimage -= inputsize*nbvoice*nboctave;


  /* Normalize the cwt and compute the f function
     --------------------------------------------*/
  normalization(Oreal, Oimage, Odreal, Odimage,
    inputsize*nbvoice*nboctave);

  f_function(Oreal, Oimage, Odreal, Odimage, f,
    centerfrequency,inputsize,nbvoice,nboctave);

  return;
}
예제 #21
0
void regRF(double *x, double *y, int *xdim, int *sampsize,
	   int *nthsize, int *nrnodes, int *nTree, int *mtry, int *imp,
	   int *cat, int *maxcat, int *jprint, int *doProx, int *oobprox,
           int *biasCorr, double *yptr, double *errimp, double *impmat,
           double *impSD, double *prox, int *treeSize, int *nodestatus,
           int *lDaughter, int *rDaughter, double *avnode, int *mbest,
           double *upper, double *mse, int *keepf, int *replace,
           int *testdat, double *xts, int *nts, double *yts, int *labelts,
           double *yTestPred, double *proxts, double *msets, double *coef,
           int *nout, int *inbag) {
    /*************************************************************************
   Input:
   mdim=number of variables in data set
   nsample=number of cases

   nthsize=number of cases in a node below which the tree will not split,
   setting nthsize=5 generally gives good results.

   nTree=number of trees in run.  200-500 gives pretty good results

   mtry=number of variables to pick to split on at each node.  mdim/3
   seems to give genrally good performance, but it can be
   altered up or down

   imp=1 turns on variable importance.  This is computed for the
   mth variable as the percent rise in the test set mean sum-of-
   squared errors when the mth variable is randomly permuted.

  *************************************************************************/

    double errts = 0.0, averrb, meanY, meanYts, varY, varYts, r, xrand,
	errb = 0.0, resid=0.0, ooberr, ooberrperm, delta, *resOOB;

    double *yb, *xtmp, *xb, *ytr, *ytree, *tgini, *coeffs;

    int k, m, mr, n, nOOB, j, jout, idx, ntest, last, ktmp, nPerm,
        nsample, mdim, keepF, keepInbag;
    int *oobpair, varImp, localImp, *varUsed;

    int *in, *nind, *nodex, *nodexts, *probs;

    nsample = xdim[0];
    mdim = xdim[1];
    ntest = *nts;
    varImp = imp[0];
    localImp = imp[1];
    nPerm = imp[2];
    keepF = keepf[0];
    keepInbag = keepf[1];

    if (*jprint == 0) *jprint = *nTree + 1;

    yb         = (double *) S_alloc(*sampsize, sizeof(double));
    xb         = (double *) S_alloc(mdim * *sampsize, sizeof(double));
    ytr        = (double *) S_alloc(nsample, sizeof(double));
    xtmp       = (double *) S_alloc(nsample, sizeof(double));
    resOOB     = (double *) S_alloc(nsample, sizeof(double));
    coeffs     = (double *) S_alloc(*sampsize, sizeof(double));
  
    probs      = (int *) S_alloc(*sampsize, sizeof(int));
    in         = (int *) S_alloc(nsample, sizeof(int));
    nodex      = (int *) S_alloc(nsample, sizeof(int));
    varUsed    = (int *) S_alloc(mdim, sizeof(int));
    nind = *replace ? NULL : (int *) S_alloc(nsample, sizeof(int));

    if (*testdat) {
	ytree      = (double *) S_alloc(ntest, sizeof(double));
	nodexts    = (int *) S_alloc(ntest, sizeof(int));
    }
    oobpair = (*doProx && *oobprox) ?
	(int *) S_alloc(nsample * nsample, sizeof(int)) : NULL;

    /* If variable importance is requested, tgini points to the second
       "column" of errimp, otherwise it's just the same as errimp. */
    tgini = varImp ? errimp + mdim : errimp;

    averrb = 0.0;
    meanY = 0.0;
    varY = 0.0;

    zeroDouble(yptr, nsample);
    zeroInt(nout, nsample);
    for (n = 0; n < nsample; ++n) {
	varY += n * (y[n] - meanY)*(y[n] - meanY) / (n + 1);
	meanY = (n * meanY + y[n]) / (n + 1);
    }
    varY /= nsample;

    varYts = 0.0;
    meanYts = 0.0;
    if (*testdat) {
	for (n = 0; n < ntest; ++n) {
	    varYts += n * (yts[n] - meanYts)*(yts[n] - meanYts) / (n + 1);
	    meanYts = (n * meanYts + yts[n]) / (n + 1);
	}
	varYts /= ntest;
    }

    if (*doProx) {
        zeroDouble(prox, nsample * nsample);
	if (*testdat) zeroDouble(proxts, ntest * (nsample + ntest));
    }

    if (varImp) {
        zeroDouble(errimp, mdim * 2);
	if (localImp) zeroDouble(impmat, nsample * mdim);
    } else {
        zeroDouble(errimp, mdim);
    }
    if (*labelts) zeroDouble(yTestPred, ntest);

    /* print header for running output */
    if (*jprint <= *nTree) {
	Rprintf("     |      Out-of-bag   ");
	if (*testdat) Rprintf("|       Test set    ");
	Rprintf("|\n");
	Rprintf("Tree |      MSE  %%Var(y) ");
	if (*testdat) Rprintf("|      MSE  %%Var(y) ");
	Rprintf("|\n");
    }
    GetRNGstate();
    /*************************************
     * Start the loop over trees.
     *************************************/
    for (j = 0; j < *nTree; ++j) {

    /* multinomial */
    /*unsigned int coeffs[*sampsize];*/
    /* for loop implementation */
    /*double probs[*sampsize];*/
    for (k = 0; k < *sampsize; ++k) {
        probs[k] = 1/(*sampsize);
    }

    ran_multinomial(*sampsize,100,probs,coeffs);

		idx = keepF ? j * *nrnodes : 0;
		zeroInt(in, nsample);
        zeroInt(varUsed, mdim);
        /* Draw a random sample for growing a tree. */
		if (*replace) { /* sampling with replacement */
			for (n = 0; n < *sampsize; ++n) {
				xrand = unif_rand();
				k = xrand * nsample;
				in[k] = 1;
				yb[n] = y[k];
				for(m = 0; m < mdim; ++m) {
					xb[m + n * mdim] = x[m + k * mdim];
				}
			}
		} else { /* sampling w/o replacement */
			for (n = 0; n < nsample; ++n) nind[n] = n;
			last = nsample - 1;
			for (n = 0; n < *sampsize; ++n) {
				ktmp = (int) (unif_rand() * (last+1));
                k = nind[ktmp];
                swapInt(nind[ktmp], nind[last]);
				last--;
				in[k] = 1;
				yb[n] = y[k];
				for(m = 0; m < mdim; ++m) {
					xb[m + n * mdim] = x[m + k * mdim];
				}
			}
		}
		if (keepInbag) {
			for (n = 0; n < nsample; ++n) inbag[n + j * nsample] = in[n];
		}
        /* grow the regression tree */
		regTree(xb, yb, mdim, *sampsize, lDaughter + idx, rDaughter + idx,
                upper + idx, avnode + idx, nodestatus + idx, *nrnodes,
                treeSize + j, *nthsize, *mtry, mbest + idx, cat, tgini,
                varUsed, coeffs);
        /* predict the OOB data with the current tree */
		/* ytr is the prediction on OOB data by the current tree */
		predictRegTree(x, nsample, mdim, lDaughter + idx,
                       rDaughter + idx, nodestatus + idx, ytr, upper + idx,
                       avnode + idx, mbest + idx, treeSize[j], cat, *maxcat,
                       nodex);
		/* yptr is the aggregated prediction by all trees grown so far */
		errb = 0.0;
		ooberr = 0.0;
		jout = 0; /* jout is the number of cases that has been OOB so far */
		nOOB = 0; /* nOOB is the number of OOB samples for this tree */
		for (n = 0; n < nsample; ++n) {
			if (in[n] == 0) {
				nout[n]++;
                nOOB++;
				yptr[n] = ((nout[n]-1) * yptr[n] + ytr[n]) / nout[n];
				resOOB[n] = ytr[n] - y[n];
                ooberr += resOOB[n] * resOOB[n];
			}
            if (nout[n]) {
				jout++;
				errb += (y[n] - yptr[n]) * (y[n] - yptr[n]);
			}
		}
		errb /= jout;
		/* Do simple linear regression of y on yhat for bias correction. */
		if (*biasCorr) simpleLinReg(nsample, yptr, y, coef, &errb, nout);

		/* predict testset data with the current tree */
		if (*testdat) {
			predictRegTree(xts, ntest, mdim, lDaughter + idx,
						   rDaughter + idx, nodestatus + idx, ytree,
                           upper + idx, avnode + idx,
						   mbest + idx, treeSize[j], cat, *maxcat, nodexts);
			/* ytree is the prediction for test data by the current tree */
			/* yTestPred is the average prediction by all trees grown so far */
			errts = 0.0;
			for (n = 0; n < ntest; ++n) {
				yTestPred[n] = (j * yTestPred[n] + ytree[n]) / (j + 1);
			}
            /* compute testset MSE */
			if (*labelts) {
				for (n = 0; n < ntest; ++n) {
					resid = *biasCorr ?
                        yts[n] - (coef[0] + coef[1]*yTestPred[n]) :
                        yts[n] - yTestPred[n];
					errts += resid * resid;
				}
				errts /= ntest;
			}
		}
        /* Print running output. */
		if ((j + 1) % *jprint == 0) {
			Rprintf("%4d |", j + 1);
			Rprintf(" %8.4g %8.2f ", errb, 100 * errb / varY);
			if(*labelts == 1) Rprintf("| %8.4g %8.2f ",
									  errts, 100.0 * errts / varYts);
			Rprintf("|\n");
		}
		mse[j] = errb;
		if (*labelts) msets[j] = errts;

		/*  DO PROXIMITIES */
		if (*doProx) {
			computeProximity(prox, *oobprox, nodex, in, oobpair, nsample);
			/* proximity for test data */
			if (*testdat) {
                /* In the next call, in and oobpair are not used. */
                computeProximity(proxts, 0, nodexts, in, oobpair, ntest);
				for (n = 0; n < ntest; ++n) {
					for (k = 0; k < nsample; ++k) {
						if (nodexts[n] == nodex[k]) {
							proxts[n + ntest * (k+ntest)] += 1.0;
						}
					}
				}
			}
		}

		/* Variable importance */
		if (varImp) {
			for (mr = 0; mr < mdim; ++mr) {
                if (varUsed[mr]) { /* Go ahead if the variable is used */
                    /* make a copy of the m-th variable into xtmp */
                    for (n = 0; n < nsample; ++n)
                        xtmp[n] = x[mr + n * mdim];
                    ooberrperm = 0.0;
                    for (k = 0; k < nPerm; ++k) {
                        permuteOOB(mr, x, in, nsample, mdim);
                        predictRegTree(x, nsample, mdim, lDaughter + idx,
                                       rDaughter + idx, nodestatus + idx, ytr,
                                       upper + idx, avnode + idx, mbest + idx,
                                       treeSize[j], cat, *maxcat, nodex);
                        for (n = 0; n < nsample; ++n) {
                            if (in[n] == 0) {
                                r = ytr[n] - y[n];
                                ooberrperm += r * r;
                                if (localImp) {
                                    impmat[mr + n * mdim] +=
                                        (r*r - resOOB[n]*resOOB[n]) / nPerm;
                                }
                            }
                        }
                    }
                    delta = (ooberrperm / nPerm - ooberr) / nOOB;
                    errimp[mr] += delta;
                    impSD[mr] += delta * delta;
                    /* copy original data back */
                    for (n = 0; n < nsample; ++n)
                        x[mr + n * mdim] = xtmp[n];
                }
            }
        }
    }
    PutRNGstate();
    /* end of tree iterations=======================================*/

    if (*biasCorr) {  /* bias correction for predicted values */
		for (n = 0; n < nsample; ++n) {
			if (nout[n]) yptr[n] = coef[0] + coef[1] * yptr[n];
		}
		if (*testdat) {
			for (n = 0; n < ntest; ++n) {
				yTestPred[n] = coef[0] + coef[1] * yTestPred[n];
			}
		}
    }

    if (*doProx) {
		for (n = 0; n < nsample; ++n) {
			for (k = n + 1; k < nsample; ++k) {
                prox[nsample*k + n] /= *oobprox ?
                    (oobpair[nsample*k + n] > 0 ? oobpair[nsample*k + n] : 1) :
                    *nTree;
                prox[nsample * n + k] = prox[nsample * k + n];
            }
			prox[nsample * n + n] = 1.0;
        }
		if (*testdat) {
			for (n = 0; n < ntest; ++n)
				for (k = 0; k < ntest + nsample; ++k)
					proxts[ntest*k + n] /= *nTree;
		}
    }

    if (varImp) {
		for (m = 0; m < mdim; ++m) {
			errimp[m] = errimp[m] / *nTree;
			impSD[m] = sqrt( ((impSD[m] / *nTree) -
							  (errimp[m] * errimp[m])) / *nTree );
			if (localImp) {
                for (n = 0; n < nsample; ++n) {
                    impmat[m + n * mdim] /= nout[n];
                }
			}
        }
    }
    for (m = 0; m < mdim; ++m) tgini[m] /= *nTree;
}
예제 #22
0
void SimOneMVN_mxIW(double *nu, double *Lbdinvhlf, double *f1f2, int *pd, 
                    int *pnreps, int *pN, double *es, double *YY)
{
  int i, j, k, l, d, d2, N, nreps, mxnreps, Jrand;
  int *lbuff;

  double xd, sm, tstnu, nu_1, nu_2, zz, lambda, f_1, f_2;

  double *df, *pW, *SgmHlf, *Y, *xbuff, *Sigma, *sig, *SigInv;

  N = *pN;
  d = *pd;
  xd = (double) d;
  d2 = d*d;

  mxnreps=0;
  for(l=0;l<N;l++) if(mxnreps < *(pnreps+l)) mxnreps = *(pnreps+l);

  lbuff         = (int   *)S_alloc(        1,sizeof(int));

  df            = (double *)S_alloc(        1, sizeof(double));
  pW            = (double *)S_alloc(       d2, sizeof(double));
  xbuff         = (double *)S_alloc(        d, sizeof(double));
  SgmHlf        = (double *)S_alloc(       d2, sizeof(double));
  Y             = (double *)S_alloc(mxnreps*d, sizeof(double));
  Sigma         = (double *)S_alloc(       d2, sizeof(double));
  SigInv        = (double *)S_alloc(       d2, sizeof(double));
  sig           = (double *)S_alloc(        d, sizeof(double));

  f_1 = *f1f2;
  f_2 = *(f1f2+1);
  lambda = *nu/(2 * xd + 2.0);

  nu_1 = (2.0 * xd + 2.0)*(1.0 + (lambda - 1.0) *(1.0 - f_1)/(1-f_1/f_2));
  nu_2 = (2.0 * xd + 2.0)*(1.0 + (lambda - 1.0) *          f_2          );

  tstnu = f_1/(nu_2 - (2.0*xd+2.0)) + (1.0-f_1)/(nu_1 - (2.0*xd+2.0));
  tstnu = 1.0/tstnu + 2.0*xd + 2.0;
  Rprintf("nu_1=%g, nu_2=%g, nu ?= %g", nu_1, nu_2, tstnu);

  GetRNGstate();

  /* NOTE:                                                                              */
  /* this block computes the average std dev over genes from the model                  */
  /* its diagonal elements, passed to the pointer, sig (of size 3)                      */
  /* are used for the purposes of assigning mean value to Y's under the alternative     */
  /*                                                                                    */
  for(i=0;i<d;i++)                                                   
    for(j=0;j<d;j++){
      sm = 0.0;
      for(k=0;k<d;k++) 
        sm += *(Lbdinvhlf + d*i + k) * (*(Lbdinvhlf + d*j + k));
      *(SigInv + d*j + i) = sm;
    }
  matinv(SigInv, Sigma, pd);
  for(i=0;i<d;i++) *(sig + i) = pow((*(Sigma + d*i + i))/(*nu - 2.0*xd - 2.0), 0.5);

  for(l=0;l<N;l++){  

    /* Pick J = 1 w.p. 1-f_1, J= 2 w.p. f_1.                                            */
    /* Then draw an InvWish_d(nu_J, Lambda) matrix.  This is done                       */
    /* using the result:  if Sigma^(-1) ~ Wish_d(nu-d-1, Lambda^(-1)) then              */
    /* Sigma ~ InvWish_d(nu, Lambda).  I simulate N i.i.d. Wish_d(nu-d-1,Lambda^(-1))   */
    /* matrices and then invert to get Sigma.  One more catch, my rwishart routine      */
    /* uses the cholesky square root of the parameter matrix, Lambda instead of Lambda  */
    /* itself.  Since I want the parameter matrix in the Wishart to be Lambda^(-1) then */
    /* I should pass its cholesky square root which is Lbdinvhlf, e.g. the cholesky     */
    /* square root of Lambda inverse.  That is computed in the calling R script and     */
    /* passed in.  Notice the need to check that Lambda is nonsingular and that         */
    /* nu > 2*d + 2 (required so that the expected value of the inverse wishart         */
    /* is finite.)                                                                      */
    /*                                                                                  */
    zz = unif_rand();
    Jrand = 1*(zz < f_1);
    *df = (1-Jrand)*nu_1 + Jrand*nu_2 - xd - 1.0;
    rwishart1(df, pd, Lbdinvhlf, pW);
    matinv(pW, Sigma, pd);
    /*                                                                                  */
    /* Sigma ~ (1-f_1)*InvWish_d(nu_1, Lambda) + f_1*InvWish_d(nu_2, Lambda)            */
    /*                                                                                  */
    /* Next, use Sigma to simulate i.i.d. N(0_d, Sigma)'s                               */
    nreps = *(pnreps + l);
    *lbuff = nreps*d;
    rnormn(lbuff, Y); 
    chol(Sigma, SgmHlf, pd);

    for(i=0;i<nreps;i++){
      for(j=0;j<d;j++){
        sm = 0.0;
        for(k=0;k<d;k++) sm += (*(SgmHlf +d*j +k))*(*(Y +d*i +k));
        *(xbuff+j) = sm;
      }
      for(j=0;j<d;j++) *(Y + d*i + j) = *(xbuff + j) + *(es + l)*(*(sig + j));
    }
    for(i=0;i<(nreps*d);i++) *(YY + mxnreps*d*l + i) = *(Y+i);
  }
  PutRNGstate();

}
예제 #23
0
static void fillin_node(int inode)
{
    int     j, k, nl, yparent;
    double  yl, sum, t, n1;
    char   *labl, *labr;

    labl = (char *) S_alloc(maxnl, sizeof(char));
    labr = (char *) S_alloc(maxnl, sizeof(char));
    *labl = *labr = '\0';
    cutleft[inode] = labl;
    cutright[inode] = labr;
    var[inode] = 0;
    if (nc) {
	n1 = 0;
	for (k = 0; k < nc; k++) yprob[nc * inode + k] = 0.0;
	for (j = 0; j < nobs; j++)
	    if (where[j] == inode) {
		n1 += w[j];
		yprob[nc * inode + (int) y[j]-1] += w[j];
	    }
	n[inode] = n1;
	yparent = -1;
	if (inode > 0) {
	    for(j = 0; j < inode; j++) 
		if(node[j] == node[inode]/2) yparent = (int)(y[j] - 1);
	}
	nl = 0;
	yl = -1.0;
	for (k = 0; k < nc; k++) {
/*	 if (yprob[nc*inode + k] > yl) {
	 nl = k;
	 yl = yprob[nc * inode + k];
	 } */
	    if (yprob[nc*inode + k] >= yl) {
		if (yprob[nc*inode + k] == yl) {
		    if(k == yparent) nl = k;
		} else {
		    nl = k;
		    yl = yprob[nc * inode + k];
		}
	    }
	    if (n1 > 0) yprob[nc * inode + k] /= n1;
	    else yprob[nc * inode + k] = 1.0/nc;
	}
/*for(k = 0; k < nc; k++) Printf(" %g", yprob[nc * inode + k]); Printf("\n");*/
	nl++;
	if(inode >= exists + offset) yval[inode] = nl;
	sum = 0.0;
	for (j = 0; j < nobs; j++)
	    if (where[j] == inode)
		sum += w[j] * log(yprob[nc * inode + (int) y[j] - 1]);
	dev[inode] = -2 * sum;
    }
    else {
	n1 = 0;
	sum = 0.0;
	for (j = 0; j < nobs; j++)
	    if (where[j] == inode) {
		n1 += w[j];
		sum += w[j] * y[j];
	    }
	n[inode] = n1;
	t = sum / n1;
	yval[inode] = t;
	sum = 0.0;
	for (j = 0; j < nobs; j++)
	    if (where[j] == inode) sum +=  w[j] * (y[j] - t) * (y[j] - t);
	dev[inode] = sum;
    }
}
예제 #24
0
파일: rf.c 프로젝트: jbleich89/rf_loss
/*
 * ja: added lossmat
 */
void classRF(double *x, int *dimx, int *cl, int *ncl, int *cat, int *maxcat,
	     int *sampsize, int *strata, int *Options, int *ntree, int *nvar,
	     int *ipi, double *classwt, double *cut, int *nodesize,
	     int *outcl, int *counttr, double *prox,
	     double *imprt, double *impsd, double *impmat, int *nrnodes,
	     int *ndbigtree, int *nodestatus, int *bestvar, int *treemap,
	     int *nodeclass, double *xbestsplit, double *errtr,
	     int *testdat, double *xts, int *clts, int *nts, double *countts,
	     int *outclts, int *labelts, double *proxts, double *errts,
             int *inbag, double* lossmat) {
    /******************************************************************
     *  C wrapper for random forests:  get input from R and drive
     *  the Fortran routines.
     *
     *  Input:
     *
     *  x:        matrix of predictors (transposed!)
     *  dimx:     two integers: number of variables and number of cases
     *  cl:       class labels of the data
     *  ncl:      number of classes in the response
     *  cat:      integer vector of number of classes in the predictor;
     *            1=continuous
     * maxcat:    maximum of cat
     * Options:   7 integers: (0=no, 1=yes)
     *     add a second class (for unsupervised RF)?
     *         1: sampling from product of marginals
     *         2: sampling from product of uniforms
     *     assess variable importance?
     *     calculate proximity?
     *     calculate proximity based on OOB predictions?
     *     calculate outlying measure?
     *     how often to print output?
     *     keep the forest for future prediction?
     *  ntree:    number of trees
     *  nvar:     number of predictors to use for each split
     *  ipi:      0=use class proportion as prob.; 1=use supplied priors
     *  pi:       double vector of class priors
     *  nodesize: minimum node size: no node with fewer than ndsize
     *            cases will be split
     *
     *  Output:
     *
     *  outcl:    class predicted by RF
     *  counttr:  matrix of votes (transposed!)
     *  imprt:    matrix of variable importance measures
     *  impmat:   matrix of local variable importance measures
     *  prox:     matrix of proximity (if iprox=1)
     ******************************************************************/

    int nsample0, mdim, nclass, addClass, mtry, ntest, nsample, ndsize,
        mimp, nimp, near, nuse, noutall, nrightall, nrightimpall,
	keepInbag, nstrata;
    int jb, j, n, m, k, idxByNnode, idxByNsample, imp, localImp, iprox,
	oobprox, keepf, replace, stratify, trace, *nright,
	*nrightimp, *nout, *nclts, Ntree;

    int *out, *bestsplitnext, *bestsplit, *nodepop, *jin, *nodex,
	*nodexts, *nodestart, *ta, *ncase, *jerr, *varUsed,
	*jtr, *classFreq, *idmove, *jvr,
	*at, *a, *b, *mind, *nind, *jts, *oobpair;
    int **strata_idx, *strata_size, last, ktmp, nEmpty, ntry;

    double av=0.0, delta=0.0;

    double *tgini, *tx, *wl, *classpop, *tclasscat, *tclasspop, *win,
        *tp, *wr, *lossmatrix;

    addClass = Options[0];
    imp      = Options[1];
    localImp = Options[2];
    iprox    = Options[3];
    oobprox  = Options[4];
    trace    = Options[5];
    keepf    = Options[6];
    replace  = Options[7];
    stratify = Options[8];
    keepInbag = Options[9];
    mdim     = dimx[0];
    nsample0 = dimx[1];
    nclass   = (*ncl==1) ? 2 : *ncl;
    ndsize   = *nodesize;
    Ntree    = *ntree;
    mtry     = *nvar;
    ntest    = *nts;
    nsample = addClass ? (nsample0 + nsample0) : nsample0;
    mimp = imp ? mdim : 1;
    nimp = imp ? nsample : 1;
    near = iprox ? nsample0 : 1;
    if (trace == 0) trace = Ntree + 1;

    tgini =      (double *) S_alloc(mdim, sizeof(double));
    wl =         (double *) S_alloc(nclass, sizeof(double));
    wr =         (double *) S_alloc(nclass, sizeof(double));
    classpop =   (double *) S_alloc(nclass* *nrnodes, sizeof(double)); //this gets allocated and then we pass it to Fortran
    tclasscat =  (double *) S_alloc(nclass*32, sizeof(double));
    tclasspop =  (double *) S_alloc(nclass, sizeof(double));
    tx =         (double *) S_alloc(nsample, sizeof(double));
    win =        (double *) S_alloc(nsample, sizeof(double));
    tp =         (double *) S_alloc(nsample, sizeof(double));

    out =           (int *) S_alloc(nsample, sizeof(int));
    bestsplitnext = (int *) S_alloc(*nrnodes, sizeof(int));
    bestsplit =     (int *) S_alloc(*nrnodes, sizeof(int));
    nodepop =       (int *) S_alloc(*nrnodes, sizeof(int));
    nodestart =     (int *) S_alloc(*nrnodes, sizeof(int));
    jin =           (int *) S_alloc(nsample, sizeof(int));
    nodex =         (int *) S_alloc(nsample, sizeof(int));
    nodexts =       (int *) S_alloc(ntest, sizeof(int));
    ta =            (int *) S_alloc(nsample, sizeof(int));
    ncase =         (int *) S_alloc(nsample, sizeof(int));
    jerr =          (int *) S_alloc(nsample, sizeof(int));
    varUsed =       (int *) S_alloc(mdim, sizeof(int));
    jtr =           (int *) S_alloc(nsample, sizeof(int));
    jvr =           (int *) S_alloc(nsample, sizeof(int));
    classFreq =     (int *) S_alloc(nclass, sizeof(int));
    jts =           (int *) S_alloc(ntest, sizeof(int));
    idmove =        (int *) S_alloc(nsample, sizeof(int));
    at =            (int *) S_alloc(mdim*nsample, sizeof(int));
    a =             (int *) S_alloc(mdim*nsample, sizeof(int));
    b =             (int *) S_alloc(mdim*nsample, sizeof(int));
    mind =          (int *) S_alloc(mdim, sizeof(int));
    nright =        (int *) S_alloc(nclass, sizeof(int));
    nrightimp =     (int *) S_alloc(nclass, sizeof(int));
    nout =          (int *) S_alloc(nclass, sizeof(int));
    if (oobprox) {
	oobpair = (int *) S_alloc(near*near, sizeof(int));
    }

    //ja: see if we can print the lossmat
    //(we can)
	/*
	int i;
	for(i = 0; i < (nclass*nclass); i++){
		Rprintf("%f\n",lossmat[i]);
	}
	/*

    /* Count number of cases in each class. */
    zeroInt(classFreq, nclass);
    for (n = 0; n < nsample; ++n) classFreq[cl[n] - 1] ++;
    /* Normalize class weights. */
    normClassWt(cl, nsample, nclass, *ipi, classwt, classFreq);

    if (stratify) {
	/* Count number of strata and frequency of each stratum. */
	nstrata = 0;
	for (n = 0; n < nsample0; ++n)
	    if (strata[n] > nstrata) nstrata = strata[n];
        /* Create the array of pointers, each pointing to a vector
	   of indices of where data of each stratum is. */
        strata_size = (int  *) S_alloc(nstrata, sizeof(int));
	for (n = 0; n < nsample0; ++n) {
	    strata_size[strata[n] - 1] ++;
	}
	strata_idx =  (int **) S_alloc(nstrata, sizeof(int *));
	for (n = 0; n < nstrata; ++n) {
	    strata_idx[n] = (int *) S_alloc(strata_size[n], sizeof(int));
	}
	zeroInt(strata_size, nstrata);
	for (n = 0; n < nsample0; ++n) {
	    strata_size[strata[n] - 1] ++;
	    strata_idx[strata[n] - 1][strata_size[strata[n] - 1] - 1] = n;
	}
    } else {
	nind = replace ? NULL : (int *) S_alloc(nsample, sizeof(int));
    }

    /*    INITIALIZE FOR RUN */
    if (*testdat) zeroDouble(countts, ntest * nclass);
    zeroInt(counttr, nclass * nsample);
    zeroInt(out, nsample);
    zeroDouble(tgini, mdim);
    zeroDouble(errtr, (nclass + 1) * Ntree);

    if (*labelts) {
	nclts  = (int *) S_alloc(nclass, sizeof(int));
	for (n = 0; n < ntest; ++n) nclts[clts[n]-1]++;
	zeroDouble(errts, (nclass + 1) * Ntree);
    }

    if (imp) {
        zeroDouble(imprt, (nclass+2) * mdim);
        zeroDouble(impsd, (nclass+1) * mdim);
	if (localImp) zeroDouble(impmat, nsample * mdim);
    }
    if (iprox) {
        zeroDouble(prox, nsample0 * nsample0);
        if (*testdat) zeroDouble(proxts, ntest * (ntest + nsample0));
    }
    makeA(x, mdim, nsample, cat, at, b);

    R_CheckUserInterrupt();

    /* Starting the main loop over number of trees. */
    GetRNGstate();
    if (trace <= Ntree) {
	/* Print header for running output. */
	Rprintf("ntree      OOB");
	for (n = 1; n <= nclass; ++n) Rprintf("%7i", n);
	if (*labelts) {
	    Rprintf("|    Test");
	    for (n = 1; n <= nclass; ++n) Rprintf("%7i", n);
	}
	Rprintf("\n");
    }
    idxByNnode = 0;
    idxByNsample = 0;
    for (jb = 0; jb < Ntree; jb++) {
        /* Do we need to simulate data for the second class? */
        if (addClass) createClass(x, nsample0, nsample, mdim);
		do {
			zeroInt(nodestatus + idxByNnode, *nrnodes);
			zeroInt(treemap + 2*idxByNnode, 2 * *nrnodes);
			zeroDouble(xbestsplit + idxByNnode, *nrnodes);
			zeroInt(nodeclass + idxByNnode, *nrnodes);
            zeroInt(varUsed, mdim);
            /* TODO: Put all sampling code into a function. */
            /* drawSample(sampsize, nsample, ); */
			if (stratify) {  /* stratified sampling */
				zeroInt(jin, nsample);
				zeroDouble(tclasspop, nclass);
				zeroDouble(win, nsample);
				if (replace) {  /* with replacement */
					for (n = 0; n < nstrata; ++n) {
						for (j = 0; j < sampsize[n]; ++j) {
							ktmp = (int) (unif_rand() * strata_size[n]);
							k = strata_idx[n][ktmp];
							tclasspop[cl[k] - 1] += classwt[cl[k] - 1];
							win[k] += classwt[cl[k] - 1];
							jin[k] = 1;
						}
					}
				} else { /* stratified sampling w/o replacement */
					/* re-initialize the index array */
					zeroInt(strata_size, nstrata);
					for (j = 0; j < nsample; ++j) {
						strata_size[strata[j] - 1] ++;
						strata_idx[strata[j] - 1][strata_size[strata[j] - 1] - 1] = j;
					}
					/* sampling without replacement */
					for (n = 0; n < nstrata; ++n) {
						last = strata_size[n] - 1;
						for (j = 0; j < sampsize[n]; ++j) {
							ktmp = (int) (unif_rand() * (last+1));
							k = strata_idx[n][ktmp];
                            swapInt(strata_idx[n][last], strata_idx[n][ktmp]);
							last--;
							tclasspop[cl[k] - 1] += classwt[cl[k]-1];
							win[k] += classwt[cl[k]-1];
							jin[k] = 1;
						}
					}
				}
			} else {  /* unstratified sampling */
				ntry = 0;
				do {
					nEmpty = 0;
					zeroInt(jin, nsample);
					zeroDouble(tclasspop, nclass);
					zeroDouble(win, nsample);
					if (replace) {
						for (n = 0; n < *sampsize; ++n) {
							k = unif_rand() * nsample;
							tclasspop[cl[k] - 1] += classwt[cl[k]-1]; //total #of obs in each class in the boot sample
							win[k] += classwt[cl[k]-1];  //number of times each obs appears in our boot sample (wgted by class)
							jin[k] = 1;   //are you in or not?
						}
					} else {
						for (n = 0; n < nsample; ++n) nind[n] = n;
						last = nsample - 1;  //size of bootstrap sample - 1
						for (n = 0; n < *sampsize; ++n) {
							ktmp = (int) (unif_rand() * (last+1)); //a random index from 1,...n
							k = nind[ktmp];    //class of the random observation
                            				swapInt(nind[ktmp], nind[last]);
							last--;
							tclasspop[cl[k] - 1] += classwt[cl[k]-1];
							win[k] += classwt[cl[k]-1];
							jin[k] = 1;
						}
					}
					/* check if any class is missing in the sample */
					for (n = 0; n < nclass; ++n) {
						if (tclasspop[n] == 0.0) nEmpty++;
					}
					ntry++;
				} while (nclass - nEmpty < 2 && ntry <= 30);
				/* If there are still fewer than two classes in the data, throw an error. */
				if (nclass - nEmpty < 2) error("Still have fewer than two classes in the in-bag sample after 30 attempts.");
			}

            /* If need to keep indices of inbag data, do that here. */
            if (keepInbag) {
                for (n = 0; n < nsample0; ++n) {
                    inbag[n + idxByNsample] = jin[n];
                }
            }

			/* Copy the original a matrix back. */
			memcpy(a, at, sizeof(int) * mdim * nsample);
      	    modA(a, &nuse, nsample, mdim, cat, *maxcat, ncase, jin);

			//ja: added lossmat to list of arguments...
			F77_CALL(buildtree)(a, b, cl, cat, maxcat, &mdim, &nsample,
								&nclass,
								treemap + 2*idxByNnode, bestvar + idxByNnode,
								bestsplit, bestsplitnext, tgini,
								nodestatus + idxByNnode, nodepop,
								nodestart, classpop, tclasspop, tclasscat,
								ta, nrnodes, idmove, &ndsize, ncase,
								&mtry, varUsed, nodeclass + idxByNnode,
								ndbigtree + jb, win, wr, wl, &mdim,
								&nuse, mind, lossmat);
			/* if the "tree" has only the root node, start over */
		} while (ndbigtree[jb] == 1);

		Xtranslate(x, mdim, *nrnodes, nsample, bestvar + idxByNnode,
				   bestsplit, bestsplitnext, xbestsplit + idxByNnode,
				   nodestatus + idxByNnode, cat, ndbigtree[jb]);

		/*  Get test set error */
		if (*testdat) {
            predictClassTree(xts, ntest, mdim, treemap + 2*idxByNnode,
                             nodestatus + idxByNnode, xbestsplit + idxByNnode,
                             bestvar + idxByNnode,
                             nodeclass + idxByNnode, ndbigtree[jb],
                             cat, nclass, jts, nodexts, *maxcat);
			TestSetError(countts, jts, clts, outclts, ntest, nclass, jb+1,
						 errts + jb*(nclass+1), *labelts, nclts, cut);
		}

		/*  Get out-of-bag predictions and errors. */
        predictClassTree(x, nsample, mdim, treemap + 2*idxByNnode,
                         nodestatus + idxByNnode, xbestsplit + idxByNnode,
                         bestvar + idxByNnode,
                         nodeclass + idxByNnode, ndbigtree[jb],
                         cat, nclass, jtr, nodex, *maxcat);

		zeroInt(nout, nclass);
		noutall = 0;
		for (n = 0; n < nsample; ++n) {
			if (jin[n] == 0) {
				/* increment the OOB votes */
				counttr[n*nclass + jtr[n] - 1] ++;
				/* count number of times a case is OOB */
				out[n]++;
				/* count number of OOB cases in the current iteration.
				   nout[n] is the number of OOB cases for the n-th class.
				   noutall is the number of OOB cases overall. */
				nout[cl[n] - 1]++;
				noutall++;
			}
		}

        /* Compute out-of-bag error rate. */
		oob(nsample, nclass, jin, cl, jtr, jerr, counttr, out,
			errtr + jb*(nclass+1), outcl, cut);

		if ((jb+1) % trace == 0) {
			Rprintf("%5i: %6.2f%%", jb+1, 100.0*errtr[jb * (nclass+1)]);
			for (n = 1; n <= nclass; ++n) {
				Rprintf("%6.2f%%", 100.0 * errtr[n + jb * (nclass+1)]);
			}
			if (*labelts) {
				Rprintf("| ");
				for (n = 0; n <= nclass; ++n) {
					Rprintf("%6.2f%%", 100.0 * errts[n + jb * (nclass+1)]);
				}
			}
			Rprintf("\n");
#ifdef WIN32
			R_FlushConsole();
			R_ProcessEvents();
#endif
			R_CheckUserInterrupt();
		}

		/*  DO PROXIMITIES */
		if (iprox) {
            computeProximity(prox, oobprox, nodex, jin, oobpair, near);
			/* proximity for test data */
			if (*testdat) {
                computeProximity(proxts, 0, nodexts, jin, oobpair, ntest);
                /* Compute proximity between testset and training set. */
				for (n = 0; n < ntest; ++n) {
					for (k = 0; k < near; ++k) {
						if (nodexts[n] == nodex[k])
							proxts[n + ntest * (k+ntest)] += 1.0;
					}
				}
			}
		}

		/*  DO VARIABLE IMPORTANCE  */
		if (imp) {
			nrightall = 0;
			/* Count the number of correct prediction by the current tree
			   among the OOB samples, by class. */
			zeroInt(nright, nclass);
			for (n = 0; n < nsample; ++n) {
       	        /* out-of-bag and predicted correctly: */
				if (jin[n] == 0 && jtr[n] == cl[n]) {
					nright[cl[n] - 1]++;
					nrightall++;
				}
			}
			for (m = 0; m < mdim; ++m) {
				if (varUsed[m]) {
					nrightimpall = 0;
					zeroInt(nrightimp, nclass);
					for (n = 0; n < nsample; ++n) tx[n] = x[m + n*mdim];
					/* Permute the m-th variable. */
                    permuteOOB(m, x, jin, nsample, mdim);
					/* Predict the modified data using the current tree. */
                    predictClassTree(x, nsample, mdim, treemap + 2*idxByNnode,
                                     nodestatus + idxByNnode,
                                     xbestsplit + idxByNnode,
                                     bestvar + idxByNnode,
                                     nodeclass + idxByNnode, ndbigtree[jb],
                                     cat, nclass, jvr, nodex, *maxcat);
					/* Count how often correct predictions are made with
					   the modified data. */
					for (n = 0; n < nsample; n++) {
						/* Restore the original data for that variable. */
						x[m + n*mdim] = tx[n];
						if (jin[n] == 0) {
							if (jvr[n] == cl[n]) {
+								nrightimp[cl[n] - 1]++;
								nrightimpall++;
							}
							if (localImp && jvr[n] != jtr[n]) {
								if (cl[n] == jvr[n]) {
									impmat[m + n*mdim] -= 1.0;
								} else {
									impmat[m + n*mdim] += 1.0;
								}
							}
						}
					}
					/* Accumulate decrease in proportions of correct
					   predictions. */
					/* class-specific measures first: */
					for (n = 0; n < nclass; ++n) {
						if (nout[n] > 0) {
							delta = ((double) (nright[n] - nrightimp[n])) / nout[n];
							imprt[m + n*mdim] += delta;
							impsd[m + n*mdim] += delta * delta;
						}
					}
					/* overall measure, across all classes: */
					if (noutall > 0) {
						delta = ((double)(nrightall - nrightimpall)) / noutall;
						imprt[m + nclass*mdim] += delta;
						impsd[m + nclass*mdim] += delta * delta;
					}
				}
			}
		}

		R_CheckUserInterrupt();
#ifdef WIN32
		R_ProcessEvents();
#endif
        if (keepf) idxByNnode += *nrnodes;
        if (keepInbag) idxByNsample += nsample0;
    }
    PutRNGstate();

    /*  Final processing of variable importance. */
    for (m = 0; m < mdim; m++) tgini[m] /= Ntree;
    if (imp) {
		for (m = 0; m < mdim; ++m) {
			if (localImp) { /* casewise measures */
				for (n = 0; n < nsample; ++n) impmat[m + n*mdim] /= out[n];
			}
			/* class-specific measures */
			for (k = 0; k < nclass; ++k) {
				av = imprt[m + k*mdim] / Ntree;
				impsd[m + k*mdim] =
                    sqrt(((impsd[m + k*mdim] / Ntree) - av*av) / Ntree);
				imprt[m + k*mdim] = av;
				/* imprt[m + k*mdim] = (se <= 0.0) ? -1000.0 - av : av / se; */
			}
			/* overall measures */
			av = imprt[m + nclass*mdim] / Ntree;
			impsd[m + nclass*mdim] =
                sqrt(((impsd[m + nclass*mdim] / Ntree) - av*av) / Ntree);
			imprt[m + nclass*mdim] = av;
			imprt[m + (nclass+1)*mdim] = tgini[m];
		}
    } else {
		for (m = 0; m < mdim; ++m) imprt[m] = tgini[m];
    }

    /*  PROXIMITY DATA ++++++++++++++++++++++++++++++++*/
    if (iprox) {
		for (n = 0; n < near; ++n) {
			for (k = n + 1; k < near; ++k) {
                prox[near*k + n] /= oobprox ?
                    (oobpair[near*k + n] > 0 ? oobpair[near*k + n] : 1) :
                    Ntree;
				prox[near*n + k] = prox[near*k + n];
			}
			prox[near*n + n] = 1.0;
		}
		if (*testdat) {
			for (n = 0; n < ntest; ++n) {
				for (k = 0; k < ntest + nsample; ++k)
					proxts[ntest*k + n] /= Ntree;
				proxts[ntest * n + n] = 1.0;
			}
		}
    }
}
예제 #25
0
void 
BDRgrow1(double *pX, double *pY, double *pw, Sint *plevels, Sint *junk1, 
	 Sint *pnobs, Sint *pncol, Sint *pnode, Sint *pvar, char **pcutleft, 
	 char **pcutright, double *pn, double *pdev, double *pyval, 
	 double *pyprob, Sint *pminsize, Sint *pmincut, double *pmindev, 
	 Sint *pnnode, Sint *pwhere, Sint *pnmax, Sint *stype, Sint *pordered)
{
    int i, nl;

    X = pX; y = pY; w = pw; dev = pdev; yval = pyval; yprob = pyprob;
    nobs = *pnobs; nvar = *pncol;
    levels = plevels; node = pnode; var = pvar; n = pn; mindev = *pmindev;
    minsize = *pminsize; mincut = *pmincut; nmax = *pnmax; nnode = *pnnode;
    where = pwhere; cutleft = pcutleft; cutright = pcutright; 
    ordered= pordered; Gini = *stype;
    nc = levels[nvar];
    Printf("nnode: %d\n", nnode);
    Printf("nvar: %d\n", nvar);
    for(i = 0; i <= nvar; i++) Printf("%d ", (int)levels[i]);
    Printf("\n");
    /* allocate scratch storage */
    nl = 0;
    for(i = 0; i <= nvar; i++)
	if (levels[i] > nl) nl = levels[i];
    maxnl = max(nl, 10);
    if (maxnl > 32) error("factor predictors must have at most 32 levels");
    twhere = (int *) S_alloc(nobs, sizeof(int));
    ttw = (int *) S_alloc(nobs, sizeof(int));
    tvar = (double *) S_alloc(nobs, sizeof(double));
    ind = (int *) S_alloc(nl, sizeof(int));
    w1 = (double *) S_alloc(nobs, sizeof(double));
    cnt = (double *) S_alloc(nl, sizeof(double));
    cprob = (double*) S_alloc(nl, sizeof(double));
    scprob = (double*) S_alloc(nl, sizeof(double));
    indl = (int*) S_alloc(nl, sizeof(int));
    if (nc > 0) {
	yp = (double *) S_alloc(nc, sizeof(double));
	tab = (double*) S_alloc(nl*(1+nc), sizeof(double));
	indr = (int*) S_alloc(nl, sizeof(int));
	ty = (int *) S_alloc(nobs, sizeof(int));
    } else {
	tyc = (double *) S_alloc(nobs, sizeof(double));
	ys = (double *) S_alloc(nl, sizeof(double));
    }
    exists = nnode;
    offset = 0;
    if (exists <= 1) {
	for(i = 0; i < nobs; i++) where[i] = 0;
	nnode = 1;
	node[0] = 1;
	divide_node(0);
    } else {
	/* Adjust from S indexing */
	for(i = 0; i < nobs; i++) where[i]--;
	for(i = 0; i < exists; i++)
	    if (!var[i+offset]) {
/* Printf("trying node %d at offset %d, nnode %d\n", i, offset, nnode);*/
		divide_node(i + offset);
	    }
    }
    /* Adjust to S indexing */

    for(i = 0; i < nobs; i++) {
	if(where[i] < 0) where[i] -= NALEVEL;
	where[i]++;
    }
    *pnnode = nnode;
    Printf("Finished!\n");
}
예제 #26
0
void Sridge_annealing(double *cost, double *smodulus,
  double *phi, double *plambda, double *pmu, double *pc, int *psigsize,
  int *pnscale, int *piteration, int *pstagnant, int *pseed,
  int *pcount, int *psub, int *pblocksize, int *psmodsize)
{
  int i,sigsize,ncount,iteration,up,pos,num,a,count, costcount,sub;
  long idum=-9;
  int again, tbox, blocksize,smodsize;
  int nscale, stagnant, recal;
  double lambda, c, mu;
  double *bcost, *phi2;
  double ran, gibbs;
  double cost1;
  double temperature, tmp=0.0;
  /* FILE *fp; */


  /* Generalities; initializations
     -----------------------------*/
  mu = *pmu;
  stagnant = *pstagnant;
  nscale = *pnscale;
  iteration = *piteration;
  lambda = *plambda;
  c = *pc;
  sigsize = *psigsize;
  idum = *pseed;
  sub = *psub;
  blocksize = *pblocksize;
  smodsize = *psmodsize;

  recal = 1000000; /* recompute cost function every 'recal' iterations */

  if(!(bcost = (double *) R_alloc(blocksize, sizeof(double) )))
    Rf_error("Memory allocation failed for bcost at ridge_annealing.c \n");

  if(!(phi2 = (double *)S_alloc((smodsize+1)*sub,sizeof(double))))
    Rf_error("Memory allocation failed for phi2 at ridge_annealing.c \n");

/*
  if(blocksize != 1) {
    if((fp = fopen("annealing.cost","w")) == NULL)
      Rf_error("can't open file at ridge_annealing.c \n");
  }
*/
  tbox = 0;
  ncount = 0; /* count for cost */
  count = 0; /* total count */
  temperature = c/log(2. + (double)count); /* Initial temperature */
  cost1 = 0;


  /* Smooth and subsample the wavelet transform modulus
     --------------------------------------------------*/
/*  smoothwt(modulus,smodulus,sigsize,nscale,sub); */
/*  smoothwt2(modulus,smodulus,sigsize,nscale,sub, &smodsize); */
/*   printf("smodsize=%d\n",smodsize); */
/*  for(i=0;i<smodsize;i++){
    phi[i] = phi[sub*i];
  } */

  for(i=0;i<smodsize;i++){
    phi[i] = phi[(int)((sigsize-1)/(smodsize-1)*i)];
  }


  /* Iterations:
     -----------*/

  while(1) {
    for(costcount = 0; costcount < blocksize; costcount++) {


      /* Initialize the cost function
	 ----------------------------*/
      if(count == 0) {
	for(i = 1; i < smodsize-1; i++) {
	  tmp = (double)((phi[i-1]+ phi[i+1]-2 * phi[i]));
	  cost1 += (double)((lambda * tmp * tmp));

	  tmp = (double)((phi[i] - phi[i+1]));
	  cost1 += (double)((mu * tmp * tmp));

	  a = (int)phi[i];
          tmp = smodulus[smodsize * a + i];
/*	  cost1 -= (tmp * tmp - noise[a]); */
	  cost1 -= tmp;
	}

        tmp = (double)((phi[0] - phi[1]));
	cost1 += (double) ((mu * tmp * tmp));
	a = (int)phi[0];
        tmp = smodulus[smodsize * a];
/*	cost1 -= (tmp * tmp - noise[a]); */
	cost1 -= tmp;

	a = (int)phi[smodsize-1];
        tmp = smodulus[smodsize * a + smodsize-1];
/*	cost1 -= (tmp * tmp - noise[a]); */
	cost1 -= tmp;

	cost[ncount++] = (double)cost1;
	bcost[0] = (double)cost1;
	count ++;
	costcount = 1;
	if(costcount == blocksize) break;
      }

      /* Generate potential random move
	 ------------------------------*/
      again = YES;
      while(again) {
	randomwalker2(smodsize,&num,&idum); 
	/* returns between 0 and 2 * smodsize - 1*/
	pos = num/2;
	up = -1;
	if(num%2 == 0) up = 1;
	again = NO;
	if((((int)phi[pos] == 0) && (up == -1)) ||
	   (((int)phi[pos] == (nscale-1) && (up == 1)))) again = YES; 
	   /* boundary effects */
      }

      /* Compute corresponding update of the cost function
	 -------------------------------------------------*/
      if(inrange(2,pos,smodsize-3)) {
	tmp = (double)(lambda*up);
	tmp *=(double)((6*up+(12*phi[pos]-8*(phi[pos-1]+phi[pos+1])
		+2*(phi[pos-2]+phi[pos+2]))));

	tmp += (double)(mu*up*(4.0*phi[pos]
		-2.0*(phi[pos-1]+phi[pos+1])+2.0*up));

	a = (int)phi[pos];
/*	tmp += ((smodulus[smodsize*a+pos]*smodulus[smodsize*a+pos])
		-noise[a]);  */
	tmp += smodulus[smodsize*a+pos];
	a = (int)phi[pos] +  up;
/*	tmp -= ((smodulus[smodsize*a+pos]*smodulus[smodsize * a + pos])
		-noise[a]); */
	tmp -= smodulus[smodsize*a+pos];
      }

      if(inrange(2,pos,smodsize-3) == NO) {
	tmp = (double)(lambda*up);
	if(pos == 0) {
	  tmp *= (double)((up+2.0*(phi[0]-2*phi[1]+phi[2])));
	  tmp += (double)(mu*up*((2.0*phi[pos]-2.0*phi[pos+1]) + up));
	}
	else if(pos == 1) {
	  tmp *= (double)((5*up+2.0*(-2*phi[0]+5*phi[1]-4*phi[2]+phi[3])));
	  tmp += (double)(mu*up*(4.0*phi[pos]-2.0*(phi[pos-1]+phi[pos+1])
				 +2.0*up));
	}
	else if(pos == (smodsize-2)) {
	  tmp *= (double)((5*up+2.0*(phi[pos-2]-4*phi[pos-1]+5*phi[pos]
				     -2*phi[pos+1])));
	  tmp += (double)(mu*up*(4.0*phi[pos]-2.0*(phi[pos-1]+phi[pos+1])
				 +2.0*up));
	}
	else if(pos == (smodsize-1)) {
	  tmp *= (double)((up+2.0*(phi[pos-2]-2*phi[pos-1]+phi[pos])));
	  tmp += (double)(mu*up*((2.0*phi[pos]-2.0*phi[pos-1]) + up));
	}
	a = (int)phi[pos];
/*	tmp +=((smodulus[smodsize*a+pos]*smodulus[smodsize*a+pos])-noise[a]); */
	tmp += smodulus[smodsize*a+pos];
	a = (int)phi[pos] +  up;
/*	tmp -=((smodulus[smodsize*a+pos]*smodulus[smodsize*a+pos])-noise[a]); */
	tmp -= smodulus[smodsize*a+pos];
      }

      /* To move or not to move: that's the question
	 -------------------------------------------*/
      if(tmp < (double)0.0) {
	phi[pos] = phi[pos] + up; /* good move */
	if(phi[pos] < 0) Rprintf("Error \n");
	cost1 += tmp;
	tbox = 0;
      }
      else {
	gibbs = exp(-tmp/temperature);
	ran = ran1(&idum); 
	if(ran < gibbs) {      
	  phi[pos] = phi[pos] + up; /* adverse move */
	  cost1 += tmp;
	  tbox = 0;
	}
	tbox ++;
	if(tbox >= stagnant)  {
	  cost[ncount++] = (double)cost1;
	  *pcount = ncount;
/*	  if((blocksize != 1)){
	    for(i = 0; i < costcount+1; i++)
	      fprintf(fp, "%f ", bcost[i]);
	    fclose(fp);
	  }
*/
	  /* Interpolate from subsampled ridge
	     --------------------------------*/
	  splridge(sub, phi, smodsize, phi2);
	  for(i=0;i<sigsize;i++) phi[i]=phi2[i];
	  /* splridge(1, phi, smodsize, phi2);
	  for(i=0;i<sigsize;i++) phi[i]=phi2[i];*/
	  return;
	}
      }
      bcost[costcount] = (double)cost1;

      count ++;
      if(count >=  iteration) 	{
	cost[ncount++] = (double)cost1;
	*pcount = ncount;

	/* Write cost function to a file
	   -----------------------------*/
/*	if((blocksize != 1)){
	  for(i = 0; i < costcount+1; i++)
	    fprintf(fp, "%f ", bcost[i]);
	  fclose(fp);
	}
*/
	/* Interpolate from subsampled ridge
	   --------------------------------*/
	splridge(sub, phi, smodsize, phi2);
	for(i=0;i<sigsize;i++) phi[i]=phi2[i];
	/* splridge(1, phi, smodsize, phi2);
	for(i=0;i<sigsize;i++) phi[i]=phi2[i];*/
	//printf("Done !\n");
	return;
      }
      temperature = c/log(1. + (double)count);
    }

    bcost[blocksize-1] = (double)cost1;
    if((blocksize != 1)){
/*      for(i = 0; i < blocksize; i++)
	fprintf(fp, "%f ", bcost[i]); */
      for(i = 0; i < blocksize; i++)
	bcost[i] = 0.0;
    }

    /* recalculate cost to prevent error propagation 
       ---------------------------------------------*/
    if(count % recal == 0) {
      cost1 = 0.0;
      for(i = 1; i < smodsize-1; i++) {
	tmp = (double)((phi[i-1]+ phi[i+1]-2 * phi[i]));
	cost1 += (double)((lambda * tmp * tmp));
	tmp = (double)((phi[i]-phi[i+1]));
	cost1 += (double)((mu * tmp * tmp));

	a = (int)phi[i];
	cost1 -= smodulus[smodsize * a + i];
/*	cost1 -= (smodulus[smodsize * a + i] * smodulus[smodsize * a + i]
		  -noise[a]); */
      }
      a = (int)phi[0];
      tmp = (double)((phi[0]-phi[1]));
      cost1 += (double)((mu * tmp * tmp));
      cost1 -= smodulus[smodsize * a];
/*      cost1 -= (smodulus[smodsize * a] * smodulus[smodsize * a]
		-noise[a]); */
      a = (int)phi[smodsize-1];
/*      cost1 -= (smodulus[smodsize * a + smodsize-1] *
		smodulus[smodsize * a + smodsize-1] -noise[a]); */
      cost1 -= smodulus[smodsize * a + smodsize-1];
    }
    cost[ncount++] = (double)cost1;
  }
  /* return; */
}
예제 #27
0
파일: panjer.c 프로젝트: cran/actuar
SEXP actuar_do_panjer(SEXP args)
{
    SEXP p0, p1, fs0, sfx, a, b, conv, tol, maxit, echo, sfs;
    double *fs, *fx, cumul;
    int upper, m, k, n, x = 1;
    double norm;                /* normalizing constant */
    double term;                /* constant in the (a, b, 1) case */

    /*  The length of vector fs is not known in advance. We opt for a
     *  simple scheme: allocate memory for a vector of size 'size',
     *  double the size when the vector is full. */
    int size = INITSIZE;
    fs = (double *) S_alloc(size, sizeof(double));

    /*  All values received from R are then protected. */
    PROTECT(p0 = coerceVector(CADR(args), REALSXP));
    PROTECT(p1 = coerceVector(CADDR(args), REALSXP));
    PROTECT(fs0 = coerceVector(CADDDR(args), REALSXP));
    PROTECT(sfx = coerceVector(CAD4R(args), REALSXP));
    PROTECT(a = coerceVector(CAD5R(args), REALSXP));
    PROTECT(b = coerceVector(CAD6R(args), REALSXP));
    PROTECT(conv = coerceVector(CAD7R(args), INTSXP));
    PROTECT(tol = coerceVector(CAD8R(args), REALSXP));
    PROTECT(maxit = coerceVector(CAD9R(args), INTSXP));
    PROTECT(echo = coerceVector(CAD10R(args), LGLSXP));

    /* Initialization of some variables */
    fx = REAL(sfx);             /* severity distribution */
    upper = length(sfx) - 1;    /* severity distribution support upper bound */
    fs[0] = REAL(fs0)[0];       /* value of Pr[S = 0] (computed in R) */
    cumul = REAL(fs0)[0];       /* cumulative probability computed */
    norm = 1 - REAL(a)[0] * fx[0]; /* normalizing constant */
    n = INTEGER(conv)[0];	   /* number of convolutions to do */

    /* If printing of recursions was asked for, start by printing a
     * header and the probability at 0. */
    if (LOGICAL(echo)[0])
        Rprintf("x\tPr[S = x]\tCumulative probability\n%d\t%.8g\t%.8g\n",
                0, fs[0], fs[0]);

    /* (a, b, 0) case (if p0 is NULL) */
    if (isNull(CADR(args)))
        do
        {
            /* Stop after 'maxit' recursions and issue warning. */
            if (x > INTEGER(maxit)[0])
            {
                warning(_("maximum number of recursions reached before the probability distribution was complete"));
                break;
            }

            /* If fs is too small, double its size */
            if (x >= size)
            {
                fs = (double *) S_realloc((char *) fs, size << 1, size, sizeof(double));
                size = size << 1;
            }

	    m = x;
	    if (x > upper) m = upper; /* upper bound of the sum */

            /* Compute probability up to the scaling constant */
            for (k = 1; k <= m; k++)
                fs[x] += (REAL(a)[0] + REAL(b)[0] * k / x) * fx[k] * fs[x - k];
            fs[x] = fs[x]/norm;   /* normalization */
            cumul += fs[x];       /* cumulative sum */

            if (LOGICAL(echo)[0])
                Rprintf("%d\t%.8g\t%.8g\n", x, fs[x], cumul);

            x++;
        } while (cumul < REAL(tol)[0]);
    /* (a, b, 1) case (if p0 is non-NULL) */
    else
    {
        /* In the (a, b, 1) case, the recursion formula has an
         * additional term involving f_X(x). The mathematical notation
         * assumes that f_X(x) = 0 for x > m (the maximal value of the
         * distribution). We need to treat this specifically in
         * programming, though. */
	double fxm;

        /* Constant term in the (a, b, 1) case. */
        term = (REAL(p1)[0] - (REAL(a)[0] + REAL(b)[0]) * REAL(p0)[0]);

        do
        {
            /* Stop after 'maxit' recursions and issue warning. */
            if (x > INTEGER(maxit)[0])
            {
                warning(_("maximum number of recursions reached before the probability distribution was complete"));
                break;
            }

            if (x >= size)
            {
                fs = (double *) S_realloc((char *) fs, size << 1, size, sizeof(double));
                size = size << 1;
            }

	    m = x;
	    if (x > upper)
	    {
		m = upper;	/* upper bound of the sum */
		fxm = 0.0;	/* i.e. no additional term */
	    }
	    else
		fxm = fx[m];	/* i.e. additional term */

            for (k = 1; k <= m; k++)
                fs[x] += (REAL(a)[0] + REAL(b)[0] * k / x) * fx[k] * fs[x - k];
            fs[x] = (fs[x] + fxm * term) / norm;
            cumul += fs[x];

            if (LOGICAL(echo)[0])
                Rprintf("%d\t%.8g\t%.8g\n", x, fs[x], cumul);

            x++;
        } while (cumul < REAL(tol)[0]);
    }

    /* If needed, convolve the distribution obtained above with itself
     * using a very simple direct technique. Since we want to
     * continue storing the distribution in array 'fs', we need to
     * copy the vector in an auxiliary array at each convolution. */
    if (n)
    {
	int i, j, ox;
	double *ofs;		/* auxiliary array */

	/* Resize 'fs' to its final size after 'n' convolutions. Each
	 * convolution increases the length from 'x' to '2 * x - 1'. */
	fs = (double *) S_realloc((char *) fs, (1 << n) * (x - 1) + 1, size, sizeof(double));

	/* Allocate enough memory in the auxiliary array for the 'n'
	 * convolutions. This is just slightly over half the final
	 * size of 'fs'. */
	ofs = (double *) S_alloc((1 << (n - 1)) * (x - 1) + 1, sizeof(double));

	for (k = 0; k < n; k++)
	{
	    memcpy(ofs, fs, x * sizeof(double)); /* keep previous array */
	    ox = x;		/* previous array length */
	    x = (x << 1) - 1;	/* new array length */
	    for(i = 0; i < x; i++)
		fs[i] = 0.0;
	    for(i = 0; i < ox; i++)
		for(j = 0; j < ox; j++)
		    fs[i + j] += ofs[i] * ofs[j];
	}
    }

    /*  Copy the values of fs to a SEXP which will be returned to R. */
    PROTECT(sfs = allocVector(REALSXP, x));
    memcpy(REAL(sfs), fs, x * sizeof(double));

    UNPROTECT(11);
    return(sfs);
}
예제 #28
0
파일: optim.c 프로젝트: SoraxOriginali/pqR
void lbfgsb(int n, int m, double *x, double *l, double *u, int *nbd,
	    double *Fmin, optimfn fminfn, optimgr fmingr, int *fail,
	    void *ex, double factr, double pgtol,
	    int *fncount, int *grcount, int maxit, char *msg,
	    int trace, int nREPORT)
{
    char task[60];
    double f, *g, dsave[29], *wa;
    int tr = -1, iter = 0, *iwa, isave[44], lsave[4];

    /* shut up gcc -Wall in 4.6.x */

    for(int i = 0; i < 4; i++) lsave[i] = 0;

    if(n == 0) { /* not handled in setulb */
	*fncount = 1;
	*grcount = 0;
	*Fmin = fminfn(n, u, ex);
	strcpy(msg, "NOTHING TO DO");
	*fail = 0;
	return;
    }
    if (nREPORT <= 0)
	error(_("REPORT must be > 0 (method = \"L-BFGS-B\")"));
    switch(trace) {
    case 2: tr = 0; break;
    case 3: tr = nREPORT; break;
    case 4: tr = 99; break;
    case 5: tr = 100; break;
    case 6: tr = 101; break;
    default: tr = -1; break;
    }

    *fail = 0;
    g = vect(n);
    /* this needs to be zeroed for snd in mainlb to be zeroed */
    wa = (double *) S_alloc(2*m*n+4*n+11*m*m+8*m, sizeof(double));
    iwa = (int *) R_alloc(3*n, sizeof(int));
    strcpy(task, "START");
    while(1) {
	setulb(n, m, x, l, u, nbd, &f, g, factr, &pgtol, wa, iwa, task,
	       tr, lsave, isave, dsave);
/*	Rprintf("in lbfgsb - %s\n", task);*/
	if (strncmp(task, "FG", 2) == 0) {
	    f = fminfn(n, x, ex);
	    if (!R_FINITE(f))
		error(_("L-BFGS-B needs finite values of 'fn'"));
	    fmingr(n, x, g, ex);
	} else if (strncmp(task, "NEW_X", 5) == 0) {
	    iter++;
	    if(trace == 1 && (iter % nREPORT == 0)) {
		Rprintf("iter %4d value %f\n", iter, f);
	    }
	    if (iter > maxit) {
		*fail = 1;
		break;
	    }
	} else if (strncmp(task, "WARN", 4) == 0) {
	    *fail = 51;
	    break;
	} else if (strncmp(task, "CONV", 4) == 0) {
	    break;
	} else if (strncmp(task, "ERROR", 5) == 0) {
	    *fail = 52;
	    break;
	} else { /* some other condition that is not supposed to happen */
	    *fail = 52;
	    break;
	}
    }
    *Fmin = f;
    *fncount = *grcount = isave[33];
    if (trace) {
	Rprintf("final  value %f \n", *Fmin);
	if (iter < maxit && *fail == 0) Rprintf("converged\n");
	else Rprintf("stopped after %i iterations\n", iter);
    }
    strcpy(msg, task);
}
예제 #29
0
SEXP
R_tarExtract(SEXP r_filename,  SEXP r_filenames, SEXP r_fun, SEXP r_data,
             SEXP r_workBuf)
{
   TarExtractCallbackFun callback = R_tarCollectContents;
   RTarCallInfo rcb;
   Rboolean doRcallback = (TYPEOF(r_fun) == CLOSXP);
   void *data;

   gzFile *f = NULL;

   int numFiles = LENGTH(r_filenames), i;
   const char **argv;
   int argc = numFiles + 1;

   if(TYPEOF(r_filename) == STRSXP) {
       const char *filename;
       filename = CHAR(STRING_ELT(r_filename, 0));
       f = gzopen(filename, "rb");

       if(!f) {
	   PROBLEM "Can't open file %s", filename
	       ERROR;
       }
   }

   if(doRcallback) {

       SEXP p;

       rcb.rawData = r_workBuf;
       rcb.numProtects = 0;
       rcb.offset = 0;
				 

       PROTECT(rcb.e = p = allocVector( LANGSXP, 3));
       SETCAR(p, r_fun);

       callback = R_tarCollectContents;

       data = (void *) &rcb;

   } else {
       data = (void *) r_data;
       callback = (TarExtractCallbackFun) R_ExternalPtrAddr(r_fun);
   }

   argv = (char **) S_alloc(numFiles + 1, sizeof(char *));
   argv[0] = "R";
   for(i = 1; i < numFiles + 1; i++)
       argv[i] = CHAR(STRING_ELT(r_filenames, i-1));


   if(TYPEOF(r_filename) == STRSXP)
      tar(f, TGZ_EXTRACT, numFiles + 1, argc, argv, (TarCallbackFun) callback, (void *) data);
   else {
       DataSource src;
       R_rawStream stream;
       stream.data = RAW(r_filename);
       stream.len = LENGTH(r_filename);
       stream.pos = 0;

       src.data = &stream;
       src.throwError = rawError;
       src.read = rawRead;
       funTar(&src, TGZ_EXTRACT, numFiles + 1, argc, argv, (TarCallbackFun) callback, (void *) data);
   }

   if(doRcallback) 
       UNPROTECT(1);
   if(rcb.numProtects > 0)
       UNPROTECT(rcb.numProtects);

   if (f && gzclose(f) != Z_OK)
      error("failed gzclose");

   return(R_NilValue);
}
예제 #30
0
파일: cwt_phase.c 프로젝트: cran/Rwave
void Scwt_squeezed(double *input, double *squeezed_r,
  double *squeezed_i, int *pnboctave, int *pnbvoice,
  int *pinputsize, double *pcenterfrequency)
{
  int nboctave, nbvoice, i, j, inputsize, bigsize;
  double centerfrequency, a;
  double *Ri2, *Ri1, *Ii1, *Ii2, *Rdi2, *Idi2, *Ii, *Ri;
  double *Oreal, *Oimage, *Odreal, *Odimage;


  centerfrequency = *pcenterfrequency;
  nboctave = *pnboctave;
  nbvoice = *pnbvoice;
  inputsize = *pinputsize;
  bigsize = inputsize*nbvoice*nboctave;

  /* Memory allocations
     ------------------*/
  if(!(Oreal = (double *) S_alloc(bigsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ri1 in cwt_phase.c \n");
  if(!(Oimage = (double *) S_alloc(bigsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ii1 in cwt_phase.c \n");

  if(!(Odreal = (double *) S_alloc(bigsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ri1 in cwt_phase.c \n");
  if(!(Odimage = (double *) S_alloc(bigsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ii1 in cwt_phase.c \n");

  if(!(Ri1 = (double *) S_alloc(inputsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ri1 in cwt_phase.c \n");
  if(!(Ii1 = (double *) S_alloc(inputsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ii1 in cwt_phase.c \n");

  if(!(Ii2 = (double *) S_alloc(inputsize,sizeof(double))))
    Rf_error("Memory allocation failed for Ri2 in cwt_phase.c \n");
  if(!(Ri2 = (double *) S_alloc(inputsize,sizeof(double))))
    Rf_error("Memory allocation failed for Ri2 in cwt_phase.c \n");

  if(!(Idi2 = (double *) S_alloc(inputsize,sizeof(double))))
    Rf_error("Memory allocation failed for Ri2 in cwt_phase.c \n");
  if(!(Rdi2 = (double *) S_alloc(inputsize,sizeof(double))))
    Rf_error("Memory allocation failed for Ri2 in cwt_phase.c \n");

  if(!(Ri = (double *) S_alloc(inputsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ri in cwt_phase.c \n");
  if(!(Ii = (double *) S_alloc(inputsize, sizeof(double))))
    Rf_error("Memory allocation failed for Ii in cwt_phase.c \n");

  for(i = 0; i < inputsize; i++){
    *Ri = (double)(*input);
    Ri++; input++;
  }
  Ri -= inputsize;
  input -= inputsize;
  
  /* Compute fft of the signal
     -------------------------*/
  double_fft(Ri1,Ii1,Ri,Ii,inputsize,-1);   
  
  /* Multiply signal and wavelets in the Fourier space
     -------------------------------------------------*/
  for(i = 1; i <= nboctave; i++) {
    for(j=0; j < nbvoice; j++) {
      a = (double)(pow((double)2,(double)(i+j/((double)nbvoice))));
      morlet_frequencyph(centerfrequency,a,Ri2,Idi2,inputsize); 
      multiply(Ri1,Ii1,Ri2,Ii2,Oreal,Oimage,inputsize);
      multiply(Ri1,Ii1,Rdi2,Idi2,Odreal,Odimage,inputsize);
      double_fft(Oreal,Oimage,Oreal,Oimage,inputsize,1); 
      double_fft(Odreal,Odimage,Odreal,Odimage,inputsize,1); 
      Oreal += inputsize;
      Oimage += inputsize;  
      Odreal += inputsize;
      Odimage += inputsize; 
    }
  }

  Oreal -= bigsize;
  Odreal -= bigsize;
  Oimage -= bigsize;
  Odimage -= bigsize;


  /* Normalize the cwt and compute the squeezed transform
     ----------------------------------------------------*/
  normalization(Oreal, Oimage, Odreal, Odimage, bigsize);

  w_reassign(Oreal, Oimage, Odreal, Odimage, squeezed_r,
    squeezed_i, centerfrequency,inputsize, nbvoice, nboctave);

  return;

}