Пример #1
0
SEXP shift(SEXP obj, SEXP k, SEXP fill, SEXP type) {

  size_t size;
  int protecti=0;
  SEXP x, tmp=R_NilValue, elem, ans, thisfill, klass;
  unsigned long long *dthisfill;
  enum {LAG, LEAD/*, SHIFT, CYCLIC*/} stype = LAG; // currently SHIFT maps to LAG and CYCLIC is unimplemented (see comments in #1708)
  if (!xlength(obj)) return(obj); // NULL, list()
  if (isVectorAtomic(obj)) {
    x = PROTECT(allocVector(VECSXP, 1)); protecti++;
    SET_VECTOR_ELT(x, 0, obj);
  } else x = obj;
  if (!isNewList(x))
    error("x must be a list, data.frame or data.table");
  if (length(fill) != 1)
    error("fill must be a vector of length 1");
  // the following two errors should be caught by match.arg() at the R level
  if (!isString(type) || length(type) != 1)
    error("Internal error: invalid type for shift(), should have been caught before. please report to data.table issue tracker"); // # nocov
  if (!strcmp(CHAR(STRING_ELT(type, 0)), "lag")) stype = LAG;
  else if (!strcmp(CHAR(STRING_ELT(type, 0)), "lead")) stype = LEAD;
  else if (!strcmp(CHAR(STRING_ELT(type, 0)), "shift")) stype = LAG; // when we get rid of nested if branches we can use SHIFT, for now it maps to LAG
  else error("Internal error: invalid type for shift(), should have been caught before. please report to data.table issue tracker"); // # nocov

  int nx = length(x), nk = length(k);
  if (!isInteger(k)) error("Internal error: k must be integer"); // # nocov
  const int *kd = INTEGER(k);
  for (int i=0; i<nk; i++) if (kd[i]==NA_INTEGER) error("Item %d of n is NA", i+1);  // NA crashed (#3354); n is called k at C level

  ans = PROTECT(allocVector(VECSXP, nk * nx)); protecti++;
  for (int i=0; i<nx; i++) {
    elem  = VECTOR_ELT(x, i);
    size  = SIZEOF(elem);
    R_xlen_t xrows = xlength(elem);
    switch (TYPEOF(elem)) {
    case INTSXP :
      thisfill = PROTECT(coerceVector(fill, INTSXP)); protecti++;
      int ifill = INTEGER(thisfill)[0];
      for (int j=0; j<nk; j++) {
        R_xlen_t thisk = MIN(abs(kd[j]), xrows);
        SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(INTSXP, xrows) );
        int *itmp = INTEGER(tmp);
        size_t tailk = xrows-thisk;
        if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
          // LAG when type = 'lag' and n >= 0 _or_ type = 'lead' and n < 0
          if (tailk > 0) memmove(itmp+thisk, INTEGER(elem), tailk*size);
          for (int m=0; m<thisk; m++) itmp[m] = ifill;
        } else {
          // only two possibilities left: type = 'lead', n>=0 _or_ type = 'lag', n<0
          if (tailk > 0) memmove(itmp, INTEGER(elem)+thisk, tailk*size);
          for (int m=xrows-thisk; m<xrows; m++) itmp[m] = ifill;
        }
        copyMostAttrib(elem, tmp);
        if (isFactor(elem)) setAttrib(tmp, R_LevelsSymbol, getAttrib(elem, R_LevelsSymbol));
      }
      break;

    case REALSXP :
      klass = getAttrib(elem, R_ClassSymbol);
      if (isString(klass) && STRING_ELT(klass, 0) == char_integer64) {
        thisfill = PROTECT(allocVector(REALSXP, 1)); protecti++;
        dthisfill = (unsigned long long *)REAL(thisfill);
        if (INTEGER(fill)[0] == NA_INTEGER)
          dthisfill[0] = NA_INT64_LL;
        else dthisfill[0] = (unsigned long long)INTEGER(fill)[0];
      } else {
        thisfill = PROTECT(coerceVector(fill, REALSXP)); protecti++;
      }
      double dfill = REAL(thisfill)[0];
      for (int j=0; j<nk; j++) {
        R_xlen_t thisk = MIN(abs(kd[j]), xrows);
        SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(REALSXP, xrows) );
        double *dtmp = REAL(tmp);
        size_t tailk = xrows-thisk;
        if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
          if (tailk > 0) memmove(dtmp+thisk, REAL(elem), tailk*size);
          for (int m=0; m<thisk; m++) dtmp[m] = dfill;
        } else {
          if (tailk > 0) memmove(dtmp, REAL(elem)+thisk, tailk*size);
          for (int m=tailk; m<xrows; m++) dtmp[m] = dfill;
        }
        copyMostAttrib(elem, tmp);
      }
      break;

    case LGLSXP :
      thisfill = PROTECT(coerceVector(fill, LGLSXP)); protecti++;
      int lfill = LOGICAL(thisfill)[0];
      for (int j=0; j<nk; j++) {
        R_xlen_t thisk = MIN(abs(kd[j]), xrows);
        SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(LGLSXP, xrows) );
        int *ltmp = LOGICAL(tmp);
        size_t tailk = xrows-thisk;
        if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
          if (tailk > 0) memmove(ltmp+thisk, LOGICAL(elem), tailk*size);
          for (int m=0; m<thisk; m++) ltmp[m] = lfill;
        } else {
          if (tailk > 0) memmove(ltmp, LOGICAL(elem)+thisk, tailk*size);
          for (int m=tailk; m<xrows; m++) ltmp[m] = lfill;
        }
        copyMostAttrib(elem, tmp);
      }
      break;

    case STRSXP :
      thisfill = PROTECT(coerceVector(fill, STRSXP)); protecti++;
      for (int j=0; j<nk; j++) {
        SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(STRSXP, xrows) );
        int thisk = abs(kd[j]);
        if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
          for (int m=0; m<xrows; m++) SET_STRING_ELT(tmp, m, (m < thisk) ? STRING_ELT(thisfill, 0) : STRING_ELT(elem, m - thisk));
        } else {
          for (int m=0; m<xrows; m++) SET_STRING_ELT(tmp, m, (xrows-m <= thisk) ? STRING_ELT(thisfill, 0) : STRING_ELT(elem, m + thisk));
        }
        copyMostAttrib(elem, tmp);
      }
      break;

    case VECSXP :
      thisfill = PROTECT(coerceVector(fill, VECSXP)); protecti++;
      for (int j=0; j<nk; j++) {
        SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(VECSXP, xrows) );
        int thisk = abs(kd[j]);
        if ((stype == LAG && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
          for (int m=0; m<xrows; m++) SET_VECTOR_ELT(tmp, m, (m < thisk) ? VECTOR_ELT(thisfill, 0) : VECTOR_ELT(elem, m - thisk));
        } else {
          for (int m=0; m<xrows; m++) SET_VECTOR_ELT(tmp, m, (xrows-m <= thisk) ? VECTOR_ELT(thisfill, 0) : VECTOR_ELT(elem, m + thisk));
        }
        copyMostAttrib(elem, tmp);
      }
      break;

    default :
      error("Unsupported type '%s'", type2char(TYPEOF(elem)));
    }
  }

  UNPROTECT(protecti);
  return isVectorAtomic(obj) && length(ans) == 1 ? VECTOR_ELT(ans, 0) : ans;
}
Пример #2
0
SEXP Muste_Command(SEXP para) // RS EDT 19.9.2012
{
extern int muste_lopetus;
extern int muste_window_existing;
extern int op_load();
extern void op_theme();
extern int g;
extern char *parm[];
extern char *word[];
extern char orig_setup[], current_setup[];
extern int sur_dump();
extern char sur_session[];
char *kojo, *txtparm;
//Rprintf("\nMuste_Command: %s",CHAR(STRING_ELT(para,0)));

kojo=(char *)CHAR(STRING_ELT(para,0));
if (strcmp(kojo,"LoadEdt")==0)
	{
	sur_dump(sur_session);	
	g=2;
	parm[1]=(char *)CHAR(STRING_ELT(para,1));
	op_load();
	disp();
	return(para);
	}

if (strcmp(kojo,"Restore")==0)
	{
	muste_emergency_stop=1;
	return(para);
	}

if (strcmp(kojo,"DumpEdt")==0)
	{
	extern int sur_dump();
	sur_dump();
	return(para);
	}

if (strcmp(kojo,"SaveEdt")==0)
	{
	extern int muste_save_firstline();
	int i;
	i=muste_save_firstline();
	if (i<0) muste_set_R_int(".muste$saverror",1);
	return(para);
	}

if (strcmp(kojo,"SaveEdtName")==0)
	{
	extern int muste_save_firstline_name();
	word[1]=(char *)CHAR(STRING_ELT(para,1));
	muste_save_firstline_name(word[1]);
	return(para);
	}

if (strcmp(kojo,"RemovePlotWindows")==0)
	{
	extern int op_gplot();
	g=3; parm[1]="/DEL"; parm[2]="ALL";
	op_gplot();
	return(para);
	}	
	
	
if (strcmp(kojo,"GetSaveName")==0)
	{	
	edread(str1,1);
    g=splitq(str1+1,parm,2);
    if (g>1) 
    	{
    	if (strcmp(parm[0],"SAVE")==0) muste_set_R_string(".muste$savename",parm[1]);
    	}
    return(para);
    }	

if (strcmp(kojo,"Theme")==0)
	{
	g=2;
	word[1]=(char *)CHAR(STRING_ELT(para,1));
	op_theme();
	disp();
	return(para);
	}	

if (strcmp(kojo,"Cut")==0)
	{
	extern int muste_cutselection();
	extern int muste_selection;
	int i;

	sur_dump(sur_session);	
	i=atoi((char *)CHAR(STRING_ELT(para,1)));
	if (i<10 && muste_selection)
		{	
		muste_cutselection(i);
		}
	else if (i>10) muste_cutselection(i);
	return(para);
	}	

if (strcmp(kojo,"Undo")==0)
	{
	extern int op_undo();
	op_undo();
	return(para);
	}	

if (strcmp(kojo,"Redo")==0)
	{
	extern int op_redo();
	op_redo();
	return(para);
	}

if (strcmp(kojo,"Require")==0)
	{
	txtparm=(char *)CHAR(STRING_ELT(para,1));
	if (strcmp(txtparm,"tcltk")==0)
	    {
        muste_evalr("require(tcltk)");
	    }
	else // RS 29.8.2013
	    {
	    muste_requirepackage(txtparm);
	    }
	return(para);
	}
	
if (strcmp(kojo,"Apufile")==0)
	{
	word[1]=(char *)CHAR(STRING_ELT(para,1));
	strcpy(orig_setup,word[1]);
	strcpy(current_setup,word[1]);
	return(para);
	}	

/*
if (strcmp(kojo,"HookLast")==0)
    {
//    sprintf(cmd,".Last.sys <- function() { cat('collection is invoked...') }");
sprintf(cmd,"qq <- q"); 
    muste_evalr(cmd);
sprintf(cmd,"quit <- q <- function(save = \"default\", status = 0, runLast = TRUE) { if (exists(\"editor\",where=.muste)) muste:::.muste.end(); else qq(save,status,runLast); }");
    muste_evalr(cmd);
    return(para);
    }
*/
if (strcmp(kojo,"Exit")==0)
	{
	muste_lopetus=TRUE;
	muste_window_existing=FALSE;
	}
	
return(para);
}   
Пример #3
0
  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 とセットされる
	
	// 	///////////////////////////////////////////////////////
  }
Пример #4
0
//
// The main glob() routine: compiles the pattern (optionally processing
// quotes), calls glob1() to do the real pattern matching, and finally
// sorts the list (unless unsorted operation is requested).  Returns 0
// if things went well, nonzero if errors occurred.
//
static int glob0(const char *pattern, glob_t *pglob, size_t *limit) {
  const char *qpatnext;
  int c, err;
  size_t oldpathc;
  char *bufnext, patbuf[MAXPATH];

  qpatnext = globtilde(pattern, patbuf, MAXPATH, pglob);
  oldpathc = pglob->gl_pathc;
  bufnext = patbuf;

  // We don't need to check for buffer overflow any more
  while ((c = *qpatnext++) != EOS) {
    switch (c) {
      case LBRACKET:
        c = *qpatnext;
        if (c == NOT) ++qpatnext;
        if (*qpatnext == EOS || strchr(qpatnext + 1, RBRACKET) == NULL) {
          *bufnext++ = LBRACKET;
          if (c == NOT) --qpatnext;
          break;
        }
        *bufnext++ = M_SET;
        if (c == NOT) *bufnext++ = M_NOT;
        c = *qpatnext++;
        do {
          *bufnext++ = CHAR(c);
          if (*qpatnext == RANGE && (c = qpatnext[1]) != RBRACKET) {
            *bufnext++ = M_RNG;
            *bufnext++ = CHAR(c);
            qpatnext += 2;
          }
        } while ((c = *qpatnext++) != RBRACKET);
        pglob->gl_flags |= GLOB_MAGCHAR;
        *bufnext++ = M_END;
        break;

      case QUESTION:
        pglob->gl_flags |= GLOB_MAGCHAR;
        *bufnext++ = M_ONE;
        break;

      case STAR:
        pglob->gl_flags |= GLOB_MAGCHAR;
        // Collapse adjacent stars to one, to avoid exponential behavior
        if (bufnext == patbuf || bufnext[-1] != M_ALL) *bufnext++ = M_ALL;
        break;

      default:
        *bufnext++ = CHAR(c);
        break;
    }
  }
  *bufnext = EOS;
#ifdef DEBUG
  qprintf("glob0:", patbuf);
#endif

  if ((err = glob1(patbuf, pglob, limit)) != 0) return err;

  //
  // If there was no match we are going to append the pattern
  // if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was specified
  // and the pattern did not contain any magic characters
  // GLOB_NOMAGIC is there just for compatibility with csh.
  //

  if (pglob->gl_pathc == oldpathc) {
    if (((pglob->gl_flags & GLOB_NOCHECK) ||
        ((pglob->gl_flags & GLOB_NOMAGIC) &&
      !(pglob->gl_flags & GLOB_MAGCHAR)))) {
      return globextend(pattern, pglob, limit);
    } else {
      return GLOB_NOMATCH;
    }
  }

  if (!(pglob->gl_flags & GLOB_NOSORT)) {
    qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc,
        pglob->gl_pathc - oldpathc, sizeof(char *), compare);
  }
  
  return 0;
}
Пример #5
0
SEXP cr_set(SEXP sc, SEXP keys, SEXP values) {
    rconn_t *c;
    int n, i;
    const char **argv = argbuf;
    size_t *argsz = argszbuf;
    redisReply *reply;

    if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
    c = (rconn_t*) EXTPTR_PTR(sc);
    if (!c) Rf_error("invalid connection (NULL)");
    rc_validate_connection(c, 0);
    if (TYPEOF(keys) != STRSXP)
	Rf_error("invalid keys");
    n = LENGTH(keys);
    if (n < 1) return R_NilValue;
    /* FIXME: we check only the first ... in the hope that we support more formats later */
    if (TYPEOF(values) != VECSXP || TYPEOF(VECTOR_ELT(values, 0)) != RAWSXP)
	Rf_error ("Sorry, values can only be a list of raw vectors for now");
    if (LENGTH(values) != n) Rf_error("keys/values length mismatch");
    if (2 * n + 1 > NARGBUF) {
	argv = malloc(sizeof(const char*) * (2 * n + 2));
	if (!argv)
	    Rf_error("out of memory");
	argsz = malloc(sizeof(size_t) * (2 * n + 2));
	if (!argsz) {
	    free(argv);
	    Rf_error("out of memory");
	}
    }
    argv[0] = "MSET"; argsz[0] = strlen(argv[0]);
    for (i = 0; i < n; i++) {
	argv [2 * i + 1] = CHAR(STRING_ELT(keys, i));
	argsz[2 * i + 1] = strlen(argv[2 * i + 1]);
	argv [2 * i + 2] = (char*) RAW(VECTOR_ELT(values, i));
	argsz[2 * i + 2] = LENGTH(VECTOR_ELT(values, i));
    }
    reply = redisCommandArgv(c->rc, 2 * n + 1, argv, argsz);
    if (!reply && (c->flags & RCF_RETRY)) {
	SEXP es = Rf_mkChar(c->rc->errstr);
	rc_close(c);
	rc_validate_connection(c, 1);
	if (c->rc)
	    reply = redisCommandArgv(c->rc, 2 * n + 1, argv, argsz);
	else {
	    if (argv != argbuf) {
		free(argv);
		free(argsz);
	    }
	    Rf_error("MGET error: %s and re-connect failed", CHAR(es));
	}
    }
    if (argv != argbuf) {
	free(argv);
	free(argsz);
    }
    if (!reply) {
	SEXP es = Rf_mkChar(c->rc->errstr);
	rc_close(c);
	Rf_error("MSET error: %s", CHAR(es));
    }
    /* Rprintf("reply, type=%d\n", reply->type); */
    /* Note: the result is normally "status" - probably nothing useful we can do with that? */
    freeReplyObject(reply);
    return R_NilValue;
}
Пример #6
0
Файл: jri.c Проект: s-u/rJava
/* returns string from a CHARSXP making sure that the result is in UTF-8 */
const char *jri_char_utf8(SEXP s) {
        if (Rf_getCharCE(s) == CE_UTF8) return CHAR(s);
        return Rf_reEnc(CHAR(s), getCharCE(s), CE_UTF8, 1); /* subst. invalid chars: 1=hex, 2=., 3=?, other=skip */
}
Пример #7
0
/*
 * 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] = get_element_type(typeids[i]);

			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 */
	SWITCHTO_PLR_SPI_CONTEXT(oldcontext);

	/*
	 * 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;
}
Пример #8
0
SEXP RS_connect(SEXP sHost, SEXP sPort, SEXP useTLS, SEXP sProxyTarget, SEXP sProxyWait) {
    int port = asInteger(sPort), use_tls = (asInteger(useTLS) == 1), px_get_slot = (asInteger(sProxyWait) == 0);
    const char *host;
    char idstr[32];
    rsconn_t *c;
    SEXP res, caps = R_NilValue;

    if (port < 0 || port > 65534)
	Rf_error("Invalid port number");
#ifdef WIN32
    if (!port)
	Rf_error("unix sockets are not supported in Windows");
#endif
#ifndef USE_TLS
    if (use_tls)
	Rf_error("TLS is not supported in this build - recompile with OpenSSL");
#endif
    if (sHost == R_NilValue && !port)
	Rf_error("socket name must be specified in socket mode");
    if (sHost == R_NilValue)
	host = "127.0.0.1";
    else {
	if (TYPEOF(sHost) != STRSXP || LENGTH(sHost) != 1)
	    Rf_error("host must be a character vector of length one");
	host = R2UTF8(sHost);
    }
    c = rsc_connect(host, port);
    if (!c)
	Rf_error("cannot connect to %s:%d", host, port);
#ifdef USE_TLS
    if (use_tls && tls_upgrade(c) != 1) {
	rsc_close(c);
	Rf_error("TLS handshake failed");
    }
#endif	
    if (rsc_read(c, idstr, 32) != 32) {
	rsc_close(c);
	Rf_error("Handshake failed - ID string not received");
    }
    if (!memcmp(idstr, "RSpx", 4) && !memcmp(idstr + 8, "QAP1", 4)) { /* RSpx proxy protocol */
	const char *proxy_target;
	struct phdr hdr;
	if (TYPEOF(sProxyTarget) != STRSXP || LENGTH(sProxyTarget) < 1) {
	    rsc_close(c);
	    Rf_error("Connected to a non-transparent proxy, but no proxy target was specified");
	}
	/* send CMD_PROXY_TARGET and re-fetch ID string */
	proxy_target = CHAR(STRING_ELT(sProxyTarget, 0));
	hdr.cmd = itop(CMD_PROXY_TARGET);
	hdr.len = itop(strlen(proxy_target) + 1);
	hdr.dof = 0;
	hdr.res = 0;
	rsc_write(c, &hdr, sizeof(hdr));
	rsc_write(c, proxy_target, strlen(proxy_target) + 1);
	if (px_get_slot) { /* send CMD_PROXY_GET_SLOT as well if requested */
	    hdr.cmd = itop(CMD_PROXY_GET_SLOT);
	    hdr.len = 0;
	    rsc_write(c, &hdr, sizeof(hdr));
	}
	rsc_flush(c);
	if (rsc_read(c, idstr, 32) != 32) {
	    rsc_close(c);
	    Rf_error("Handshake failed - ID string not received (after CMD_PROXY_TARGET)");
	}
    }
    /* OC mode */
    if (((const int*)idstr)[0] == itop(CMD_OCinit)) {
	int sb_len;
	struct phdr *hdr = (struct phdr *) idstr;
	hdr->len = itop(hdr->len);
	if (hdr->res || hdr->dof || hdr->len > sizeof(slurp_buffer) || hdr->len < 16) {
	    rsc_close(c);
	    Rf_error("Handshake failed - invalid RsOC OCinit message");
	}
	sb_len = 32 - sizeof(struct phdr);
	memcpy(slurp_buffer, idstr + sizeof(struct phdr), sb_len);
	if (rsc_read(c, slurp_buffer + sb_len, hdr->len - sb_len) != hdr->len - sb_len) {
	    rsc_close(c);
	    Rf_error("Handshake failed - truncated RsOC OCinit message");
	} else {
	    unsigned int *ibuf = (unsigned int*) slurp_buffer;
	    int par_type = PAR_TYPE(*ibuf);
	    int is_large = (par_type & DT_LARGE) ? 1 : 0;
	    if (is_large) par_type ^= DT_LARGE;
	    if (par_type != DT_SEXP) {
		rsc_close(c);
		Rf_error("Handshake failed - invalid payload in OCinit message");
	    }
	    ibuf += is_large + 1;
	    caps = QAP_decode(&ibuf);
	    if (caps != R_NilValue)
		PROTECT(caps);
	}
    } else {
	if (memcmp(idstr, "Rsrv", 4) || memcmp(idstr + 8, "QAP1", 4)) {
	    rsc_close(c);
	    Rf_error("Handshake failed - unknown protocol");
	}

	/* supported range 0100 .. 0103 */
	if (memcmp(idstr + 4, "0100", 4) < 0 || memcmp(idstr + 4, "0103", 4) > 0) {
	    rsc_close(c);
	    Rf_error("Handshake failed - server protocol version too high");
	}
    }

    res = PROTECT(R_MakeExternalPtr(c, R_NilValue, R_NilValue));
    setAttrib(res, R_ClassSymbol, mkString("RserveConnection"));
    R_RegisterCFinalizer(res, rsconn_fin);
    if (caps != R_NilValue) {
	setAttrib(res, install("capabilities"), caps);
	UNPROTECT(1);
    }	  
    UNPROTECT(1);
    return res;
}
Пример #9
0
/*
 * The main glob() routine: compiles the pattern (optionally processing
 * quotes), calls glob1() to do the real pattern matching, and finally
 * sorts the list (unless unsorted operation is requested).  Returns 0
 * if things went well, nonzero if errors occurred.  It is not an error
 * to find no matches.
 */
static int
glob0(const Char *pattern, glob_t *pglob)
{
	const Char *qpatnext;
	int c, error;
	__gl_size_t oldpathc;
	Char *bufnext, patbuf[MAXPATHLEN+1];
	size_t limit = 0;

	if ((qpatnext = globtilde(pattern, patbuf, sizeof(patbuf),
	    pglob)) == NULL)
		return GLOB_ABEND;
	oldpathc = pglob->gl_pathc;
	bufnext = patbuf;

	/* We don't need to check for buffer overflow any more. */
	while ((c = *qpatnext++) != EOS) {
		switch (c) {
		case LBRACKET:
			c = *qpatnext;
			if (c == NOT)
				++qpatnext;
			if (*qpatnext == EOS ||
			    g_strchr(qpatnext+1, RBRACKET) == NULL) {
				*bufnext++ = LBRACKET;
				if (c == NOT)
					--qpatnext;
				break;
			}
			*bufnext++ = M_SET;
			if (c == NOT)
				*bufnext++ = M_NOT;
			c = *qpatnext++;
			do {
				*bufnext++ = CHAR(c);
				if (*qpatnext == RANGE &&
				    (c = qpatnext[1]) != RBRACKET) {
					*bufnext++ = M_RNG;
					*bufnext++ = CHAR(c);
					qpatnext += 2;
				}
			} while ((c = *qpatnext++) != RBRACKET);
			pglob->gl_flags |= GLOB_MAGCHAR;
			*bufnext++ = M_END;
			break;
		case QUESTION:
			pglob->gl_flags |= GLOB_MAGCHAR;
			*bufnext++ = M_ONE;
			break;
		case STAR:
			pglob->gl_flags |= GLOB_MAGCHAR;
			/* collapse adjacent stars to one, 
			 * to avoid exponential behavior
			 */
			if (bufnext == patbuf || bufnext[-1] != M_ALL)
				*bufnext++ = M_ALL;
			break;
		default:
			*bufnext++ = CHAR(c);
			break;
		}
	}
	*bufnext = EOS;
#ifdef DEBUG
	qprintf("glob0:", patbuf);
#endif

	if ((error = glob1(patbuf, pglob, &limit)) != 0)
		return(error);

	if (pglob->gl_pathc == oldpathc) {	
		/*
		 * If there was no match we are going to append the pattern 
		 * if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was
		 * specified and the pattern did not contain any magic
		 * characters GLOB_NOMAGIC is there just for compatibility
		 * with csh.
		 */
		if ((pglob->gl_flags & GLOB_NOCHECK) ||
		    ((pglob->gl_flags & (GLOB_NOMAGIC|GLOB_MAGCHAR))
		     == GLOB_NOMAGIC)) {
			return globextend(pattern, pglob, &limit);
		} else {
			return (GLOB_NOMATCH);
		}
	} else if (!(pglob->gl_flags & GLOB_NOSORT)) {
		qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc,
		    (size_t)pglob->gl_pathc - oldpathc, sizeof(char *),
		    compare);
	}

	return(0);
}
Пример #10
0
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int   i, rc;
    ParseStatus status;
    SEXP  x, fn, envir, ed, src, srcfile, Rfn;
    char *filename, *editcmd;
    const char *cmd;
    const void *vmaxsave;
    FILE *fp;
#ifdef Win32
    SEXP ti;
    char *title;
#endif

	checkArity(op, args);

    vmaxsave = vmaxget();

    x = CAR(args); args = CDR(args);
    if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
    else envir = R_NilValue;
    PROTECT(envir);

    fn = CAR(args); args = CDR(args);
    if (!isString(fn))
	error(_("invalid argument to edit()"));

    if (LENGTH(STRING_ELT(fn, 0)) > 0) {
	const char *ss = translateChar(STRING_ELT(fn, 0));
	filename = R_alloc(strlen(ss), sizeof(char));
	strcpy(filename, ss);
    }
    else filename = DefaultFileName;

    if (x != R_NilValue) {
	if((fp=R_fopen(R_ExpandFileName(filename), "w")) == nullptr)
	    errorcall(call, _("unable to open file"));
	if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
	    src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
	for (i = 0; i < LENGTH(src); i++)
	    fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
	fclose(fp);
    }
#ifdef Win32
    ti = CAR(args);
#endif
    args = CDR(args);
    ed = CAR(args);
    if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
    cmd = translateChar(STRING_ELT(ed, 0));
    if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
    editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
    if (!strcmp(cmd,"internal")) {
	if (!isString(ti))
	    error(_("'title' must be a string"));
	if (LENGTH(STRING_ELT(ti, 0)) > 0) {
	    title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
	    strcpy(title, CHAR(STRING_ELT(ti, 0)));
	} else {
	    title = R_alloc(strlen(filename)+1, sizeof(char));
	    strcpy(title, filename);
	}
	Rgui_Edit(filename, CE_NATIVE, title, 1);
    }
    else {
	/* Quote path if necessary */
	if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
	    sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
	else
	    sprintf(editcmd, "%s \"%s\"", cmd, filename);
	rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
	if (rc == NOLAUNCH)
	    errorcall(call, _("unable to run editor '%s'"), cmd);
	if (rc != 0)
	    warningcall(call, _("editor ran but returned error status"));
    }
#else
    if (ptr_R_EditFile)
	rc = ptr_R_EditFile(filename);
    else {
	sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
	rc = R_system(editcmd);
    }
    if (rc != 0)
	errorcall(call, _("problem with running editor %s"), cmd);
#endif

    if (asLogical(GetOption1(install("keep.source")))) {
	PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
	PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
	PROTECT(src = eval(src, R_BaseEnv));
	PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
	PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
	srcfile = eval(srcfile, R_BaseEnv);
	UNPROTECT(5);
    } else
    	srcfile = R_NilValue;
    PROTECT(srcfile);
    
    /* <FIXME> setup a context to close the file, and parse and eval
       line by line */
    if((fp = R_fopen(R_ExpandFileName(filename), "r")) == nullptr)
	errorcall(call, _("unable to open file to read"));

    x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
    fclose(fp);

    if (status != PARSE_OK)
	errorcall(call,
		  _("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
    R_ResetConsole();
    {   /* can't just eval(x) here */
	int j, n;
	SEXP tmp = R_NilValue;

	n = LENGTH(x);
	for (j = 0 ; j < n ; j++)
	    tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
	x = tmp;
    }
    if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
	SET_CLOENV(x, envir);
    UNPROTECT(3);
    vmaxset(vmaxsave);
    return x;
}
Пример #11
0
/* "do_parse" - the user interface input/output to files.

 The internal R_Parse.. functions are defined in ./gram.y (-> gram.c)

 .Internal( parse(file, n, text, prompt, srcfile, encoding) )
 If there is text then that is read and the other arguments are ignored.
*/
SEXP attribute_hidden do_parse(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
    SEXP text, prompt, s, source;
    Rconnection con;
    Rboolean wasopen, old_latin1 = known_to_be_latin1,
	old_utf8 = known_to_be_utf8, allKnown = TRUE;
    int ifile, num, i;
    const char *encoding;
    ParseStatus status;

    op->checkNumArgs(num_args, call);
    R_ParseError = 0;
    R_ParseErrorMsg[0] = '\0';

    ifile = asInteger(args[0]);                       args = (args + 1);

    con = getConnection(ifile);
    wasopen = con->isopen;
    num = asInteger(args[0]);				args = (args + 1);
    if (num == 0)
	return(allocVector(EXPRSXP, 0));

    PROTECT(text = coerceVector(args[0], STRSXP));
    if(length(args[0]) && !length(text))
	errorcall(call, _("coercion of 'text' to character was unsuccessful"));
    args = (args + 1);
    prompt = args[0];					args = (args + 1);
    source = args[0];					args = (args + 1);
    if(!isString(args[0]) || LENGTH(args[0]) != 1)
	error(_("invalid '%s' value"), "encoding");
    encoding = CHAR(STRING_ELT(args[0], 0)); /* ASCII */
    known_to_be_latin1 = known_to_be_utf8 = FALSE;
    /* allow 'encoding' to override declaration on 'text'. */
    if(streql(encoding, "latin1")) {
	known_to_be_latin1 = TRUE;
	allKnown = FALSE;
    } else if(streql(encoding, "UTF-8"))  {
	known_to_be_utf8 = TRUE;
	allKnown = FALSE;
    } else if(!streql(encoding, "unknown") && !streql(encoding, "native.enc")) 
    	warning(_("argument '%s = \"%s\"' will be ignored"), "encoding", encoding);

    if (prompt == R_NilValue)
	PROTECT(prompt);
    else
	PROTECT(prompt = coerceVector(prompt, STRSXP));

    if (length(text) > 0) {
	/* If 'text' has known encoding then we can be sure it will be
	   correctly re-encoded to the current encoding by
	   translateChar in the parser and so could mark the result in
	   a Latin-1 or UTF-8 locale.

	   A small complication is that different elements could have
	   different encodings, but all that matters is that all
	   non-ASCII elements have known encoding.
	*/
	for(i = 0; i < length(text); i++)
	    if(!ENC_KNOWN(STRING_ELT(text, i)) &&
	       !IS_ASCII(STRING_ELT(text, i))) {
		allKnown = FALSE;
		break;
	    }
	if(allKnown) {
	    known_to_be_latin1 = old_latin1;
	    known_to_be_utf8 = old_utf8;
	}
	if (num == NA_INTEGER) num = -1;
	s = R_ParseVector(text, num, &status, source);
	if (status != PARSE_OK) parseError(call, R_ParseError);
    }
    else if (ifile >= 3) {/* file != "" */
	if (num == NA_INTEGER) num = -1;
	try {
	    if(!wasopen && !con->open(con))
		error(_("cannot open the connection"));
	    if(!con->canread) error(_("cannot read from this connection"));
	    s = R_ParseConn(con, num, &status, source);
	    if(!wasopen) con->close(con);
	} catch (...) {
	    if (!wasopen && con->isopen)
		con->close(con);
	    throw;
	}
	if (status != PARSE_OK) parseError(call, R_ParseError);
    }
    else {
	if (num == NA_INTEGER) num = 1;
	s = R_ParseBuffer(&R_ConsoleIob, num, &status, prompt, source);
	if (status != PARSE_OK) parseError(call, R_ParseError);
    }
    UNPROTECT(2);
    known_to_be_latin1 = old_latin1;
    known_to_be_utf8 = old_utf8;
    return s;
}
Пример #12
0
SEXP parse_dt(SEXP str, SEXP ord, SEXP formats, SEXP lt) {
  // STR: character vector of date-times.
  // ORD: formats (as in strptime) or orders (as in parse_date_time)
  // FORMATS: TRUE if ord is a string of formats (as in strptime)
  // LT: TRUE - return POSIXlt type list, FALSE - return POSIXct seconds

  if ( !isString(str) ) error("Date-time must be a character vector");
  if ( !isString(ord) || (LENGTH(ord) > 1))
    error("Format argument must be a character vector of length 1");

  R_len_t n = LENGTH(str);
  int is_fmt = *LOGICAL(formats);
  int out_lt = *LOGICAL(lt);

  SEXP oYEAR, oMONTH, oDAY, oHOUR, oMIN, oSEC;

  if(out_lt){
    oYEAR  = PROTECT(allocVector(INTSXP, n));
    oMONTH = PROTECT(allocVector(INTSXP, n));
    oDAY   = PROTECT(allocVector(INTSXP, n));
    oHOUR  = PROTECT(allocVector(INTSXP, n));
    oMIN   = PROTECT(allocVector(INTSXP, n));
    oSEC   = PROTECT(allocVector(REALSXP, n));
  } else {
    oSEC = PROTECT(allocVector(REALSXP, n));
  }

  const char *O = CHAR(STRING_ELT(ord, 0));

  for (int i = 0; i < n; i++) {

    const char *c = CHAR(STRING_ELT(str, i));
    const char *o = O;

    double secs = 0.0; // only accumulator for POSIXct case
    int y = 0, q = 0, m = 0, d = 0, H = 0, M = 0 , S = 0;
    int succeed = 1, O_format = 0, pm = 0, am = 0; // control logical

    // read order/format character by character
    while( *o && succeed ) {

      if( is_fmt && (*o != '%')) {
        // with fmt: non formatting characters should match exactly
        if ( *c == *o ) { c++; o++; } else succeed = 0;

      } else {

        if ( is_fmt ){
          o++; // skip %
        } else if ( *o != 'O' && *o != 'z' && *o != 'p' && *o != 'm' && *o != 'b' && *o != 'B') {
          // skip non-digits
          // O, z, p formats are treated specially below
          while (*c && !DIGIT(*c)) c++;
		}

        if ( *o == 'O' ) {
          // Special two letter orders/formats:
		  // Ou (Z), Oz (-0800), OO (-08:00) and Oo (-08)
          O_format = 1;
          o++;
        } else {
		  O_format = 0;
		}

        if (!(DIGIT(*c) || O_format || *o == 'z' || *o == 'p' || *o == 'm' || *o == 'b' || *o == 'B')) {
          succeed = 0;
        } else {

          /* Rprintf("c=%c o=%c\n", *c, *o); */

          switch( *o ) {
          case 'Y': // year in yyyy format
            y = parse_int(&c, 4, TRUE);
            if (y < 0)
              succeed = 0;
            break;
          case 'y': // year in yy format
            y = parse_int(&c, 2, FALSE);
            if (y < 0)
              succeed = 0;
			else if (y <= 68)
			  y += 2000;
			else
			  y += 1900;
            break;
          case 'q': // quarter
            q = parse_int(&c, 2, FALSE);
            if (!(0 < q && q < 5)) succeed = 0;
            break;
          case 'm': // month (allowing all months formats - m, b and B)
            SKIP_NON_ALPHANUMS(c);
            m = parse_int(&c, 2, FALSE);
            if (m == -1) { // failed
              m = parse_alpha_month(&c);
              if (m == 0) { // failed
                SKIP_NON_DIGITS(c);
                m = parse_int(&c, 2, FALSE);
              }
            }
            if (!(0 < m && m < 13))
              succeed = 0;
            break;
          case 'b': // alpha English months (both abbreviated and long versions)
          case 'B':
            /* SKIP_NON_ALPHANUMS(c); */
            m = parse_alpha_month(&c);
            succeed = m;
            /* Rprintf("succ=%d c=%c\n", succeed, *c); */
            break;
          case 'd': // day
            d = parse_int(&c, 2, FALSE);
            if (!(0 < d && d < 32)) succeed = 0;
            break;
          case 'H': // hour 24
            H = parse_int(&c, 2, FALSE);
            if (H > 24) succeed = 0;
            break;
          case 'I': // hour 12
            H = parse_int(&c, 2, FALSE);
            if (H > 12) succeed = 0;
            break;
          case 'M': // minute
            M = parse_int(&c, 2, FALSE);
            if (M > 59) succeed = 0;
            break;
          case 'S': // second
            if( O_format && !is_fmt ){
              while (*c && !DIGIT(*c)) c++;
              if (!*c) {
                succeed = 0;
                break;
              }
            }
            S = parse_int(&c, 2, FALSE);
            if (S < 62){ // allow leap seconds
              secs += S;
              if (O_format){
                // Parse milliseconds; both . and , as decimal separator are allowed
                if( *c == '.' || *c == ','){
                  double ms = 0.0, msfact = 0.1;
                  c++;
                  while (DIGIT(*c)) { ms = ms + (*c - '0')*msfact; msfact *= 0.1; c++; }
                  secs += ms;
                }
              }
            } else succeed = 0;
            break;
          case 'p': // AM/PM Both standard 'p' and lubridate 'Op' format
            SKIP_NON_ALPHANUMS(c);
            if (O_format) {
              // with Op format, p is optional (for order parsimony reasons)
              if (!(*c == 'P' || *c == 'p' || *c == 'A' || *c == 'a'))
                break;
            }
            if (*c == 'P' || *c == 'p') {
              pm = 1;
              c++;
            } else if (*c == 'A' ||  *c == 'a'){
              am = 1;
              c++;
            } else {
              succeed = 0;
            }
            if (succeed && !(*c && (*c == 'M' || *c == 'm'))){
              succeed = 0;
            }
            if (succeed) c++;
            break;
		  case 'u':
			// %Ou: "2013-04-16T04:59:59Z"
            if( O_format )
              if( *c == 'Z' || *c == 'z') c++;
              else succeed = 0;
            else succeed  = 0;
            break;
          case 'z':
            // for %z: "+O100" or "+O1" or "+01:00"
            if( !O_format ) {
              if( !is_fmt ) {
                while (*c && *c != '+' && *c != '-' && *c != 'Z') c++; // skip non + -
                if( !*c ) { succeed = 0; break; };
              }
              int Z = 0, sig;
              if( *c == 'Z') {c++; break;}
              else if ( *c == '+' ) sig = -1;
              else if ( *c == '-') sig = 1;
              else {succeed = 0; break;}
              c++;
              Z = parse_int(&c, 2, FALSE);
              if (Z < 0) {succeed = 0; break;}
              secs += sig*Z*3600;
              if( *c == ':' ){
                c++;
                if ( !DIGIT(*c) ) {succeed = 0; break;}
              }
              if( DIGIT(*c) ){
                Z = 0;
                Z = parse_int(&c, 2, FALSE);
                secs += sig*Z*60;
              }
              break;
            }
            // else O_format %Oz: "+0100"; pass through
          case 'O':
            // %OO: "+01:00"
          case 'o':
            // %Oo: "+01"
            if( O_format ){
              while (*c && *c != '+' && *c != '-' ) c++; // skip non + -
              int Z = 0, sig;
              if ( *c == '+' ) sig = -1;
              else if ( *c == '-') sig = 1;
              else { succeed = 0; break; }
              c++;
              Z = parse_int(&c, 2, FALSE);
              if (Z < 0) {succeed = 0; break;}
              secs += sig*Z*3600;
              if( *o == 'O'){
                if ( *c == ':') c++;
				else { succeed = 0; break; }
			  }
              if ( *o != 'o' ){ // z or O
                Z = parse_int(&c, 2, FALSE);
                if (Z < 0) {succeed = 0; break;}
                secs += sig*Z*60;
              }
            } else error("Unrecognized format '%c' supplied", *o);
            break;
          default:
            error("Unrecognized format %c supplied", *o);
          }

          o++;
        }
      }
    }

    // skip all remaining non digits
    if( !is_fmt )
      while (*c && !DIGIT(*c)) c++;

    // If at least one subparser hasn't finished it's a failure.
    if ( *c || *o ) succeed = 0;

    int is_leap;

    // adjust months for quarter
    if (q > 1)
      m += (q - 1) * 3 + 1;

    if (succeed) {
      // leap year every 400 years; no leap every 100 years
      is_leap = IS_LEAP(y);

      // check month
      if (m == 2){
		// no check for d > 0 because we allow missing days in parsing
        if (is_leap)
          succeed = d < 30;
        else
          succeed = d < 29;
      } else {
		succeed = d <= mdays[m];
      }
    }

    // allow missing months and days
    if (m == 0) m = 1;
    if (d == 0) d = 1;

    if(pm){
      if(H > 12)
        succeed = 0;
      else if (H < 12)
        H += 12;
    }

    if (am){
      if (H > 12)
        succeed = 0;
      else if (H == 12)
        H = 0;
    }

    if (succeed) {
      if(out_lt){

        INTEGER(oYEAR)[i] = y - 1900;
        INTEGER(oMONTH)[i] = m - 1;
        INTEGER(oDAY)[i] = d;
        INTEGER(oHOUR)[i] = H;
        INTEGER(oMIN)[i] = M;
        REAL(oSEC)[i] = secs;

      } else {

        secs += sm[m];
        secs += (d - 1) * 86400;
        secs += H * 3600;
        secs += M * 60;
        // process leap years
        y -= 2000;
        secs += y * yearlen;
        secs += adjust_leap_years(y, m, is_leap);

        REAL(oSEC)[i] = secs + d30;
      }

    } else {
      if(out_lt){
        INTEGER(oYEAR)[i] = NA_INTEGER;
        INTEGER(oMONTH)[i] = NA_INTEGER;
        INTEGER(oDAY)[i] = NA_INTEGER;
        INTEGER(oHOUR)[i] = NA_INTEGER;
        INTEGER(oMIN)[i] = NA_INTEGER;
        REAL(oSEC)[i] = NA_REAL;
      } else {
        REAL(oSEC)[i] = NA_REAL;
      }
    }
  }

  if (out_lt){
    SEXP names, out;
    PROTECT(names = allocVector(STRSXP, 6));
    for(int i = 0; i < 6; i++)
      SET_STRING_ELT(names, i, mkChar(ltnames[i]));
    PROTECT(out = allocVector(VECSXP, 6));
    SET_VECTOR_ELT(out, 0, oSEC);
    SET_VECTOR_ELT(out, 1, oMIN);
    SET_VECTOR_ELT(out, 2, oHOUR);
    SET_VECTOR_ELT(out, 3, oDAY);
    SET_VECTOR_ELT(out, 4, oMONTH);
    SET_VECTOR_ELT(out, 5, oYEAR);
    setAttrib(out, R_NamesSymbol, names);
    UNPROTECT(8);
    return out;
  } else {
    UNPROTECT(1);
    return oSEC;
  }

}
Пример #13
0
// STR: string in HxMyS format where x and y are arbitrary non-numeric separators
// ORD: orders. Can be any combination of "h", "m" and "s"
// RETURN: numeric vector (H1 M1 S1 H2 M2 S2 ...)
SEXP parse_hms(SEXP str, SEXP ord) {

  if (TYPEOF(str) != STRSXP) error("HMS argument must be a character vector");
  if ((TYPEOF(ord) != STRSXP) || (LENGTH(ord) > 1))
    error("Orders vector must be a character vector of length 1");

  int n = LENGTH(str);
  int len = 3*n;
  const char *O = CHAR(STRING_ELT(ord, 0));
  SEXP res;
  double *data;
  res = allocVector(REALSXP, len);
  data = REAL(res);

  for (int i = 0; i < n; i++) {

    const char *c = CHAR(STRING_ELT(str, i));
    const char *o = O;
    int H=0, M=0, j=i*3;
    int sign = 1;
    double S=0.0;

    while (*c && !SDIGIT(*c)) c++;

    if (SDIGIT(*c)) {

      while( *o ){

        if (*c == '-'){
          sign = -1;
          c++;
        }

        switch( *o ) {
        case 'H':
          if(!DIGIT(*c)) {data[j] = NA_REAL; break;}
          while (DIGIT(*c)) { H = H * 10 + (*c - '0'); c++; }
          data[j] = H * sign;
          break;
        case 'M':
          if(!DIGIT(*c)) {data[j+1] = NA_REAL; break;}
          while (DIGIT(*c)) { M = M * 10 + (*c - '0'); c++; }
          data[j+1]= M * sign;
          break;
        case 'S':
          if(!DIGIT(*c)) {data[j+2] = NA_REAL; break;}
          while (DIGIT(*c) ) { S = S * 10 + (*c - '0'); c++; }
          // both . and , as decimal Seconds separator are allowed
          if( *c == '.' || *c == ','){
            double ms = 0.0, msfact = 0.1;
            c++;
            while (DIGIT(*c)) { ms = ms + (*c - '0')*msfact; msfact *= 0.1; c++; }
            S += ms;
          }
          data[j+2] = S * sign;
          break;
        default:
          error("Unrecognized format %c supplied", *o);
        }

        while (*c && !SDIGIT(*c)) c++;

        sign = 1;
        o++;
      }
    }

    // unfinished parsing, return NA
    if ( *c || *o ){
      data[j] = NA_REAL;
      data[j+1] = NA_REAL;
      data[j+2] = NA_REAL;
    }
  }
  return res;
}
Пример #14
0
SEXP
do_getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP result = R_NilValue, prompt;
    pDevDesc dd;
    pGEDevDesc gd;
    int i, count=0, devNum;
    
    checkArity(op, args);
    
    prompt = CAR(args);
    if (!isString(prompt) || !length(prompt)) error(_("invalid prompt"));
    
    /* NB:  cleanup of event handlers must be done by driver in onExit handler */
    
    if (!NoDevices()) {
        /* Initialize all devices */
        i = 1;
	devNum = curDevice();
	while (i++ < NumDevices()) {
	    gd = GEgetDevice(devNum);
	    dd = gd->dev;
	    if (dd->gettingEvent)
	    	error(_("recursive use of 'getGraphicsEvent' not supported"));
	    if (dd->eventEnv != R_NilValue) {
	        if (dd->eventHelper) dd->eventHelper(dd, 1);
	        dd->gettingEvent = TRUE;
	        defineVar(install("result"), R_NilValue, dd->eventEnv);
	        count++;
	    }
	    devNum = nextDevice(devNum);
	}
	if (!count)
	    error(_("no graphics event handlers set"));
	
	Rprintf("%s\n", CHAR(asChar(prompt)));
	R_FlushConsole();
	
	/* Poll them */
	while (result == R_NilValue) {
	    /* make sure we still have at least one device listening for events, and throw an error if not*/
	    if(!haveListeningDev()) 
		return R_NilValue;
#ifdef Win32
	    R_WaitEvent();
#endif
	    R_ProcessEvents();
	    R_CheckUserInterrupt();
	    i = 1;
	    devNum = curDevice();
	    while (i++ < NumDevices()) {
		gd = GEgetDevice(devNum);
		dd = gd->dev;
		if (dd->eventEnv != R_NilValue) {
		    if (dd->eventHelper) dd->eventHelper(dd, 2);
		    result = findVar(install("result"), dd->eventEnv);
		    if (result != R_NilValue && result != R_UnboundValue) {
			break;
		    }
		}
		devNum = nextDevice(devNum);
	    }
	}
	/* clean up */
        i = 1;
	devNum = curDevice();
	while (i++ < NumDevices()) {
	    gd = GEgetDevice(devNum);
	    dd = gd->dev;
	    if (dd->eventEnv != R_NilValue) {
	        if (dd->eventHelper) dd->eventHelper(dd, 0);
	        dd->gettingEvent = FALSE;
	    }
	    devNum = nextDevice(devNum);
	}
	
    }
    return(result);
}
Пример #15
0
SEXP Rgraphviz_buildEdgeList(SEXP nodes, SEXP edgeL, SEXP edgeMode,
                             SEXP subGList, SEXP edgeNames,
                             SEXP removedEdges, SEXP edgeAttrs,
                             SEXP defAttrs) {
    int x, y, curEle = 0;
    SEXP from;
    SEXP peList;
    SEXP peClass, curPE;
    SEXP curAttrs, curFrom, curTo, curWeights = R_NilValue;
    SEXP attrNames;
    SEXP tmpToSTR, tmpWtSTR, tmpW;
    SEXP curSubG, subGEdgeL, subGEdges, subGNodes, elt;
    SEXP recipAttrs, newRecipAttrs, recipAttrNames, newRecipAttrNames;
    SEXP goodEdgeNames;
    SEXP toName;
    SEXP recipPE;
    char *edgeName, *recipName;
    int i, j, k, nSubG;
    int nEdges = length(edgeNames);

    if (length(edgeL) == 0)
        return(allocVector(VECSXP, 0));

    PROTECT(peClass = MAKE_CLASS("pEdge"));

    PROTECT(peList = allocVector(VECSXP, nEdges -
                                 length(removedEdges)));
    PROTECT(goodEdgeNames = allocVector(STRSXP, nEdges -
                                        length(removedEdges)));
    PROTECT(curAttrs = allocVector(VECSXP, 3));

    PROTECT(attrNames = allocVector(STRSXP, 3));

    /* TODO: get rid of attrs "arrowhead"/"arrowtail", "dir" is sufficient */
    SET_STRING_ELT(attrNames, 0, mkChar("arrowhead"));
    SET_STRING_ELT(attrNames, 1, mkChar("weight"));
    SET_STRING_ELT(attrNames, 2, mkChar("dir"));
    setAttrib(curAttrs, R_NamesSymbol, attrNames);

    PROTECT(from = getAttrib(edgeL, R_NamesSymbol));
    nSubG = length(subGList);

    /* For each edge, create a new object of class pEdge */
    /* and then assign the 'from' and 'to' strings as */
    /* as well as the default attrs (arrowhead & weight) */

    for (x = 0; x < length(from); x++) {
        PROTECT(curFrom = allocVector(STRSXP, 1));
        SET_STRING_ELT(curFrom, 0, STRING_ELT(from, x));
        if (length(VECTOR_ELT(edgeL, x)) == 0)
            error("Invalid edgeList element given to buildEdgeList in Rgraphviz, is NULL");
        PROTECT(curTo = coerceVector(VECTOR_ELT(VECTOR_ELT(edgeL, x), 0),
                                     INTSXP));
        if (length(VECTOR_ELT(edgeL, x)) > 1) {
            curWeights = VECTOR_ELT(VECTOR_ELT(edgeL, x), 1);
        }
        if (curWeights == R_NilValue || (length(curWeights) != length(curTo))) {
            curWeights = allocVector(REALSXP, length(curTo));
            for (i = 0; i < length(curWeights); i++)
                REAL(curWeights)[i] = 1;
        }
        PROTECT(curWeights);

        for (y = 0; y < length(curTo); y++) {
            PROTECT(toName = STRING_ELT(from, INTEGER(curTo)[y]-1));
            edgeName = (char *)malloc((strlen(STR(curFrom))+
                                       strlen(CHAR(toName)) + 2) *
                                      sizeof(char));
            sprintf(edgeName, "%s~%s", STR(curFrom), CHAR(toName));

            /* See if this edge is a removed edge */
            for (i = 0; i < length(removedEdges); i++) {
                if (strcmp(CHAR(STRING_ELT(edgeNames,
                                           INTEGER(removedEdges)[i]-1)),
                           edgeName) == 0)
                    break;
            }

            if (i < length(removedEdges)) {
                /* This edge is to be removed */
                if (strcmp(STR(edgeMode), "directed") == 0) {
                    /* Find the recip and add 'open' to tail */

                    recipName = (char *)malloc((strlen(STR(curFrom))+
                                                strlen(CHAR(toName)) + 2) *
                                               sizeof(char));
                    sprintf(recipName, "%s~%s", CHAR(toName), STR(curFrom));

                    for (k = 0; k < curEle; k++) {
                        if (strcmp(CHAR(STRING_ELT(goodEdgeNames, k)),
                                   recipName) == 0)
                            break;
                    }
                    free(recipName);

                    PROTECT(recipPE = VECTOR_ELT(peList, k));

                    recipAttrs = GET_SLOT(recipPE, Rf_install("attrs"));
                    recipAttrNames = getAttrib(recipAttrs,
                                               R_NamesSymbol);
                    /* We need to add this to the current set of
                       recipAttrs, so create a new list which is one
                       element longer and copy everything over, adding
                       the new element */
                    PROTECT(newRecipAttrs = allocVector(VECSXP,
                                                        length(recipAttrs)+1));
                    PROTECT(newRecipAttrNames = allocVector(STRSXP,
                                                            length(recipAttrNames)+1));
                    for (j = 0; j < length(recipAttrs); j++) {
                      if ( !strcmp(CHAR(STRING_ELT(recipAttrNames, j)), "dir") )
                        SET_VECTOR_ELT(newRecipAttrs, j, mkString("both"));
                      else
                        SET_VECTOR_ELT(newRecipAttrs, j, 
                                       VECTOR_ELT(recipAttrs, j));

                      SET_STRING_ELT(newRecipAttrNames, j,
                                       STRING_ELT(recipAttrNames, j));
                    }

                    SET_VECTOR_ELT(newRecipAttrs, j, mkString("open"));
                    SET_STRING_ELT(newRecipAttrNames, j, mkChar("arrowtail"));
                    setAttrib(newRecipAttrs, R_NamesSymbol, newRecipAttrNames);

                    SET_SLOT(recipPE, Rf_install("attrs"), newRecipAttrs);
                    SET_VECTOR_ELT(peList, k, recipPE);
                    UNPROTECT(3);

                }
                UNPROTECT(1);
                continue;
            }
            PROTECT(tmpToSTR = allocVector(STRSXP, 1));
            PROTECT(curPE = NEW_OBJECT(peClass));
            SET_SLOT(curPE, Rf_install("from"), curFrom);
            SET_STRING_ELT(tmpToSTR, 0, toName);
            SET_SLOT(curPE, Rf_install("to"), tmpToSTR);
            if (strcmp(STR(edgeMode), "directed") == 0)
	    {
                SET_VECTOR_ELT(curAttrs, 0, mkString("open"));
                SET_VECTOR_ELT(curAttrs, 2, mkString("forward"));
            }
            else
	    {
                SET_VECTOR_ELT(curAttrs, 0, mkString("none"));
                SET_VECTOR_ELT(curAttrs, 2, mkString("none"));
            }
            PROTECT(tmpWtSTR = allocVector(STRSXP, 1));
            PROTECT(tmpW = Rf_ScalarReal(REAL(curWeights)[y]));
            SET_STRING_ELT(tmpWtSTR, 0, asChar(tmpW));
            UNPROTECT(1);
            SET_VECTOR_ELT(curAttrs, 1, tmpWtSTR);
            SET_SLOT(curPE, Rf_install("attrs"), curAttrs);
            SET_STRING_ELT(goodEdgeNames, curEle, mkChar(edgeName));
            SET_VECTOR_ELT(peList, curEle, curPE);
            curEle++;
            for (i = 0; i < nSubG; i++) {
                curSubG = getListElement(VECTOR_ELT(subGList, i), "graph");
                subGEdgeL = GET_SLOT(curSubG, Rf_install("edgeL"));
                subGNodes = GET_SLOT(curSubG, Rf_install("nodes"));
                elt = getListElement(subGEdgeL, STR(curFrom));
                if (elt == R_NilValue)
                    continue;
                /* Extract out the edges */
                subGEdges = VECTOR_ELT(elt, 0);
                for (j = 0; j < length(subGEdges); j++) {
                    int subGIdx = INTEGER(subGEdges)[j]-1;
                    int graphIdx  = INTEGER(curTo)[y]-1;
                    if(strcmp(CHAR(STRING_ELT(subGNodes, subGIdx)),CHAR(STRING_ELT(nodes, graphIdx))) == 0)
                        break;
                }
                if (j == length(subGEdges))
                    continue;
                /* If we get here, then this edge is in subG 'i' */
                SET_SLOT(curPE, Rf_install("subG"), Rf_ScalarInteger(i+1));

                /* Only one subgraph per edge */
                break;
            }
            free(edgeName);
            UNPROTECT(4);
        }
        UNPROTECT(3);
    }
    setAttrib(peList, R_NamesSymbol, goodEdgeNames);
    peList = assignAttrs(edgeAttrs, peList, defAttrs);

    UNPROTECT(6);

    return(peList);
}
Пример #16
0
SEXP rgeos_geosring2Polygon(SEXP env, GEOSGeom lr, int hole) {
    
    GEOSContextHandle_t GEOShandle = getContextHandle(env);
    int pc=0;
    
    GEOSCoordSeq s = (GEOSCoordSequence *) GEOSGeom_getCoordSeq_r(GEOShandle, lr);
    if (s == NULL) 
        error("rgeos_geosring2Polygon: CoordSeq failure");
    
    unsigned int n;
    if (GEOSCoordSeq_getSize_r(GEOShandle, s, &n) == 0)
        error("rgeos_geosring2Polygon: CoordSeq failure");
    
    // Get coordinates
    SEXP crd;
    PROTECT(crd = rgeos_crdMatFixDir(rgeos_CoordSeq2crdMat(env, s, FALSE, hole), hole)); pc++;
    
    // Calculate area
    GEOSGeom p = GEOSGeom_createPolygon_r(GEOShandle,GEOSGeom_clone_r(GEOShandle,lr),NULL,0);
    if (p == NULL) 
        error("rgeos_geosring2Polygon: unable to create polygon");
    
    SEXP area;
    PROTECT(area = NEW_NUMERIC(1)); pc++;
    NUMERIC_POINTER(area)[0] = 0.0;
    if (!GEOSArea_r(GEOShandle, p, NUMERIC_POINTER(area)))
        error("rgeos_geosring2Polygon: area calculation failure");
    
    
    // Calculate label position
    SEXP labpt;
    PROTECT(labpt = NEW_NUMERIC(2)); pc++;
    
    GEOSGeom centroid = GEOSGetCentroid_r(GEOShandle, p);
    double xc, yc;
    rgeos_Pt2xy(env, centroid, &xc, &yc);
    
    if (!R_FINITE(xc) || !R_FINITE(yc)) {
        xc = 0.0;
        yc = 0.0;
        for(int i=0; i != n; i++) {
            xc += NUMERIC_POINTER(crd)[i];
            yc += NUMERIC_POINTER(crd)[(int) (n) +i];
        }
        
        xc /= n;
        yc /= n;
    }
    
    NUMERIC_POINTER(labpt)[0] = xc;
    NUMERIC_POINTER(labpt)[1] = yc;
    
    GEOSGeom_destroy_r(GEOShandle, centroid);
    GEOSGeom_destroy_r(GEOShandle, p);
    
    // Get ring direction
    SEXP ringDir;
    PROTECT(ringDir = NEW_INTEGER(1)); pc++;
    INTEGER_POINTER(ringDir)[0] = hole ? -1 : 1;
    
    // Get hole status
    SEXP Hole;
    PROTECT(Hole = NEW_LOGICAL(1)); pc++;
    LOGICAL_POINTER(Hole)[0] = hole;
    
    SEXP ans;
    PROTECT(ans = NEW_OBJECT(MAKE_CLASS("Polygon"))); pc++;    
    SET_SLOT(ans, install("ringDir"), ringDir);
    SET_SLOT(ans, install("labpt"), labpt);
    SET_SLOT(ans, install("area"), area);
    SET_SLOT(ans, install("hole"), Hole);
    SET_SLOT(ans, install("coords"), crd);
    
    SEXP valid;
    PROTECT(valid = SP_PREFIX(Polygon_validate_c)(ans)); pc++;
    if (!isLogical(valid)) {
        UNPROTECT(pc);
        if (isString(valid)) 
            error(CHAR(STRING_ELT(valid, 0)));
        else 
            error("invalid Polygon object");
    }
    
    UNPROTECT(pc);
    return(ans);
}
Пример #17
0
/* used in eval.c */
SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input, SEXP call)
{
    SEXP y, nlist;
    size_t slen;

    PROTECT(x);
    PROTECT(input);

    /* Optimisation to prevent repeated recalculation */
    slen = strlen(translateChar(input));
     /* The mechanism to allow a class extending "environment" */
    if( IS_S4_OBJECT(x) && TYPEOF(x) == S4SXP ){
        x = R_getS4DataSlot(x, ANYSXP);
	if(x == R_NilValue)
	    errorcall(call, "$ operator not defined for this S4 class");
    }

    /* If this is not a list object we return NULL. */

    if (isPairList(x)) {
	SEXP xmatch = R_NilValue;
	int havematch;
	UNPROTECT(2);
	havematch = 0;
	for (y = x ; y != R_NilValue ; y = CDR(y)) {
	    switch(pstrmatch(TAG(y), input, slen)) {
	    case EXACT_MATCH:
		y = CAR(y);
		if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
		return y;
	    case PARTIAL_MATCH:
		havematch++;
		xmatch = y;
		break;
	    case NO_MATCH:
		break;
	    }
	}
	if (havematch == 1) { /* unique partial match */
	    if(R_warn_partial_match_dollar) {
		const char *st = "";
		SEXP target = TAG(y);
		switch (TYPEOF(target)) {
		case SYMSXP:
		    st = CHAR(PRINTNAME(target));
		    break;
		case CHARSXP:
		    st = translateChar(target);
		    break;
		}
		warningcall(call, _("partial match of '%s' to '%s'"),
			    translateChar(input), st);
	    }
	    y = CAR(xmatch);
	    if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
	    return y;
	}
	return R_NilValue;
    }
    else if (isVectorList(x)) {
	R_xlen_t i, n, imatch = -1;
	int havematch;
	nlist = getAttrib(x, R_NamesSymbol);
	UNPROTECT(2);
	n = xlength(nlist);
	havematch = 0;
	for (i = 0 ; i < n ; i = i + 1) {
	    switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) {
	    case EXACT_MATCH:
		y = VECTOR_ELT(x, i);
		if (NAMED(x) > NAMED(y))
		    SET_NAMED(y, NAMED(x));
		return y;
	    case PARTIAL_MATCH:
		havematch++;
		if (havematch == 1) {
		    /* partial matches can cause aliasing in eval.c:evalseq
		       This is overkill, but alternative ways to prevent
		       the aliasing appear to be even worse */
		    y = VECTOR_ELT(x,i);
		    SET_NAMED(y,2);
		    SET_VECTOR_ELT(x,i,y);
		}
		imatch = i;
		break;
	    case NO_MATCH:
		break;
	    }
	}
	if(havematch == 1) { /* unique partial match */
	    if(R_warn_partial_match_dollar) {
		const char *st = "";
		SEXP target = STRING_ELT(nlist, imatch);
		switch (TYPEOF(target)) {
		case SYMSXP:
		    st = CHAR(PRINTNAME(target));
		    break;
		case CHARSXP:
		    st = translateChar(target);
		    break;
		}
		warningcall(call, _("partial match of '%s' to '%s'"),
			    translateChar(input), st);
	    }
	    y = VECTOR_ELT(x, imatch);
	    if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
	    return y;
	}
	return R_NilValue;
    }
    else if( isEnvironment(x) ){
	y = findVarInFrame(x, install(translateChar(input)));
	if( TYPEOF(y) == PROMSXP ) {
	    PROTECT(y);
	    y = eval(y, R_GlobalEnv);
	    UNPROTECT(1);
	}
	UNPROTECT(2);
	if( y != R_UnboundValue ) {
	    if (NAMED(y))
		SET_NAMED(y, 2);
	    else if (NAMED(x) > NAMED(y))
		SET_NAMED(y, NAMED(x));
	    return(y);
	}
	return R_NilValue;
    }
    else if( isVectorAtomic(x) ){
	errorcall(call, "$ operator is invalid for atomic vectors");
    }
    else /* e.g. a function */
	errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
    UNPROTECT(2);
    return R_NilValue;
}
Пример #18
0
SEXP rgeos_geosline2SpatialLines(SEXP env, GEOSGeom geom, SEXP p4s, SEXP idlist, int nlines) {
    
    GEOSContextHandle_t GEOShandle = getContextHandle(env);
    
    GEOSGeom curgeom;
    GEOSGeom subgeom;
    GEOSCoordSeq s;
    int type = GEOSGeomTypeId_r(GEOShandle, geom);
    if (type != GEOS_LINESTRING && type != GEOS_MULTILINESTRING && 
        type != GEOS_LINEARRING && type != GEOS_GEOMETRYCOLLECTION ) {

        error("rgeos_geosline2SpatialLines: invalid type");
    }
    if (nlines < 1) error("rgeos_geosline2SpatialLines: invalid number of geometries");
    
    int pc=0;

    if (nlines > length(idlist))
        error("rgeos_geosline2SpatialLines: nlines > length(idlist)");

    SEXP bbox, lines_list;
    PROTECT(bbox = rgeos_geom2bbox(env, geom)); pc++;
    PROTECT(lines_list = NEW_LIST(nlines)); pc++;
    
    for(int j = 0; j < nlines; j++) {
        
        curgeom = (type == GEOS_GEOMETRYCOLLECTION) ?
                                (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, geom, j) :
                                geom;
        if (curgeom == NULL) 
            error("rgeos_geosline2SpatialLines: unable to get geometry collection geometry");
        int curtype = GEOSGeomTypeId_r(GEOShandle, curgeom);
        
        int n = GEOSGetNumGeometries_r(GEOShandle, curgeom);
        if (n == -1) error("rgeos_geosline2SpatialLines: invalid number of geometries in current geometry");
        n = n ? n : 1;
        
        SEXP line_list;
        PROTECT(line_list = NEW_LIST(n));
        
        for(int i = 0; i < n; i++) {
            subgeom = (curtype == GEOS_MULTILINESTRING && !GEOSisEmpty_r(GEOShandle, curgeom)) ?
                                    (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, curgeom, i) :
                                    curgeom;
            if(subgeom == NULL) error("rgeos_geosline2SpatialLines: unable to get subgeometry");
            
            SEXP crdmat;
            if (GEOSisEmpty_r(GEOShandle, subgeom) == 0) {
                s = (GEOSCoordSeq) GEOSGeom_getCoordSeq_r(GEOShandle, subgeom);
                if (s == NULL) 
                    error("rgeos_geosline2SpatialLines: unable to generate coordinate sequence");

                PROTECT( crdmat = rgeos_CoordSeq2crdMat(env, s, FALSE, FALSE));
            } else {
                error("rgeos_geosline2SpatialLines: empty line found");
//                PROTECT( crdmat = R_NilValue);
            }

            SEXP line;
            PROTECT(line = NEW_OBJECT(MAKE_CLASS("Line")));   
            SET_SLOT(line, install("coords"), crdmat);
            SET_VECTOR_ELT(line_list, i, line );
        
            UNPROTECT(2);
        }

        SEXP lines;
        PROTECT( lines = NEW_OBJECT(MAKE_CLASS("Lines")) );
        SET_SLOT(lines, install("Lines"), line_list);
        
        char idbuf[BUFSIZ];
        strcpy(idbuf, CHAR( STRING_ELT(idlist, j) ));
        
        SEXP id;
        PROTECT( id = NEW_CHARACTER(1) );
        SET_STRING_ELT(id, 0, COPY_TO_USER_STRING(idbuf));
        SET_SLOT(lines, install("ID"), id);

        SET_VECTOR_ELT( lines_list, j, lines );
        
        UNPROTECT(3);
    }
    
    SEXP ans;    
    PROTECT(ans = NEW_OBJECT(MAKE_CLASS("SpatialLines"))); pc++;    
    SET_SLOT(ans, install("lines"), lines_list);
    SET_SLOT(ans, install("bbox"), bbox);
    SET_SLOT(ans, install("proj4string"), p4s);


    UNPROTECT(pc);
    return(ans);
}
Пример #19
0
/*
 * 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 */
	SWITCHTO_PLR_SPI_CONTEXT(oldcontext);

	/*
	 * 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;
}
Пример #20
0
SEXP rgeos_geosring2SpatialRings(SEXP env, GEOSGeom geom, SEXP p4s, SEXP idlist, int nrings) {
    
    GEOSContextHandle_t GEOShandle = getContextHandle(env);
    
    int type = GEOSGeomTypeId_r(GEOShandle, geom);
    if (type != GEOS_LINEARRING && type != GEOS_GEOMETRYCOLLECTION )
        error("rgeos_geosring2SpatialRings: invalid type");
    
    if (nrings < 1) error("rgeos_geosring2SpatialRings: invalid number of geometries");
    
    int pc=0;
    SEXP bbox, rings_list;
    PROTECT(bbox = rgeos_geom2bbox(env, geom)); pc++;
    PROTECT(rings_list = NEW_LIST(nrings)); pc++;
    
    for(int j = 0; j < nrings; j++) {
        
        GEOSGeom curgeom = (type == GEOS_GEOMETRYCOLLECTION) ?
                                (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, geom, j) :
                                geom;
        if (curgeom == NULL) 
            error("rgeos_geosring2SpatialRings: unable to get geometry collection geometry");
        
        SEXP crdmat;
        if (GEOSisEmpty_r(GEOShandle, curgeom) == 0) {
            GEOSCoordSeq s = (GEOSCoordSeq) GEOSGeom_getCoordSeq_r(GEOShandle, curgeom);
            if (s == NULL) 
                error("rgeos_geosring2SpatialRings: unable to generate coordinate sequence");

            PROTECT(crdmat = rgeos_crdMatFixDir(rgeos_CoordSeq2crdMat(env, s, FALSE, FALSE), FALSE));
        } else {
            PROTECT( crdmat = R_NilValue);
        }
        
        SEXP ring;
        PROTECT(ring = NEW_OBJECT(MAKE_CLASS("Ring")));   
        SET_SLOT(ring, install("coords"), crdmat);
        
        SEXP id;
        PROTECT( id = NEW_CHARACTER(1) );
        char idbuf[BUFSIZ];
        strcpy(idbuf, CHAR( STRING_ELT(idlist, j) ));
        SET_STRING_ELT(id, 0, COPY_TO_USER_STRING(idbuf));
        
        SET_SLOT(ring, install("ID"), id);

        SET_VECTOR_ELT(rings_list, j, ring );
        
        
        UNPROTECT(3);
    }
    
    SEXP ans;    
    PROTECT(ans = NEW_OBJECT(MAKE_CLASS("SpatialRings"))); pc++;    
    SET_SLOT(ans, install("rings"), rings_list);
    SET_SLOT(ans, install("bbox"), bbox);
    SET_SLOT(ans, install("proj4string"), p4s);

    UNPROTECT(pc);
    return(ans);
}
Пример #21
0
/*
 * Takes the prepared plan rsaved_plan and creates a cursor 
 * for it using the values specified in ragvalues.
 *
 */
SEXP
plr_SPI_cursor_open(SEXP cursor_name_arg,SEXP rsaved_plan, SEXP rargvalues)
{
	saved_plan_desc	   *plan_desc = (saved_plan_desc *) R_ExternalPtrAddr(rsaved_plan);
	void			   *saved_plan = plan_desc->saved_plan;
	int					nargs = plan_desc->nargs;
	Oid				   *typeids = plan_desc->typeids;
	FmgrInfo		   *typinfuncs = plan_desc->typinfuncs;
	int					i;
	Datum			   *argvalues = NULL;
	char			   *nulls = NULL;
	bool				isnull = false;
	SEXP				obj;
	SEXP				result = NULL;
	MemoryContext		oldcontext;
	char				cursor_name[64];
	Portal				portal=NULL;
	PREPARE_PG_TRY;
	PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_open");

	/* Divide rargvalues */
	if (nargs > 0)
	{
		if (!Rf_isVectorList(rargvalues))
			error("%s", "second parameter must be a list of arguments " \
						"to the prepared plan");

		if (length(rargvalues) != nargs)
			error("list of arguments (%d) is not the same length " \
				  "as that of the prepared plan (%d)",
				  length(rargvalues), nargs);

		argvalues = (Datum *) palloc(nargs * sizeof(Datum));
		nulls = (char *) palloc(nargs * sizeof(char));
	}

	for (i = 0; i < nargs; i++)
	{
		PROTECT(obj = VECTOR_ELT(rargvalues, i));

		argvalues[i] = get_scalar_datum(obj, typeids[i], typinfuncs[i], &isnull);
		if (!isnull)
			nulls[i] = ' ';
		else
			nulls[i] = 'n';

		UNPROTECT(1);
	}
	strncpy(cursor_name, CHAR(STRING_ELT(cursor_name_arg,0)), 64);

	/* switch to SPI memory context */
	SWITCHTO_PLR_SPI_CONTEXT(oldcontext);

	/*
	 * trap elog/ereport so we can let R finish up gracefully
	 * and generate the error once we exit the interpreter
	 */
	PG_TRY();
	{
		/* Open the cursor */
		portal = SPI_cursor_open(cursor_name,saved_plan, argvalues, nulls,1);

	}
	PLR_PG_CATCH();
	PLR_PG_END_TRY();

	/* back to caller's memory context */
	MemoryContextSwitchTo(oldcontext);

	if(portal==NULL) 
		error("SPI_cursor_open() failed");
	else 
		result = R_MakeExternalPtr(portal, R_NilValue, R_NilValue);

	POP_PLERRCONTEXT;
	return result;
}
Пример #22
0
/* 
 * ------------------------------------------------------------------------
 * 
 * "rcqpCmd_dump_subcorpus(SEXP inSubcorpus, SEXP inField, SEXP inFirst, SEXP inLast)" --
 * 
 * 
 * ------------------------------------------------------------------------
 */
SEXP rcqpCmd_dump_subcorpus(SEXP inSubcorpus, SEXP inFirst, SEXP inLast)
{
	SEXP			result = R_NilValue;
	char *			subcorpus;
	CorpusList *	cl;
	int				i, first, last, nrows;
	
	if (!isString(inSubcorpus) || length(inSubcorpus) != 1) error("invalid subcorpus name");
	
	PROTECT(inSubcorpus);
	PROTECT(inFirst);
	PROTECT(inLast);
	
	first = asInteger(inFirst);
	if (first == NA_INTEGER) {
		UNPROTECT(3);
	    error("invalid 'first' value (too large or NA)");
	}
	last = asInteger(inLast);
	if (last == NA_INTEGER) {
		UNPROTECT(3);
	    error("invalid 'last' value (too large or NA)");
	}
	subcorpus = (char*)CHAR(STRING_ELT(inSubcorpus,0));
	
	cl = cqi_find_corpus(subcorpus);
	if (cl == NULL) {
		UNPROTECT(3);
		rcqp_error_code(cqi_errno);
	}
	
	if ((last < first) || (first < 0) || (last >= cl->size)) {
		error("indices out of range\n");
	}

	nrows = last - first + 1;
	result = PROTECT(allocMatrix(INTSXP, nrows, 4));
	
	for (i = 0; i< nrows; i++) {
		/* 'match' column */
		INTEGER(result)[i] = cl->range[i+first].start;
		
		/* 'matchend' column */
		INTEGER(result)[i+nrows] = cl->range[i+first].end;
		
		/* 'target' column */
		if (cl->targets == NULL) {
			INTEGER(result)[i+2*nrows] = -1;
		} else {
			INTEGER(result)[i+2*nrows] = cl->targets[i+first];
		} 
		
		/* 'keyword' column */
		if (cl->keywords == NULL) {
			INTEGER(result)[i+3*nrows] = -1;
		} else {
			INTEGER(result)[i+3*nrows] = cl->keywords[i+first];
		} 
	}
	
	UNPROTECT(4);
	
	return result;
}
Пример #23
0
SEXP cr_get(SEXP sc, SEXP keys, SEXP asList) {
    rconn_t *c;
    int n, i, use_list = Rf_asInteger(asList);
    const char **argv = argbuf;
    redisReply *reply;
    SEXP res;

    if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
    c = (rconn_t*) EXTPTR_PTR(sc);
    if (!c) Rf_error("invalid connection (NULL)");
    rc_validate_connection(c, 0);
    if (TYPEOF(keys) != STRSXP)
	Rf_error("invalid keys");
    n = LENGTH(keys);
    if (use_list < 0) /* asList == NA -> list for non scalar results only */
	use_list = (n == 1) ? 0 : 1;
    if (n != 1 && !use_list) Rf_error("exaclty one key must be specified with list=FALSE");
    if (n + 1 > NARGBUF) {
	argv = malloc(sizeof(const char*) * (n + 2));
	if (!argv)
	    Rf_error("out of memory");
    }
    argv[0] = "MGET";
    for (i = 0; i < n; i++)
	argv[i + 1] = CHAR(STRING_ELT(keys, i));
    /* we use strings only, so no need to supply argvlen */
    reply = redisCommandArgv(c->rc, n + 1, argv, 0);
    if (!reply && (c->flags & RCF_RETRY)) {
	SEXP es = Rf_mkChar(c->rc->errstr);
	rc_close(c);
	rc_validate_connection(c, 1);
	if (c->rc)
	    reply = redisCommandArgv(c->rc, n + 1, argv, 0);
	else {
	    if (argv != argbuf)
		free(argv);
	    Rf_error("MGET error: %s and re-connect failed", CHAR(es));
	}
    }
    if (argv != argbuf)
	free(argv);
    if (!reply) {
	SEXP es = Rf_mkChar(c->rc->errstr);
	rc_close(c);
	Rf_error("MGET error: %s", CHAR(es));
    }
    /* Rprintf("reply, type=%d\n", reply->type); */
    if (reply->type != REDIS_REPLY_ARRAY) {
	freeReplyObject(reply);
	Rf_error("unexpected result type");
    }
    if (reply->elements != n) {
	freeReplyObject(reply);
	Rf_error("unexpected result length - should be %d but is %d", n, (int) reply->elements);
    }
    if (use_list) {
	int n = reply->elements;
	res = PROTECT(Rf_allocVector(VECSXP, n));
	Rf_setAttrib(res, R_NamesSymbol, keys);
	for (i = 0; i < n; i++)
	    SET_VECTOR_ELT(res, i, rc_reply2R(reply->element[i]));
	UNPROTECT(1);
    } else
	res = rc_reply2R(reply->element[0]);
    freeReplyObject(reply);
    return res;
}
Пример #24
0
  SEXP spSVCPredictJoint(SEXP m_r, SEXP n_r, SEXP KDiag_r, SEXP obsD_r, SEXP predObsD_r, SEXP predD_r, SEXP q_r,
			 SEXP samples_r, SEXP wSamples_r, SEXP nSamples_r, 
			 SEXP AIndx_r, SEXP phiIndx_r, SEXP nuIndx_r, 	   
			 SEXP covModel_r, 
			 SEXP verbose_r, SEXP nReport_r, SEXP nThreads_r){

    /*****************************************
                Common variables
    *****************************************/
    int i, j, k, l, b, s, h, info, nProtect=0;
    char const *lower = "L";
    char const *upper = "U";
    char const *nUnit = "N";
    char const *yUnit = "U";
    char const *ntran = "N";
    char const *ytran = "T";
    char const *rside = "R";
    char const *lside = "L";
    const double one = 1.0;
    const double negOne = -1.0;
    const double zero = 0.0;
    const int incOne = 1;
    
    /*****************************************
                     Set-up
    *****************************************/
    double *obsD = REAL(obsD_r);
    double *predObsD = REAL(predObsD_r);
    double *predD = REAL(predD_r);
    int m = INTEGER(m_r)[0];
    int mm = m*m;
    int n = INTEGER(n_r)[0];
    int nn = n*n;
    int nm = n*m;
    int nmnm = nm*nm;
    int q = INTEGER(q_r)[0];//number of prediction locations
    int qm = q*m;
    int qmnm = qm*nm;
    int qmqm = qm*qm;
    bool KDiag = static_cast<bool>(INTEGER(KDiag_r)[0]);
    int nLTr = m*(m-1)/2+m;
	
    double *samples = REAL(samples_r);
    double *wSamples = REAL(wSamples_r);
    int nSamples = INTEGER(nSamples_r)[0];

    int AIndx = INTEGER(AIndx_r)[0]; 
    int phiIndx = INTEGER(phiIndx_r)[0]; 
    int nuIndx  = INTEGER(nuIndx_r)[0]; 

    std::string covModel = CHAR(STRING_ELT(covModel_r,0));
    int verbose = INTEGER(verbose_r)[0];
    int nReport = INTEGER(nReport_r)[0];
    int nThreads = INTEGER(nThreads_r)[0];
    
    /*****************************************
       Set-up MCMC alg. vars. matrices etc.
    *****************************************/
    SEXP wPredSamples_r;
    PROTECT(wPredSamples_r = allocMatrix(REALSXP, qm, nSamples)); nProtect++; 

    int status=1;
    double *A = (double *) R_alloc(mm, sizeof(double)); zeros(A, mm); //to simplify a future move to the more general cross-cov model
    double *K = (double *) R_alloc(nmnm, sizeof(double)); 
    double *B = (double *) R_alloc(qmnm, sizeof(double)); 
    double *C = (double *) R_alloc(qmqm, sizeof(double));
    double *tmp_nltr = (double *) R_alloc(nLTr, sizeof(double)); 
    double *tmp_qmnm = (double *) R_alloc(qmnm, sizeof(double)); 
    double *tmp_qm = (double *) R_alloc(qm, sizeof(double));
    double *tmp_qmqm = (double *) R_alloc(qmqm, sizeof(double));
    double *phi = (double *) R_alloc(m, sizeof(double));
    double *nu = (double *) R_alloc(m, sizeof(double)); zeros(nu, m); //this just remains empty of not matern

    double maxNu = 0; //needed for thread safe bessel
    
    if(covModel == "matern"){
      for(s = 0; s < nSamples; s++){
	for(i = 0; i < m; i++){
	  if(samples[(nuIndx+i)*nSamples+s] > maxNu){
	    maxNu = samples[(nuIndx+i)*nSamples+s];
	  }
	}
      }
    }

    int threadID = 0;
    int bessel_ws_inc = static_cast<int>(1.0+maxNu);
    double *bessel_ws = (double *) R_alloc(nThreads*bessel_ws_inc, sizeof(double));

#ifdef _OPENMP
    omp_set_num_threads(nThreads);
      if(verbose){
    Rprintf("Source compiled with OpenMP, posterior sampling is using %i thread(s).\n", nThreads);
      }
#else
    if(nThreads > 1){
      warning("n.omp.threads = %i, but source not compiled with OpenMP support.", nThreads);
      nThreads = 1;
    }
#endif  
    
    if(verbose){
	Rprintf("-------------------------------------------------\n");
	Rprintf("\tJoint sampling of predicted w\n");
	Rprintf("-------------------------------------------------\n");
      #ifdef Win32
      R_FlushConsole();
      #endif
    }
    
    GetRNGstate();
    
    for(s = 0; s < nSamples; s++){
      
      if(KDiag == false){
	dcopy_(&nLTr, &samples[AIndx*nSamples+s], &nSamples, tmp_nltr, &incOne);
      	covExpand(tmp_nltr, A, m);//note this is K, so we need chol
      	F77_NAME(dpotrf)(lower, &m, A, &m, &info); if(info != 0){error("c++ error: dpotrf failed 1\n");} 
      	clearUT(A, m); //make sure upper tri is clear
      }

      for(k = 0; k < m; k++){

	if(KDiag){
	  A[k*m+k] = sqrt(samples[(AIndx+k)*nSamples+s]);
	}
	
	phi[k] = samples[(phiIndx+k)*nSamples+s]; 
	
	if(covModel == "matern"){
	  nu[k] = samples[(nuIndx+k)*nSamples+s]; 
	}
	
      }
      
      //construct covariance matrix
#ifdef _OPENMP
#pragma omp parallel for private(i, k, l, h, threadID)
#endif
      for(j = 0; j < n; j++){
#ifdef _OPENMP
	threadID = omp_get_thread_num();
#endif
	for(i = 0; i < n; i++){	
	  for(k = 0; k < m; k++){
	    for(l = 0; l < m; l++){
	      K[(k+j*m)*nm+(i*m+l)] = 0.0; 
	      for(h = 0; h < m; h++){
		K[(k+j*m)*nm+(i*m+l)] += A[k+m*h]*A[l+m*h]*spCorTS(obsD[j*n+i], phi[h], nu[h], covModel, &bessel_ws[threadID*bessel_ws_inc]);
	      }
	    }
	  }
	}
      }
      
#ifdef _OPENMP
#pragma omp parallel for private(i, k, l, h, threadID)
#endif
      for(j = 0; j < n; j++){
#ifdef _OPENMP
	threadID = omp_get_thread_num();
#endif	
	for(i = 0; i < q; i++){	
	  for(k = 0; k < m; k++){
	    for(l = 0; l < m; l++){
	      B[(k+j*m)*qm+(i*m+l)] = 0.0; 
	      for(h = 0; h < m; h++){
		B[(k+j*m)*qm+(i*m+l)] += A[k+m*h]*A[l+m*h]*spCorTS(predObsD[j*q+i], phi[h], nu[h], covModel, &bessel_ws[threadID*bessel_ws_inc]);
	      }
	    }
	  }
	}
      }
      
      //printMtrx(B, qm, nm);
      
#ifdef _OPENMP
#pragma omp parallel for private(i, k, l, h, threadID)
#endif
      for(j = 0; j < q; j++){
#ifdef _OPENMP
	threadID = omp_get_thread_num();
#endif
	for(i = 0; i < q; i++){	
	  for(k = 0; k < m; k++){
	    for(l = 0; l < m; l++){
	      C[(k+j*m)*qm+(i*m+l)] = 0.0; 
	      for(h = 0; h < m; h++){
		C[(k+j*m)*qm+(i*m+l)] += A[k+m*h]*A[l+m*h]*spCorTS(predD[j*q+i], phi[h], nu[h], covModel, &bessel_ws[threadID*bessel_ws_inc]);
	      }
	    }
	  }
	}
      }
         
      F77_NAME(dpotrf)(lower, &nm, K, &nm, &info); if(info != 0){error("c++ error: dpotrf failed 1\n");}
      F77_NAME(dpotri)(lower, &nm, K, &nm, &info); if(info != 0){error("c++ error: dpotri failed\n");}     
      F77_NAME(dsymm)(rside, lower, &qm, &nm, &one, K, &nm, B, &qm, &zero, tmp_qmnm, &qm);
      
      //mu
      F77_NAME(dgemv)(ntran, &qm, &nm, &one, tmp_qmnm, &qm, &wSamples[s*nm], &incOne, &zero, tmp_qm, &incOne);

      //var
      F77_NAME(dgemm)(ntran, ytran, &qm, &qm, &nm, &one, tmp_qmnm, &qm, B, &qm, &zero, tmp_qmqm, &qm);

      for(i = 0; i < qmqm; i++){
	C[i] = C[i] - tmp_qmqm[i];
      }
            
      F77_NAME(dpotrf)(lower, &qm, C, &qm, &info); if(info != 0){error("c++ error: dpotrf failed 2\n");}
      
      mvrnorm(&REAL(wPredSamples_r)[s*qm], tmp_qm, C, qm, false);
      
      //report
      if(verbose){
      	if(status == nReport){
	  Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
          #ifdef Win32
      	  R_FlushConsole();
          #endif
      	  status = 0;
      	}
      }
      status++;
      R_CheckUserInterrupt();
    }//end sample loop
    
    PutRNGstate();
    
    //make return object
    SEXP result_r, resultName_r;
    int nResultListObjs = 1;

    PROTECT(result_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
    PROTECT(resultName_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
    
    //samples
    SET_VECTOR_ELT(result_r, 0, wPredSamples_r);
    SET_VECTOR_ELT(resultName_r, 0, mkChar("p.w.predictive.samples")); 

    namesgets(result_r, resultName_r);
    
    //unprotect
    UNPROTECT(nProtect);
    
    return(result_r);

    }
Пример #25
0
/* check neighbourhood sets and markov blanets for consistency.. */
SEXP bn_recovery(SEXP bn, SEXP strict, SEXP mb, SEXP filter, SEXP debug) {

int i = 0, j = 0, k = 0, n = 0, counter = 0;
short int *checklist = NULL, err = 0;
int debuglevel = isTRUE(debug), checkmb = isTRUE(mb), *flt = INTEGER(filter);
SEXP temp, temp2, nodes, elnames = NULL, fixed;

  /* get the names of the nodes. */
  nodes = getAttrib(bn, R_NamesSymbol);
  n = length(nodes);

  /* allocate and initialize the checklist. */
  checklist = allocstatus(UPTRI_MATRIX(n));

  if (debuglevel > 0) {

    Rprintf("----------------------------------------------------------------\n");

    if (checkmb)
      Rprintf("* checking consistency of markov blankets.\n");
    else
      Rprintf("* checking consistency of neighbourhood sets.\n");

   }/*THEN*/

  /* scan the structure to determine the number of arcs.  */
  for (i = 0; i < n; i++) {

     if (debuglevel > 0)
       Rprintf("  > checking node %s.\n",  NODE(i));

    /* get the entry for the (neighbours|elements of the markov blanket)
       of the node.*/
    temp = getListElement(bn, (char *)NODE(i));
    if (!checkmb)
      temp = getListElement(temp, "nbr");

    /* check each element of the array and identify which variable it
       corresponds to. */
    for (j = 0; j < length(temp); j++) {

      for (k = 0; k < n; k++) {

        /* increment the right element of checklist. */
        if (!strcmp(NODE(k), (char *)CHAR(STRING_ELT(temp, j))))
          checklist[UPTRI(i + 1, k + 1, n)]++;

      }/*FOR*/

    }/*FOR*/

  }/*FOR*/

  /* if A is a neighbour of B, B is a neighbour of A; therefore each entry in
   * the checklist array must be equal to either zero (if the corresponding
   * nodes are not neighbours) or two (if the corresponding nodes are neighbours).
   * Any other value (typically one) is caused by an incorrect (i.e. asymmetric)
   * neighbourhood structure. The same logic holds for the markov blankets. */
  for (i = 0; i < n; i++)
    for (j = i; j < n; j++) {

      if ((checklist[UPTRI(i + 1, j + 1, n)] != 0) &&
          (checklist[UPTRI(i + 1, j + 1, n)] != 2)) {

        if (debuglevel > 0) {

          if (checkmb)
            Rprintf("@ asymmetry in the markov blankets for %s and %s.\n",
              NODE(i), NODE(j));
          else
            Rprintf("@ asymmetry in the neighbourhood sets for %s and %s.\n",
              NODE(i), NODE(j));

        }/*THEN*/

        err = 1;

      }/*THEN*/

    }/*FOR*/

  /* no need to go on if the (neighbourhood sets|markov blankets) are symmetric;
   * otherwise throw either an error or a warning according to the value of the
   * strict parameter. */
  if (!err) {

    return bn;

  }/*THEN*/
  else if (isTRUE(strict)) {

    if (checkmb)
      error("markov blankets are not symmetric.\n");
    else
      error("neighbourhood sets are not symmetric.\n");

  }/*THEN*/

  /* build a correct structure to return. */
  PROTECT(fixed = allocVector(VECSXP, n));
  setAttrib(fixed, R_NamesSymbol, nodes);

  /* allocate colnames. */
  if (!checkmb)
    PROTECT(elnames = mkStringVec(2, "mb", "nbr"));

  for (i = 0; i < n; i++) {

    if (!checkmb) {

      /* allocate the "mb" and "nbr" elements of the node. */
      PROTECT(temp = allocVector(VECSXP, 2));
      SET_VECTOR_ELT(fixed, i, temp);
      setAttrib(temp, R_NamesSymbol, elnames);

      /* copy the "mb" part from the old structure. */
      temp2 = getListElement(bn, (char *)NODE(i));
      temp2 = getListElement(temp2, "mb");
      SET_VECTOR_ELT(temp, 0, temp2);

    }/*THEN*/

    /* rescan the checklist. */
    for (j = 0; j < n; j++)
      if (checklist[UPTRI(i + 1, j + 1, n)] >= *flt)
        if (i != j)
          counter++;

    /* allocate and fill the "nbr" element. */
    PROTECT(temp2 = allocVector(STRSXP, counter));

    for (j = 0; j < n; j++)
      if (checklist[UPTRI(i + 1, j + 1, n)] == *flt)
        if (i != j)
          SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j));

    if (checkmb) {

      SET_VECTOR_ELT(fixed, i, temp2);
      UNPROTECT(1);

    }/*THEN*/
    else {

      SET_VECTOR_ELT(temp, 1, temp2);
      UNPROTECT(2);

    }/*ELSE*/

  }/*FOR*/

  if (checkmb)
    UNPROTECT(1);
  else
    UNPROTECT(2);

  return fixed;

}/*BN_RECOVERY*/
Пример #26
0
SEXP R_el_named(SEXP object, SEXP what)
{
    const char * str;
    str = CHAR(asChar(what));
    return R_element_named(object, str);
}
Пример #27
0
void CGameControllerBoomFNG::DoInteractions()
{
	DoHookers();

	for(int i = 0; i < MAX_CLIENTS; i++)
	{
		CCharacter *pChr = CHAR(i);
		if (!pChr)
			continue;

		int FrzTicks = pChr->GetFreezeTicks();
		int Col = GameServer()->Collision()->GetCollisionAt(pChr->m_Pos.x, pChr->m_Pos.y);
		if (Col == TILE_SHRINE_ALL || Col == TILE_SHRINE_RED || Col == TILE_SHRINE_BLUE)
		{
			if (FrzTicks > 0 && m_aLastInteraction[i] < 0)
				pChr->Freeze(FrzTicks = 0);

			bool WasSacrificed = false;
			if (FrzTicks > 0)
			{
				int ShrineTeam = Col == TILE_SHRINE_RED ? TEAM_RED : Col == TILE_SHRINE_BLUE ? TEAM_BLUE : -1;
				HandleSacr(m_aLastInteraction[i], i, ShrineTeam);
				WasSacrificed = true;
			}

			pChr->Die(pChr->GetPlayer()->GetCID(), WEAPON_WORLD, WasSacrificed);
		}


		if (FrzTicks > 0)
		{
			if ((FrzTicks+1) % TS == 0)
			{
				if (pChr->GetPlayer()->GetTeam() != -1)
					GS->CreateDamageInd(pChr->m_Pos, 0, (FrzTicks+1) / TS, CmaskOne(pChr->GetPlayer()->GetCID()));
				else
					GS->CreateDamageInd(pChr->m_Pos, 0, (FrzTicks+1) / TS, m_aCltMask[pChr->GetPlayer()->GetTeam()&1]);
					
				if (g_Config.m_SvTickSound == 1) GS->CreateSound(GS->m_apPlayers[i]->m_ViewPos, SOUND_WEAPON_NOAMMO, CmaskOne(i));
				if (g_Config.m_SvTickSound == 2) GS->CreateSound(pChr->m_Pos, SOUND_WEAPON_NOAMMO);
			}
			if (FrzTicks == 1 && CFG(MeltSafeticks))
				pChr->SetEmote(EMOTE_SURPRISE, TICK + CFG(MeltSafeticks) + 1);

			m_aMoltenBy[i] = -1;

			if (m_aFrozenBy[i] != -1)
				continue;

			int Killer = pChr->WasFrozenBy();
			if (Killer < 0) //may happen then the gods are not pleased
			{
				m_aFrozenBy[i] = -1;
				continue;
			}

			m_aFrozenBy[i] = Killer;
			
			HandleFreeze(Killer, i);
		}
		else
		{
			m_aFrozenBy[i] = -1;

			int Melter = pChr->WasMoltenBy();
			if (Melter < 0)
				m_aMoltenBy[i] = -1;
			
			if (Melter == m_aMoltenBy[i])
				continue;

			m_aMoltenBy[i] = Melter;

			HandleMelt(Melter, i);
		}
	}
}
Пример #28
0
SEXP R_set_el_named(SEXP object, SEXP what, SEXP value)
{
    const char * str;
    str = CHAR(asChar(what));
    return R_insert_element(object, str, value);
}
Пример #29
0
/**
 * Callback if the remote host requires authentication in order to
 * connect to it
 *
 * @param cred The newly created credential object.
 * @param url The resource for which we are demanding a credential.
 * @param user_from_url The username that was embedded in a "[email protected]"
 * remote url, or NULL if not included.
 * @param allowed_types A bitmask stating which cred types are OK to return.
 * @param payload The payload provided when specifying this callback.
 * @return 0 on success, else -1.
 */
int git2r_cred_acquire_cb(
    git_cred **cred,
    const char *url,
    const char *username_from_url,
    unsigned int allowed_types,
    void *payload)
{
    int err = -1;
    SEXP credentials = (SEXP)payload;

    GIT_UNUSED(url);

    if (R_NilValue != credentials) {
        SEXP class_name;

        class_name = getAttrib(credentials, R_ClassSymbol);
        if (0 == strcmp(CHAR(STRING_ELT(class_name, 0)), "cred_ssh_key")) {
            if (GIT_CREDTYPE_SSH_KEY & allowed_types) {
                SEXP slot;
                const char *publickey;
                const char *privatekey = NULL;
                const char *passphrase = NULL;

                publickey = CHAR(STRING_ELT(
                                     GET_SLOT(credentials,
                                              Rf_install("publickey")), 0));
                privatekey = CHAR(STRING_ELT(
                                      GET_SLOT(credentials,
                                               Rf_install("privatekey")), 0));

                slot = GET_SLOT(credentials, Rf_install("passphrase"));
                if (length(slot)) {
                    if (NA_STRING != STRING_ELT(slot, 0))
                        passphrase = CHAR(STRING_ELT(slot, 0));
                }

                err = git_cred_ssh_key_new(
                    cred,
                    username_from_url,
                    publickey,
                    privatekey,
                    passphrase);
            }
        } else if (0 == strcmp(CHAR(STRING_ELT(class_name, 0)), "cred_plaintext")) {
            if (GIT_CREDTYPE_USERPASS_PLAINTEXT & allowed_types) {
                const char *username;
                const char *password;

                username = CHAR(STRING_ELT(
                                    GET_SLOT(credentials,
                                             Rf_install("username")), 0));
                password = CHAR(STRING_ELT(
                                    GET_SLOT(credentials,
                                             Rf_install("password")), 0));

                err = git_cred_userpass_plaintext_new(cred, username, password);
            }
        }
    } else if (GIT_CREDTYPE_SSH_KEY & allowed_types) {
        err = git_cred_ssh_key_from_agent(cred, username_from_url);
    }

    return err;
}
Пример #30
0
/*
 * The main glob() routine: compiles the pattern (optionally processing
 * quotes), calls glob1() to do the real pattern matching, and finally
 * sorts the list (unless unsorted operation is requested).  Returns 0
 * if things went well, nonzero if errors occurred.  It is not an error
 * to find no matches.
 */
static int
glob0(const Char *pattern, glob_t *pglob, struct glob_lim *limitp)
{
    const Char *qpatnext;
    int c, err, oldpathc;
    Char *bufnext, patbuf[PATH_MAX];

    qpatnext = pattern;
    oldpathc = pglob->gl_pathc;
    bufnext = patbuf;

    /* We don't need to check for buffer overflow any more. */
    while ((c = *qpatnext++) != EOS) {
        switch (c) {
        case LBRACKET:
            c = *qpatnext;
            if (c == NOT) {
                ++qpatnext;
            }
            if (*qpatnext == EOS ||
                g_strchr(qpatnext + 1, RBRACKET) == NULL) {
                *bufnext++ = LBRACKET;
                if (c == NOT) {
                    --qpatnext;
                }
                break;
            }
            *bufnext++ = M_SET;
            if (c == NOT) {
                *bufnext++ = M_NOT;
            }
            c = *qpatnext++;
            do {
                *bufnext++ = CHAR(c);
                if (*qpatnext == RANGE &&
                    (c = qpatnext[1]) != RBRACKET) {
                    *bufnext++ = M_RNG;
                    *bufnext++ = CHAR(c);
                    qpatnext += 2;
                }
            } while ((c = *qpatnext++) != RBRACKET);
            pglob->gl_flags |= GLOB_MAGCHAR;
            *bufnext++ = M_END;
            break;
        case QUESTION:
            pglob->gl_flags |= GLOB_MAGCHAR;
            *bufnext++ = M_ONE;
            break;
        case STAR:
            pglob->gl_flags |= GLOB_MAGCHAR;
            /* collapse adjacent stars to one,
             * to avoid exponential behavior
             */
            if (bufnext == patbuf || bufnext[-1] != M_ALL) {
                *bufnext++ = M_ALL;
            }
            break;
        default:
            *bufnext++ = CHAR(c);
            break;
        }
    }
    *bufnext = EOS;

    if ((err = glob1(patbuf, patbuf+PATH_MAX - 1, pglob, limitp, 1)) != 0) {
        return err;
    }

    /*
     * If there was no match we are going to append the pattern
     * if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was specified
     * and the pattern did not contain any magic characters
     * GLOB_NOMAGIC is there just for compatibility with csh.
     */
    if (pglob->gl_pathc == oldpathc) {
        if ((pglob->gl_flags & GLOB_NOCHECK) ||
            ((pglob->gl_flags & GLOB_NOMAGIC) &&
                !(pglob->gl_flags & GLOB_MAGCHAR))) {
            return globextend(pattern, pglob, limitp, NULL);
        } else {
            return GLOB_NOMATCH;
        }
    }
    if (!(pglob->gl_flags & GLOB_NOSORT)) {
        if ((pglob->gl_flags & GLOB_KEEPSTAT)) {
            /* Keep the paths and stat info synced during sort */
            struct glob_path_stat *path_stat;
            int i;
            int n = pglob->gl_pathc - oldpathc;
            int o = pglob->gl_offs + oldpathc;

            if ((path_stat = calloc(n, sizeof(*path_stat))) == NULL) {
                return GLOB_NOSPACE;
            }
            for (i = 0; i < n; i++) {
                path_stat[i].gps_path = pglob->gl_pathv[o + i];
                path_stat[i].gps_stat = pglob->gl_statv[o + i];
            }
            qsort(path_stat, n, sizeof(*path_stat), compare_gps);
            for (i = 0; i < n; i++) {
                pglob->gl_pathv[o + i] = path_stat[i].gps_path;
                pglob->gl_statv[o + i] = path_stat[i].gps_stat;
            }
            free(path_stat);
        } else {
            qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc,
                  pglob->gl_pathc - oldpathc, sizeof(char *),
                  compare);
        }
    }
    return 0;
}