#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#include <stdio.h>
#include <stdlib.h>
#include <Rembedded.h>
#include <Rmath.h>
#include <Rinterface.h>
#include <Rinternals.h>
#include <R_ext/Parse.h>
#include <R_ext/Arith.h>
#include <Rdefines.h>
typedef struct VECTOR_SEXPREC RVec;
extern uintptr_t R_CStackLimit;
extern int R_Signalhandlers;
//End R session
IV end_R() {
Rf_endEmbeddedR(0);
return EXIT_SUCCESS;
}
//Eval R command
RVec * eval_R(char * cmd) {
SEXP cmdSexp, cmdExpr, ans = R_NilValue;
ParseStatus status;
int i;
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(cmd));
cmdExpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
error("invalie cmd %s", cmd);
}
for(i=0; i<length(cmdExpr); i++) {
ans = eval(VECTOR_ELT(cmdExpr, i), R_GlobalEnv);
}
UNPROTECT(2);
return (RVec*)ans;
}
//Return the data type of R object
const char * getType(RVec * robj) {
SEXPTYPE type = TYPEOF((SEXP)robj);
switch(type) {
case NILSXP:
return "NILSXP";
case SYMSXP:
return "SYMSXP";
case LISTSXP:
return "LISTSXP";
case CLOSXP:
return "CLOSXP";
case ENVSXP:
return "ENVSXP";
case PROMSXP:
return "PROMSXP";
case LANGSXP:
return "LANGSXP";
case SPECIALSXP:
return "SPECIALSXP";
case BUILTINSXP:
return "BUILTINSXP";
case CHARSXP:
return "CHARSXP";
case LGLSXP:
return "LGLSXP";
case INTSXP:
return "INTSXP";
case REALSXP:
return "REALSXP";
case CPLXSXP:
return "CPLXSXP";
case STRSXP:
return "STRSXP";
case DOTSXP:
return "DOTSXP";
case ANYSXP:
return "ANYSXP";
case VECSXP:
return "VECSXP";
case EXPRSXP:
return "EXPRSXP";
case BCODESXP:
return "BCODESXP";
case EXTPTRSXP:
return "EXTPTRSXP";
case WEAKREFSXP:
return "WEAKREFSXP";
case RAWSXP:
return "RAWSXP";
case S4SXP:
return "S4SXP";
case FUNSXP:
return "FUNSXP";
default:
return "Unknown";
}
}
#define GET_VEC_NAME(x,y) CHAR(STRING_ELT(GET_NAMES(x), y)); //Equal to names(obj)
#define PUT_RV_2HV(x,y,z) hv_store(x, y, strlen(y), newRV_noinc(z), 0); //copy one sv z, make a rv and then store it into hv x with key named as y
//Fetch integer vector
AV * fetchINT(RVec * robj) {
AV * arr = newAV();
int len, i;
len = LENGTH((SEXP)robj);
for(i=0;i<len;i++) {
av_push(arr, newSViv((INTEGER((SEXP)robj))[i]));
}
return arr;
}
//Fetch real vector
AV * fetchREAL(RVec * robj) {
AV * arr = newAV();
int len, i;
len = LENGTH((SEXP)robj);
for(i=0;i<len;i++) {
av_push(arr, newSVnv((REAL((SEXP)robj))[i]));
}
return arr;
}
//Fetch string vector
AV * fetchSTR(RVec * robj) {
AV * arr = newAV();
int len, i;
len = LENGTH((SEXP)robj);
for(i=0;i<len;i++) {
av_push(arr, newSVpv(CHAR(STRING_ELT((SEXP)robj, i)), 0));
}
return arr;
}
//Fetch object(intsxp, realsxp, strsxp, vecsxp) value. Return a hash storing ref of av.
HV * fetchValue(RVec * robj) {
HV * res = newHV();
AV * arr;
int len, i;
RVec * v;
const char * name;
switch(TYPEOF((SEXP)robj)) {
case INTSXP:
arr = fetchINT(robj);
name = "int";
PUT_RV_2HV(res, name, (SV*)arr);
break;
case REALSXP:
arr = fetchREAL(robj);
name = "real";
PUT_RV_2HV(res, name, (SV*)arr);
break;
case STRSXP:
arr = fetchSTR(robj);
name = "str";
PUT_RV_2HV(res, name, (SV*)arr);
break;
case VECSXP:
len = LENGTH((SEXP)robj);
for(i=0;i<len;i++) {
name = GET_VEC_NAME((SEXP)robj, i);
v = (RVec*)VECTOR_ELT((SEXP)robj, i);
switch(TYPEOF((SEXP)v)) {
case INTSXP:
arr = fetchINT(v);
PUT_RV_2HV(res, name, (SV*)arr);
break;
case REALSXP:
arr = fetchREAL(v);
PUT_RV_2HV(res, name, (SV*)arr);
break;
case STRSXP:
arr = fetchSTR(v);
PUT_RV_2HV(res, name, (SV*)arr);
break;
case VECSXP:
PUT_RV_2HV(res, name, (SV*)fetchValue(v));
break;
default:
hv_store(res, name, strlen(name), &PL_sv_undef, 0);
}
}
break;
default:
hv_store(res, "null", 4, &PL_sv_undef, 0);
}
return res;
}
RVec * setINT(AV * intArr) {
RVec * intVec;
int i;
SV ** mem;
PROTECT((SEXP)(intVec = (RVec*)allocVector(INTSXP, av_len(intArr)+1)));
for(i=0;i<av_len(intArr)+1;i++) {
mem = av_fetch(intArr, i, 0);
if(SvTYPE(*mem)==SVt_PVIV || SvTYPE(*mem)==SVt_IV || SvTYPE(*mem)==SVt_PV) {
INTEGER((SEXP)intVec)[i] = SvIV(*mem);
}
else if(SvTYPE(*mem)==SVt_NULL) {
INTEGER((SEXP)intVec)[i] = NA_INTEGER;
}
else {
croak("Data No.%d is not integer number", i+1);
}
}
UNPROTECT(1);
return intVec;
}
RVec * setREAL(AV * realArr) {
RVec * realVec;
int i;
SV ** mem;
PROTECT((SEXP)(realVec = (RVec*)allocVector(REALSXP, av_len(realArr)+1)));
for(i=0;i<av_len(realArr)+1;i++) {
mem = av_fetch(realArr, i, 0);
if(SvTYPE(*mem)==SVt_PVNV || SvTYPE(*mem)==SVt_NV || SvTYPE(*mem)==SVt_PV) {
REAL((SEXP)realVec)[i] = SvNV(*mem);
}
else if(SvTYPE(*mem)==SVt_NULL) {
REAL((SEXP)realVec)[i] = NA_REAL;
}
else {
croak("Data No.%d is not real number", i+1);
}
}
UNPROTECT(1);
return realVec;
}
RVec * setSTR(AV * strArr) {
RVec * strVec;
int i;
SV ** mem;
PROTECT((SEXP)(strVec = (RVec*)allocVector(STRSXP, av_len(strArr)+1)));
for(i=0;i<av_len(strArr)+1;i++) {
mem = av_fetch(strArr, i, 0);
if(SvTYPE(*mem)==SVt_PV || SvTYPE(*mem) == SVt_PVIV || SVt_PVNV) {
SET_STRING_ELT((SEXP)strVec, i, mkChar(SvPV_nolen(*mem)));
}
else if(SvTYPE(*mem)==SVt_NULL){
SET_STRING_ELT((SEXP)strVec, i, NA_STRING);
}
else {
croak("Data No.%d is not string", i+1);
}
}
UNPROTECT(1);
return strVec;
}
MODULE = Statistics::useR PACKAGE = Statistics::useR
IV
init_R(optc=0,opts=NULL)
int optc;
char ** opts;
PREINIT:
char * defArgv[] = {"REmbedded", "--quiet", "--vanilla"};
CODE:
if(opts==NULL){opts = defArgv; optc = sizeof(defArgv)/sizeof(char*);}
R_SignalHandlers = 0;
RETVAL = Rf_initEmbeddedR(optc, opts);
R_CStackLimit = -1;
OUTPUT:
RETVAL
RVec * eval_R(cmd)
char * cmd;
IV
end_R()
MODULE = Statistics::useR PACKAGE = Statistics::RData
const char *
getType(rObj)
RVec * rObj;
IV
getLen(rObj)
RVec * rObj;
CODE:
RETVAL = LENGTH((SEXP)rObj);
OUTPUT:
RETVAL
AV *
getNames(rObj)
RVec * rObj;
PREINIT:
RVec * names;
AV * nameAV;
int i;
CODE:
names = (RVec*)GET_NAMES((SEXP)rObj);
nameAV = (AV*)sv_2mortal((SV*)newAV());
for(i=0;i<LENGTH((SEXP)names);i++) {
av_push(nameAV, newSVpv((CHAR(STRING_ELT((SEXP)names,i))), 0));
}
RETVAL = nameAV;
OUTPUT:
RETVAL
HV *
getDimNames(rObj)
RVec * rObj;
PREINIT:
HV * nameHV;
AV * nameAV;
RVec * dimNames;
RVec * names;
int i,j;
char name[2];
CODE:
nameHV = (HV*)sv_2mortal((SV*)newHV());
dimNames = (RVec*)GET_DIMNAMES((SEXP)rObj);
if(TYPEOF((SEXP)dimNames)!=VECSXP) {
nameHV=(HV*)&PL_sv_undef;
}
else {
for(i=0;i<LENGTH((SEXP)dimNames);i++) {
nameAV = newAV();
names = (RVec*)VECTOR_ELT((SEXP)dimNames,i);
for(j=0;j<LENGTH((SEXP)names);j++) {
av_push(nameAV, newSVpv((CHAR(STRING_ELT((SEXP)names,j))), 0));
}
sprintf(name, "%c", i+48);
hv_store(nameHV, name, strlen(name), newRV_noinc((SV*)nameAV), 0);
}
}
RETVAL = nameHV;
OUTPUT:
RETVAL
HV *
getValue(rObj)
RVec * rObj;
CODE:
RETVAL = (HV*)sv_2mortal((SV*)fetchValue(rObj));
OUTPUT:
RETVAL
RVec *
setValue(dataHV, typeHV, keyCount)
HV * dataHV;
HV * typeHV; //Contains 'int', 'real', 'str'
IV keyCount;
PREINIT:
RVec * res;
RVec * names;
AV * keys;
AV * colvalue;
int i,j,k;
char * key;
CODE:
if(SvROK(ST(0)) && SvTYPE(SvRV(ST(0)))==SVt_PVHV) {
dataHV = (HV*)SvRV(ST(0));
}
else {
croak("First argument is not hash ref");
}
typeHV = (HV*)SvRV(ST(1));
keyCount = SvIV(ST(2));
PROTECT((SEXP)(res = (RVec*)allocVector(VECSXP, keyCount)));
PROTECT((SEXP)(names = (RVec*)allocVector(STRSXP, keyCount)));
keys = (AV*)(SvRV(*(hv_fetch(typeHV, "str", 3, 0))));
for(i=0;i<=av_len(keys);i++) {
key = SvPV_nolen(*(av_fetch(keys, i, 0)));
SET_STRING_ELT((SEXP)names, i, mkChar(key));
colvalue = (AV*)(SvRV(*(hv_fetch(dataHV, key, strlen(key),0))));
SET_VECTOR_ELT((SEXP)res, i, (SEXP)setSTR(colvalue));
}
i = av_len(keys);
keys = (AV*)(SvRV(*(hv_fetch(typeHV, "int", 3, 0))));
for(j=0;j<=av_len(keys);j++) {
key = SvPV_nolen(*(av_fetch(keys, j, 0)));
SET_STRING_ELT((SEXP)names, (i+j+1), mkChar(key));
colvalue = (AV*)(SvRV(*(hv_fetch(dataHV, key, strlen(key),0))));
SET_VECTOR_ELT((SEXP)res, (i+j+1), (SEXP)setINT(colvalue));
}
j = av_len(keys);
keys = (AV*)(SvRV(*(hv_fetch(typeHV, "real", 4, 0))));
for(k=0;k<=av_len(keys);k++) {
key = SvPV_nolen(*(av_fetch(keys, k, 0)));
SET_STRING_ELT((SEXP)names, (i+j+k+2), mkChar(key));
colvalue = (AV*)(SvRV(*(hv_fetch(dataHV, key, strlen(key),0))));
SET_VECTOR_ELT((SEXP)res, (i+j+k+2), (SEXP)setREAL(colvalue));
}
SET_NAMES((SEXP)res, (SEXP)names);
UNPROTECT(2);
RETVAL = res;
OUTPUT:
RETVAL
void
insVar(var, varName)
RVec * var;
char * varName;
CODE:
defineVar(install(varName), (SEXP)var, R_GlobalEnv);