/* **** PA_UnpackInput ****
* The input parameters/data to the ParallelAgent is given as an R vector.
* This function unpacks the vector, putting the pieces into the appropriate
* variables.
*/
int PA_UnpackInput(SEXP sxInputVector, int *ipDims, double **dppA,
double **dppB, int *ipNumProcs, int *ipFunction, int *ipSpawnFlag) {
SEXP s;
int iMB;
int ipReleaseFlag;
/* First parameter is the first matrix. --populates ipDims[0] and ipDims[1] */
/* Second parameter is the second matrix. --populates ipDims[2] and ipDims[3] */
/* Third Parameter is number of Process Rows -- populates ipDims[6] = NPROWS*/
/* Fourth Parameter is number of Process Cols -- populates ipDims[7] = NPCOLS */
/* Fifth Parameter is Block Size -- populates ipDims[4] =ipDims [5]= MB */
/* Sixth Parameter is function identifier -- populates ipDims[8] = functionID */
/* Seventh parameter --- Instruction to Release Grid or not -- populates ipDims[9]=ReleaseFlag */
/* Eighth parameter --- Instruction to Spawn Grid or not*/
/* First parameter is the first matrix. --populates ipDims[0] and ipDims[1] */
s = VECTOR_PTR(sxInputVector)[0];
if (TYPEOF(s) != REALSXP) {
Rprintf("1st parameter (Matrix A) is not an array of doubles.\n");
return -1;
}
if (PA_GetTwoDims(s, ipDims) > 2) {
Rprintf("1st parameter (Matrix A) has too many dimensions.\n");
return -2;
}
/* If the object is one dimensional, set the second dimension to length 1 */
if (ipDims[1] == 0) ipDims[1] = 1;
/* Save a pointer to the first matrix */
*dppA = REAL(s);
/* Second parameter is the second matrix. --populates ipDims[2] and ipDims[3] */
s = VECTOR_PTR(sxInputVector)[1];
if (TYPEOF(s) != REALSXP) {
Rprintf("2nd parameter (Matrix B) is not an array of doubles.\n");
return -3;
}
if (PA_GetTwoDims(s, ipDims + 2) > 2) {
Rprintf("2nd parameter (Matrix B) has too many dimensions.\n");
return -4;
}
/* If the object is one dimensional, set the second dimension to length 1,
* unless the length is zero (i.e, there is no second matrix). */
if (ipDims[3] == 0 && LENGTH(s) != 0) ipDims[3] = 1;
/* Save a pointer to the second matrix */
*dppB = REAL(s);
/* Third Parameter is number of Process Rows -- populates ipDims[6] = NPROWS*/
s = VECTOR_PTR(sxInputVector)[2];
if (TYPEOF(s) != INTSXP) {
Rprintf("Third parameter (number of row processors) is not an integer.\n");
return -5;
}
if (LENGTH(s) != 1) {
Rprintf("First parameter (number of row processors) is not a single number.\n");
return -6;
}
ipDims[6] = INTEGER(s)[0];
/* Fourth Parameter is number of Process Cols -- populates ipDims[7] = NPCOLS */
s = VECTOR_PTR(sxInputVector)[3];
if (TYPEOF(s) != INTSXP) {
Rprintf("Fourth parameter (number of col processors) is not an integer.\n");
return -7;
}
if (LENGTH(s) != 1) {
Rprintf("Fourth parameter (number of col processors) is not a single number.\n");
return -8;
}
ipDims[7] = INTEGER(s)[0];
*ipNumProcs = ipDims[6] * ipDims[7]; /* iNumProcs = iNPRows * iNPCols */
/* Fifth Parameter is Block Size -- populates ipDims[4] =ipDims [5]= MB */
s = VECTOR_PTR(sxInputVector)[4];
if (TYPEOF(s) != INTSXP) {
Rprintf("Fifth parameter (row block size of LHS matrix) is not an integer.\n");
return -9;
}
if (LENGTH(s) != 1) {
Rprintf("Fifth parameter (row block size of LHS matrix) is not a single number.\n");
return -10;
}
iMB = INTEGER(s)[0];
/* !!! If the block size is larger than the input size, reduce the block
* size down to the size of the input. Needed for the eigen function.
*/
if (iMB > ipDims[0] && iMB > ipDims[1] && iMB > ipDims[2] &&
iMB > ipDims[3])
iMB = max(ipDims[0], max(ipDims[1], max(ipDims[2], ipDims[3])));
/* Once upon a time, the block dimensions were taken as two inputs. Now,
* the blocksize is forced to be square.
*/
ipDims[4] = ipDims[5] = iMB;
/* Sixth Parameter is function identifier -- populates ipDims[8] = functionID */
s = VECTOR_PTR(sxInputVector)[5];
if (TYPEOF(s) != INTSXP) {
Rprintf("Sixth parameter (function) is not an integer.\n");
return -11;
}
if (LENGTH(s) != 1) {
Rprintf("Sixth parameter (function) is not a single number.\n");
return -12;
}
*ipFunction = INTEGER(s)[0];
if (*ipFunction < 0 || *ipFunction > 7) {
Rprintf("Error: Unknown function ID (%d).\n", *ipFunction);
return -13;
}
ipDims[8]= *ipFunction;
/* Seventh parameter --- Instruction to Release Grid or not -- populates ipDims[9]=ReleaseFlag */
/* Populating ipDims array is complete ... */
s = VECTOR_PTR(sxInputVector)[6];
if (TYPEOF(s) != INTSXP) {
Rprintf("Seventh parameter (function) is not an integer.\n");
return -11;
}
ipReleaseFlag = INTEGER(s)[0];
if(ipReleaseFlag != 0 && ipReleaseFlag != 1) {
Rprintf ("Warning: Proper value for Release Flag= %d not used \n \t Release Flag is set to 1 \n", ipReleaseFlag );
ipReleaseFlag = 1;
}
ipDims[9]= ipReleaseFlag;
/* ipSpawnFlag is the information sent from R to ParallelAgent requesting
* it either to spawn the processes or not to spawn (use the existing ones)
*/
/* Eighth parameter --- Instruction to Spawn Grid or not*/
s = VECTOR_PTR(sxInputVector)[7];
if (TYPEOF(s) != INTSXP) {
Rprintf("Sixth parameter (function) is not an integer.\n");
return -11;
}
*ipSpawnFlag = INTEGER(s)[0];
D_Rprintf(("spawn flag : %d \n", *ipSpawnFlag));
return 0;
}
// [[Rcpp::register]]
SEXP* get_vector_ptr(SEXP x){
return VECTOR_PTR(x) ;
}
SEXP
R_readFromJSON(SEXP r_input, SEXP depth, SEXP allowComments, SEXP func, SEXP data, SEXP maxChar)
{
JSON_config conf;
struct JSON_parser_struct *parser;
SEXP ans = R_NilValue;
int do_unprotect = 1;
RJSONParserInfo info = {NULL, NULL, CE_NATIVE};
init_JSON_config(&conf);
conf.depth = INTEGER(depth)[0];
conf.allow_comments = LOGICAL(allowComments)[0];
/* Handle the callback function and data here. First the C routines and data context.*/
if(Rf_length(data)) {
SEXP tmp = VECTOR_ELT(data, 1);
void *ptr;
switch(TYPEOF(tmp)) {
case NILSXP:
ptr = NULL;
break;
case INTSXP:
case LGLSXP:
ptr = INTEGER(tmp);
break;
case REALSXP:
ptr = REAL(tmp);
break;
case VECSXP:
ptr = VECTOR_PTR(tmp);
break;
default:
ptr = NULL;
}
conf.callback = (JSON_parser_callback) R_ExternalPtrAddr(VECTOR_ELT(data, 0));
conf.callback_ctx = ptr;
do_unprotect = 0;
} else if(func != R_NilValue && TYPEOF(func) == CLOSXP) {
/* we have a function*/
SEXP e;
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, func);
SETCAR(CDR(e), allocVector(INTSXP, 1));
SET_NAMES(CAR(CDR(e)), info.names = NEW_CHARACTER(1));
SETCAR(CDR(CDR(e)), R_NilValue);
info.func = e;
ans = R_NilValue;
conf.callback = R_json_basicCallback;
conf.callback_ctx = &info;
} else if(func == R_NilValue)
PROTECT(ans = NEW_LIST(1));
else { /* You what? */
PROBLEM "unhandled type of R object as handler function %d", TYPEOF(func)
ERROR;
}
parser = new_JSON_parser(&conf);
if(inherits(r_input, "connection")) {
R_json_parse_connection(r_input, maxChar, parser);
} else {
R_json_parse_character(r_input, maxChar, parser);
}
if(do_unprotect)
UNPROTECT(1);
return(ans);
}
