Ejemplo n.º 1
0
SEXP attribute_hidden do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP env, s = CAR(args);

    checkArity(op, args);
    check1arg(args, call, "x");

    env = CADR(args);

    if (TYPEOF(CAR(args)) == CLOSXP
	&& (isEnvironment(env) ||
	    isEnvironment(env = simple_as_environment(env)) ||
	    isNull(env))) {
	if (isNull(env))
	    error(_("use of NULL environment is defunct"));
	if(MAYBE_SHARED(s))
	    /* this copies but does not duplicate args or code */
	    s = duplicate(s);
	if (TYPEOF(BODY(s)) == BCODESXP)
	    /* switch to interpreted version if compiled */
	    SET_BODY(s, R_ClosureExpr(CAR(args)));
	SET_CLOENV(s, env);
    }
    else if (isNull(env) || isEnvironment(env) ||
	isEnvironment(env = simple_as_environment(env)))
	setAttrib(s, R_DotEnvSymbol, env);
    else
	error(_("replacement object is not an environment"));
    return s;
}
Ejemplo n.º 2
0
SEXP attribute_hidden do_parentenvgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP env, parent;
    checkArity(op, args);

    env = CAR(args);
    if (isNull(env)) {
	error(_("use of NULL environment is defunct"));
	env = R_BaseEnv;
    } else
    if( !isEnvironment(env) &&
	!isEnvironment((env = simple_as_environment(env))))
	error(_("argument is not an environment"));
    if( env == R_EmptyEnv )
	error(_("can not set parent of the empty environment"));
    if (R_EnvironmentIsLocked(env) && R_IsNamespaceEnv(env))
	error(_("can not set the parent environment of a namespace"));
    if (R_EnvironmentIsLocked(env) && R_IsImportsEnv(env))
	error(_("can not set the parent environment of package imports"));
    parent = CADR(args);
    if (isNull(parent)) {
	error(_("use of NULL environment is defunct"));
	parent = R_BaseEnv;
    } else
    if( !isEnvironment(parent) &&
	!isEnvironment((parent = simple_as_environment(parent))))
	error(_("'parent' is not an environment"));

    SET_ENCLOS(env, parent);

    return( CAR(args) );
}
Ejemplo n.º 3
0
SEXP attribute_hidden do_delayed(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP name = R_NilValue /* -Wall */, expr, eenv, aenv;
    checkArity(op, args);

    if (!isString(CAR(args)) || length(CAR(args)) == 0)
	error(_("invalid first argument"));
    else
	name = installTrChar(STRING_ELT(CAR(args), 0));
    args = CDR(args);
    expr = CAR(args);

    args = CDR(args);
    eenv = CAR(args);
    if (isNull(eenv)) {
	error(_("use of NULL environment is defunct"));
	eenv = R_BaseEnv;
    } else
    if (!isEnvironment(eenv))
	errorcall(call, _("invalid '%s' argument"), "eval.env");

    args = CDR(args);
    aenv = CAR(args);
    if (isNull(aenv)) {
	error(_("use of NULL environment is defunct"));
	aenv = R_BaseEnv;
    } else
    if (!isEnvironment(aenv))
	errorcall(call, _("invalid '%s' argument"), "assign.env");

    defineVar(name, mkPROMISE(expr, eenv), aenv);
    return R_NilValue;
}
Ejemplo n.º 4
0
/** do_newenv() :  .Internal(new.env(hash, parent, size))
 *
 * @return a newly created environment()
 */
SEXP attribute_hidden do_newenv(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP enclos, size, ans;
    int hash;

    checkArity(op, args);

    hash = asInteger(CAR(args));
    args = CDR(args);
    enclos = CAR(args);
    if (isNull(enclos)) {
	error(_("use of NULL environment is defunct"));
	enclos = R_BaseEnv;
    } else
    if( !isEnvironment(enclos)   &&
	!isEnvironment((enclos = simple_as_environment(enclos))))
	error(_("'enclos' must be an environment"));

    if( hash ) {
	args = CDR(args);
	PROTECT(size = coerceVector(CAR(args), INTSXP));
	if (INTEGER(size)[0] == NA_INTEGER)
	    INTEGER(size)[0] = 0; /* so it will use the internal default */
	ans = R_NewHashedEnv(enclos, size);
	UNPROTECT(1);
    } else
	ans = NewEnvironment(R_NilValue, R_NilValue, enclos);
    return ans;
}
Ejemplo n.º 5
0
/* makeLazy(names, values, expr, eenv, aenv) */
SEXP attribute_hidden do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP names, values, val, expr, eenv, aenv, expr0;
    R_xlen_t i;

    checkArity(op, args);
    names = CAR(args); args = CDR(args);
    if (!isString(names))
	error(_("invalid first argument"));
    values = CAR(args); args = CDR(args);
    expr = CAR(args); args = CDR(args);
    eenv = CAR(args); args = CDR(args);
    if (!isEnvironment(eenv)) error(_("invalid '%s' argument"), "eval.env");
    aenv = CAR(args);
    if (!isEnvironment(aenv)) error(_("invalid '%s' argument"), "assign.env");

    for(i = 0; i < XLENGTH(names); i++) {
	SEXP name = installChar(STRING_ELT(names, i));
	PROTECT(val = eval(VECTOR_ELT(values, i), eenv));
	PROTECT(expr0 = duplicate(expr));
	SETCAR(CDR(expr0), val);
	defineVar(name, mkPROMISE(expr0, eenv), aenv);
	UNPROTECT(2);
    }
    return R_NilValue;
}
Ejemplo n.º 6
0
SEXP attribute_hidden do_parentenv(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    SEXP arg = CAR(args);

    if( !isEnvironment(arg)  &&
	!isEnvironment((arg = simple_as_environment(arg))))
	error( _("argument is not an environment"));
    if( arg == R_EmptyEnv )
	error(_("the empty environment has no parent"));
    return( ENCLOS(arg) );
}
Ejemplo n.º 7
0
Archivo: r8.c Proyecto: renkun-ken/R6
SEXP get_function_from_env_attrib(SEXP x, SEXP attribSym, SEXP nameSym) {
  SEXP methods_env = Rf_getAttrib(x, attribSym);
  if (isEnvironment(methods_env)) {
    return Rf_findVarInFrame(methods_env, nameSym);
  }
  return R_NilValue;
}
Ejemplo n.º 8
0
SEXP CHM_set_common_env(SEXP rho) {
    if (!isEnvironment(rho))
	error(_("Argument rho must be an environment"));
    chm_common_env = rho;
    dboundSym = install("dbound");
    grow0Sym = install("grow0");
    grow1Sym = install("grow1");
    grow2Sym = install("grow2");
    maxrankSym = install("maxrank");
    supernodal_switchSym = install("supernodal_switch");
    supernodalSym = install("supernodal");
    final_asisSym = install("final_asis");
    final_superSym = install("final_super");
    final_llSym = install("final_ll");
    final_packSym = install("final_pack");
    final_monotonicSym = install("final_monotonic");
    final_resymbolSym = install("final_resymbol");
    prefer_zomplexSym = install("final_zomplex");
    prefer_upperSym = install("final_upper");
    quick_return_if_not_posdefSym = install("quick_return_if_not_posdef");
    nmethodsSym = install("nmethods");
    m0_ordSym = install("m0.ord");
    postorderSym = install("postorder");
    CHM_store_common();
    return R_NilValue;
}
Ejemplo n.º 9
0
SEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho,
		 SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v)
{
    int i, n = LENGTH(d);
    SEXP xpt;
    double *b = (double *) NULL, *g = (double *) NULL,
	*h = (double *) NULL, fx = R_PosInf;
    if (isNull(rho)) {
	error(_("use of NULL environment is defunct"));
	rho = R_BaseEnv;
    } else
    if (!isEnvironment(rho))
	error(_("'rho' must be an environment"));
    if (!isReal(d) || n < 1)
	error(_("'d' must be a nonempty numeric vector"));
    if (hs != R_NilValue && gr == R_NilValue)
	error(_("When Hessian defined must also have gradient defined"));
    if (R_NilValue == (xpt = findVarInFrame(rho, install(".par"))) ||
	!isReal(xpt) || LENGTH(xpt) != n)
	error(_("environment 'rho' must contain a numeric vector '.par' of length %d"),
	      n);
    /* We are going to alter .par, so must duplicate it */
    defineVar(install(".par"), duplicate(xpt), rho);
    PROTECT(xpt = findVarInFrame(rho, install(".par")));

    if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
	if (isReal(lowerb) && isReal(upperb)) {
	    double *rl=REAL(lowerb), *ru=REAL(upperb);
	    b = Calloc(2*n, double);
	    for (i = 0; i < n; i++) {
		b[2*i] = rl[i];
		b[2*i + 1] = ru[i];
	    }
	} else error(_("'lower' and 'upper' must be numeric vectors"));
Ejemplo n.º 10
0
SEXP bcplm_metrop_rw(SEXP n, SEXP m, SEXP sd, SEXP lb, SEXP rb, 
		     SEXP fun, SEXP rho){
  mh_str *da;
  SEXP ans, acc;  
  double sm;                /* the mean used in each iteration */
  int ns = INTEGER(n)[0];
  if (!isFunction(fun)) error(("'fun' is not a function"));
  if (!isEnvironment(rho)) error(("'rho'is not an environment"));

  /* construct the mh_str object */
  da = (mh_str *) R_alloc(1, sizeof(mh_str));
  PROTECT(da->R_fcall = lang2(fun, R_NilValue));
  da->R_env = rho;

  /* run the random walk metropolis algorithm */
  PROTECT(ans = allocVector(REALSXP, ns));
  PROTECT(acc = allocVector(INTSXP, 1));
  INTEGER(acc)[0] = 0;
  GetRNGstate();
  for (int i = 0; i < ns; i++){
    sm = (i) ? REAL(ans)[i - 1] : REAL(m)[0];
    INTEGER(acc)[0] += metrop_tnorm_rw(sm, REAL(sd)[0], REAL(lb)[0], REAL(rb)[0], 
		    REAL(ans) + i, R_fun, da);
  }
  setAttrib(ans, install("accept"), acc);
  UNPROTECT(3);
  PutRNGstate();
  return ans;
}
Ejemplo n.º 11
0
SEXP rpy_remove(SEXP symbol, SEXP env, SEXP rho)
{
  SEXP c_R, call_R, res, fun_R;

  PROTECT(fun_R = rpy_findFun(install("rm"), rho));

  if(!isEnvironment(rho)) error("'rho' should be an environment");
  /* incantation to summon R */
  PROTECT(c_R = call_R = allocList(2+1));
  SET_TYPEOF(c_R, LANGSXP);
  SETCAR(c_R, fun_R);
  c_R = CDR(c_R);

  /* first argument is the name of the variable to be removed */
  SETCAR(c_R, symbol);
  //SET_TAG(c_R, install("list"));
  c_R = CDR(c_R);

  /* second argument is the environment in which the variable 
     should be removed  */
  SETCAR(c_R, env);
  SET_TAG(c_R, install("envir"));
  c_R = CDR(c_R);

  int error = 0;
  PROTECT(res = R_tryEval(call_R, rho, &error));

  UNPROTECT(3);
  return res;
}
Ejemplo n.º 12
0
SEXP librinterface_remove(SEXP symbol, SEXP env, SEXP rho)
{
  SEXP c_R, call_R, res;

  static SEXP fun_R = NULL;
  /* Only fetch rm() the first time */
  if (fun_R == NULL) {
    PROTECT(fun_R = librinterface_FindFun(install("rm"), rho));
    R_PreserveObject(fun_R);
    UNPROTECT(1);
  }
  if(!isEnvironment(rho)) error("'rho' should be an environment");
  /* incantation to summon R */
  PROTECT(c_R = call_R = allocList(2+1));
  SET_TYPEOF(c_R, LANGSXP);
  SETCAR(c_R, fun_R);
  c_R = CDR(c_R);

  /* first argument is the name of the variable to be removed */
  SETCAR(c_R, symbol);
  //SET_TAG(c_R, install("list"));
  c_R = CDR(c_R);

  /* second argument is the environment in which the variable 
     should be removed  */
  SETCAR(c_R, env);
  SET_TAG(c_R, install("envir"));
  c_R = CDR(c_R);

  int error = 0;
  PROTECT(res = R_tryEval(call_R, rho, &error));

  UNPROTECT(3);
  return res;
}
Ejemplo n.º 13
0
Archivo: r8.c Proyecto: renkun-ken/R6
SEXP subset_R8(SEXP x, SEXP name) {
  // Look in x (an environment) for the object
  SEXP nameSym = Rf_install(CHAR(STRING_ELT(name, 0)));
  SEXP foundVar = Rf_findVarInFrame(x, nameSym);
  if (foundVar != R_UnboundValue) {
    return foundVar;
  }

  // if not found in x, look in methods
  SEXP fun = get_function_from_env_attrib(x, Rf_install("methods"), nameSym);

  // If not found in methods, search in methods2. This is present only for
  // storing private methods in a superclass.
  if (!isFunction(fun)) {
    fun = get_function_from_env_attrib(x, Rf_install("methods2"), nameSym);
  }
  if (!isFunction(fun)) {
    return R_NilValue;
  }

  // Make a copy of the function, with a new environment
  SEXP fun2 = PROTECT(duplicate(fun));
  SEXP eval_env = Rf_getAttrib(x, Rf_install("eval_env"));
  if (!isEnvironment(eval_env)) {
    UNPROTECT(1);
    return R_NilValue;
  }
  SET_CLOENV(fun2, eval_env);
  UNPROTECT(1);
  return fun2;
}
Ejemplo n.º 14
0
/* -------- getvar from environment ------------------------------------------*/
SEXP getvar(SEXP name, SEXP Rho) {
  SEXP ans;
  if(!isString(name) || length(name) != 1)
    error("name is not a single string");
  if(!isEnvironment(Rho))
    error("Rho should be an environment");
  ans = findVar(install(CHAR(STRING_ELT(name, 0))), Rho);
  return(ans);
}
Ejemplo n.º 15
0
//get from the R doc! (see the R doc for further explanation)
SEXP C_getVarInEnvir(char* name, SEXP rho) {
  SEXP ans;

  //if(!isString(name) || length(name) != 1) error("name is not a single string");
  if(!isEnvironment(rho)) error("rho should be an environment");
  ans = findVar(install(name), rho);
  //Rprintf("first value is %f\n", REAL(ans)[0]);
  return(ans);
}
Ejemplo n.º 16
0
SEXP rzmq_unserialize(SEXP data, SEXP rho) {
  static SEXP R_unserialize_fun  = findVar(install("unserialize"), R_GlobalEnv);
  SEXP R_fcall, ans;

  if(!isEnvironment(rho)) error("'rho' should be an environment");
  PROTECT(R_fcall = lang2(R_unserialize_fun, data));
  PROTECT(ans = eval(R_fcall, rho));
  UNPROTECT(2);
  return ans;
}
Ejemplo n.º 17
0
SEXP getvar(SEXP name, SEXP rho)
{
    SEXP ans;

    if(!isString(name) || length(name) != 1)
	error("name is not a single string");
    if(!isEnvironment(rho))
	error("rho should be an environment");
    ans = findVar(install(CHAR(STRING_ELT(name, 0))), rho);
    printf("first value is %f\n", REAL(ans)[0]);
    return(R_NilValue);
}
Ejemplo n.º 18
0
SEXP rpy_devoff(SEXP devnum, SEXP rho)
{
  SEXP c_R, call_R, res, fun_R;

#ifdef RPY_DEBUG_GRDEV
    printf("rpy_devoff(): checking 'rho'.\n");
#endif
  if(!isEnvironment(rho)) {
#ifdef RPY_DEBUG_GRDEV
    printf("rpy_devoff(): invalid 'rho'.\n");
#endif
    error("'rho' should be an environment\n");
  }

#ifdef RPY_DEBUG_GRDEV
  printf("rpy_devoff(): Looking for dev.off()...\n");
#endif
  PROTECT(fun_R = rpy2_findfun(install("dev.off"), rho));
  if (fun_R == R_UnboundValue)
    printf("dev.off() could not be found.\n");
#ifdef RPY_DEBUG_GRDEV
  printf("rpy_devoff(): found.\n");
#endif


  /* incantation to summon R */
  PROTECT(c_R = call_R = allocList(2));
  SET_TYPEOF(c_R, LANGSXP);
  SETCAR(c_R, fun_R);
  c_R = CDR(c_R);

  /* first argument is the device number to be closed */
  SETCAR(c_R, devnum);
  SET_TAG(c_R, install("which"));
  c_R = CDR(c_R);
  int error = 0;

#ifdef RPY_DEBUG_GRDEV
  printf("rpy_devoff(): R_tryEval()\n");
#endif

  PROTECT(res = R_tryEval(call_R, rho, &error));

#ifdef RPY_DEBUG_GRDEV
  printf("rpy_devoff(): unprotecting.\n");
#endif

  UNPROTECT(3);
  return res;
}
Ejemplo n.º 19
0
static void getParseFilename(char* buffer, size_t buflen)
{
    buffer[0] = '\0';
    if (R_ParseErrorFile) {
    	if (isEnvironment(R_ParseErrorFile)) {
	    SEXP filename;
	    PROTECT(filename = findVar(install("filename"), R_ParseErrorFile));
	    if (isString(filename) && length(filename))
		strncpy(buffer, CHAR(STRING_ELT(filename, 0)), buflen - 1);
	    UNPROTECT(1);
        } else if (isString(R_ParseErrorFile) && length(R_ParseErrorFile)) 
            strncpy(buffer, CHAR(STRING_ELT(R_ParseErrorFile, 0)), buflen - 1);
    }
}
Ejemplo n.º 20
0
R_init_splusTimeSeries(DllInfo *dll)
{
  R_registerRoutines(dll, cMethods, NULL, NULL, NULL);
  R_useDynamicSymbols(dll, FALSE);

/* These are callable from other packages' C code: */

#define RREGDEF(name)  R_RegisterCCallable("splusTimeSeries", #name, (DL_FUNC) name)

    splusTimeSeries_NS = R_FindNamespace(mkString("splusTimeSeries"));
    if(splusTimeSeries_NS == R_UnboundValue)
      error("missing 'splusTimeSeries' namespace: should never happen");

#ifdef DEBUG_splusTimeSeries
    if(isEnvironment(splusTimeSeries_NS))
	Rprintf("splusTimeSeries_NS: %s\n",
		CHAR(asChar(eval(lang2(install("format"),splusTimeSeries_NS),
				 R_GlobalEnv))));
    else
#else
    if(!isEnvironment(splusTimeSeries_NS))
#endif
	error("splusTimeSeries namespace not determined correctly");
}
Ejemplo n.º 21
0
SEXP lapply(SEXP list, SEXP expr, SEXP rho)
{
    int i, n = length(list);
    SEXP ans;

    if(!isNewList(list)) error("`list' must be a list");
    if(!isEnvironment(rho)) error("`rho' should be an environment");
    PROTECT(ans = allocVector(VECSXP, n));
    for(i = 0; i < n; i++) {
	defineVar(install("x"), VECTOR_ELT(list, i), rho);
	SET_VECTOR_ELT(ans, i, eval(expr, rho));
    }
    setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
    UNPROTECT(1);
    return(ans);
}
Ejemplo n.º 22
0
static Rboolean R_IsImportsEnv(SEXP env)
{
    if (isNull(env) || !isEnvironment(env))
        return FALSE;
    if (ENCLOS(env) != R_BaseNamespace)
        return FALSE;
    SEXP name = getAttrib(env, R_NameSymbol);
    if (!isString(name) || length(name) != 1)
        return FALSE;

    const char *imports_prefix = "imports:";
    const char *name_string = CHAR(STRING_ELT(name, 0));
    if (!strncmp(name_string, imports_prefix, strlen(imports_prefix)))
        return TRUE;
    else
        return FALSE;
}
Ejemplo n.º 23
0
SEXP lapply2(SEXP list, SEXP fn, SEXP rho)
{
    int i, n = length(list);
    SEXP R_fcall, ans;

    if(!isNewList(list)) error("`list' must be a list");
    if(!isFunction(fn)) error("`fn' must be a function");
    if(!isEnvironment(rho)) error("`rho' should be an environment");
    PROTECT(R_fcall = lang2(fn, R_NilValue));
    PROTECT(ans = allocVector(VECSXP, n));
    for(i = 0; i < n; i++) {
	SETCADR(R_fcall, VECTOR_ELT(list, i));
	SET_VECTOR_ELT(ans, i, eval(R_fcall, rho));
    }
    setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol));
    UNPROTECT(2);
    return(ans);
}
Ejemplo n.º 24
0
SEXP rpy_unserialize(SEXP connection, SEXP rho)
{
  SEXP c_R, call_R, res, fun_R;
  PROTECT(fun_R = rpy_findFun(install("unserialize"), rho));
  if(!isEnvironment(rho)) error("'rho' should be an environment");
  /* obscure incatation to summon R */
  PROTECT(c_R = call_R = allocList(2));
  SET_TYPEOF(c_R, LANGSXP);
  SETCAR(c_R, fun_R);
  c_R = CDR(c_R);

  /* first argument is a RAWSXP representation of the object to unserialize */
  SETCAR(c_R, connection);
  c_R = CDR(c_R);
  
  PROTECT(res = eval(call_R, rho));
  UNPROTECT(2);
  return res;
}
int Inspect(char* str, int len, Object* object){
  if( isNil(object) )
    return InspectNil(str, len, object);

  if( isConsCell(object) )
    return InspectConsCell(str, len, object);

  if( isSymbol(object) )
    return InspectSymbol(str, len, object);

  if( isInteger(object) )
    return InspectInteger(str, len, object);

  if( isLambda(object) )
    return InspectLambda(str, len, object);

  if( isPrimitiveFunc(object) )
    return InspectPrimitiveFunc(str, len, object);

  if( isContinuation(object) )
    return InspectContinuation(str, len, object);

  if( isEnvironment(object) )
    return InspectEnvironment(str, len, object);

  if( isBool(object) )
    return InspectBool(str, len, object);

  if( isSpecialForm(object) )
    return InspectSpecialForm(str, len, object);

  if( isCondition(object) )
    return InspectCondition(str, len, object);

  if( isCharacter(object) )
    return InspectCharacter(str, len, object);

  else
    return InspectUnknown(str, len, object);
}
Ejemplo n.º 26
0
void redux_redis_subscribe_loop(redisContext* context, int pattern,
                                SEXP callback, SEXP envir) {
  if (!isFunction(callback)) {
    error("'callback' must be a function");
  }
  if (!isEnvironment(envir)) {
    error("'envir' must be an environment");
  }
  SEXP call = PROTECT(lang2(callback, R_NilValue));
  redisReply *reply = NULL;
  int keep_going = 1;
  // Nasty:
  SEXP nms = PROTECT(allocVector(STRSXP, pattern ? 4 : 3));
  int i = 0;
  SET_STRING_ELT(nms, i++, mkChar("type"));
  if (pattern) {
    SET_STRING_ELT(nms, i++, mkChar("pattern"));
  }
  SET_STRING_ELT(nms, i++, mkChar("channel"));
  SET_STRING_ELT(nms, i++, mkChar("value"));

  // And we're off.  Adding a timeout here seems sensible to me as
  // that would allow for _some_ sort of interrupt checking, but as it
  // is, this seems extremely difficult to do without risking killing
  // the client.
  while (keep_going) {
    R_CheckUserInterrupt();
    redisGetReply(context, (void*)&reply);
    SEXP x = PROTECT(redis_reply_to_sexp(reply, REPLY_ERROR_OK));
    setAttrib(x, R_NamesSymbol, nms);
    SETCADR(call, x);
    freeReplyObject(reply);
    SEXP val = PROTECT(eval(call, envir));
    if (TYPEOF(val) == LGLSXP && LENGTH(val) == 1 && INTEGER(val)[0] == 1) {
      keep_going = 0;
    }
    UNPROTECT(2); // x, val
  }
  UNPROTECT(2); // nms, call
}
int Describe(char* str, int len, Object* object){
  if( isNil(object) )
    return DescribeNil(str, len, object);

  if( isConsCell(object) )
    return DescribeConsCell(str, len, object);

  if( isSymbol(object) )
    return DescribeSymbol(str, len, object);

  if( isInteger(object) )
    return DescribeInteger(str, len, object);

  if( isLambda(object) )
    return DescribeLambda(str, len, object);

  if( isPrimitiveFunc(object) )
    return DescribePrimitiveFunc(str, len, object);

  if( isContinuation(object) )
    return DescribeContinuation(str, len, object);

  if( isEnvironment(object) )
    return DescribeEnvironment(str, len, object);

  if( isBool(object) )
    return DescribeBool(str, len, object);

  if( isSpecialForm(object) )
    return DescribeSpecialForm(str, len, object);

  if( isCondition(object) )
    return DescribeCondition(str, len, object);

  if( isCharacter(object) )
    return DescribeCharacter(str, len, object);

  else
    return DescribeUnknown(str, len, object);
}
Ejemplo n.º 28
0
SEXP loop_apply(SEXP n, SEXP f, SEXP rho) {
  if(!isFunction(f)) error("'f' must be a function");
  if(!isEnvironment(rho)) error("'rho' should be an environment");

  int n1 = INTEGER(n)[0];

  SEXP results, R_fcall;
  PROTECT(results = allocVector(VECSXP, n1));
  PROTECT(R_fcall = lang2(f, R_NilValue));

  SEXP ii;
  for(int i = 0; i < n1; i++) {
    PROTECT(ii = ScalarInteger(i + 1));
    SETCADR(R_fcall, ii);
    SET_VECTOR_ELT(results, i, eval(R_fcall, rho));

    UNPROTECT(1);
  }

  UNPROTECT(2);
  return results;
}
Ejemplo n.º 29
0
SEXP rpy_serialize(SEXP object, SEXP rho)
{
  SEXP c_R, call_R, res, fun_R;

  PROTECT(fun_R = rpy_findFun(install("serialize"), rho));
  if(!isEnvironment(rho)) error("'rho' should be an environment");
  /* obscure incatation to summon R */
  PROTECT(c_R = call_R = allocList(3));
  SET_TYPEOF(c_R, LANGSXP);
  SETCAR(c_R, fun_R);
  c_R = CDR(c_R);

  /* first argument is the SEXP object to serialize */
  SETCAR(c_R, object);
  c_R = CDR(c_R);

  /* second argument is NULL */
  SETCAR(c_R, R_NilValue);
  c_R = CDR(c_R);
  PROTECT(res = eval(call_R, rho));
  UNPROTECT(3);
  return res;
}
Ejemplo n.º 30
0
SEXP numeric_deriv(SEXP args)
{
    SEXP theta, expr, rho, ans, ans1, gradient, par, dimnames;
    double tt, xx, delta, eps = sqrt(DOUBLE_EPS);
    int start, i, j;

    expr = CADR(args);
    if(!isString(theta = CADDR(args)))
	error("theta should be of type character");
    if(!isEnvironment(rho = CADDDR(args)))
	error("rho should be an environment");

    PROTECT(ans = coerceVector(eval(expr, rho), REALSXP));
    PROTECT(gradient = allocMatrix(REALSXP, LENGTH(ans), LENGTH(theta)));

    for(i = 0, start = 0; i < LENGTH(theta); i++, start += LENGTH(ans)) {
	PROTECT(par = findVar(install(CHAR(STRING_ELT(theta, i))), rho));
	tt = REAL(par)[0];
	xx = fabs(tt);
	delta = (xx < 1) ? eps : xx*eps;
	REAL(par)[0] += delta;
	PROTECT(ans1 = coerceVector(eval(expr, rho), REALSXP));
	for(j = 0; j < LENGTH(ans); j++)
	    REAL(gradient)[j + start] =
		(REAL(ans1)[j] - REAL(ans)[j])/delta;
	REAL(par)[0] = tt;
	UNPROTECT(2); /* par, ans1 */
    }

    PROTECT(dimnames = allocVector(VECSXP, 2));
    SET_VECTOR_ELT(dimnames, 1,  theta);
    dimnamesgets(gradient, dimnames);
    setAttrib(ans, install("gradient"), gradient);
    UNPROTECT(3); /* ans  gradient  dimnames */
    return ans;
}