SEXP R_SUMA_HistString (SEXP SCallingFunc, SEXP Sarg, SEXP Shold) {
char *CallingFunc=NULL;
SEXP Rname = R_NilValue;
char *fname = NULL, *hold=NULL, **arg=NULL, *res=NULL;
int debug=0, nprot=0, narg=0, i= 0;
if (!debug) debug = get_odebug();
if (isNull(SCallingFunc) || isNull(Sarg)) {
ERROR_message("Null input to R_SUMA_HistString");
return(Rname);
}
/* get the executable name */
PROTECT(SCallingFunc = AS_CHARACTER(SCallingFunc)); ++nprot;
fname = R_alloc(strlen(CHAR(STRING_ELT(SCallingFunc,0)))+1, sizeof(char));
strcpy(fname, CHAR(STRING_ELT(SCallingFunc,0)));
if (debug) INFO_message("filename %s\n", fname);
/* get the arg */
PROTECT(Sarg = AS_CHARACTER(Sarg)); ++nprot;
narg = (LENGTH(Sarg));
arg = (char **)calloc(narg+1, sizeof(char *));
if (fname) arg[0] = strdup(fname);
else arg[0] = strdup("UnChevalSansNom");
for (i=1; i<=narg; ++i) {
arg[i] = (char *)calloc(strlen(CHAR(STRING_ELT(Sarg,i-1)))+1,
sizeof(char));
strcpy(arg[i], CHAR(STRING_ELT(Sarg,i-1)));
if (debug) INFO_message("arg %d/%d %s\t", i, narg, arg[i]);
}
/* any old history ? */
if (!isNull(Shold)) {
PROTECT(Shold = AS_CHARACTER(Shold)); ++nprot;
hold = R_alloc(strlen(CHAR(STRING_ELT(Shold,0)))+1, sizeof(char));
strcpy(hold, CHAR(STRING_ELT(Shold,0)));
if (debug) INFO_message("hold %s\n", hold);
}
if (( res = SUMA_HistString (fname, narg+1, arg, hold))) {
PROTECT(Rname = allocVector(STRSXP, 1)); ++nprot;
SET_STRING_ELT(Rname, 0, mkChar(res));
if (debug) INFO_message("hist is %s\n", res);
SUMA_free(res); res=NULL;
} else {
ERROR_message("Call to SUMA_HistString %s failed", fname);
}
for (i=0; i<=narg; ++i) { if (arg[i]) free(arg[i]); } free(arg); arg=NULL;
UNPROTECT(nprot);
return(Rname);
}
SEXP R_SUMA_ParseModifyName(SEXP Sfname, SEXP Swhat, SEXP Sval, SEXP Scwd)
{
SEXP Rname = R_NilValue;
char *fname = NULL, *what=NULL, *val=NULL, *cwd=NULL, *res=NULL;
int debug=0, nprot=0;
if (!debug) debug = get_odebug();
if (isNull(Sfname) || isNull(Swhat) || isNull(Sval)) {
ERROR_message("Null input to R_SUMA_ModifyName");
return(Rname);
}
/* get the filename */
PROTECT(Sfname = AS_CHARACTER(Sfname)); ++nprot;
fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char));
strcpy(fname, CHAR(STRING_ELT(Sfname,0)));
if (debug) INFO_message("filename %s\n", fname);
/* get the what */
PROTECT(Swhat = AS_CHARACTER(Swhat)); ++nprot;
what = R_alloc(strlen(CHAR(STRING_ELT(Swhat,0)))+1, sizeof(char));
strcpy(what, CHAR(STRING_ELT(Swhat,0)));
if (debug) INFO_message("what %s\n", what);
/* get the val */
PROTECT(Sval = AS_CHARACTER(Sval)); ++nprot;
val = R_alloc(strlen(CHAR(STRING_ELT(Sval,0)))+1, sizeof(char));
strcpy(val, CHAR(STRING_ELT(Sval,0)));
if (debug) INFO_message("val %s\n", val);
/* get the cwd */
if (!isNull(Scwd)) {
PROTECT(Scwd = AS_CHARACTER(Scwd)); ++nprot;
cwd = R_alloc(strlen(CHAR(STRING_ELT(Scwd,0)))+1, sizeof(char));
strcpy(cwd, CHAR(STRING_ELT(Scwd,0)));
if (debug) INFO_message("cwd %s\n", cwd);
}
if (debug) INFO_message("Modifying %s\n", fname);
if ((res = SUMA_ModifyName(fname, what, val, cwd))) {
PROTECT(Rname = allocVector(STRSXP, 1)); ++nprot;
SET_STRING_ELT(Rname, 0, mkChar(res));
SUMA_free(res); res=NULL;
} else {
ERROR_message("Call to SUMA_ModifyName %s %s %s failed", fname, what, val);
}
UNPROTECT(nprot);
return(Rname);
}
//----------------------------------------------------------------------------
SEXP dbnGenerateEvidences(SEXP net, SEXP numSlices)
{
SEXP res;
int flag = -1;
PROTECT(net = AS_INTEGER(net));
int NetNum = INTEGER_VALUE(net);
PROTECT(numSlices = AS_CHARACTER(numSlices));
char * arg1 = CHAR(asChar(numSlices));
try
{
pDBNs[NetNum]->GenerateEvidences(arg1);
}
catch (pnl::CException &E)
{
ErrorString = E.GetMessage();
flag = 1;
}
catch(...)
{
ErrorString = "Unrecognized exception during execution of GenerateEvidences function";
flag = 1;
}
PROTECT(res = NEW_INTEGER(1));
int * pres = INTEGER_POINTER(res);
pres[0] = flag;
UNPROTECT(3);
return (res);
}
void SEXP_to_pchar(SEXP val_sexp, char* val, int max_num) {
PROTECT(val_sexp=AS_CHARACTER(val_sexp));
const char *pcstring = CHAR(CHARACTER_POINTER(val_sexp)[0]);
if(strlen(pcstring)<max_num)
strcpy(val,pcstring);
else
error("character string too long\n");
UNPROTECT(1);
}
static R_INLINE void setrownames (SEXP x, SEXP names, int n) {
int nprotect = 0;
SEXP dimnms, nm;
PROTECT(nm = AS_CHARACTER(names)); nprotect++;
PROTECT(dimnms = allocVector(VECSXP,n)); nprotect++;
SET_ELEMENT(dimnms,0,nm); // set row names
SET_DIMNAMES(x,dimnms);
UNPROTECT(nprotect);
}
/**
* @brief Summarizes a list of vectors into a list of binned vectors of equal length. Each vector bin summarizes an approximately equal amount of values.
*
* @param method Charater array defining the method to be used for binning. Can be 'mean' 'median' or 'max'
* @param score_list List with numeric vectors
* @param window_size Window width of the vectors that will be returned
* @return List with updated vectors
* @details Walks through the vectors and calls shrink or expand to set vectors to equal widths
* @note Nothing
* @todo Nothing
*/
SEXP approx_window(SEXP window_count, SEXP score_list, SEXP method) {
const char *methodn = STRING_VALUE(method);
const int wsize=INTEGER_VALUE(window_count);
SEXP lnames = getAttrib(score_list, R_NamesSymbol);
SEXP ori_vec,new_vec,out_names,out_list;
int elcount=0,elements=LENGTH(lnames),upc=0,olen;
signal(SIGINT,SIG_DFL);
PROTECT(lnames = AS_CHARACTER(lnames));
upc++;
PROTECT(out_list = allocVector(VECSXP, elements));
upc++;
PROTECT(out_names = allocVector(STRSXP,elements));
upc++;
//Select proper call back
double (*summarizep)(int *,int,double *);
if(!strcmp(methodn,"mean")) {
summarizep=mean_dble;
} else if(!strcmp(methodn,"median")) {
summarizep=median_dble;
} else if(!strcmp(methodn,"max")) {
summarizep=vect_max_dble;
} else {
error("%s not known",methodn);
goto FINALIZE;
}
for(; elcount<elements; ++elcount) {
PROTECT(ori_vec=AS_NUMERIC(VECTOR_ELT(score_list, elcount)));
PROTECT(new_vec = NEW_NUMERIC(wsize));
olen=LENGTH(ori_vec);
double *ori_vecp= NUMERIC_POINTER(ori_vec);
double *new_vecp= NUMERIC_POINTER(new_vec);
SET_STRING_ELT(out_names,elcount,mkChar(CHAR(STRING_ELT(lnames, elcount))));
if(olen>wsize) {
shrink_dble(ori_vecp,new_vecp,olen,wsize,summarizep);
SET_VECTOR_ELT(out_list, elcount, new_vec);
} else if(olen<wsize) {
expand_dble(ori_vecp,new_vecp,olen,wsize);
SET_VECTOR_ELT(out_list, elcount, new_vec);
} else {
SET_VECTOR_ELT(out_list, elcount, ori_vec);
}
UNPROTECT(2);
}
setAttrib(out_list, R_NamesSymbol, out_names);
FINALIZE:
UNPROTECT(upc);
return(out_list);
}
static R_INLINE SEXP matchnames (SEXP x, SEXP names, const char *where) {
int nprotect = 0;
int n = length(names);
int *idx, k;
SEXP index, nm;
PROTECT(nm = AS_CHARACTER(names)); nprotect++;
PROTECT(index = match(x,names,0)); nprotect++;
idx = INTEGER(index);
for (k = 0; k < n; k++) {
if (idx[k]==0)
error("variable '%s' not found among the %s",
CHARACTER_DATA(STRING_ELT(nm,k)),
where);
idx[k] -= 1;
}
UNPROTECT(nprotect);
return index;
}
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);
}
/**
* @brief Sets optionally provided filter which is passed from R as a list
*
* @param filterList passed from R in the form list("chr1"=c(100,200,3000,3010...start,end...))
* @param ft pointer to struct filter
* @return upc -> unprotect counter to remember SEXPs to unprotect
* @details This function processes the filter passed from R and makes it compatible to work on the densities
* @note Filters are used after the density has been copied
* @todo nothing.
*/
int set_filter(SEXP filterList, filter_t * ft){
SEXP fnames = getAttrib(filterList, R_NamesSymbol);
SEXP fvals;
int flen=LENGTH(fnames),upc=0;
ft->sequence_name = (char**)Calloc(flen,char*);
ft->values = (int32_t **)Calloc(flen,int32_t*);
ft->value_length = (int32_t *)Calloc(flen,int32_t);
PROTECT(fnames = AS_CHARACTER(fnames));upc++;
int j=0;
for(;j<flen;j++){
PROTECT(fvals=AS_INTEGER(VECTOR_ELT(filterList, j)));upc++;
ft->sequence_name[j] = Calloc(strlen(CHAR(STRING_ELT(fnames, j))), char);
strcpy(ft->sequence_name[j], CHAR(STRING_ELT(fnames, j)));
ft->values[j] = INTEGER_POINTER(fvals);
ft->value_length[j] = LENGTH(VECTOR_ELT(filterList, j));
if(ft->value_length[j]<2)error("Filter must have the form: list('chr1'=c(100,200,3000,3010,start,end,...),...");
}
ft->seqn=flen;
return(upc);
}
/*
* plr_quote_literal() - quote literal strings that are to
* be used in SPI_exec query strings
*/
SEXP
plr_quote_literal(SEXP rval)
{
const char *value;
text *value_text;
text *result_text;
SEXP result;
/* extract the C string */
PROTECT(rval = AS_CHARACTER(rval));
value = CHAR(STRING_ELT(rval, 0));
/* convert using the pgsql quote_literal function */
value_text = PG_STR_GET_TEXT(value);
result_text = DatumGetTextP(DirectFunctionCall1(quote_literal, PointerGetDatum(value_text)));
/* copy result back into an R object */
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(PG_TEXT_GET_STR(result_text)));
UNPROTECT(2);
return result;
}
SEXP docDF(SEXP directory,
SEXP origF,
SEXP fileN,
SEXP ft,
SEXP type,
SEXP pos,
SEXP posN,
SEXP minFreq,
SEXP N,
// SEXP sym,
// SEXP kigo,
SEXP Genkei,
SEXP nDF,
SEXP mydic ){
// Rprintf("BUF1 = %i\n", BUF1); //
// Rprintf("BUF2 = %i\n", BUF2); //
// Rprintf("BUF3 = %i\n", BUF3); //
// Rprintf("BUF4 = %i\n", BUF4); //
// Rprintf("FILEINPUT = %i\n", FILEINPUT); //
int file = 0, n0 = 0, i = 0, j = 0, pc = 0, xx = 1;
const char* dic = CHAR(STRING_ELT(mydic, 0));//指定辞書
int f_count = INTEGER_VALUE( fileN );//ファイル(行)数
char* path = 0;// 2011 03 11 char* path;
// 2011 03 10 // char * f[f_count];
vector <string> ff;
//const char* KIGO = CHAR(STRING_ELT(kigo,0));
int typeSet = INTEGER_VALUE( type );// 形態素か，品詞か，文字か
int Ngram = INTEGER_VALUE( N );// N の数
int mFreq = INTEGER_VALUE( minFreq );// 最小頻度の数
if(mFreq < 1){
mFreq = 1;
}
//int mSym = INTEGER_VALUE( sym );// 記号を含めるか 0 含めない;1 含める
int NDF = INTEGER_VALUE( nDF );// データフレームの列数
int genkei = INTEGER_VALUE( Genkei );// 活用は原型か 0 表層形か 1
char file_name[FILEN];
char input[BUF4];
char * p;
string str;
char buf1[BUF1];// [512];//入力された語形を記憶
// char buf2[1024];
char buf3[BUF1];// [512];品詞チェック用
char buf4[BUF1];// [1024];品詞チェック用
SEXP tmp, row_names, mydf = R_NilValue, varlabels = R_NilValue;// 2011 03 11 // SEXP mydf, tmp, row_names, varlabels;// SEXP ans, dim, dimnames, row_names, col_names;
int mFt = INTEGER_VALUE( ft );// ファイル 0 かディレクトリ 1 かデータフレーム列か2
/////
FILE *fp;// 2009 04 03
map<string, int> ma0;//, ma[f_count]; // ファイル数の数+登録単語用マップの数1
vector <map<string, int> > vecmap;// 2011 03 09
for (i = 0; i < f_count; i++) vecmap.push_back(map<string, int>() );
map<string, int>::iterator pma0, pma;// マップ検索用
list <string> hinsi, strL, saibun;
list <string>::iterator hinsi_it, iter, saibun_it;// 2009 04 03
/////
// Rprintf("f_file = %i\n", f_count); // 2011 03 09
PROTECT(directory = AS_CHARACTER(directory));pc++;
PROTECT(origF = AS_CHARACTER(origF));pc++;//ファイル名//各列文字の処理
if(mFt == 1 || mFt == 0 ){// ファイル 0 かディレクトリ 1
path = R_alloc(strlen(CHAR(STRING_ELT(directory, 0))), sizeof(char));//ディレクトリ名
strcpy(path, CHAR(STRING_ELT(directory, 0)));
// 2011 03 10 // for(file = 0; file < f_count; file++){
// 2011 03 10 // f[file] = R_alloc(strlen(CHAR(STRING_ELT(origF, file))), sizeof(char));
// 2011 03 10 // }
for(file = 0; file < f_count; file++){
// 2011 03 10 // strcpy(f[file], CHAR(STRING_ELT(origF, file)));
ff.push_back(CHAR(STRING_ELT(origF, file)));
// 2011 03 10 // Rprintf("f[file] = %s\n", f[file]); // 2011 03 09
// 2011 03 10 // Rprintf("ff[file] = %s\n", ff[file].c_str()); // 2011 03 09
}
}
// Rprintf("after loop: f[1] = %s\n", f[1]); // 2011 03 09
int pos_n = INTEGER_VALUE( posN );// pos の数 // 2005 06 3
// bool flag = 1;
// if(pos_n == 0){
// pos_n = 1;
// flag = 0;
// }
// 2011 03 10 // char *Ppos[pos_n];
vector <string> Ppos2;
SEXP myPos;
if(pos_n > 0){// if(flag){//if(pos_n > 0){}
PROTECT(myPos = AS_CHARACTER(pos));pc++;
// 2011 03 10 // for( i = 0; i < pos_n; i++){
// 2011 03 10 // Ppos[i] = R_alloc(strlen(CHAR(STRING_ELT(myPos, i))), sizeof(char));
// 2011 03 10 // }
// Rprintf("end myPos = AS_CHARACTER(pos) \n");
for( i = 0; i < pos_n; i++){
// 2011 03 10 // strcpy(Ppos[i], CHAR(STRING_ELT(myPos, i)));
Ppos2.push_back (CHAR(STRING_ELT(myPos, i)) ) ;// 2011 03 10
// Rprintf("Pos[%d] = %s\n", i, Ppos[i]);
}
}// 2005 06 23
else{
// 2011 03 10 // Ppos[pos_n] = '\0';
myPos = NULL;
// strcpy(buf3 , meisiCode());
// // if (strcmp(buf3, "名詞") == 0){
// // Rprintf("%s\n", buf3);
// // }
// PROTECT(myPos = allocVector(STRSXP, 1));pc++;
// SET_STRING_ELT(myPos, 0, mkCharCE(buf3, (utf8locale)?CE_UTF8:CE_NATIVE ));
// Ppos[0] = R_alloc(strlen(CHAR(STRING_ELT(myPos, 0))), sizeof(char));
// strcpy(Ppos[0], CHAR(STRING_ELT(myPos, 0)));
}
// FILE *fp;
// map<string, int> ma0, ma[f_count]; // ファイル数の数+登録単語用マップの数1
// map<string, int>::iterator pma0, pma;// マップ検索用
// list <string> hinsi, strL, saibun;
// list <string>::iterator hinsi_it, iter, saibun_it;
// Rprintf("after loop2: f[1] = %s\n", f[1]); // 2011 03 09
for(file = 0; file < f_count; file++) {
// Rprintf("in for loop: file = %i :f[file] = %s\n", file, f[file] ); // 2011 03 09
if(mFt == 2){//データフレームのベクトル
if( strlen(CHAR(STRING_ELT(origF, file))) < 1 || STRING_ELT(origF, file) == NA_STRING ) {
// Rprintf("in ISNA\n");
continue;
}
//input = (char []) R_alloc(strlen(CHAR(STRING_ELT(directory, file))), sizeof(char));
strcpy(input , CHAR(STRING_ELT(origF, file)));
//Rprintf("to setMeCabMap\n");
pma0 = ma0.begin();
pma = (vecmap.at(file)).begin();// ma[file].begin();
strL.clear();
hinsi.clear();
saibun.clear();
//setMeCabMap(typeSet, input, ma0, ma[file], pma0, pma, strL, iter, hinsi, hinsi_it, saibun, saibun_it, Ppos, pos_n, mSym, KIGO, Ngram, genkei);
setMeCabMap(typeSet, input, ma0, vecmap.at(file), pma0, pma, strL, iter, hinsi, hinsi_it, saibun, saibun_it, Ppos2, pos_n, Ngram, genkei, dic);
////////////////////////////////////////////////
}else if(mFt == 0 || mFt ==1){// ファイル 0 かディレクトリ 1
// Rprintf("file = %i: f[file] = %s\n", file, f[file]); // 2011 03 09
// sprintf(file_name, "%s/%s", path, f[file]);
sprintf(file_name, "%s/%s", path, ff[file].c_str());
// Rprintf("file_name = %s not found\n",file_name);// 2011 03 09
if(strcmp(file_name, "") == 0){
continue;
}
if((fp = fopen(file_name, "r")) == NULL){
Rprintf("NULL! %s not found\n",file_name);
UNPROTECT(pc);
return(R_NilValue);
}else{
//strL.clear();
Rprintf("file_name = %s opened\n", file_name );
while(!feof(fp)){
//Rprintf("fgets\n");
if(fgets(input, FILEINPUT, fp) != NULL){// 2011 03 11 if(fgets(input, 5120, fp) != NULL){
if(strlen(input) < 1){
continue;
}
// Rprintf("to setMeCabMap\n");
pma0 = ma0.begin();
pma = (vecmap.at(file)).begin();// ma[file].begin();
strL.clear();
hinsi.clear();
saibun.clear();
//setMeCabMap(typeSet, input, ma0, ma[file], pma0, pma, strL, iter, hinsi, hinsi_it, saibun, saibun_it, Ppos, pos_n, mSym, KIGO, Ngram, genkei);
setMeCabMap(typeSet, input, ma0, vecmap.at(file), pma0, pma, strL, iter, hinsi, hinsi_it, saibun, saibun_it, Ppos2, pos_n, Ngram, genkei, dic);
////////////////////////////////////////////////
}
}//while(feop)
fclose(fp);
} //else//
}//else if(mFt == 0 || mFt ==1){// for(file);
}//for
////////////// MeCab の処理終了
// 最低頻度のチェック
pma0 = ma0.begin();
while( pma0 != ma0.end() ){
if(pma0->second < mFreq){
ma0.erase(pma0++);///// ma0.erase(pma0);// 2007 09 15 // ma0.erase(pma0++);
}else{
++pma0;
}
}
n0 = (int)ma0.size();// ターム数のチェック
if(n0 > OVERLINE ){ // 40000 -> OVERLINE // 2016 12 27
Rprintf("Warning! number of extracted terms = %d\n", n0);
}else{
Rprintf("number of extracted terms = %d\n", n0);
Rprintf("now making a data frame. wait a while!\n");
}
if(n0 < 1){
Rprintf("no terms extracted\n");
UNPROTECT(pc);
return(R_NilValue);
}
//////////////////// データフレームの作成
// Rprintf("nn = %d\n", nn);
if(typeSet == 0 || typeSet == 2){
PROTECT(mydf = allocVector(VECSXP, 1 + f_count));pc++;
SET_VECTOR_ELT(mydf, 0, allocVector(STRSXP, n0));//文字gram or 品詞gram
for(file = 0; file < f_count; file++){
SET_VECTOR_ELT(mydf, file+1, allocVector(INTSXP, n0));// 頻度
}
//文字組 + ファイル数のdata.frame // 列数
}else if(typeSet == 1){
if(NDF == 1){//名詞組を独立したデータフレーム列として返す場合
i = Ngram + 2 + f_count;
PROTECT(mydf = allocVector(VECSXP, i ));pc++;
for(j = 0; j < i ; j++){
if(j < Ngram +2){
SET_VECTOR_ELT(mydf, j, allocVector(STRSXP, n0));//単語列
}else{
SET_VECTOR_ELT(mydf, j, allocVector(INTSXP, n0));// 頻度
}
}
}else{//名詞組-品詞組ｰ再分類1 + ファイル数のdata.frame // 列数
PROTECT(mydf = allocVector(VECSXP, 3 + f_count));pc++;//名詞組-品詞組ｰ再分類1 + ファイル数のdata.frame // 列数
SET_VECTOR_ELT(mydf, 0, allocVector(STRSXP, n0));//単語列
SET_VECTOR_ELT(mydf, 1, allocVector(STRSXP, n0));//品詞列
SET_VECTOR_ELT(mydf, 2, allocVector(STRSXP, n0));//細目列
for(file = 0; file < f_count; file++){
SET_VECTOR_ELT(mydf, file+3, allocVector(INTSXP, n0));// 頻度
}
}
}
//Rprintf("data frame made\n");
///各列の代入開始
//Rprintf("data frame made\n");
///各列の代入開始
if(mydf == NULL){
Rprintf("NULL");
}
if(typeSet == 0){//文字の場合
pma0 = ma0.begin();
for (xx = 0; xx < n0 && pma0 != ma0.end(); xx++) {// n0 行のタームの数だけ繰り返す
strcpy(buf3, (pma0->first).c_str());
//Rprintf("before column");
//先頭列の xx 行に 文字組をセット
// #if defined(WIN32)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, 0), xx, mkCharCE( buf3, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, 0), xx, mkCharCE( buf3, CE_NATIVE ));
// #else
// SET_VECTOR_ELT(VECTOR_ELT(mydf, 0), xx, mkCharCE( buf3, CE_UTF8 ));
// #endif
SET_STRING_ELT(VECTOR_ELT(mydf, 0), xx, mkCharCE( buf3, (utf8locale)?CE_UTF8:CE_NATIVE ));// < 2006 04 18>
//Rprintf("column 0 is finished");
// 各ファイルから探し出してその頻度を新規列に追加
for(file = 0; file < f_count && pma0 != ma0.end(); file++){
pma = (vecmap.at(file)).begin();// ma[file].begin();
pma = (vecmap.at(file)).find( (pma0->first).c_str() );// ma[file].find( (pma0->first).c_str() );
if(pma != (vecmap.at(file)).end()){// if(pma != ma[file].end()){// 見つかった
INTEGER(VECTOR_ELT(mydf, 1+file))[xx] = pma->second;// 新規列に追加
}
else{
INTEGER(VECTOR_ELT(mydf, 1+file))[xx] = 0;// 新規列に追加
}
}
//Rprintf("column %d is finished", (file+1));
pma0++;
//if(xx % 10 == 0) Rprintf("* ");// 2006 03 27
} //////////////////////////////
}else if(typeSet == 1 ){//タームの場合
pma0 = ma0.begin();
buf3[0] = '\0';
for (xx = 0; xx < n0; xx++) {//n0 行のタームの数だけ繰り返す
strcpy(buf4, (pma0->first).c_str());// 最初の要素の文字列を取得し
p = strtok(buf4 , " " );//タームの内容を Ngramずつ区切る
// Rprintf("buf4 = %s - ", buf4);
j = 0;
i = 1;
//str.erase();
while(p != NULL){// _TYPE_1
if(NDF == 1 && i <= Ngram ){//タームはデータフレーム形式で
sprintf(buf3, "%s", p);
// #if defined(WIN32)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));//j列のxx行にセット
// #elif defined(__MINGW32__)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));
// #else
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_UTF8 ));
// #endif
SET_STRING_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, (utf8locale)?CE_UTF8:CE_NATIVE ));// < 2006 04 18>
//Rprintf("buf3 = %s \n", buf3);
i++;
p = strtok( NULL, " ");
buf3[0] = '\0';
continue;
}
if( (i % Ngram) == 0){
//sprintf(buf3, "%s", str);
strcat(buf3,p);
// Rprintf("buf3 = %s \n", buf3);
// #if defined(WIN32)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));//j列のxx行にセット
// #elif defined(__MINGW32__)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));
// #else
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_UTF8 ));
// #endif
SET_STRING_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, (utf8locale)?CE_UTF8:CE_NATIVE ));//j列のxx行にセット < 2006 04 18>
//str.erase();
buf3[0] = '\0';
//++i;
}else{
strcat(buf3, p);
strcat(buf3, "-");
//str.append(p);
//str.append("-");
//++i;
}
// // // sprintf(buf3, "%s", p);// 名詞組，品詞組,細分組の取得
// // // // Rprintf("buf3 = %s\n", buf3);
// // // #if defined(WIN32)
// // // SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));//j列のxx行にセット
// // // #elif defined(__MINGW32__)
// // // SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));
// // // #else
// // // SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_UTF8 ));
// // // #endif
p = strtok( NULL, " ");
++i;
// if( j >= 2){
// continue;
// }
}//////while(p != NULL) _TYPE_1 //////////////////////////////
/////////////////////////////////////////////////
// 各ファイルから探し出してその頻度を新規列に追加
for(file = 0; file < f_count && pma0 != ma0.end(); file++){
pma = (vecmap.at(file)).begin(); // ma[file].begin();
pma = (vecmap.at(file)).find( (pma0->first).c_str() );// ma[file].find( (pma0->first).c_str() );
if(pma != (vecmap.at(file)).end()){// if(pma != ma[file].end()){// 見つかった
if(NDF == 1){
INTEGER(VECTOR_ELT(mydf, Ngram+2+file))[xx] = pma->second;// 新規列に追加
}else{
INTEGER(VECTOR_ELT(mydf, 3+file))[xx] = pma->second;//
}
}
else{
if(NDF == 1){
INTEGER(VECTOR_ELT(mydf, Ngram+2+file))[xx] = 0;// 新規列に追加
}else{
INTEGER(VECTOR_ELT(mydf, 3+file))[xx] = 0;// 新規列に追加
}
}
}
pma0++;
// if(xx % 10 == 0) Rprintf("* ");// 2006 03 27 removed 2007 05
}// for (xx = 0; xx < n0; xx++) //n0 行のタームの数だけ繰り返す
}// else if(typeSet == 1 )//タームの場合
//Rprintf("frequnecy made\n");
//df 列ベクトルの名前を用意
// その単純な初期化
if(typeSet == 0){//文字グラムの場合
PROTECT(varlabels = allocVector(STRSXP, 1+f_count)); pc++;
// Rprintf("col names allocated\n");
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, 0, mkCharCE( "Ngram", CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, 0, mkCharCE( "Ngram", CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, 0, mkCharCE( "Ngram", CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, 0, mkCharCE( "Ngram", (utf8locale)?CE_UTF8:CE_NATIVE ));
//Rprintf("first col names set\n");
// 各ファイルあるいは行ごとの名前を設定
for(j = 0; j < f_count; j++){
if(mFt == 2){//データフレームの場合
sprintf(buf4, "Row%d", j+1);//s
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, j+1, mkCharCE(buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, j+1, mkCharCE(buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, j+1, mkCharCE(buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, j+1, mkCharCE(buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
}else{//ファイルの場合
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, j+1, mkCharCE(f[j], CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, j+1, mkCharCE(f[j], CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, j+1, mkCharCE(f[j], CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, j+1, mkCharCE(ff[j].c_str(), (utf8locale)?CE_UTF8:CE_NATIVE )); // 2011 03 10 SET_STRING_ELT(varlabels, j+1, mkCharCE(f[j], (utf8locale)?CE_UTF8:CE_NATIVE ));
}
}
}else if(typeSet == 1 ){//タームの場合
if(NDF == 1){
PROTECT(varlabels = allocVector(STRSXP, Ngram + 2 + f_count)); pc++;
for(i = 0; i< (Ngram +2); i++){
if(i < Ngram){
sprintf(buf1, "N%d", i+1);
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, i, mkCharCE( buf1, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, i, mkCharCE( buf1, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, i, mkCharCE( buf1, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, i, mkCharCE( buf1, (utf8locale)?CE_UTF8:CE_NATIVE ));
}else if (i == (Ngram)){
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS1", CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS1", CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS1", CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, i, mkCharCE( "POS1", (utf8locale)?CE_UTF8:CE_NATIVE ));
}else if(i == (Ngram +1) ){
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", CE_UTF8 ));
// #endif
// //SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", CE_NATIVE ));
SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", (utf8locale)?CE_UTF8:CE_NATIVE ));
}
}
}else{// if(NDF == 1)
PROTECT(varlabels = allocVector(STRSXP, 3+f_count)); pc++;
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, 0, mkCharCE( "TERM", CE_NATIVE ));
// SET_STRING_ELT(varlabels, 1, mkCharCE( "POS1", CE_NATIVE ));
// SET_STRING_ELT(varlabels, 2, mkCharCE( "POS2", CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, 0, mkCharCE( "TERM", CE_NATIVE ));
// SET_STRING_ELT(varlabels, 1, mkCharCE( "POS1", CE_NATIVE ));
// SET_STRING_ELT(varlabels, 2, mkCharCE( "POS2", CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, 0, mkCharCE( "TERM", CE_UTF8 ));
// SET_STRING_ELT(varlabels, 1, mkCharCE( "POS1", CE_UTF8 ));
// SET_STRING_ELT(varlabels, 2, mkCharCE( "POS2", CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, 0, mkCharCE( "TERM", (utf8locale)?CE_UTF8:CE_NATIVE ));
SET_STRING_ELT(varlabels, 1, mkCharCE( "POS1", (utf8locale)?CE_UTF8:CE_NATIVE ));
SET_STRING_ELT(varlabels, 2, mkCharCE( "POS2", (utf8locale)?CE_UTF8:CE_NATIVE ));
}
//Rprintf("col names allocated\n");
if(mFt == 0 || mFt == 1){// 各ファイル名を列名として設定
for(j = 0; j < f_count; j++){
sprintf(buf4, "%s", ff[j].c_str());// 2011 03 10 sprintf(buf4, "%s", f[j]);//s
if(NDF == 1){// Ngram 本体はいちいち単独列
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE( buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE( buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE( buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE( buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
} else{// Ngram 本体は一つでまとまり
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, 3+ j, mkCharCE(buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, 3 +j, mkCharCE(buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, 3+ j, mkCharCE(buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
}
}
//Rprintf("file names allocated\n");
} else if(mFt == 2){// 行番号を列名として設定
for(j = 0; j < f_count; j++){
sprintf(buf4, "Row%d", j+1);//
if(NDF == 1){// Ngram 本体はいちいち単独列
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE(buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE(buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE(buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE(buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
}else{
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
}
}
}
}//else if(typeset ==1) //タームの場合
Rprintf("\n");// 2006 03 27
//Rprintf("row number n0 = %d\n", n0 );
//Rprintf("after colunm names set\n" );
///////////////////////// new_end
// データフレームの行名を設定．必須
PROTECT(row_names = allocVector(STRSXP, n0));pc++;
//Rprintf("after row names set\n" );
char labelbuff[6];// char labelbuff[5]; 2006 03
for (xx = 0; xx < n0 ; xx++) {
sprintf(labelbuff, "%d", xx+1);
// #if defined(WIN32)
// SET_STRING_ELT(row_names, xx, mkCharCE(labelbuff , CE_NATIVE));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(row_names, xx, mkCharCE(labelbuff , CE_NATIVE));
// #else
// SET_STRING_ELT(row_names, xx, mkCharCE(labelbuff , CE_UTF8));
// #endif
SET_STRING_ELT(row_names, xx, mkCharCE(labelbuff , (utf8locale)?CE_UTF8:CE_NATIVE));
//Rprintf("set row %d\n", xx+1 );
}
//Rprintf("before setAttr\n" );
// データフレームオブジェクト mydf の属性設定
// // オブジェクトはデータフレームだと指定する
PROTECT(tmp = mkString("data.frame")); pc++;//tmpにその属性を一時保存
//Rprintf("data frame made");
setAttrib(mydf, R_ClassSymbol, tmp);
setAttrib(mydf, R_NamesSymbol, varlabels);
setAttrib(mydf, R_RowNamesSymbol, row_names);
//Rprintf("before UNPROTECT\n" );
UNPROTECT(pc);
// Rprintf("UNPROTECT \n");
//free(f);
return (mydf);
// 2006 03 05
// # sym 引数は，抽出タームに句読点なので記号を含めるかを指定する．
// ## デフォルトでは sym = 0 とセットされており，
// ## 記号はカウントされないが，
// ## sym = 1 とすると，記号を含めてカウントした結果が出力される
// ## pos 引数に記号が含まれた場合は自動的に sym = 1 とセットされる
// ///////////////////////////////////////////////////////
}
//take the elements of a GFF in R and make a GFF object in C; return pointer
//Assume length of vectors are all equal (except optional elements can be NULL)
SEXP rph_gff_new(SEXP seqnameP, SEXP srcP, SEXP featureP, SEXP startP, SEXP endP,
SEXP scoreP, SEXP strandP, SEXP frameP, SEXP attributeP) {
GFF_Set *gff;
GFF_Feature *feat;
int gfflen, i;
int haveScore=0, haveStrand=0, haveFrame=0, haveAttribute=0, numProtect=5;
String *seqname, *source, *feature, *attribute;
int *start, *end, frame=GFF_NULL_FRAME, *frameVec=NULL;
double *scoreVec=NULL, score;
char strand;
PROTECT(seqnameP = AS_CHARACTER(seqnameP));
PROTECT(srcP = AS_CHARACTER(srcP));
PROTECT(featureP = AS_CHARACTER(featureP));
PROTECT(startP = AS_INTEGER(startP));
start = INTEGER_POINTER(startP);
PROTECT(endP = AS_INTEGER(endP));
end = INTEGER_POINTER(endP);
if (scoreP != R_NilValue) {
PROTECT(scoreP = AS_NUMERIC(scoreP));
haveScore = 1;
scoreVec = NUMERIC_POINTER(scoreP);
} else score=0;
if (strandP != R_NilValue) {
PROTECT(strandP = AS_CHARACTER(strandP));
haveStrand=1;
} else strand='.';
if (frameP != R_NilValue) {
PROTECT(frameP = AS_INTEGER(frameP));
haveFrame=1;
frameVec = INTEGER_POINTER(frameP);
}
if (attributeP != R_NilValue) {
PROTECT(attributeP = AS_CHARACTER(attributeP));
haveAttribute=1;
}
numProtect += (haveScore + haveStrand + haveFrame + haveAttribute);
gfflen = LENGTH(seqnameP);
gff = gff_new_set_len(gfflen);
for (i=0; i<gfflen; i++) {
checkInterruptN(i, 1000);
seqname = str_new_charstr(CHAR(STRING_ELT(seqnameP, i)));
source = str_new_charstr(CHAR(STRING_ELT(srcP, i)));
feature = str_new_charstr(CHAR(STRING_ELT(featureP, i)));
if (haveScore) score = scoreVec[i];
if (haveStrand) strand = (CHAR(STRING_ELT(strandP, i)))[0];
if (haveFrame) {
if (frameVec[i] == 0) frame = 0;
else if (frameVec[i] == 1) frame = 2;
else if (frameVec[i] == 2) frame = 1;
}
if (haveAttribute) attribute = str_new_charstr(CHAR(STRING_ELT(attributeP, i)));
else attribute = str_new_charstr("");
if (seqname == NULL) die("seqname is NULL\n");
if (source == NULL) die ("source is NULL\n");
if (feature == NULL) die("feature is NULL\n");
if (attribute == NULL) die("attribute is NULL\n");
if (strand != '+' && strand != '-' && strand!='.') die("strand is %c\n", strand);
if (frame != GFF_NULL_FRAME && (frame<0 || frame>2)) die("frame is %i\n", frame);
feat = gff_new_feature(seqname, source, feature, start[i], end[i], score, strand,
frame, attribute, haveScore==0);
lst_push_ptr(gff->features, feat);
}
UNPROTECT(numProtect);
return rph_gff_new_extptr(gff);
}
SEXP lcs(SEXP a, SEXP b, SEXP r_n_char) {
SEXP M, LCS, LLCS, va, vb, QSI, list, list_names;
int *PM, *Pva, *Pvb;
double *PQSI;
int i, j, na,nb,l, pos, n_char, PLLCS;
char *names[7] = {"a","b", "LLCS", "LCS", "QSI", "va", "vb"};
/* Converting data from R */
PROTECT(a = AS_CHARACTER(a));
PROTECT(b = AS_CHARACTER(b));
PROTECT(r_n_char = AS_INTEGER(r_n_char));
n_char = INTEGER_POINTER(r_n_char)[0];
na = length(a)+1; //vorher m
nb = length(b)+1; //vorher n
l = max(na, nb) - 1;
char *Pa[na-1], *Pb[nb-1]; //pointers to strings
//Obtain strings from R
for(i = 0; i < na-1; i++) {
Pa[i]= R_alloc(strlen(CHAR(STRING_ELT(a, i))), sizeof(char));
strcpy(Pa[i], CHAR(STRING_ELT(a,i)));
}
for(j = 0; j < nb-1; j++){
Pb[j]= R_alloc(strlen(CHAR(STRING_ELT(b, j))), sizeof(char));
strcpy(Pb[j], CHAR(STRING_ELT(b,j)));
}
//build matrix to store calculation results for LCS
PROTECT(M = allocMatrix(INTSXP, (na),(nb)));
PM = INTEGER(M);
//Initialize
for(i = 0; i < na; i++) {
for(j = 0; j < nb; j++){
PM[i+na*j] = 0;
}
}
//Compare each character or string.
//if there is a match, the "match counter" stored
//in PM is incremented by one.
for(i = 1; i < na; i++) {
for(j = 1; j < nb; j++){
if (strcmp(Pa[i - 1],Pb[j - 1])==0) {
PM[i + na * j] = PM[(i - 1) + na*(j - 1)] + 1;
}
else {
PM[i + na* j] = max(PM[i + na*(j - 1)], PM[(i - 1) + na* j]);
}
}
}
//Read LCS-number from bottom right corner in PM
PLLCS = PM[(na-1) + (na)*(nb-1)];
PROTECT(LLCS = NEW_INTEGER(1));
INTEGER(LLCS)[0]=PLLCS;
//Variables to store additional results
PROTECT(va = NEW_INTEGER(PLLCS));
PROTECT(vb = NEW_INTEGER(PLLCS));
PROTECT(QSI = NEW_NUMERIC(1));
Pva = INTEGER(va);
Pvb = INTEGER(vb);
char *PLCS[PLLCS];
for(i=0;i<PLLCS;i++){
PLCS[i]= R_alloc(n_char, sizeof(char));
}
PQSI = NUMERIC_POINTER(QSI);
//build LCS-sequence by traversing PM from bottom right towards
//top left
i = na-1;
j = nb-1;
pos = PLLCS;
while (i > 0 && j > 0) {
if (PM[i + na* j] == (PM[(i - 1) + na*( j - 1)] + 1)
&& strcmp(Pa[i - 1], Pb[j - 1])==0) {
strcpy(PLCS[pos-1] , Pa[i-1]);
Pva[pos-1] = i;
Pvb[pos-1] = j;
i--;
j--;
pos--;
} else {
if (PM[(i - 1) + na* j] > PM[i + (j - 1)*na]) {
i--;
} else {
j--;
}
}
}
//Calculate fraction
PQSI[0] = (double)PLLCS/(double)l;
//Prepare LCS strings for retruning to R
PROTECT(LCS = allocVector(STRSXP, PLLCS));
for(i=0;i<PLLCS;i++){
SET_STRING_ELT(LCS, i, mkChar(PLCS[i]));
}
//Generate List
// a character string vector of the "names" attribute of the objects in our list
PROTECT(list_names = allocVector(STRSXP, 7));
for(i = 0; i < 7; i++)
SET_STRING_ELT(list_names, i, mkChar(names[i]));
PROTECT(list = allocVector(VECSXP, 7)); // Creating a list with 7 vector elements
SET_VECTOR_ELT(list, 0, a); // attaching myint vector to list
SET_VECTOR_ELT(list, 1, b); // attaching mydouble vector to list
SET_VECTOR_ELT(list, 2, LLCS);
SET_VECTOR_ELT(list, 3, LCS);
SET_VECTOR_ELT(list, 4, QSI);
SET_VECTOR_ELT(list, 5, va);
SET_VECTOR_ELT(list, 6, vb);
setAttrib(list, R_NamesSymbol, list_names); //and attaching the vector names
UNPROTECT(11);
return(list);
}
SEXP rfsrcReadMatrix(SEXP traceFlag,
SEXP fName,
SEXP rowType,
SEXP rowCnt,
SEXP tokenDelim,
SEXP colHeader,
SEXP rowHeader) {
FILE *fopen();
FILE *fPtr;
char *_fName;
SEXP _sexp_rowType ;
char **_rowType;
uint _rowCnt;
char *_tokenDelim;
char _colHeadF;
char _rowHeadF;
SmartBuffer *sb;
uint p, i;
uint rowCntActual;
uint colCntActual;
uint sbSizeActual;
char flag;
setTraceFlag(INTEGER(traceFlag)[0], 0);
_fName = (char*) CHAR(STRING_ELT(AS_CHARACTER(fName), 0));
_sexp_rowType = rowType;
_rowCnt = INTEGER(rowCnt)[0];
_tokenDelim = (char*) CHAR(STRING_ELT(AS_CHARACTER(tokenDelim), 0));
_colHeadF = (INTEGER(colHeader)[0] != 0) ? TRUE : FALSE;
_rowHeadF = (INTEGER(rowHeader)[0] != 0) ? TRUE : FALSE;
_rowType = (char**) new_vvector(1, _rowCnt, NRUTIL_CPTR);
for (p = 1; p <= _rowCnt; p++) {
_rowType[p] = (char*) CHAR(STRING_ELT(AS_CHARACTER(_sexp_rowType), p-1));
if ((strcmp(_rowType[p], "X") != 0) &&
(strcmp(_rowType[p], "C") != 0) &&
(strcmp(_rowType[p], "c") != 0) &&
(strcmp(_rowType[p], "I") != 0) &&
(strcmp(_rowType[p], "R") != 0)) {
Rprintf("\nRF-SRC: *** ERROR *** ");
Rprintf("\nRF-SRC: Invalid predictor type: [%10d] = %2s", p, _rowType[p]);
Rprintf("\nRF-SRC: Type must be 'C', 'c', 'I', or 'R'.");
Rprintf("\nRF-SRC: Please Contact Technical Support.");
error("\nRF-SRC: The application will now exit.\n");
}
}
fPtr = fopen(_fName, "r");
sb = parseLineSB(fPtr, *_tokenDelim, 0);
colCntActual = _rowHeadF ? (sb -> tokenCnt - 1) : (sb -> tokenCnt);
rowCntActual = 0;
if (_colHeadF) {
freeSB(sb);
sb = parseLineSB(fPtr, *_tokenDelim, 0);
sbSizeActual = sb -> size;
freeSB(sb);
}
else {
sbSizeActual = sb -> size;
freeSB(sb);
}
++rowCntActual;
flag = TRUE;
while (flag) {
sb = parseLineSB(fPtr, *_tokenDelim, sbSizeActual);
if (sb -> tokenCnt == 0) {
flag = FALSE;
freeSB(sb);
}
else {
++rowCntActual;
freeSB(sb);
}
}
if (rowCntActual != _rowCnt) {
Rprintf("\nRF-SRC: *** ERROR *** ");
Rprintf("\nRF-SRC: Inconsistent Predictor Count.");
Rprintf("\nRF-SRC: (encountered, expected) = (%10d, %10d)", rowCntActual, _rowCnt);
Rprintf("\nRF-SRC: Please Contact Technical Support.");
error("\nRF-SRC: The application will now exit.\n");
}
fclose(fPtr);
if (_colHeadF) {
fPtr = fopen(_fName, "r");
sb = parseLineSB(fPtr, *_tokenDelim, sbSizeActual);
freeSB(sb);
}
char **dataMatrix = cmatrix(1, colCntActual, 1, rowCntActual);
for (p=1; p <= rowCntActual; p++) {
sb = parseLineSB(fPtr, *_tokenDelim, sbSizeActual);
if (_rowHeadF) {
}
for (i = 1; i <= colCntActual; i++) {
dataMatrix[i][p] = (char) strtol(sb -> token, NULL, 10);
}
freeSB(sb);
}
free_cmatrix(dataMatrix, 1, colCntActual, 1, rowCntActual);
return R_NilValue;
}
SEXP calcCdsoneSpread
(// variables for the zero curve
SEXP baseDate_input, /* (I) Value date for zero curve */
SEXP types, //"MMMMMSSSSSSSSS"
SEXP rates, /* rates[14] = {1e-9, 1e-9, 1e-9, 1e-9, 1e-9, 1e-9, 1e-9,
1e-9, 1e-9, 1e-9, 1e-9, 1e-9, 1e-9, 1e-9};/\* (I)
Array of swap rates *\/ */
SEXP expiries,
SEXP mmDCC, /* (I) DCC of MM instruments */
SEXP fixedSwapFreq, /* (I) Fixed leg freqency */
SEXP floatSwapFreq, /* (I) Floating leg freqency */
SEXP fixedSwapDCC, /* (I) DCC of fixed leg */
SEXP floatSwapDCC, /* (I) DCC of floating leg */
SEXP badDayConvZC, //'M' badDayConv for zero curve
SEXP holidays,//'None'
SEXP todayDate_input, /*today: T (Where T = trade date)*/
SEXP valueDate_input, /* value date: T+3 Business Days*/
SEXP benchmarkDate_input, /* start date of benchmark CDS for
** internal clean spread bootstrapping;
** accrual Begin Date */
SEXP startDate_input, /* Accrual Begin Date */
SEXP endDate_input, /* Maturity (Fixed) */
SEXP stepinDate_input, /* T + 1*/
SEXP couponRate_input, /* Fixed Coupon Amt */
SEXP payAccruedOnDefault_input, /* TRUE in new contract */
SEXP dccCDS, //accrueDCC_input, /* ACT/360 */
SEXP dateInterval, /* Q - 3 months in new contract */
SEXP stubType, /* F/S */
SEXP badDayConv_input, /* (F) Following */
SEXP calendar_input, /* None (no holiday calendar) in new contract */
SEXP upfrontCharge_input,
SEXP recoveryRate_input,
SEXP payAccruedAtStart_input /* (True/False), True: Clean Upfront supplied */
)
{
static char routine[] = "JpmcdsCdsoneSpread";
SEXP spread;
TDate baseDate, todayDate, benchmarkDate, startDate, endDate, stepinDate,valueDate;
int n; /* for zero curve */
TCurve *discCurve = NULL;
char* pt_types;
char* pt_holidays;
char* pt_mmDCC;
char* pt_fixedSwapDCC;
char* pt_floatSwapDCC;
char* pt_fixedSwapFreq;
char* pt_floatSwapFreq;
TBoolean payAccruedOnDefault, payAccruedAtStart;
double couponRate, upfrontCharge, recoveryRate;
char* pt_dccCDS;
char* pt_stubType;
char* pt_dateInterval;
char* pt_calendar;
char* pt_badDayConvCDS;
const char* badDayConvZC_char;
double* pt_onespread;
pt_onespread = malloc(sizeof(double));
CDSONE_SPREAD_CONTEXT context;
baseDate_input = coerceVector(baseDate_input,INTSXP);
baseDate = JpmcdsDate((long)INTEGER(baseDate_input)[0],
(long)INTEGER(baseDate_input)[1],
(long)INTEGER(baseDate_input)[2]);
todayDate_input = coerceVector(todayDate_input,INTSXP);
todayDate = JpmcdsDate((long)INTEGER(todayDate_input)[0],
(long)INTEGER(todayDate_input)[1],
(long)INTEGER(todayDate_input)[2]);
valueDate_input = coerceVector(valueDate_input,INTSXP);
valueDate = JpmcdsDate((long)INTEGER(valueDate_input)[0],
(long)INTEGER(valueDate_input)[1],
(long)INTEGER(valueDate_input)[2]);
benchmarkDate_input = coerceVector(benchmarkDate_input,INTSXP);
benchmarkDate = JpmcdsDate((long)INTEGER(benchmarkDate_input)[0],
(long)INTEGER(benchmarkDate_input)[1],
(long)INTEGER(benchmarkDate_input)[2]);
stepinDate_input = coerceVector(stepinDate_input,INTSXP);
stepinDate = JpmcdsDate((long)INTEGER(stepinDate_input)[0],
(long)INTEGER(stepinDate_input)[1],
(long)INTEGER(stepinDate_input)[2]);
startDate_input = coerceVector(startDate_input,INTSXP);
startDate = JpmcdsDate((long)INTEGER(startDate_input)[0],
(long)INTEGER(startDate_input)[1],
(long)INTEGER(startDate_input)[2]);
endDate_input = coerceVector(endDate_input,INTSXP);
endDate = JpmcdsDate((long)INTEGER(endDate_input)[0],
(long)INTEGER(endDate_input)[1],
(long)INTEGER(endDate_input)[2]);
types = coerceVector(types, STRSXP);
pt_types = (char *) CHAR(STRING_ELT(types, 0));
holidays = coerceVector(holidays, STRSXP);
pt_holidays = (char *) CHAR(STRING_ELT(holidays, 0));
n = strlen(CHAR(STRING_ELT(types, 0))); // for zerocurve
rates = coerceVector(rates,REALSXP);
mmDCC = coerceVector(mmDCC, STRSXP);
pt_mmDCC = (char *) CHAR(STRING_ELT(mmDCC,0));
fixedSwapFreq = coerceVector(fixedSwapFreq, STRSXP);
pt_fixedSwapFreq = (char *) CHAR(STRING_ELT(fixedSwapFreq,0));
floatSwapFreq = coerceVector(floatSwapFreq, STRSXP);
pt_floatSwapFreq = (char *) CHAR(STRING_ELT(floatSwapFreq,0));
fixedSwapDCC = coerceVector(fixedSwapDCC, STRSXP);
pt_fixedSwapDCC = (char *) CHAR(STRING_ELT(fixedSwapDCC,0));
floatSwapDCC = coerceVector(floatSwapDCC, STRSXP);
pt_floatSwapDCC = (char *) CHAR(STRING_ELT(floatSwapDCC,0));
/* fixedSwapFreq = coerceVector(fixedSwapFreq,REALSXP); */
/* floatSwapFreq = coerceVector(floatSwapFreq,REALSXP); */
/* fixedSwapDCC = coerceVector(fixedSwapDCC,REALSXP); */
/* floatSwapDCC = coerceVector(floatSwapDCC,REALSXP); */
/* badDayConvZC = AS_CHARACTER(badDayConvZC); */
/* pt_badDayConvZC = CHAR(asChar(STRING_ELT(badDayConvZC, 0))); */
badDayConvZC = AS_CHARACTER(badDayConvZC);
badDayConvZC_char = CHAR(asChar(STRING_ELT(badDayConvZC, 0)));
// main.c dates
/* TDateInterval ivl; */
/* long dcc; */
/* double freq; */
TDateInterval fixedSwapIvl_curve;
TDateInterval floatSwapIvl_curve;
long fixedSwapDCC_curve;
long floatSwapDCC_curve;
double fixedSwapFreq_curve;
double floatSwapFreq_curve;
long mmDCC_zc_main;
static char *routine_zc_main = "BuildExampleZeroCurve";
/* if (JpmcdsStringToDayCountConv("Act/360", &mmDCC_zc_main) != SUCCESS) */
/* goto done; */
if (JpmcdsStringToDayCountConv(pt_mmDCC, &mmDCC_zc_main) != SUCCESS)
goto done;
/* if (JpmcdsStringToDayCountConv("30/360", &dcc) != SUCCESS) */
/* goto done; */
if (JpmcdsStringToDayCountConv(pt_fixedSwapDCC, &fixedSwapDCC_curve) != SUCCESS)
goto done;
if (JpmcdsStringToDayCountConv(pt_floatSwapDCC, &floatSwapDCC_curve) != SUCCESS)
goto done;
/* if (JpmcdsStringToDateInterval("6M", routine_zc_main, &ivl) != SUCCESS) */
/* goto done; */
if (JpmcdsStringToDateInterval(pt_fixedSwapFreq, routine_zc_main, &fixedSwapIvl_curve) != SUCCESS)
goto done;
if (JpmcdsStringToDateInterval(pt_floatSwapFreq, routine_zc_main, &floatSwapIvl_curve) != SUCCESS)
goto done;
/* if (JpmcdsDateIntervalToFreq(&ivl, &freq) != SUCCESS) */
/* goto done; */
if (JpmcdsDateIntervalToFreq(&fixedSwapIvl_curve, &fixedSwapFreq_curve) != SUCCESS)
goto done;
if (JpmcdsDateIntervalToFreq(&floatSwapIvl_curve, &floatSwapFreq_curve) != SUCCESS)
goto done;
expiries = coerceVector(expiries, VECSXP);
TDate *dates_main = NULL;
dates_main = NEW_ARRAY1(TDate, n);
int i;
for (i = 0; i < n; i++)
{
TDateInterval tmp;
// if (JpmcdsStringToDateInterval(expiries[i], routine_zc_main, &tmp) != SUCCESS)
/* if (JpmcdsStringToDateInterval(CHAR(asChar(VECTOR_ELT(expiries, i))), routine_zc_main, &tmp) != SUCCESS) { */
if (JpmcdsStringToDateInterval(strdup(CHAR(asChar(VECTOR_ELT(expiries, i)))), routine_zc_main, &tmp) != SUCCESS)
{
JpmcdsErrMsg ("%s: invalid interval for element[%d].\n", routine_zc_main, i);
goto done;
}
if (JpmcdsDateFwdThenAdjust(baseDate, &tmp, JPMCDS_BAD_DAY_NONE, "None", dates_main+i) != SUCCESS)
{
JpmcdsErrMsg ("%s: invalid interval for element[%d].\n", routine_zc_main, i);
goto done;
}
}
// discCurve = (TCurve*)malloc(sizeof(TCurve));
discCurve = JpmcdsBuildIRZeroCurve(baseDate,
pt_types,
dates_main,
REAL(rates),
(long) n,
(long) mmDCC_zc_main,
(long) fixedSwapFreq_curve,
(long) floatSwapFreq_curve,
fixedSwapDCC_curve,
floatSwapDCC_curve,
(char) *badDayConvZC_char,
pt_holidays);
if (discCurve == NULL) JpmcdsErrMsg("IR curve not available ... \n");
couponRate = *REAL(couponRate_input);
payAccruedOnDefault = *LOGICAL(payAccruedOnDefault_input);
/* pt_dateInterval = (TDateInterval*)malloc(sizeof(TDateInterval)); */
/* pt_dateInterval->prd_typ = *CHAR(STRING_ELT(coerceVector(dateInterval, STRSXP), 0)); */
/* pt_dateInterval->prd = 6; */
/* pt_dateInterval->flag = 0; */
dateInterval = coerceVector(dateInterval, STRSXP);
pt_dateInterval = (char *) CHAR(STRING_ELT(dateInterval,0));
/* TBoolean stubAtEnd = FALSE; */
/* TBoolean longStub = FALSE; */
/* pt_stubType = (TStubMethod*)malloc(sizeof(TStubMethod)); */
/* pt_stubType->stubAtEnd = stubAtEnd; */
/* pt_stubType->longStub = longStub; */
stubType = coerceVector(stubType, STRSXP);
pt_stubType = (char *) CHAR(STRING_ELT(stubType,0));
/* accrueDCC = *INTEGER(dccCDS); */
/* badDayConv = *INTEGER(badDayConv_input); */
dccCDS = coerceVector(dccCDS, STRSXP);
pt_dccCDS = (char *) CHAR(STRING_ELT(dccCDS,0));
badDayConv_input = coerceVector(badDayConv_input, STRSXP);
pt_badDayConvCDS = (char *) CHAR(STRING_ELT(badDayConv_input,0));
TDateInterval ivl;
TStubMethod stub;
long dcc;
if (JpmcdsStringToDayCountConv(pt_dccCDS, &dcc) != SUCCESS)
goto done;
if (JpmcdsStringToDateInterval(pt_dateInterval, routine, &ivl) != SUCCESS)
goto done;
if (JpmcdsStringToStubMethod(pt_stubType, &stub) != SUCCESS)
goto done;
pt_calendar = (char *) CHAR(STRING_ELT(coerceVector(calendar_input, STRSXP), 0));
upfrontCharge = *REAL(upfrontCharge_input);
recoveryRate = *REAL(recoveryRate_input);
payAccruedAtStart = *LOGICAL(payAccruedAtStart_input);
context.today = todayDate;
context.valueDate = valueDate;
context.benchmarkDate = benchmarkDate;
context.stepinDate = stepinDate;
context.startDate = startDate;
context.endDate = endDate;
context.couponRate = couponRate;
context.payAccruedOnDefault = payAccruedOnDefault;
context.dateInterval = &ivl;
context.stubType = &stub;
/* context.accrueDCC = (long) accrueDCC; */
context.accrueDCC = dcc;
// context.badDayConv = (long) badDayConv;
context.badDayConv = *pt_badDayConvCDS;
context.calendar = pt_calendar;
context.discCurve = discCurve;
context.upfrontCharge = upfrontCharge;
context.recoveryRate = recoveryRate;
context.payAccruedAtStart = payAccruedAtStart;
if (JpmcdsRootFindBrent ((TObjectFunc)cdsoneSpreadSolverFunction,
&context,
0.0, /* boundLo */
100.0, /* boundHi */
100, /* numIterations */
0.01, /* guess */
0.0001, /* initialXStep */
0.0, /* initialFDeriv */
1e-8, /* xacc */
1e-8, /* facc */
pt_onespread) != SUCCESS)
goto done;
done:
PROTECT(spread = allocVector(REALSXP, 1));
REAL(spread)[0] = (*pt_onespread) * 1e4;
UNPROTECT(1);
// if (status != SUCCESS)
// JpmcdsErrMsgFailure (routine);
return spread;
}
/*
* plr_SPI_prepare - The builtin SPI_prepare command for the R interpreter
*/
SEXP
plr_SPI_prepare(SEXP rsql, SEXP rargtypes)
{
const char *sql;
int nargs;
int i;
Oid *typeids = NULL;
Oid *typelems = NULL;
FmgrInfo *typinfuncs = NULL;
void *pplan = NULL;
void *saved_plan;
saved_plan_desc *plan_desc;
SEXP result;
MemoryContext oldcontext;
PREPARE_PG_TRY;
/* set up error context */
PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.prepare");
/* switch to long lived context to create plan description */
oldcontext = MemoryContextSwitchTo(TopMemoryContext);
plan_desc = (saved_plan_desc *) palloc(sizeof(saved_plan_desc));
MemoryContextSwitchTo(oldcontext);
PROTECT(rsql = AS_CHARACTER(rsql));
sql = CHAR(STRING_ELT(rsql, 0));
UNPROTECT(1);
if (sql == NULL)
error("%s", "cannot prepare empty query");
PROTECT(rargtypes = AS_INTEGER(rargtypes));
if (!isVector(rargtypes) || !isInteger(rargtypes))
error("%s", "second parameter must be a vector of PostgreSQL datatypes");
/* deal with case of no parameters for the prepared query */
if (rargtypes == R_MissingArg || INTEGER(rargtypes)[0] == NA_INTEGER)
nargs = 0;
else
nargs = length(rargtypes);
if (nargs < 0) /* can this even happen?? */
error("%s", "second parameter must be a vector of PostgreSQL datatypes");
if (nargs > 0)
{
/* switch to long lived context to create plan description elements */
oldcontext = MemoryContextSwitchTo(TopMemoryContext);
typeids = (Oid *) palloc(nargs * sizeof(Oid));
typelems = (Oid *) palloc(nargs * sizeof(Oid));
typinfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo));
MemoryContextSwitchTo(oldcontext);
for (i = 0; i < nargs; i++)
{
int16 typlen;
bool typbyval;
char typdelim;
Oid typinput,
typelem;
char typalign;
FmgrInfo typinfunc;
typeids[i] = INTEGER(rargtypes)[i];
/* switch to long lived context to create plan description elements */
oldcontext = MemoryContextSwitchTo(TopMemoryContext);
get_type_io_data(typeids[i], IOFunc_input, &typlen, &typbyval,
&typalign, &typdelim, &typelem, &typinput);
typelems[i] = typelem;
MemoryContextSwitchTo(oldcontext);
/* perm_fmgr_info already uses TopMemoryContext */
perm_fmgr_info(typinput, &typinfunc);
typinfuncs[i] = typinfunc;
}
}
else
typeids = NULL;
UNPROTECT(1);
/* switch to SPI memory context */
oldcontext = MemoryContextSwitchTo(plr_SPI_context);
/*
* trap elog/ereport so we can let R finish up gracefully
* and generate the error once we exit the interpreter
*/
PG_TRY();
{
/* Prepare plan for query */
pplan = SPI_prepare(sql, nargs, typeids);
}
PLR_PG_CATCH();
PLR_PG_END_TRY();
if (pplan == NULL)
{
char buf[128];
char *reason;
switch (SPI_result)
{
case SPI_ERROR_ARGUMENT:
reason = "SPI_ERROR_ARGUMENT";
break;
case SPI_ERROR_UNCONNECTED:
reason = "SPI_ERROR_UNCONNECTED";
break;
case SPI_ERROR_COPY:
reason = "SPI_ERROR_COPY";
break;
case SPI_ERROR_CURSOR:
reason = "SPI_ERROR_CURSOR";
break;
case SPI_ERROR_TRANSACTION:
reason = "SPI_ERROR_TRANSACTION";
break;
case SPI_ERROR_OPUNKNOWN:
reason = "SPI_ERROR_OPUNKNOWN";
break;
default:
snprintf(buf, sizeof(buf), "unknown RC %d", SPI_result);
reason = buf;
break;
}
/* internal error */
error("SPI_prepare() failed: %s", reason);
}
/* SPI_saveplan already uses TopMemoryContext */
saved_plan = SPI_saveplan(pplan);
if (saved_plan == NULL)
{
char buf[128];
char *reason;
switch (SPI_result)
{
case SPI_ERROR_ARGUMENT:
reason = "SPI_ERROR_ARGUMENT";
break;
case SPI_ERROR_UNCONNECTED:
reason = "SPI_ERROR_UNCONNECTED";
break;
default:
snprintf(buf, sizeof(buf), "unknown RC %d", SPI_result);
reason = buf;
break;
}
/* internal error */
error("SPI_saveplan() failed: %s", reason);
}
/* back to caller's memory context */
MemoryContextSwitchTo(oldcontext);
/* no longer need this */
SPI_freeplan(pplan);
plan_desc->saved_plan = saved_plan;
plan_desc->nargs = nargs;
plan_desc->typeids = typeids;
plan_desc->typelems = typelems;
plan_desc->typinfuncs = typinfuncs;
result = R_MakeExternalPtr(plan_desc, R_NilValue, R_NilValue);
POP_PLERRCONTEXT;
return result;
}
/*
* plr_SPI_exec - The builtin SPI_exec command for the R interpreter
*/
SEXP
plr_SPI_exec(SEXP rsql)
{
int spi_rc = 0;
char buf[64];
const char *sql;
int count = 0;
int ntuples;
SEXP result = NULL;
MemoryContext oldcontext;
PREPARE_PG_TRY;
/* set up error context */
PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.exec");
PROTECT(rsql = AS_CHARACTER(rsql));
sql = CHAR(STRING_ELT(rsql, 0));
UNPROTECT(1);
if (sql == NULL)
error("%s", "cannot exec empty query");
/* switch to SPI memory context */
oldcontext = MemoryContextSwitchTo(plr_SPI_context);
/*
* trap elog/ereport so we can let R finish up gracefully
* and generate the error once we exit the interpreter
*/
PG_TRY();
{
/* Execute the query and handle return codes */
spi_rc = SPI_exec(sql, count);
}
PLR_PG_CATCH();
PLR_PG_END_TRY();
/* back to caller's memory context */
MemoryContextSwitchTo(oldcontext);
switch (spi_rc)
{
case SPI_OK_UTILITY:
snprintf(buf, sizeof(buf), "%d", 0);
SPI_freetuptable(SPI_tuptable);
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(buf));
UNPROTECT(1);
break;
case SPI_OK_SELINTO:
case SPI_OK_INSERT:
case SPI_OK_DELETE:
case SPI_OK_UPDATE:
snprintf(buf, sizeof(buf), "%d", SPI_processed);
SPI_freetuptable(SPI_tuptable);
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(buf));
UNPROTECT(1);
break;
case SPI_OK_SELECT:
ntuples = SPI_processed;
if (ntuples > 0)
{
result = rpgsql_get_results(ntuples, SPI_tuptable);
SPI_freetuptable(SPI_tuptable);
}
else
result = R_NilValue;
break;
case SPI_ERROR_ARGUMENT:
error("SPI_exec() failed: SPI_ERROR_ARGUMENT");
break;
case SPI_ERROR_UNCONNECTED:
error("SPI_exec() failed: SPI_ERROR_UNCONNECTED");
break;
case SPI_ERROR_COPY:
error("SPI_exec() failed: SPI_ERROR_COPY");
break;
case SPI_ERROR_CURSOR:
error("SPI_exec() failed: SPI_ERROR_CURSOR");
break;
case SPI_ERROR_TRANSACTION:
error("SPI_exec() failed: SPI_ERROR_TRANSACTION");
break;
case SPI_ERROR_OPUNKNOWN:
error("SPI_exec() failed: SPI_ERROR_OPUNKNOWN");
break;
default:
error("SPI_exec() failed: %d", spi_rc);
break;
}
POP_PLERRCONTEXT;
return result;
}
SEXP xmethas(
SEXP ncif,
SEXP cifname,
SEXP beta,
SEXP ipar,
SEXP iparlen,
SEXP period,
SEXP xprop,
SEXP yprop,
SEXP mprop,
SEXP ntypes,
SEXP nrep,
SEXP p,
SEXP q,
SEXP nverb,
SEXP nrep0,
SEXP x,
SEXP y,
SEXP marks,
SEXP ncond,
SEXP fixall,
SEXP track,
SEXP thin,
SEXP snoopenv,
SEXP temper,
SEXP invertemp)
{
char *cifstring;
double cvd, cvn, qnodds, anumer, adenom, betavalue;
double *iparvector;
int verb, marked, tempered, mustupdate, itype;
int nfree, nsuspect;
int irep, ix, j, maxchunk, iverb;
int Ncif;
int *plength;
long Nmore;
int permitted;
double invtemp;
double *xx, *yy, *xpropose, *ypropose;
int *mm, *mpropose, *pp, *aa;
SEXP out, xout, yout, mout, pout, aout;
int tracking, thinstart;
#ifdef HISTORY_INCLUDES_RATIO
SEXP numout, denout;
double *nn, *dd;
#endif
State state;
Model model;
Algor algo;
Propo birthprop, deathprop, shiftprop;
History history;
Snoop snooper;
/* The following variables are used only for a non-hybrid interaction */
Cifns thecif; /* cif structure */
Cdata *thecdata; /* pointer to initialised cif data block */
/* The following variables are used only for a hybrid interaction */
Cifns *cif; /* vector of cif structures */
Cdata **cdata; /* vector of pointers to initialised cif data blocks */
int *needupd; /* vector of logical values */
int k; /* loop index for cif's */
/* =================== Protect R objects from garbage collector ======= */
PROTECT(ncif = AS_INTEGER(ncif));
PROTECT(cifname = AS_CHARACTER(cifname));
PROTECT(beta = AS_NUMERIC(beta));
PROTECT(ipar = AS_NUMERIC(ipar));
PROTECT(iparlen = AS_INTEGER(iparlen));
PROTECT(period = AS_NUMERIC(period));
PROTECT(xprop = AS_NUMERIC(xprop));
PROTECT(yprop = AS_NUMERIC(yprop));
PROTECT(mprop = AS_INTEGER(mprop));
PROTECT(ntypes = AS_INTEGER(ntypes));
PROTECT(nrep = AS_INTEGER(nrep));
PROTECT( p = AS_NUMERIC(p));
PROTECT( q = AS_NUMERIC(q));
PROTECT(nverb = AS_INTEGER(nverb));
PROTECT(nrep0 = AS_INTEGER(nrep0));
PROTECT( x = AS_NUMERIC(x));
PROTECT( y = AS_NUMERIC(y));
PROTECT( marks = AS_INTEGER(marks));
PROTECT(fixall = AS_INTEGER(fixall));
PROTECT(ncond = AS_INTEGER(ncond));
PROTECT(track = AS_INTEGER(track));
PROTECT(thin = AS_INTEGER(thin));
PROTECT(temper = AS_INTEGER(temper));
PROTECT(invertemp = AS_NUMERIC(invertemp));
/* that's 24 protected objects */
/* =================== Translate arguments from R to C ================ */
/*
Ncif is the number of cif's
plength[i] is the number of interaction parameters in the i-th cif
*/
Ncif = *(INTEGER_POINTER(ncif));
plength = INTEGER_POINTER(iparlen);
/* copy RMH algorithm parameters */
algo.nrep = *(INTEGER_POINTER(nrep));
algo.nverb = *(INTEGER_POINTER(nverb));
algo.nrep0 = *(INTEGER_POINTER(nrep0));
algo.p = *(NUMERIC_POINTER(p));
algo.q = *(NUMERIC_POINTER(q));
algo.fixall = ((*(INTEGER_POINTER(fixall))) == 1);
algo.ncond = *(INTEGER_POINTER(ncond));
algo.tempered = tempered = (*(INTEGER_POINTER(temper)) != 0);
algo.invtemp = invtemp = *(NUMERIC_POINTER(invertemp));
/* copy model parameters without interpreting them */
model.beta = NUMERIC_POINTER(beta);
model.ipar = iparvector = NUMERIC_POINTER(ipar);
model.period = NUMERIC_POINTER(period);
model.ntypes = *(INTEGER_POINTER(ntypes));
state.ismarked = marked = (model.ntypes > 1);
/* copy initial state */
state.npts = LENGTH(x);
state.npmax = 4 * ((state.npts > 256) ? state.npts : 256);
state.x = (double *) R_alloc(state.npmax, sizeof(double));
state.y = (double *) R_alloc(state.npmax, sizeof(double));
xx = NUMERIC_POINTER(x);
yy = NUMERIC_POINTER(y);
if(marked) {
state.marks =(int *) R_alloc(state.npmax, sizeof(int));
mm = INTEGER_POINTER(marks);
}
if(!marked) {
for(j = 0; j < state.npts; j++) {
state.x[j] = xx[j];
state.y[j] = yy[j];
}
} else {
for(j = 0; j < state.npts; j++) {
state.x[j] = xx[j];
state.y[j] = yy[j];
state.marks[j] = mm[j];
}
}
#if MH_DEBUG
Rprintf("\tnpts=%d\n", state.npts);
#endif
/* access proposal data */
xpropose = NUMERIC_POINTER(xprop);
ypropose = NUMERIC_POINTER(yprop);
mpropose = INTEGER_POINTER(mprop);
/* we need to initialise 'mpropose' to keep compilers happy.
mpropose is only used for marked patterns.
Note 'mprop' is always a valid pointer */
/* ================= Allocate space for cifs etc ========== */
if(Ncif > 1) {
cif = (Cifns *) R_alloc(Ncif, sizeof(Cifns));
cdata = (Cdata **) R_alloc(Ncif, sizeof(Cdata *));
needupd = (int *) R_alloc(Ncif, sizeof(int));
} else {
/* Keep the compiler happy */
cif = (Cifns *) R_alloc(1, sizeof(Cifns));
cdata = (Cdata **) R_alloc(1, sizeof(Cdata *));
needupd = (int *) R_alloc(1, sizeof(int));
}
/* ================= Determine process to be simulated ========== */
/* Get the cif's */
if(Ncif == 1) {
cifstring = (char *) STRING_VALUE(cifname);
thecif = getcif(cifstring);
mustupdate = NEED_UPDATE(thecif);
if(thecif.marked && !marked)
fexitc("cif is for a marked point process, but proposal data are not marked points; bailing out.");
/* Keep compiler happy*/
cif[0] = thecif;
needupd[0] = mustupdate;
} else {
mustupdate = NO;
for(k = 0; k < Ncif; k++) {
cifstring = (char *) CHAR(STRING_ELT(cifname, k));
cif[k] = getcif(cifstring);
needupd[k] = NEED_UPDATE(cif[k]);
if(needupd[k])
mustupdate = YES;
if(cif[k].marked && !marked)
fexitc("component cif is for a marked point process, but proposal data are not marked points; bailing out.");
}
}
/* ============= Initialise transition history ========== */
tracking = (*(INTEGER_POINTER(track)) != 0);
/* Initialise even if not needed, to placate the compiler */
if(tracking) { history.nmax = algo.nrep; } else { history.nmax = 1; }
history.n = 0;
history.proptype = (int *) R_alloc(history.nmax, sizeof(int));
history.accepted = (int *) R_alloc(history.nmax, sizeof(int));
#ifdef HISTORY_INCLUDES_RATIO
history.numerator = (double *) R_alloc(history.nmax, sizeof(double));
history.denominator = (double *) R_alloc(history.nmax, sizeof(double));
#endif
/* ============= Visual debugging ========== */
/* Active if 'snoopenv' is an environment */
#if MH_DEBUG
Rprintf("Initialising mhsnoop\n");
#endif
initmhsnoop(&snooper, snoopenv);
#if MH_DEBUG
Rprintf("Initialised\n");
if(snooper.active) Rprintf("Debugger is active.\n");
#endif
/* ================= Thinning of initial state ==================== */
thinstart = (*(INTEGER_POINTER(thin)) != 0);
/* ================= Initialise algorithm ==================== */
/* Interpret the model parameters and initialise auxiliary data */
if(Ncif == 1) {
thecdata = (*(thecif.init))(state, model, algo);
/* keep compiler happy */
cdata[0] = thecdata;
} else {
for(k = 0; k < Ncif; k++) {
if(k > 0)
model.ipar += plength[k-1];
cdata[k] = (*(cif[k].init))(state, model, algo);
}
/* keep compiler happy */
thecdata = cdata[0];
}
/* Set the fixed elements of the proposal objects */
birthprop.itype = BIRTH;
deathprop.itype = DEATH;
shiftprop.itype = SHIFT;
birthprop.ix = NONE;
if(!marked)
birthprop.mrk = deathprop.mrk = shiftprop.mrk = NONE;
/* Set up some constants */
verb = (algo.nverb !=0);
qnodds = (1.0 - algo.q)/algo.q;
/* Set value of beta for unmarked process */
/* (Overwritten for marked process, but keeps compiler happy) */
betavalue = model.beta[0];
/* ============= Run Metropolis-Hastings ================== */
/* Initialise random number generator */
GetRNGstate();
/*
Here comes the code for the M-H loop.
The basic code (in mhloop.h) is #included many times using different options
The C preprocessor descends through a chain of files
mhv1.h, mhv2.h, ...
to enumerate all possible combinations of flags.
*/
#include "mhv1.h"
/* relinquish random number generator */
PutRNGstate();
/* ============= Done ================== */
/* Create space for output, and copy final state */
/* Point coordinates */
PROTECT(xout = NEW_NUMERIC(state.npts));
PROTECT(yout = NEW_NUMERIC(state.npts));
xx = NUMERIC_POINTER(xout);
yy = NUMERIC_POINTER(yout);
for(j = 0; j < state.npts; j++) {
xx[j] = state.x[j];
yy[j] = state.y[j];
}
/* Marks */
if(marked) {
PROTECT(mout = NEW_INTEGER(state.npts));
mm = INTEGER_POINTER(mout);
for(j = 0; j < state.npts; j++)
mm[j] = state.marks[j];
} else {
/* Keep the compiler happy */
PROTECT(mout = NEW_INTEGER(1));
mm = INTEGER_POINTER(mout);
mm[0] = 0;
}
/* Transition history */
if(tracking) {
PROTECT(pout = NEW_INTEGER(algo.nrep));
PROTECT(aout = NEW_INTEGER(algo.nrep));
pp = INTEGER_POINTER(pout);
aa = INTEGER_POINTER(aout);
for(j = 0; j < algo.nrep; j++) {
pp[j] = history.proptype[j];
aa[j] = history.accepted[j];
}
#ifdef HISTORY_INCLUDES_RATIO
PROTECT(numout = NEW_NUMERIC(algo.nrep));
PROTECT(denout = NEW_NUMERIC(algo.nrep));
nn = NUMERIC_POINTER(numout);
dd = NUMERIC_POINTER(denout);
for(j = 0; j < algo.nrep; j++) {
nn[j] = history.numerator[j];
dd[j] = history.denominator[j];
}
#endif
} else {
/* Keep the compiler happy */
PROTECT(pout = NEW_INTEGER(1));
PROTECT(aout = NEW_INTEGER(1));
pp = INTEGER_POINTER(pout);
aa = INTEGER_POINTER(aout);
pp[0] = aa[0] = 0;
#ifdef HISTORY_INCLUDES_RATIO
PROTECT(numout = NEW_NUMERIC(1));
PROTECT(denout = NEW_NUMERIC(1));
nn = NUMERIC_POINTER(numout);
dd = NUMERIC_POINTER(denout);
nn[0] = dd[0] = 0;
#endif
}
/* Pack up into list object for return */
if(!tracking) {
/* no transition history */
if(!marked) {
PROTECT(out = NEW_LIST(2));
SET_VECTOR_ELT(out, 0, xout);
SET_VECTOR_ELT(out, 1, yout);
} else {
PROTECT(out = NEW_LIST(3));
SET_VECTOR_ELT(out, 0, xout);
SET_VECTOR_ELT(out, 1, yout);
SET_VECTOR_ELT(out, 2, mout);
}
} else {
/* transition history */
if(!marked) {
#ifdef HISTORY_INCLUDES_RATIO
PROTECT(out = NEW_LIST(6));
#else
PROTECT(out = NEW_LIST(4));
#endif
SET_VECTOR_ELT(out, 0, xout);
SET_VECTOR_ELT(out, 1, yout);
SET_VECTOR_ELT(out, 2, pout);
SET_VECTOR_ELT(out, 3, aout);
#ifdef HISTORY_INCLUDES_RATIO
SET_VECTOR_ELT(out, 4, numout);
SET_VECTOR_ELT(out, 5, denout);
#endif
} else {
#ifdef HISTORY_INCLUDES_RATIO
PROTECT(out = NEW_LIST(7));
#else
PROTECT(out = NEW_LIST(5));
#endif
SET_VECTOR_ELT(out, 0, xout);
SET_VECTOR_ELT(out, 1, yout);
SET_VECTOR_ELT(out, 2, mout);
SET_VECTOR_ELT(out, 3, pout);
SET_VECTOR_ELT(out, 4, aout);
#ifdef HISTORY_INCLUDES_RATIO
SET_VECTOR_ELT(out, 5, numout);
SET_VECTOR_ELT(out, 6, denout);
#endif
}
}
#ifdef HISTORY_INCLUDES_RATIO
UNPROTECT(32); /* 24 arguments plus xout, yout, mout, pout, aout, out,
numout, denout */
#else
UNPROTECT(30); /* 24 arguments plus xout, yout, mout, pout, aout, out */
#endif
return(out);
}
SEXP R_THD_write_dset(SEXP Sfname, SEXP Sdset, SEXP Opts)
{
SEXP Rdset, brik, head, names, opt, node_list;
int i=0, ip=0, sb, cnt=0, scale = 1, overwrite=0, addFDR=0,
kparts=2, *iv=NULL;
char *fname = NULL, *head_str, *stmp=NULL, *hist=NULL;
NI_group *ngr=NULL;
NI_element *nel=NULL;
char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose
for backward compatibility */
double *dv=NULL;
float *fv=NULL;
THD_3dim_dataset *dset = NULL;
int debug=0;
if (!debug) debug = get_odebug();
/* get the options list, maybe */
PROTECT(Opts = AS_LIST(Opts));
if ((opt = getListElement(Opts,"debug")) != R_NilValue) {
debug = (int)INTEGER_VALUE(opt);
if (debug>2) set_odebug(debug);
if (debug > 1) INFO_message("Debug is %d\n", debug);
}
/* get the filename */
PROTECT(Sfname = AS_CHARACTER(Sfname));
fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char));
strcpy(fname, CHAR(STRING_ELT(Sfname,0)));
if (debug >1) INFO_message("Output filename %s\n"
, fname);
/* get the dset structure elements */
PROTECT(Rdset = AS_LIST(Sdset));
if ((head = AS_CHARACTER(getListElement(Rdset,"head"))) == R_NilValue) {
ERROR_message("No header found");
UNPROTECT(3);
return(R_NilValue);
}
if (debug > 1) INFO_message("First head element %s\n"
, CHAR(STRING_ELT(head,0)));
if ((brik = AS_NUMERIC(getListElement(Rdset,"brk"))) == R_NilValue) {
ERROR_message("No brick found");
UNPROTECT(3);
return(R_NilValue);
}
dv = NUMERIC_POINTER(brik);
if (debug > 1) INFO_message("First brik value %f\n"
, dv[0]);
ngr = NI_new_group_element();
NI_rename_group(ngr, "AFNI_dataset" );
NI_set_attribute(ngr,"AFNI_prefix", fname);
if ((opt = getListElement(Opts,"idcode")) != R_NilValue) {
opt = AS_CHARACTER(opt);
stmp = (char *)(CHAR(STRING_ELT(opt,0)));
if (stmp && !strcmp(stmp,"SET_AT_WRITE_FILENAME")) {
stmp = UNIQ_hashcode(fname);
NI_set_attribute(ngr, "AFNI_idcode", stmp);
free(stmp);
} else if (stmp && !strcmp(stmp,"SET_AT_WRITE_RANDOM")) {
stmp = UNIQ_idcode() ;
NI_set_attribute(ngr, "AFNI_idcode", stmp);
free(stmp);
} else if (stmp) {
NI_set_attribute(ngr, "AFNI_idcode",
(char *)(CHAR(STRING_ELT(opt,0))));
}
}
if ((opt = getListElement(Opts,"scale")) != R_NilValue) {
scale = (int)INTEGER_VALUE(opt);
if (debug > 1) INFO_message("Scale is %d\n", scale);
}
if ((opt = getListElement(Opts,"overwrite")) != R_NilValue) {
overwrite = (int)INTEGER_VALUE(opt);
if (debug > 1) INFO_message("overwrite is %d\n", overwrite);
THD_force_ok_overwrite(overwrite) ;
if (overwrite) THD_set_quiet_overwrite(1);
}
if ((opt = getListElement(Opts,"addFDR")) != R_NilValue) {
addFDR = (int)INTEGER_VALUE(opt);
if (debug > 1) INFO_message("addFDR is %d\n", addFDR);
}
PROTECT(opt = getListElement(Opts,"hist"));
if ( opt != R_NilValue) {
opt = AS_CHARACTER(opt);
hist = R_alloc(strlen(CHAR(STRING_ELT(opt,0)))+1, sizeof(char));
strcpy(hist, CHAR(STRING_ELT(opt,0)));
if (debug > 1) INFO_message("hist is %s\n", hist);
}
UNPROTECT(1);
for (ip=0,i=0; i<length(head); ++i) {
head_str = (char *)CHAR(STRING_ELT(head,i));
if (debug > 1) {
INFO_message("Adding %s\n", head_str);
}
nel = NI_read_element_fromstring(head_str);
if (!nel->vec) {
ERROR_message("Empty attribute vector for\n%s\n"
"This is not expected.\n",
head_str);
UNPROTECT(3);
return(R_NilValue);
}
NI_add_to_group(ngr,nel);
}
if (debug > 1) INFO_message("Creating dset header\n");
if (!(dset = THD_niml_to_dataset(ngr, 1))) {
ERROR_message("Failed to create header");
UNPROTECT(3);
return(R_NilValue);
}
if (debug > 2) {
INFO_message("Have header of %d, %d, %d, %d, scale=%d\n",
DSET_NX(dset), DSET_NY(dset),
DSET_NZ(dset), DSET_NVALS(dset), scale);
}
for (i=0; i<DSET_NVALS(dset); ++i) {
if (debug > 2) {
INFO_message("Putting values in sub-brick %d, type %d\n",
i, DSET_BRICK_TYPE(dset,i));
}
if ( ( DSET_BRICK_TYPE(dset,i) == MRI_byte ||
DSET_BRICK_TYPE(dset,i) == MRI_short ) ) {
EDIT_substscale_brick(dset, i,
MRI_double, dv+i*DSET_NVOX(dset),
DSET_BRICK_TYPE(dset,i), scale ? -1.0:1.0);
} else if ( DSET_BRICK_TYPE(dset,i) == MRI_double ) {
EDIT_substitute_brick(dset, i,
MRI_double, dv+i*DSET_NVOX(dset));
} else if ( DSET_BRICK_TYPE(dset,i) == MRI_float ) {
float *ff=(float*)calloc(DSET_NVOX(dset), sizeof(float));
double *dvi=dv+i*DSET_NVOX(dset);
for (ip=0; ip<DSET_NVOX(dset); ++ip) {
ff[ip] = dvi[ip];
}
EDIT_substitute_brick(dset, i, MRI_float, ff);
}
}
/* THD_update_statistics( dset ) ; */
if (addFDR) {
DSET_BRICK_FDRCURVE_ALLKILL(dset) ;
DSET_BRICK_MDFCURVE_ALLKILL(dset) ; /* 22 Oct 2008 */
if( addFDR > 0 ){
int nFDRmask=0; /* in the future, perhaps allow for a mask */
byte *FDRmask=NULL; /* to be sent in also, for now, mask is exact */
/* 0 voxels . */
mri_fdr_setmask( (nFDRmask == DSET_NVOX(dset)) ? FDRmask : NULL ) ;
ip = THD_create_all_fdrcurves(dset) ;
if( ip > 0 ){
if (debug)
ININFO_message("created %d FDR curve%s in dataset header",
ip,(ip==1)?"\0":"s") ;
} else {
if (debug)
ININFO_message("failed to create FDR curves in dataset header") ;
}
}
}
/* Do we have an index_list? */
if ((node_list=AS_INTEGER(getListElement(Rdset,"index_list")))!=R_NilValue) {
iv = INTEGER_POINTER(node_list);
if (debug > 1) INFO_message("First node index value %d, total (%d)\n",
iv[0], length(node_list));
dset->dblk->nnodes = length(node_list);
dset->dblk->node_list = (int *)XtMalloc(dset->dblk->nnodes * sizeof(int));
memcpy(dset->dblk->node_list, iv, dset->dblk->nnodes*sizeof(int));
}
if (hist) {
tross_Append_History(dset, hist);
}
DSET_write(dset);
UNPROTECT(3);
return(R_NilValue);
}
SEXP R_THD_load_dset(SEXP Sfname, SEXP Opts)
{
SEXP Rdset, brik, head, names, opt, node_list=R_NilValue;
int i=0, ip=0, sb, cnt=0, *iv=NULL, kparts=2;
char *fname = NULL, *head_str;
NI_group *ngr=NULL;
NI_element *nel=NULL;
char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose
for backward compatibility */
double *dv=NULL;
float *fv=NULL;
THD_3dim_dataset *dset = NULL;
int debug=0;
if (!debug) debug = get_odebug();
/* get the options list, maybe */
PROTECT(Opts = AS_LIST(Opts));
if ((opt = getListElement(Opts,"debug")) != R_NilValue) {
debug = (int)INTEGER_VALUE(opt);
if (debug>2) set_odebug(debug);
if (debug>1) INFO_message("Debug is %d\n", debug);
}
/* get the filename */
PROTECT(Sfname = AS_CHARACTER(Sfname));
fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char));
strcpy(fname, CHAR(STRING_ELT(Sfname,0)));
/* open dset */
dset = THD_open_dataset(fname);
if (dset) {
if (debug > 1) INFO_message("Dset %s was loaded 2\n", fname);
} else {
ERROR_message("Dset %s could not be loaded\n", fname);
UNPROTECT(2);
return(R_NilValue);
}
/* form one long header string */
ngr = THD_nimlize_dsetatr(dset);
PROTECT(head = allocVector(STRSXP, ngr->part_num));
for (ip=0,i=0; i<ngr->part_num; ++i) {
switch( ngr->part_typ[i] ){
/*-- a sub-group ==> recursion! --*/
case NI_GROUP_TYPE:
break ;
case NI_ELEMENT_TYPE:
nel = (NI_element *)ngr->part[i] ;
head_str = NI_write_element_tostring(nel);
if (debug > 1) fprintf(stderr,"%s\n", head_str);
SET_STRING_ELT(head, ip, mkChar(head_str)); ++ip;
free(head_str);
break;
default:
break;
}
}
NI_free_element(ngr);
if (debug > 1) fprintf(stderr,"Forming data array of %d elements\n",
DSET_NVOX(dset)*DSET_NVALS(dset));
/* form one long array of data */
PROTECT(brik = NEW_NUMERIC(DSET_NVOX(dset)*DSET_NVALS(dset)));
dv = NUMERIC_POINTER(brik);
EDIT_floatize_dataset(dset);
for (cnt=0, sb=0; sb<DSET_NVALS(dset); ++sb) {
if (!(fv = (float *)DSET_BRICK_ARRAY(dset,sb))) {
ERROR_message("NULL brick array %d!\n", sb);
UNPROTECT(4);
return(R_NilValue);
}
if (debug > 1) fprintf(stderr,"Filling sb %d\n", sb);
for (i=0; i<DSET_NVOX(dset); ++i) {
dv[cnt++] = fv[i];
if (debug > 1) {
if (debug > 2 || i<10) {
fprintf(stderr,"%f\t", fv[i]);
}
}
}
if (debug == 2) fprintf(stderr,"...\n");
else if (debug > 2) fprintf(stderr,"\n");
}
/* how about an index list ? */
if (dset->dblk->nnodes && dset->dblk->node_list) {
if (debug > 1)
fprintf(stderr,"Copying %d node indices\n", dset->dblk->nnodes);
PROTECT(node_list = NEW_INTEGER(dset->dblk->nnodes));
iv = INTEGER_POINTER(node_list);
memcpy(iv, dset->dblk->node_list, dset->dblk->nnodes*sizeof(int));
kparts = 3;
} else {
kparts = 2;
if (debug > 1)
fprintf(stderr,"No node indices %d %p\n",
dset->dblk->nnodes, dset->dblk->node_list);
}
/* done with dset, dump it */
DSET_delete(dset);
/* form output list */
PROTECT(names = allocVector(STRSXP,kparts));
for (i=0; i<kparts; ++i) {
SET_STRING_ELT(names, i, mkChar(listels[i]));
}
PROTECT(Rdset = allocVector(VECSXP,kparts));
SET_VECTOR_ELT(Rdset, 0, head);
SET_VECTOR_ELT(Rdset, 1, brik);
if (node_list != R_NilValue) SET_VECTOR_ELT(Rdset, 2, node_list);
setAttrib(Rdset, R_NamesSymbol, names);
if (debug > 1) fprintf(stderr,"Unprotecting...\n");
if (kparts==3) UNPROTECT(7);
else UNPROTECT(6);
return(Rdset);
}
