/*
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, ¶ms, methodIds, numNamedArgs, namedArgPositions);
if(FAILED(hr)) {
clearVariants(¶ms);
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, ¶ms, 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(¶ms);
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(¶ms);
freeSysStrings(comNames, numNames);
#ifdef ANNOUNCE_COM_CALLS
fprintf(stderr, "</COM>\n", (int) callType);fflush(stderr);
#endif
return(ans);
}
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);
}
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();
}
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++;
}
}
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;
}
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);
}
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);
}
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);
}
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);
}
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); */
}
/* 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;
}
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--]));
}
}
/*----------------------------------------------------------------------*/
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;
}
}
}
/*
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];
}
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;
}
/*
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);
}
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);
}
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);
}
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);
}
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;
}
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;
}
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();
}
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;
}
}
/*
* 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;
}
}
}
}
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");
}
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; */
}
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);
}
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);
}
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);
}
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;
}
