/*
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);
}
void BigSum(BigMatrix *mat, SEXP colIndices, SEXP rowIndices, double *value) {
BMAccessorType m( *mat );
double *cols = NUMERIC_DATA(colIndices);
double *rows = NUMERIC_DATA(rowIndices);
index_type i=0;
index_type j=0;
index_type xj=0;
index_type numCols = GET_LENGTH(colIndices);
index_type numRows = GET_LENGTH(rowIndices);
CType *pColumn;
double s = 0;
for (i = 0; i < numCols; ++i) {
pColumn = m[static_cast<index_type>(cols[i])-1];
for (j = 0; j < numRows; ++j) {
xj = static_cast<index_type>(rows[j])-1;
s += (double)pColumn[xj];
}
}
value[0] = s;
return;
}
void DeepCopy(BigMatrix *pInMat, BigMatrix *pOutMat, SEXP rowInds, SEXP colInds)
{
in_BMAccessorType inMat( *pInMat );
out_BMAccessorType outMat( *pOutMat );
double *pRows = NUMERIC_DATA(rowInds);
double *pCols = NUMERIC_DATA(colInds);
index_type nRows = GET_LENGTH(rowInds);
index_type nCols = GET_LENGTH(colInds);
if (nRows != pOutMat->nrow())
Rf_error("length of row indices does not equal # of rows in new matrix");
if (nCols != pOutMat->ncol())
Rf_error("length of col indices does not equal # of cols in new matrix");
index_type i = 0;
index_type j = 0;
in_CType *pInColumn;
out_CType *pOutColumn;
for (i = 0; i < nCols; ++i) {
pInColumn = inMat[static_cast<index_type>(pCols[i])-1];
pOutColumn = outMat[i];
for (j = 0; j < nRows; ++j) {
pOutColumn[j] = static_cast<out_CType>(
pInColumn[static_cast<index_type>(pRows[j])-1]);
}
}
return;
}
SEXP CombineSubMapsTransSimpleMain(SEXP LIST_allVoxs_allSubs, SEXP ADDR_oneVox_allSubs, SEXP Rseed_index, SEXP Rvoxindices, SEXP Rnvoxs, SEXP Rnsubs) {
BigMatrix *oneVox_allSubs = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(ADDR_oneVox_allSubs));
index_type seed = static_cast<index_type>(NUMERIC_DATA(Rseed_index)[0]) - 1;
double *pVoxs = NUMERIC_DATA(Rvoxindices);
index_type nvoxs = static_cast<index_type>(NUMERIC_DATA(Rnvoxs)[0]);
index_type nsubs = static_cast<index_type>(NUMERIC_DATA(Rnsubs)[0]);
CALL_BIGFUNCTION_ARGS_SIX(CombineSubMapsTransSimple, oneVox_allSubs, LIST_allVoxs_allSubs, seed, pVoxs, nvoxs, nsubs)
return(ret);
}
SEXP CBinIt2(MatrixType x, index_type nr, SEXP pcols,
SEXP B1addr, SEXP B2addr)
{
index_type i, j, k;
double *pB1 = NUMERIC_DATA(B1addr);
double *pB2 = NUMERIC_DATA(B2addr);
double min1 = pB1[0];
double min2 = pB2[0];
double max1 = pB1[1];
double max2 = pB2[1];
index_type nbins1 = (index_type) pB1[2];
index_type nbins2 = (index_type) pB2[2];
double *cols = NUMERIC_DATA(pcols);
index_type col1 = (index_type) cols[0] - 1;
index_type col2 = (index_type) cols[1] - 1;
int good;
T *pc1 = x[col1];
T *pc2 = x[col2];
SEXP Rret;
Rret = PROTECT(NEW_NUMERIC(nbins1*nbins2));
double *ret = NUMERIC_DATA(Rret);
for (i=0; i<nbins1; i++) {
for (j=0; j<nbins2; j++) {
ret[j*nbins1+i] = 0.0;
}
}
for (k=0; k<nr; k++) {
if ( !isna(pc1[k]) && !isna(pc2[k]) ){
good = 1;
if ( (((double)pc1[k])>=min1) && (((double)pc1[k])<=max1) ) {
i = (index_type) ( nbins1 * (((double)pc1[k])-min1) / (max1-min1) );
if (i==nbins1) i--;
} else { good = 0; }
if ( (((double)pc2[k])>=min2) & (((double)pc2[k])<=max2) ) {
j = (index_type) ( nbins2 * (((double)pc2[k])-min2) / (max2-min2) );
if (j==nbins2) j--;
} else { good = 0; }
if (good == 1) {
ret[j*nbins1+i]++;
}
} // End only do work in there isn't an NA value
} // End looping over all rows.
UNPROTECT(1);
return(Rret);
}
double
asCNumeric(USER_OBJECT_ s_num)
{
if (GET_LENGTH(s_num) == 0)
return(0);
return(NUMERIC_DATA(s_num)[0]);
}
SEXP binit1RNumericMatrix(SEXP x, SEXP col, SEXP breaks)
{
index_type numRows = static_cast<index_type>(nrows(x));
MatrixAccessor<double> mat(NUMERIC_DATA(x), numRows);
return CBinIt1<double, MatrixAccessor<double> >(mat,
numRows, col, breaks);
}
/* Pointer utility, returns a double pointer for either a BigMatrix or a
* standard R matrix.
*/
double *
make_double_ptr (SEXP matrix, SEXP isBigMatrix)
{
double *matrix_ptr;
if (LOGICAL_VALUE (isBigMatrix) == (Rboolean) TRUE) // Big Matrix
{
SEXP address = GET_SLOT (matrix, install ("address"));
BigMatrix *pbm =
reinterpret_cast < BigMatrix * >(R_ExternalPtrAddr (address));
if (!pbm)
return (NULL);
// Check that have acceptable big.matrix
if (pbm->row_offset () > 0 && pbm->ncol () > 1)
{
std::string errMsg =
string ("sub.big.matrix objects cannoth have row ") +
string
("offset greater than zero and number of columns greater than 1");
Rf_error (errMsg.c_str ());
return (NULL);
}
index_type offset = pbm->nrow () * pbm->col_offset ();
matrix_ptr = reinterpret_cast < double *>(pbm->matrix ()) + offset;
}
else // Regular R Matrix
{
matrix_ptr = NUMERIC_DATA (matrix);
}
return (matrix_ptr);
};
/**
Computes the smoothed values for the y variable
for the bivariate X and Y identified by column
index for the data set in ggobi.
This calls the R/S function currently registered
in the variable RS_smoothFunction with three arguments:
the numeric vectors x & y
the desired window width as specified by the
the argument `width'.
*/
double *
RS_GGOBI(smooth)(int x_index, int y_index, double width, ggobid *gg)
{
double *values;
USER_OBJECT_ vals, tmp;
USER_OBJECT_ e;
if(RS_smoothFunction == NULL || RS_smoothFunction == R_UnboundValue)
return(NULL);
e = allocVector(LANGSXP, 4);
PROTECT(e);
SETCAR(e, RS_smoothFunction);
SETCAR(CDR(e), RS_GGOBI(variableToRS)(x_index, gg));
SETCAR(CDR(CDR(e)), RS_GGOBI(variableToRS)(y_index, gg));
tmp = NEW_NUMERIC(1);
NUMERIC_DATA(tmp)[0] = width;
SETCAR(CDR(CDR(CDR(e))), tmp);
vals = eval(e, R_GlobalEnv);
PROTECT(vals);
/* PrintValue(vals); */
values = asCArray(vals, double, asCNumeric);
UNPROTECT(2);
return(values);
}
static void php_r_to_zval(SEXP value, zval *result) /* {{{ */
{
int value_len, i;
zval_dtor(result);
array_init(result);
value_len = GET_LENGTH(value);
if (value_len == 0) {
return;
}
for (i = 0; i < value_len; i++) {
switch (TYPEOF(value)) {
case INTSXP:
add_next_index_long(result, INTEGER_DATA(value)[i]);
break;
case REALSXP:
add_next_index_double(result, NUMERIC_DATA(value)[i]);
break;
case LGLSXP:
add_next_index_bool(result, LOGICAL_DATA(value)[i]);
break;
case STRSXP:
add_next_index_string(result, CHAR(STRING_ELT(value, 0)), 1);
break;
}
}
return;
}
SEXP
GetRScalar(SV *val)
{
dTHX;
SEXP ans = NULL_USER_OBJECT;
if(SvIOKp(val)) {
PROTECT(ans = NEW_INTEGER(1));
INTEGER_DATA(ans)[0] = SvIV(val);
UNPROTECT(1);
} else if(SvNOKp(val)) {
PROTECT(ans = NEW_NUMERIC(1));
NUMERIC_DATA(ans)[0] = SvNV(val);
UNPROTECT(1);
} else if(SvPOK(val)) {
PROTECT(ans = NEW_CHARACTER(1));
SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(SvPV(val, PL_na)));
UNPROTECT(1);
} else if(SvROK(val)) {
fprintf(stderr, "Not handling nested references in conversion from Perl to R at present. Suggestions for semantics welcome!\n");fflush(stderr);
} else if(SvTYPE(val) == SVt_PVMG) {
/*XXX get more info about the type of the magic object.
struct magic *mg = SvMAGIC(val);
*/
PROTECT(ans = createPerlReference(val));
UNPROTECT(1);
} else {
fprintf(stderr, "Cannot deal currently with Perl types %d\n", SvTYPE(val));fflush(stderr);
}
return(ans);
}
USER_OBJECT_
asRNumeric(double val)
{
USER_OBJECT_ ans;
ans = NEW_NUMERIC(1);
NUMERIC_DATA(ans)[0] = val;
return(ans);
}
Workbook *
RGnumeric_resolveWorkbookReference(USER_OBJECT_ sref)
{
Workbook *book;
double val;
val = NUMERIC_DATA(sref)[0];
book = (Workbook*) (long) val;
return(book);
}
/*
Converts and inserts the Perl primitive value `val'
into the R/S object `ans' in position `i'.
It knows the type of the Perl object and hence the
S object type.
See PerlAllocHomogeneousVector() above.
*/
void
PerlAddHomogeneousElement(SV *val, int i, USER_OBJECT_ ans, svtype elementType)
{
dTHX;
switch(elementType) {
case SVt_IV:
INTEGER_DATA(ans)[i] = SvIV(val);
break;
case SVt_PVIV:
INTEGER_DATA(ans)[i] = SvIV(val);
break;
case SVt_NV:
NUMERIC_DATA(ans)[i] = SvNV(val);
break;
case SVt_PVNV:
NUMERIC_DATA(ans)[i] = SvNV(val);
break;
case SVt_PV:
SET_STRING_ELT(ans, i, COPY_TO_USER_STRING(SvPV(val, PL_na)));
break;
#if 0
case SVt_RV:
SET_VECTOR_ELT(ans, i, fromPerl(sv_isobject(val) ? val : val/*XXX SvRV(val)*/, 1));
break;
#endif
case SVt_PVMG: /* magic variable */
/*XXX */ SET_VECTOR_ELT(ans, i, fromPerl(val, 0));
break;
case SVt_PVGV: /* glob value*/
SET_VECTOR_ELT(ans, i, fromPerl(val, 1));
break;
case SVt_NULL:
if(TYPEOF(ans) == VECSXP)
SET_VECTOR_ELT(ans, i, R_NilValue);
else
fprintf(stderr, "Unhandled NULL object at position %d in array conversion into R object of type %d\n", i, TYPEOF(ans));
break;
default:
fprintf(stderr, "Unhandled type %d at position %d in array conversion\n", elementType, i);
break;
}
}
SEXP CBinIt1(MatrixType x, index_type nr, SEXP pcol, SEXP Baddr)
{
index_type i, k;
double *pB = NUMERIC_DATA(Baddr);
double min = pB[0];
double max = pB[1];
index_type nbins = (index_type) pB[2];
index_type col = (index_type) NUMERIC_VALUE(pcol) - 1;
int good;
T *pc = x[col];
SEXP Rret;
Rret = PROTECT(NEW_NUMERIC(nbins));
double *ret = NUMERIC_DATA(Rret);
for (i=0; i<nbins; i++) {
ret[i] = 0.0;
}
for (k=0; k<nr; k++) {
if ( !isna(pc[k]) ){
good = 1;
if ( (((double)pc[k])>=min) && (((double)pc[k])<=max) ) {
i = (index_type) ( nbins * (((double)pc[k])-min) / (max-min) );
if (i==(index_type)nbins) i--;
} else { good = 0; }
if (good == 1) {
ret[i]++;
}
} // End only do work in there isn't an NA value
} // End looping over all rows.
UNPROTECT(1);
return(Rret);
}
SEXP BigSumMain(SEXP addr, SEXP cols, SEXP rows) {
SEXP ret = R_NilValue;
ret = PROTECT(NEW_NUMERIC(1));
double *pRet = NUMERIC_DATA(ret);
BigMatrix *pMat = (BigMatrix*)R_ExternalPtrAddr(addr);
if (pMat->separated_columns()) {
switch (pMat->matrix_type()) {
case 1:
BigSum<char, SepMatrixAccessor<char> >(
pMat, cols, rows, pRet);
break;
case 2:
BigSum<short, SepMatrixAccessor<short> >(
pMat, cols, rows, pRet);
break;
case 4:
BigSum<int, SepMatrixAccessor<int> >(
pMat, cols, rows, pRet);
break;
case 8:
BigSum<double, SepMatrixAccessor<double> >(
pMat, cols, rows, pRet);
break;
}
}
else {
switch (pMat->matrix_type()) {
case 1:
BigSum<char, MatrixAccessor<char> >(
pMat, cols, rows, pRet);
break;
case 2:
BigSum<short, MatrixAccessor<short> >(
pMat, cols, rows, pRet);
break;
case 4:
BigSum<int, MatrixAccessor<int> >(
pMat, cols, rows, pRet);
break;
case 8:
BigSum<double, MatrixAccessor<double> >(
pMat, cols, rows, pRet);
break;
}
}
UNPROTECT(1);
return(ret);
}
/* Wrappers for miscellaneous BLAS and LAPACK routines. */
SEXP
dgemm_wrapper (SEXP TRANSA, SEXP TRANSB, SEXP M, SEXP N, SEXP K,
SEXP ALPHA, SEXP A, SEXP LDA, SEXP B, SEXP LDB, SEXP BETA,
SEXP C, SEXP LDC, SEXP A_isBM, SEXP B_isBM, SEXP C_isBM,
SEXP C_offset)
{
long j = *(DOUBLE_DATA (C_offset));
double *pA = make_double_ptr (A, A_isBM);
double *pB = make_double_ptr (B, B_isBM);
double *pC;
SEXP ans;
INT MM = (INT) * (DOUBLE_DATA (M));
INT NN = (INT) * (DOUBLE_DATA (N));
INT KK = (INT) * (DOUBLE_DATA (K));
INT LDAA = (INT) * (DOUBLE_DATA (LDA));
INT LDBB = (INT) * (DOUBLE_DATA (LDB));
INT LDCC = (INT) * (DOUBLE_DATA (LDC));
if(LOGICAL_VALUE(C_isBM) == (Rboolean) TRUE)
{
/* Return results in a big matrix */
pC = make_double_ptr (C, C_isBM) + j;
PROTECT(ans = C);
} else {
/* Allocate an output R matrix and return results there
XXX Add check for size of MM and NN XXX
*/
PROTECT(ans = allocMatrix(REALSXP, (int)MM, (int)NN));
pC = NUMERIC_DATA(ans);
}
/* An example of an alternate C-blas interface (e.g., ACML) */
#ifdef CBLAS
dgemm (*((char *) CHARACTER_VALUE (TRANSA)),
*((char *) CHARACTER_VALUE (TRANSB)),
MM, NN, KK, *(NUMERIC_DATA (ALPHA)), pA, LDAA, pB,
LDBB, *(NUMERIC_DATA (BETA)), pC, LDCC);
#elif REFBLAS
/* Standard Fortran interface without underscoring */
int8_dgemm ((char *) CHARACTER_VALUE (TRANSA),
(char *) CHARACTER_VALUE (TRANSB),
&MM, &NN, &KK, NUMERIC_DATA (ALPHA), pA, &LDAA, pB,
&LDBB, NUMERIC_DATA (BETA), pC, &LDCC);
#else
/* Standard Fortran interface from R's blas */
dgemm_ ((char *) CHARACTER_VALUE (TRANSA),
(char *) CHARACTER_VALUE (TRANSB),
&MM, &NN, &KK, NUMERIC_DATA (ALPHA), pA, &LDAA, pB,
&LDBB, NUMERIC_DATA (BETA), pC, &LDCC);
#endif
unprotect(1);
return ans;
}
SEXP ComputePvalsMain(SEXP Rinmat, SEXP Routmat, SEXP Routcol) {
BigMatrix *inMat = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(Rinmat));
BigMatrix *outMat = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(Routmat));
double outCol = NUMERIC_DATA(Routcol)[0];
if (inMat->separated_columns() != outMat->separated_columns())
Rf_error("all big matrices are not the same column separated type");
if (inMat->matrix_type() != outMat->matrix_type())
Rf_error("all big matrices are not the same matrix type");
if (inMat->ncol() != outMat->nrow())
Rf_error("inMat # of cols must be the same as outMat # of rows");
CALL_BIGFUNCTION_ARGS_THREE(ComputePvals, inMat, outMat, outCol)
return(ret);
}
USER_OBJECT_
RGnumeric_workbookReference(Workbook *sheet)
{
USER_OBJECT_ ans, klass;
double val = (double) (long) sheet;
PROTECT(ans = NEW_NUMERIC(1));
NUMERIC_DATA(ans)[0] = val;
PROTECT(klass = NEW_CHARACTER(1));
SET_STRING_ELT(klass, 0, COPY_TO_USER_STRING("GnumericWorkbookRef"));
SET_CLASS(ans, klass);
UNPROTECT(2);
return(ans);
}
/*
Creates
Note that we could use the conversion used
by the .C() routine to convert the objects
in both directions.
*/
USER_OBJECT_
RS_GGOBI(variableToRS)(gint index, ggobid *gg)
{
GGobiData *d = NULL;
gint n, i;
USER_OBJECT_ obj;
if (g_slist_length (gg->d) == 1)
d = (GGobiData *) g_slist_nth_data (gg->d, 0);
else return(NULL_USER_OBJECT);
n = d->nrows;
PROTECT(obj = NEW_NUMERIC(n));
for(i = 0 ; i < n ; i++) {
NUMERIC_DATA(obj)[i] = d->raw.vals[index][i];
}
UNPROTECT(1);
return (obj);
}
static SEXP php_zval_to_r(zval **value) /* {{{ */
{
SEXP result = NULL_USER_OBJECT;
switch (Z_TYPE_PP(value)) {
case IS_LONG:
PROTECT(result = NEW_INTEGER(1));
INTEGER_DATA(result)[0] = Z_LVAL_PP(value);
UNPROTECT(1);
break;
case IS_DOUBLE:
PROTECT(result = NEW_NUMERIC(1));
NUMERIC_DATA(result)[0] = Z_DVAL_PP(value);
UNPROTECT(1);
break;
case IS_STRING:
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(Z_STRVAL_PP(value)));
UNPROTECT(1);
break;
case IS_BOOL:
PROTECT(result = NEW_LOGICAL(1));
LOGICAL_DATA(result)[0] = Z_BVAL_PP(value);
UNPROTECT(1);
break;
case IS_ARRAY:
result = php_hash_to_r(Z_ARRVAL_PP(value));
break;
default:
convert_to_string_ex(value);
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(Z_STRVAL_PP(value)));
UNPROTECT(1);
break;
}
return result;
}
USER_OBJECT_
makeRSReferenceObject(char *id, USER_OBJECT_ classes, ForeignReferenceTable *table)
{
USER_OBJECT_ ans, names, tmp;
char *slotNames[] = {"id", "table", "pid", "class"};
int i;
if(classes && GET_LENGTH(classes)) {
PROTECT(classes);
}
PROTECT(ans = NEW_LIST(NUM_REF_SLOTS));
SET_VECTOR_ELT(ans, ID_SLOT, tmp = NEW_CHARACTER(1));
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(id));
SET_VECTOR_ELT(ans, TABLE_SLOT, tmp = NEW_CHARACTER(1));
/* No name yet. */
SET_VECTOR_ELT(ans, PID_SLOT, tmp = NEW_NUMERIC(1));
NUMERIC_DATA(tmp)[0] = getpid();
PROTECT(names = NEW_CHARACTER(NUM_REF_SLOTS));
for(i = 0; i < NUM_REF_SLOTS; i++)
SET_STRING_ELT(names, i, COPY_TO_USER_STRING(slotNames[i]));
SET_NAMES(ans, names);
if(classes && GET_LENGTH(classes))
SET_CLASS(ans, classes);
UNPROTECT(2);
if(GET_LENGTH(classes)) {
UNPROTECT(1);
}
return(ans);
}
/* Determines whether we can use the error information from the
source object and if so, throws that as an error.
If serr is non-NULL, then the error is not thrown in R
but a COMSErrorInfo object is returned with the information in it.
*/
HRESULT
checkErrorInfo(IUnknown *obj, HRESULT status, SEXP *serr)
{
HRESULT hr;
ISupportErrorInfo *info;
fprintf(stderr, "<checkErrorInfo> %X \n", (unsigned int) status);
if(serr)
*serr = NULL;
hr = obj->QueryInterface(IID_ISupportErrorInfo, (void **)&info);
if(hr != S_OK) {
fprintf(stderr, "No support for ISupportErrorInfo\n");fflush(stderr);
return(hr);
}
info->AddRef();
hr = info->InterfaceSupportsErrorInfo(IID_IDispatch);
info->Release();
if(hr != S_OK) {
fprintf(stderr, "No support for InterfaceSupportsErrorInfo\n");fflush(stderr);
return(hr);
}
IErrorInfo *errorInfo;
hr = GetErrorInfo(0L, &errorInfo);
if(hr != S_OK) {
/* fprintf(stderr, "GetErrorInfo failed\n");fflush(stderr); */
COMError(status);
return(hr);
}
/* So there is some information for us. Use it. */
SEXP klass, ans, tmp;
BSTR ostr;
char *str;
errorInfo->AddRef();
if(serr) {
PROTECT(klass = MAKE_CLASS("SCOMErrorInfo"));
PROTECT(ans = NEW(klass));
PROTECT(tmp = NEW_CHARACTER(1));
errorInfo->GetSource(&ostr);
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(FromBstr(ostr)));
SET_SLOT(ans, Rf_install("source"), tmp);
UNPROTECT(1);
PROTECT(tmp = NEW_CHARACTER(1));
errorInfo->GetDescription(&ostr);
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(str = FromBstr(ostr)));
SET_SLOT(ans, Rf_install("description"), tmp);
UNPROTECT(1);
PROTECT(tmp = NEW_NUMERIC(1));
NUMERIC_DATA(tmp)[0] = status;
SET_SLOT(ans, Rf_install("status"), tmp);
*serr = ans;
UNPROTECT(3);
errorInfo->Release();
PROBLEM "%s", str
WARN;
} else {
errorInfo->GetDescription(&ostr);
str = FromBstr(ostr);
errorInfo->GetSource(&ostr);
errorInfo->Release();
PROBLEM "%s (%s)", str, FromBstr(ostr)
ERROR;
}
return(hr);
}
SV *
toPerl(USER_OBJECT_ val, Rboolean perlOwned)
{
int n = GET_LENGTH(val);
dTHX;
SV *sv = &sv_undef;
if(val == NULL_USER_OBJECT)
return(sv);
if(isRSReferenceObject(val)){
return(getForeignPerlReference(val));
}
if(GET_LENGTH(GET_CLASS(val))) {
SV *o = userLevelConversionToPerl(val);
if(!o)
return(o);
}
if(n == 1) {
if(IS_CHARACTER(val))
sv = newSVpv(CHAR_DEREF(STRING_ELT(val, 0)), 0);
else if(IS_LOGICAL(val))
sv = newSViv(LOGICAL_DATA(val)[0]);
else if(IS_INTEGER(val))
sv = newSViv(INTEGER_DATA(val)[0]);
else if(IS_NUMERIC(val))
sv = newSVnv(NUMERIC_DATA(val)[0]);
else if(IS_FUNCTION(val))
sv = RPerl_createRProxy(val);
} else {
AV *arr;
int i;
arr = newAV();
SvREFCNT_inc(arr);
if(n > 0)
av_extend(arr, n);
/* Did try using av_make() and storing the SVs in an array first, but didn't fix the problem
of bizarre array.
*/
for(i = 0; i < n ; i++) {
if(IS_CHARACTER(val))
sv = newSVpv(CHAR_DEREF(STRING_ELT(val, i)), 0);
else if(IS_LOGICAL(val))
sv = newSViv(LOGICAL_DATA(val)[i]);
else if(IS_INTEGER(val))
sv = newSViv(INTEGER_DATA(val)[i]);
else if(IS_NUMERIC(val))
sv = newSVnv(NUMERIC_DATA(val)[i]);
SvREFCNT_inc(sv);
av_push(arr, sv);
}
sv = (SV *) arr;
SvREFCNT_dec(arr);
#if 0
{SV *rv = newSVrv(arr, NULL);
sv = rv;
}
#endif
}
if(perlOwned)
#if 0 /*XXX Just experimenting */
sv = sv_2mortal(sv);
#else
sv = SvREFCNT_inc(sv);
#endif
return(sv);
}
/* {{{ proto mixed R::__call(string function_name, array arguments)
*/
static PHP_METHOD(R, __call)
{
char *func;
int func_len, error_occurred = 0, num_args;
zval *args;
SEXP e, fun, val, arg, next;
HashPosition pos;
zval **element;
SEXPTYPE type;
if (zend_parse_parameters(ZEND_NUM_ARGS() TSRMLS_CC, "sa", &func, &func_len, &args) == FAILURE) {
return;
}
fun = Rf_install(func);
if (!fun) {
RETURN_FALSE;
}
num_args = zend_hash_num_elements(Z_ARRVAL_P(args));
PROTECT(fun);
PROTECT(e = allocVector(LANGSXP, num_args + 1));
SETCAR(e, fun);
next = CDR(e);
for(zend_hash_internal_pointer_reset_ex(Z_ARRVAL_P(args), &pos);
zend_hash_get_current_data_ex(Z_ARRVAL_P(args), (void **)&element, &pos) == SUCCESS;
zend_hash_move_forward_ex(Z_ARRVAL_P(args), &pos)
) {
arg = php_zval_to_r(element);
SETCAR(next, arg);
next = CDR(next);
}
val = R_tryEval(e, R_GlobalEnv, &error_occurred);
if (error_occurred) {
UNPROTECT(2);
RETURN_FALSE;
}
/* okay, the call succeeded */
PROTECT(val);
if (val == NULL_USER_OBJECT || GET_LENGTH(val) == 0) {
/* ignore the return value */
} else if (php_is_r_primitive(val, &type)) {
int i;
array_init(return_value);
for (i = 0; i < GET_LENGTH(val); i++) {
switch (type) {
case STRSXP:
add_next_index_string(return_value, CHAR(STRING_ELT(val, 0)), 1);
break;
case LGLSXP:
add_next_index_bool(return_value, LOGICAL_DATA(val)[0] ? 1 : 0);
break;
case INTSXP:
add_next_index_long(return_value, INTEGER_DATA(val)[0]);
break;
case REALSXP:
add_next_index_double(return_value, NUMERIC_DATA(val)[0]);
break;
default:
add_next_index_null(return_value);
break;
}
}
UNPROTECT(3);
return;
}
UNPROTECT(3);
RETURN_TRUE;
}
SEXP print_result_R(Sites *site,int nsites,int numSeq,char **seq,char **rseq,int *seqLen,
double logev,double **opwm,int pwmLen,int id,char *sdyad,char *pwmConsensus,int numCycle,
double pvalueCutoff,double maxpFactor,int *geneID) {
register int i,j;
int cn[4];//maxHeaderLen;
int *seqCn;
SEXP PWM;
SEXP seqConsencus;
SEXP motifname;
SEXP motifname2;
SEXP returnData;
SEXP LengthSequence;
SEXP SequencesIdent;
SEXP StrandIdent;
SEXP AccessionIdent;
SEXP PositionIdent;
SEXP SeqIden;
SEXP PValue;
SEXP GADEMList;
PROTECT(returnData=NEW_LIST(5));
PROTECT(GADEMList=NEW_LIST(6));
PROTECT(PWM=allocMatrix(REALSXP,4,pwmLen));
PROTECT(seqConsencus=NEW_CHARACTER(1));
PROTECT(motifname=NEW_INTEGER(1));
PROTECT(motifname2=NEW_CHARACTER(1));
PROTECT(SequencesIdent=NEW_CHARACTER(nsites));
PROTECT(PositionIdent=NEW_INTEGER(nsites));
PROTECT(SeqIden=NEW_INTEGER(nsites));
PROTECT(StrandIdent=NEW_CHARACTER(nsites));
PROTECT(AccessionIdent=NEW_INTEGER(nsites));
PROTECT(PValue=NEW_NUMERIC(nsites));
PROTECT(LengthSequence=NEW_INTEGER(nsites));
int increment_sequence=0;
int compt=0;
seqCn=alloc_int(numSeq);
//maxHeaderLen=min(maxHeaderLen,MAX_SEQ_HEADER);
for (i=0; i<numSeq; i++) seqCn[i]=0;
for (i=0; i<nsites; i++) seqCn[site[i].seq]++;
for (i=0; i<4; i++) cn[i]=0;
for (i=0; i<numSeq; i++) {
if (seqCn[i]==0) cn[0]++;
if (seqCn[i]==1) cn[1]++;
if (seqCn[i]==2) cn[2]++;
if (seqCn[i]>2) cn[3]++;
}
if (seqCn) { free(seqCn); seqCn=NULL; }
for (i=0; i<nsites; i++) {
//SET_STRING_ELT(AccessionIdent,increment_sequence,mkChar(geneID[site[i].seq]));
INTEGER(AccessionIdent)[increment_sequence]=(geneID[site[i].seq]);
if (site[i].rev=='0') {
if (site[i].pos<0) {
char sequence_conca[100]="";
for (j=0; j<pwmLen+site[i].pos; j++) {
switch(seq[site[i].seq][j]) {
case 'a': strcat(sequence_conca,"A");break;
case 'c': strcat(sequence_conca,"C");break;
case 'g': strcat(sequence_conca,"G");break;
case 't': strcat(sequence_conca,"T");break;
case 'n': strcat(sequence_conca,"N");break;
default: break;
}
}
}
else {
char sequence_conca[100]="";
for (j=site[i].pos; j<min(seqLen[site[i].seq],site[i].pos+pwmLen); j++) {
switch(seq[site[i].seq][j]) {
case 'a': strcat(sequence_conca,"A");break;
case 'c': strcat(sequence_conca,"C");break;
case 'g': strcat(sequence_conca,"G");break;
case 't': strcat(sequence_conca,"T");break;
case 'n': strcat(sequence_conca,"N");break;
default: break;
}
}
SET_STRING_ELT(SequencesIdent,increment_sequence,mkChar(sequence_conca));
}
// print flanking region
for (j=site[i].pos+pwmLen; j<min(site[i].pos+pwmLen+FLANKING_BASES,seqLen[site[i].seq]); j++)
SET_STRING_ELT(StrandIdent,increment_sequence,mkChar("+"));
INTEGER(SeqIden)[increment_sequence]=site[i].seq+1;
INTEGER(PositionIdent)[increment_sequence]=site[i].pos+1;
DOUBLE_DATA(PValue)[increment_sequence]=site[i].pvalue;
increment_sequence=increment_sequence+1;
}
else {
if (site[i].pos<0) {
char sequence_conca[50]="";
//for (j=site[i].pos; j<0; j++) Rprintf("X");
for (j=0; j<pwmLen+site[i].pos; j++) {
switch(rseq[site[i].seq][j]) {
case 'a': strcat(sequence_conca,"A");break;
case 'c': strcat(sequence_conca,"C");break;
case 'g': strcat(sequence_conca,"G");break;
case 't': strcat(sequence_conca,"T");break;
case 'n': strcat(sequence_conca,"N");break;
default: break;
}
}
}
else {
char sequence_conca[50]="";
for (j=site[i].pos; j<min(seqLen[site[i].seq],site[i].pos+pwmLen); j++) {
switch(rseq[site[i].seq][j]) {
case 'a': strcat(sequence_conca,"A");break;
case 'c': strcat(sequence_conca,"C");break;
case 'g': strcat(sequence_conca,"G");break;
case 't': strcat(sequence_conca,"T");break;
case 'n': strcat(sequence_conca,"N");break;
default: break;
}
}
SET_STRING_ELT(SequencesIdent,increment_sequence,mkChar(sequence_conca));
}
if (site[i].pos+pwmLen-seqLen[site[i].seq]>0) {
//for (j=seqLen[site[i].seq]; j<site[i].pos+pwmLen; j++) Rprintf("X");
}
// print flanking region
for (j=site[i].pos+pwmLen; j<min(site[i].pos+pwmLen+FLANKING_BASES,seqLen[site[i].seq]); j++)
SET_STRING_ELT(StrandIdent,increment_sequence,mkChar("-"));
INTEGER(SeqIden)[increment_sequence]=site[i].seq+1;
INTEGER(PositionIdent)[increment_sequence]=seqLen[site[i].seq]-site[i].pos;
DOUBLE_DATA(PValue)[increment_sequence]=site[i].pvalue;
increment_sequence=increment_sequence+1;
}
}
for (int aa=0;aa<pwmLen;aa++)
{
for(int bb=0;bb<4;bb++)
{
NUMERIC_DATA(PWM)[compt]=opwm[aa][bb];
compt++;
}
}
SET_STRING_ELT(seqConsencus,0,mkChar(pwmConsensus));
INTEGER(LengthSequence)[0]=125;
INTEGER(motifname)[0]=id;
const char base[] = "m";
char filename [ FILENAME_MAX ];
int number = id;
/*Rprintf("%s%d", base, number);*/
SET_STRING_ELT(motifname2,0,mkChar(filename));
SET_VECTOR_ELT(returnData,0,seqConsencus);
SET_VECTOR_ELT(returnData,2,LengthSequence);
SET_VECTOR_ELT(returnData,4,motifname2);
SET_VECTOR_ELT(returnData,1,PWM);
SET_VECTOR_ELT(GADEMList,0,SequencesIdent);
SET_VECTOR_ELT(GADEMList,1,StrandIdent);
SET_VECTOR_ELT(GADEMList,2,PositionIdent);
SET_VECTOR_ELT(GADEMList,3,PValue);
SET_VECTOR_ELT(GADEMList,4,AccessionIdent);
SET_VECTOR_ELT(GADEMList,5,SeqIden);
SET_VECTOR_ELT(returnData,3,GADEMList);
UNPROTECT(13);
return (returnData);
}
HRESULT
R_convertRObjectToDCOM(SEXP obj, VARIANT *var)
{
HRESULT status;
int type = R_typeof(obj);
if(!var)
return(S_FALSE);
#ifdef RDCOM_VERBOSE
errorLog("Type of argument %d\n", type);
#endif
if(type == EXTPTRSXP && EXTPTR_TAG(obj) == Rf_install("R_VARIANT")) {
VARIANT *tmp;
tmp = (VARIANT *) R_ExternalPtrAddr(obj);
if(tmp) {
//XXX
VariantCopy(var, tmp);
return(S_OK);
}
}
if(ISCOMIDispatch(obj)) {
IDispatch *ptr;
ptr = (IDispatch *) derefRIDispatch(obj);
V_VT(var) = VT_DISPATCH;
V_DISPATCH(var) = ptr;
//XX
ptr->AddRef();
return(S_OK);
}
if(ISSInstanceOf(obj, "COMDate")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_DATE;
V_DATE(var) = val;
return(S_OK);
} else if(ISSInstanceOf(obj, "COMCurrency")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_R8;
V_R8(var) = val;
VariantChangeType(var, var, 0, VT_CY);
return(S_OK);
} else if(ISSInstanceOf(obj, "COMDecimal")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_R8;
V_R8(var) = val;
VariantChangeType(var, var, 0, VT_DECIMAL);
return(S_OK);
}
/* We have a complex object and we are not going to try to convert it directly
but instead create an COM server object to represent it to the outside world. */
if((type == VECSXP && Rf_length(GET_NAMES(obj))) || Rf_length(GET_CLASS(obj)) > 0 || isMatrix(obj)) {
status = createGenericCOMObject(obj, var);
if(status == S_OK)
return(S_OK);
}
if(Rf_length(obj) == 0) {
V_VT(var) = VT_VOID;
return(S_OK);
}
if(type == VECSXP || Rf_length(obj) > 1) {
createRDCOMArray(obj, var);
return(S_OK);
}
switch(type) {
case STRSXP:
V_VT(var) = VT_BSTR;
V_BSTR(var) = AsBstr(getRString(obj, 0));
break;
case INTSXP:
V_VT(var) = VT_I4;
V_I4(var) = R_integerScalarValue(obj, 0);
break;
case REALSXP:
V_VT(var) = VT_R8;
V_R8(var) = R_realScalarValue(obj, 0);
break;
case LGLSXP:
V_VT(var) = VT_BOOL;
V_BOOL(var) = R_logicalScalarValue(obj, 0) ? VARIANT_TRUE : VARIANT_FALSE;
break;
case VECSXP:
break;
}
return(S_OK);
}
