/* **** 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); }