Exemple #1
0
void rlang_register_pointer(const char* ns, const char* ptr_name, DL_FUNC fn) {
  SEXP ptr = PROTECT(R_MakeExternalPtrFn(fn, R_NilValue, R_NilValue));

  SEXP ptr_obj = PROTECT(Rf_allocVector(VECSXP, 1));
  SET_VECTOR_ELT(ptr_obj, 0, ptr);

  Rf_setAttrib(ptr_obj, R_ClassSymbol, Rf_mkString("fn_pointer"));

  Rf_defineVar(Rf_install(ptr_name), ptr_obj, rlang_namespace(ns));
  UNPROTECT(2);
}
Exemple #2
0
static char *RAPIinstalladdons(void) {
	int evalErr;
	ParseStatus status;
	char rlibs[FILENAME_MAX];
	char rapiinclude[BUFSIZ];
	SEXP librisexp;
	int len;

	// r library folder, create if not exists
	len = snprintf(rlibs, sizeof(rlibs), "%s%c%s", GDKgetenv("gdk_dbpath"), DIR_SEP, "rapi_packages");
	if (len == -1 || len >= FILENAME_MAX)
		return "cannot create rapi_packages directory because the path is too large";

	if (mkdir(rlibs, S_IRWXU) != 0 && errno != EEXIST) {
		return "cannot create rapi_packages directory";
	}
#ifdef _RAPI_DEBUG_
	printf("# R libraries installed in %s\n",rlibs);
#endif

	PROTECT(librisexp = allocVector(STRSXP, 1));
	SET_STRING_ELT(librisexp, 0, mkChar(rlibs));
	Rf_defineVar(Rf_install(".rapi.libdir"), librisexp, R_GlobalEnv);
	UNPROTECT(1);

	// run rapi.R environment setup script
	{
		char *f = locate_file("rapi", ".R", 0);
		snprintf(rapiinclude, sizeof(rapiinclude), "source(\"%s\")", f);
		GDKfree(f);
	}
#if DIR_SEP != '/'
	{
		char *p;
		for (p = rapiinclude; *p; p++)
			if (*p == DIR_SEP)
				*p = '/';
	}
#endif
	R_tryEvalSilent(
		VECTOR_ELT(
			R_ParseVector(mkString(rapiinclude), 1, &status,
						  R_NilValue), 0), R_GlobalEnv, &evalErr);

	// of course the script may contain errors as well
	if (evalErr != FALSE) {
		return "failure running R setup script";
	}
	return NULL;
}
            void plot::save_snapshot_variable() {
                rhost::util::errors_to_exceptions([&] {
                    pGEDevDesc ge_dev_desc = Rf_desc2GEDesc(_device_desc);

                    SEXP snapshot = Rf_protect(GEcreateSnapshot(ge_dev_desc));

                    SEXP klass = Rf_protect(Rf_mkString("recordedplot"));
                    Rf_classgets(snapshot, klass);

                    Rf_defineVar(Rf_install(_snapshot_varname.c_str()), snapshot, R_GlobalEnv);

                    Rf_unprotect(2);
                });
            }
Exemple #4
0
SEXP init_Rcpp_cache(){   
    SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed  once in symbol table
    Rcpp::Shield<SEXP> RCPP( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
    Rcpp::Shield<SEXP> cache( Rf_allocVector( VECSXP, RCPP_CACHE_SIZE ) );
    
    // the Rcpp namespace
	SET_VECTOR_ELT( cache, 0, RCPP ) ;
	set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ; // error occured
	set_current_error( cache, R_NilValue ) ; // current error
	SET_VECTOR_ELT( cache, 3, R_NilValue ) ; // stack trace
	SET_VECTOR_ELT( cache, RCPP_HASH_CACHE_INDEX, Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE) ) ;
	Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
    
	return cache ;
}
            void plot::set_snapshot(const rhost::util::protected_sexp& snapshot) {
                // Ignore if we already created a snapshot
                if (_snapshot_varname.empty()) {
                    _snapshot_varname = get_snapshot_varname();
                }

                rhost::util::errors_to_exceptions([&] {
                    SEXP klass = Rf_protect(Rf_mkString("recordedplot"));
                    Rf_classgets(snapshot.get(), klass);

                    SEXP duplicated_snapshot = Rf_protect(Rf_duplicate(snapshot.get()));
                    Rf_defineVar(Rf_install(_snapshot_varname.c_str()), duplicated_snapshot, R_GlobalEnv);

                    Rf_unprotect(2);
                });
            }
Exemple #6
0
char *oc_register(SEXP what, char *dst, int len, const char *name) {
    SEXP x;
    if (len <= MAX_OC_TOKEN_LEN) return NULL;
    if (!oc_env) {
	SEXP env = eval(PROTECT(lang3(install("new.env"), ScalarLogical(TRUE), R_EmptyEnv)), R_GlobalEnv);
	UNPROTECT(1);
	if (TYPEOF(env) != ENVSXP) return NULL;
	oc_env = env;
	R_PreserveObject(oc_env);
    }
    x = PROTECT(CONS(what, R_NilValue));
    if (name) SET_TAG(x, install(name));
    oc_new(dst);
    Rf_defineVar(install(dst), x, oc_env);
    UNPROTECT(1);
    return dst;
}
int
SexpEnvironment_setvalue(const SEXP envir, const char* name, const SEXP value) {
  if (! RINTERF_ISREADY()) {
    printf("R is not ready.\n");
    return -1;
  }
  RStatus ^= RINTERF_IDLE;

  SEXP symbol;
  symbol = Rf_install(name);

  //FIXME: is the copy really needed / good ?
  SEXP value_copy;
  PROTECT(value_copy = Rf_duplicate(value));
  Rf_defineVar(symbol, value_copy, envir);
  //FIXME: protect/unprotect from garbage collection (for now protect only)
  UNPROTECT(1);
  RStatus ^= RINTERF_IDLE;
  return 0;
}
Exemple #8
0
SEXP init_Rcpp_cache(){   
    SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed  once in symbol table
    SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
    SEXP cache = PROTECT( Rf_allocVector( VECSXP, RCPP_CACHE_SIZE ) );
    
    // the Rcpp namespace
	SET_VECTOR_ELT( cache, 0, RCPP ) ;
	set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ; // error occured
	set_current_error( cache, R_NilValue ) ; // current error
	SET_VECTOR_ELT( cache, 3, R_NilValue ) ; // stack trace
	SET_VECTOR_ELT( cache, RCPP_HASH_CACHE_INDEX, Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE) ) ;
	SEXP stack = PROTECT(Rf_allocVector(VECSXP, RCPP_PROTECT_STACK_INITIAL_SIZE)) ;
	// we use true length to store "top"
	SET_TRUELENGTH(stack, -1 ) ;
	SET_VECTOR_ELT( cache, RCPP_PROTECTION_STACK_INDEX, stack ) ;
	Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
    
    UNPROTECT(3) ; 
    
    return cache ;
}
Exemple #9
0
str RAPIprelude(void *ret) {
	(void) ret;

	if (RAPIEnabled()) {
		MT_lock_set(&rapiLock);
		/* startup internal R environment  */
		if (!rapiInitialized) {
			char *initstatus;
			initstatus = RAPIinitialize();
			if (initstatus != 0) {
				MT_lock_unset(&rapiLock);
				throw(MAL, "rapi.eval",
					  "failed to initialize R environment (%s)", initstatus);
			}
			Rf_defineVar(Rf_install("MONETDB_LIBDIR"), ScalarString(RSTR(LIBDIR)), R_GlobalEnv);

		}
		MT_lock_unset(&rapiLock);
		printf("# MonetDB/R   module loaded\n");
	}
	return MAL_SUCCEED;
}
Exemple #10
0
int execute_tool2(const wchar_t* script_path, IArray* pParameters)
{
  if (pParameters == 0)
    return 0;
  //gp_connect_impl connect;
  //if (!connect.init())
  //  return 1;

  if (pParameters == 0)
    return 0;

  _bstr_t file_path(script_path);
  long nParams = 0;
  pParameters->get_Count(&nParams);
  //CComQIPtr<IGPScriptTool>(pGPTool)->get_FileName(file_path.GetAddress());


  bool ok = true;
  int errorOccurred = 0;

  if (file_path.length() && nParams)
  {
    std::vector< CAdapt<CComPtr<IGPParameter> > > return_params;
    //ipParameters->get_Count(&n);
    SEXP arc_env = Rf_findVar(Rf_install("arc"), R_GlobalEnv);

    {
      std::vector<SEXP> in_params;
      std::vector<std::string> in_params_names;
      std::vector<SEXP> out_params;
      std::vector<std::string> out_params_names;
      tools::protect pt;

      for (int i = 0; i < nParams; i++)
      {
        CComPtr<IUnknown> ipUnk;
        pParameters->get_Element(i, &ipUnk);
        CComQIPtr<IGPParameter> ipParam(ipUnk);
        esriGPParameterDirection eD;
        ipParam->get_Direction(&eD);
        std::pair<SEXP, std::string> p = param2r(ipParam);
        if (eD == esriGPParameterDirectionInput)
        {
          in_params.push_back(pt.add(p.first));
          in_params_names.push_back(p.second);
        }
        else
        {
          out_params.push_back(pt.add(p.first));
          out_params_names.push_back(p.second);
          return_params.push_back(ipParam);
        }
      }

      SEXP p1 = tools::newVal(in_params, pt);
      tools::nameIt(p1, in_params_names);
      SEXP p2 = tools::newVal(out_params, pt);
      tools::nameIt(p2, out_params_names);

      Rf_defineVar(Rf_install(".file"), tools::newVal(file_path, pt), arc_env);
      Rf_defineVar(Rf_install(".in"),  p1, arc_env);
      Rf_defineVar(Rf_install(".out"), p2, arc_env);
    }

    const static wchar_t eval_str[] = L"arc$.ret<-local({"
      L"en<-new.env(hash=TRUE);"
      L"eval(parse(file=arc$.file), envir=en);"
      L"tool_exec<-get('tool_exec',en);"
      L"tool_exec(in_param, out_param)"
      L"},envir=list('in_param'=arc$.in,'out_param'=arc$.out))";

    ok = current_connect->eval_one(eval_str) == 1;
    current_connect->print_out(NULL, -1);

    Rf_defineVar(Rf_install(".file"), R_NilValue, arc_env);
    Rf_defineVar(Rf_install(".in"), R_NilValue, arc_env);
    Rf_defineVar(Rf_install(".out"), R_NilValue, arc_env);
    R_gc();

    //TODO: handle ok
    if (ok)
    {
      /*CComPtr<IGPMessages> ipMsgs;
      if (connect.m_ipGeoProcessor)
        connect.m_ipGeoProcessor->GetReturnMessages(&ipMsgs);
      if (ipMsgs)
      {
        VARIANT_BOOL bErr = VARIANT_FALSE;
        CComQIPtr<IGPMessage>(ipMsgs)->IsError(&bErr);
        if (bErr != VARIANT_FALSE)
          ok = false;
      }*/
      if (!return_params.empty())
      {
        //connect.m_ipGeoProcessor->Is
        SEXP ret = Rf_findVar(Rf_install(".ret"), arc_env);
        tools::vectorGeneric ret_out(ret);
        //tools::vectorGeneric ret_out(ret.get());
        for (size_t i = 0, n = return_params.size(); i < n; i++)
        {
          _bstr_t name;
          return_params[i].m_T->get_Name(name.GetAddress());
          size_t idx = ret_out.idx(std::string(name));
          if (idx != (size_t)-1)
          {
            if (!r2param(ret_out.at(idx), return_params[i].m_T))
            {
              std::wstring msg(L"failed to set output parameter - ");
              msg += name;
              current_connect->print_out(msg.c_str(), 2);
            }
          }
        }
        //TODO list
      }
      Rf_defineVar(Rf_install(".ret"), R_NilValue, arc_env);
    }
  }
  return ok ? 0 : 1;
}
Exemple #11
0
str RAPIeval(Client cntxt, MalBlkPtr mb, MalStkPtr stk, InstrPtr pci, bit grouped) {
	sql_func * sqlfun = NULL;
	str exprStr = *getArgReference_str(stk, pci, pci->retc + 1);

	SEXP x, env, retval;
	SEXP varname = R_NilValue;
	SEXP varvalue = R_NilValue;
	ParseStatus status;
	int i = 0;
	char argbuf[64];
	char *argnames = NULL;
	size_t argnameslen;
	size_t pos;
	char* rcall = NULL;
	size_t rcalllen;
	int ret_cols = 0; /* int because pci->retc is int, too*/
	str *args;
	int evalErr;
	char *msg = MAL_SUCCEED;
	BAT *b;
	node * argnode;
	int seengrp = FALSE;

	rapiClient = cntxt;

	if (!RAPIEnabled()) {
		throw(MAL, "rapi.eval",
			  "Embedded R has not been enabled. Start server with --set %s=true",
			  rapi_enableflag);
	}
	if (!rapiInitialized) {
		throw(MAL, "rapi.eval",
			  "Embedded R initialization has failed");
	}

	if (!grouped) {
		sql_subfunc *sqlmorefun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc));
		if (sqlmorefun) sqlfun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc))->func;
	} else {
		sqlfun = *(sql_func**) getArgReference(stk, pci, pci->retc);
	}

	args = (str*) GDKzalloc(sizeof(str) * pci->argc);
	if (args == NULL) {
		throw(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
	}

	// get the lock even before initialization of the R interpreter, as this can take a second and must be done only once.
	MT_lock_set(&rapiLock);

	env = PROTECT(eval(lang1(install("new.env")), R_GlobalEnv));
	assert(env != NULL);

	// first argument after the return contains the pointer to the sql_func structure
	// NEW macro temporarily renamed to MNEW to allow including sql_catalog.h

	if (sqlfun != NULL && sqlfun->ops->cnt > 0) {
		int carg = pci->retc + 2;
		argnode = sqlfun->ops->h;
		while (argnode) {
			char* argname = ((sql_arg*) argnode->data)->name;
			args[carg] = GDKstrdup(argname);
			carg++;
			argnode = argnode->next;
		}
	}
	// the first unknown argument is the group, we don't really care for the rest.
	argnameslen = 2;
	for (i = pci->retc + 2; i < pci->argc; i++) {
		if (args[i] == NULL) {
			if (!seengrp && grouped) {
				args[i] = GDKstrdup("aggr_group");
				seengrp = TRUE;
			} else {
				snprintf(argbuf, sizeof(argbuf), "arg%i", i - pci->retc - 1);
				args[i] = GDKstrdup(argbuf);
			}
		}
		argnameslen += strlen(args[i]) + 2; /* extra for ", " */
	}

	// install the MAL variables into the R environment
	// we can basically map values to int ("INTEGER") or double ("REAL")
	for (i = pci->retc + 2; i < pci->argc; i++) {
		int bat_type = getBatType(getArgType(mb,pci,i));
		// check for BAT or scalar first, keep code left
		if (!isaBatType(getArgType(mb,pci,i))) {
			b = COLnew(0, getArgType(mb, pci, i), 0, TRANSIENT);
			if (b == NULL) {
				msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
				goto wrapup;
			}
			if ( getArgType(mb,pci,i) == TYPE_str) {
				if (BUNappend(b, *getArgReference_str(stk, pci, i), false) != GDK_SUCCEED) {
					BBPreclaim(b);
					b = NULL;
					msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
					goto wrapup;
				}
			} else {
				if (BUNappend(b, getArgReference(stk, pci, i), false) != GDK_SUCCEED) {
					BBPreclaim(b);
					b = NULL;
					msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
					goto wrapup;
				}
			}
		} else {
			b = BATdescriptor(*getArgReference_bat(stk, pci, i));
			if (b == NULL) {
				msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
				goto wrapup;
			}
		}

		// check the BAT count, if it is bigger than RAPI_MAX_TUPLES, fail
		if (BATcount(b) > RAPI_MAX_TUPLES) {
			msg = createException(MAL, "rapi.eval",
								  "Got "BUNFMT" rows, but can only handle "LLFMT". Sorry.",
								  BATcount(b), (lng) RAPI_MAX_TUPLES);
			BBPunfix(b->batCacheid);
			goto wrapup;
		}
		varname = PROTECT(Rf_install(args[i]));
		varvalue = bat_to_sexp(b, bat_type);
		if (varvalue == NULL) {
			msg = createException(MAL, "rapi.eval", "unknown argument type ");
			goto wrapup;
		}
		BBPunfix(b->batCacheid);

		// install vector into R environment
		Rf_defineVar(varname, varvalue, env);
		UNPROTECT(2);
	}

	/* we are going to evaluate the user function within an anonymous function call:
	 * ret <- (function(arg1){return(arg1*2)})(42)
	 * the user code is put inside the {}, this keeps our environment clean (TM) and gives
	 * a clear path for return values, namely using the builtin return() function
	 * this is also compatible with PL/R
	 */
	pos = 0;
	argnames = malloc(argnameslen);
	if (argnames == NULL) {
		msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
		goto wrapup;
	}
	argnames[0] = '\0';
	for (i = pci->retc + 2; i < pci->argc; i++) {
		pos += snprintf(argnames + pos, argnameslen - pos, "%s%s",
						args[i], i < pci->argc - 1 ? ", " : "");
	}
	rcalllen = 2 * pos + strlen(exprStr) + 100;
	rcall = malloc(rcalllen);
	if (rcall == NULL) {
		msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
		goto wrapup;
	}
	snprintf(rcall, rcalllen,
			 "ret <- as.data.frame((function(%s){%s})(%s), nm=NA, stringsAsFactors=F)\n",
			 argnames, exprStr, argnames);
	free(argnames);
	argnames = NULL;
#ifdef _RAPI_DEBUG_
	printf("# R call %s\n",rcall);
#endif

	x = R_ParseVector(mkString(rcall), 1, &status, R_NilValue);

	if (LENGTH(x) != 1 || status != PARSE_OK) {
		msg = createException(MAL, "rapi.eval",
							  "Error parsing R expression '%s'. ", exprStr);
		goto wrapup;
	}

	retval = R_tryEval(VECTOR_ELT(x, 0), env, &evalErr);
	if (evalErr != FALSE) {
		char* errormsg = strdup(R_curErrorBuf());
		size_t c;
		if (errormsg == NULL) {
			msg = createException(MAL, "rapi.eval", "Error running R expression.");
			goto wrapup;
		}
		// remove newlines from error message so it fits into a MAPI error (lol)
		for (c = 0; c < strlen(errormsg); c++) {
			if (errormsg[c] == '\r' || errormsg[c] == '\n') {
				errormsg[c] = ' ';
			}
		}
		msg = createException(MAL, "rapi.eval",
							  "Error running R expression: %s", errormsg);
		free(errormsg);
		goto wrapup;
	}

	// ret should be a data frame with exactly as many columns as we need from retc
	ret_cols = LENGTH(retval);
	if (ret_cols != pci->retc) {
		msg = createException(MAL, "rapi.eval",
							  "Expected result of %d columns, got %d", pci->retc, ret_cols);
		goto wrapup;
	}

	// collect the return values
	for (i = 0; i < pci->retc; i++) {
		SEXP ret_col = VECTOR_ELT(retval, i);
		int bat_type = getBatType(getArgType(mb,pci,i));
		if (bat_type == TYPE_any || bat_type == TYPE_void) {
			getArgType(mb,pci,i) = bat_type;
			msg = createException(MAL, "rapi.eval",
								  "Unknown return value, possibly projecting with no parameters.");
			goto wrapup;
		}

		// hand over the vector into a BAT
		b = sexp_to_bat(ret_col, bat_type);
		if (b == NULL) {
			msg = createException(MAL, "rapi.eval",
								  "Failed to convert column %i", i);
			goto wrapup;
		}
		// bat return
		if (isaBatType(getArgType(mb,pci,i))) {
			*getArgReference_bat(stk, pci, i) = b->batCacheid;
		} else { // single value return, only for non-grouped aggregations
			BATiter li = bat_iterator(b);
			if (VALinit(&stk->stk[pci->argv[i]], bat_type,
						BUNtail(li, 0)) == NULL) { // TODO BUNtail here
				msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
				goto wrapup;
			}
		}
		msg = MAL_SUCCEED;
	}
	/* unprotect environment, so it will be eaten by the GC. */
	UNPROTECT(1);
  wrapup:
	MT_lock_unset(&rapiLock);
	if (argnames)
		free(argnames);
	if (rcall)
		free(rcall);
	for (i = 0; i < pci->argc; i++)
		GDKfree(args[i]);
	GDKfree(args);

	return msg;
}