示例#1
0
文件: chm_common.c 项目: cran/Matrix
SEXP CHMsuper_validate(SEXP obj) /* placeholder */
{
    return ScalarLogical(1);
}
示例#2
0
文件: lm.c 项目: kalibera/rexp
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol, SEXP chk)
{
    SEXP ans;
    SEXP qr, coefficients, residuals, effects, pivot, qraux;
    int n, ny = 0, p, rank, nprotect = 4, pivoted = 0;
    double rtol = asReal(tol), *work;
    Rboolean check = asLogical(chk);

    ans = getDimAttrib(x);
    if(check && length(ans) != 2) error(_("'x' is not a matrix"));
    int *dims = INTEGER(ans);
    n = dims[0]; p = dims[1];
    if(n) ny = (int)(XLENGTH(y)/n); /* y :  n x ny, or an n - vector */
    if(check && n * ny != XLENGTH(y))
	error(_("dimensions of 'x' (%d,%d) and 'y' (%d) do not match"),
	      n,p, XLENGTH(y));

    /* These lose attributes, so do after we have extracted dims */
    if (TYPEOF(x) != REALSXP) {
	PROTECT(x = coerceVector(x, REALSXP));
	nprotect++;
    }
    if (TYPEOF(y) != REALSXP) {
	PROTECT(y = coerceVector(y, REALSXP));
	nprotect++;
    }

    double *rptr = REAL(x);
    for (R_xlen_t i = 0 ; i < XLENGTH(x) ; i++)
	if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "x");

    rptr = REAL(y);
    for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++)
	if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "y");

    const char *ansNms[] = {"qr", "coefficients", "residuals", "effects",
			    "rank", "pivot", "qraux", "tol", "pivoted", ""};
    PROTECT(ans = mkNamed(VECSXP, ansNms));
    SET_VECTOR_ELT(ans, 0, qr = duplicate(x));
    coefficients = (ny > 1) ? allocMatrix(REALSXP, p, ny) : allocVector(REALSXP, p);
    PROTECT(coefficients);
    SET_VECTOR_ELT(ans, 1, coefficients);
    SET_VECTOR_ELT(ans, 2, residuals = duplicate(y));
    SET_VECTOR_ELT(ans, 3, effects = duplicate(y));
    PROTECT(pivot = allocVector(INTSXP, p));
    int *ip = INTEGER(pivot);
    for(int i = 0; i < p; i++) ip[i] = i+1;
    SET_VECTOR_ELT(ans, 5, pivot);
    PROTECT(qraux = allocVector(REALSXP, p));
    SET_VECTOR_ELT(ans, 6, qraux);
    SET_VECTOR_ELT(ans, 7, tol);

    work = (double *) R_alloc(2 * p, sizeof(double));
    F77_CALL(dqrls)(REAL(qr), &n, &p, REAL(y), &ny, &rtol,
		    REAL(coefficients), REAL(residuals), REAL(effects),
		    &rank, INTEGER(pivot), REAL(qraux), work);
    SET_VECTOR_ELT(ans, 4, ScalarInteger(rank));
    for(int i = 0; i < p; i++)
	if(ip[i] != i+1) { pivoted = 1; break; }
    SET_VECTOR_ELT(ans, 8, ScalarLogical(pivoted));
    UNPROTECT(nprotect);

    return ans;
}
示例#3
0
SEXP pCholesky_validate(SEXP obj)
{
    return ScalarLogical(1);
}
示例#4
0
SEXP Rscc_check_clustering(const SEXP R_clustering,
                           const SEXP R_size_constraint,
                           const SEXP R_type_labels,
                           const SEXP R_type_constraints,
                           const SEXP R_primary_data_points)
{
	if (!isInteger(R_clustering)) {
		iRscc_error("`R_clustering` is not a valid clustering object.");
	}
	if (!isInteger(getAttrib(R_clustering, install("cluster_count")))) {
		iRscc_error("`R_clustering` is not a valid clustering object.");
	}
	if (!isInteger(R_size_constraint)) {
		iRscc_error("`R_size_constraint` must be integer.");
	}
	if (isNull(R_type_labels)) {
		if (!isNull(R_type_constraints)) {
			iRscc_error("`R_type_constraints` must be NULL when no types are supplied.");
		}
	} else {
		if (!isInteger(R_type_labels)) {
			iRscc_error("`R_type_labels` must be factor, integer or NULL.");
		}
		if (!isInteger(R_type_constraints)) {
			iRscc_error("`R_type_constraints` must be integer.");
		}
	}
	if (!isNull(R_primary_data_points) && !isInteger(R_primary_data_points)) {
		iRscc_error("`R_primary_data_points` must be NULL or integer.");
	}

	const uint64_t num_data_points = (uint64_t) xlength(R_clustering);
	const uint64_t num_clusters = (uint64_t) asInteger(getAttrib(R_clustering, install("cluster_count")));
	if (num_clusters == 0) {
		iRscc_error("`R_clustering` is empty.");
	}

	scc_ClusterOptions options = scc_get_default_options();

	options.size_constraint = (uint32_t) asInteger(R_size_constraint);

	if (isInteger(R_type_labels) && isInteger(R_type_constraints)) {
		const uint32_t num_types = (uint32_t) xlength(R_type_constraints);
		const size_t len_type_labels = (size_t) xlength(R_type_labels);
		if (len_type_labels != num_data_points) {
			iRscc_error("`R_type_labels` does not match `R_clustering`.");
		}
		if (num_types >= 2) {
			uint32_t* const type_constraints = (uint32_t*) R_alloc(num_types, sizeof(uint32_t)); // Automatically freed by R on return
			if (type_constraints == NULL) iRscc_error("Could not allocate memory.");
			const int* const tmp_type_constraints = INTEGER(R_type_constraints);
			for (size_t i = 0; i < num_types; ++i) {
				if (tmp_type_constraints[i] < 0) {
				  iRscc_error("Negative type size constraint.");
				}
				type_constraints[i] = (uint32_t) tmp_type_constraints[i];
			}

			options.num_types = num_types;
			options.type_constraints = type_constraints;
			options.len_type_labels = len_type_labels;
			options.type_labels = INTEGER(R_type_labels);
		}
	}

	if (isInteger(R_primary_data_points)) {
		options.len_primary_data_points = (size_t) xlength(R_primary_data_points);
		options.primary_data_points = INTEGER(R_primary_data_points);
	}

	scc_ErrorCode ec;
	scc_Clustering* clustering;
	if ((ec = scc_init_existing_clustering(num_data_points,
	                                       num_clusters,
	                                       INTEGER(R_clustering),
	                                       false,
	                                       &clustering)) != SCC_ER_OK) {
		iRscc_scc_error();
	}

	bool is_OK = false;
	if ((ec = scc_check_clustering(clustering,
	                               &options,
	                               &is_OK)) != SCC_ER_OK) {
		scc_free_clustering(&clustering);
		iRscc_scc_error();
	}

	scc_free_clustering(&clustering);

	return ScalarLogical((int) is_OK);
}
示例#5
0
文件: subset.c 项目: jagdeesh109/RRO
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, ax, px, x, subs;
    int drop, i, nsubs, type;

    /* By default we drop extents of length 1 */

    /* Handle cases of extracting a single element from a simple vector
       or matrix directly to improve speed for these simple cases. */
    SEXP cdrArgs = CDR(args);
    SEXP cddrArgs = CDR(cdrArgs);
    if (cdrArgs != R_NilValue && cddrArgs == R_NilValue &&
	TAG(cdrArgs) == R_NilValue) {
	/* one index, not named */
	SEXP x = CAR(args);
	if (ATTRIB(x) == R_NilValue) {
	    SEXP s = CAR(cdrArgs);
	    R_xlen_t i = scalarIndex(s);
	    switch (TYPEOF(x)) {
	    case REALSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarReal( REAL(x)[i-1] );
		break;
	    case INTSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarInteger( INTEGER(x)[i-1] );
		break;
	    case LGLSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarLogical( LOGICAL(x)[i-1] );
		break;
//	    do the more rare cases as well, since we've already prepared everything:
	    case CPLXSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarComplex( COMPLEX(x)[i-1] );
		break;
	    case RAWSXP:
		if (i >= 1 && i <= XLENGTH(x))
		    return ScalarRaw( RAW(x)[i-1] );
		break;
	    default: break;
	    }
	}
    }
    else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue &&
	     TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) {
	/* two indices, not named */
	SEXP x = CAR(args);
	SEXP attr = ATTRIB(x);
	if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) {
	    /* only attribute of x is 'dim' */
	    SEXP dim = CAR(attr);
	    if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) {
		/* x is a matrix */
		SEXP si = CAR(cdrArgs);
		SEXP sj = CAR(cddrArgs);
		R_xlen_t i = scalarIndex(si);
		R_xlen_t j = scalarIndex(sj);
		int nrow = INTEGER(dim)[0];
		int ncol = INTEGER(dim)[1];
		if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
		    /* indices are legal scalars */
		    R_xlen_t k = i - 1 + nrow * (j - 1);
		    switch (TYPEOF(x)) {
		    case REALSXP:
			if (k < LENGTH(x))
			    return ScalarReal( REAL(x)[k] );
			break;
		    case INTSXP:
			if (k < LENGTH(x))
			    return ScalarInteger( INTEGER(x)[k] );
			break;
		    case LGLSXP:
			if (k < LENGTH(x))
			    return ScalarLogical( LOGICAL(x)[k] );
			break;
		    case CPLXSXP:
			if (k < LENGTH(x))
			    return ScalarComplex( COMPLEX(x)[k] );
			break;
		    case RAWSXP:
			if (k < LENGTH(x))
			    return ScalarRaw( RAW(x)[k] );
			break;
		    default: break;
		    }
		}
	    }
	}
    }

    PROTECT(args);

    drop = 1;
    ExtractDropArg(args, &drop);
    x = CAR(args);

    /* This was intended for compatibility with S, */
    /* but in fact S does not do this. */
    /* FIXME: replace the test by isNull ... ? */

    if (x == R_NilValue) {
	UNPROTECT(1);
	return x;
    }
    subs = CDR(args);
    nsubs = length(subs); /* Will be short */
    type = TYPEOF(x);

    /* Here coerce pair-based objects into generic vectors. */
    /* All subsetting takes place on the generic vector form. */

    ax = x;
    if (isVector(x))
	PROTECT(ax);
    else if (isPairList(x)) {
	SEXP dim = getAttrib(x, R_DimSymbol);
	int ndim = length(dim);
	if (ndim > 1) {
	    PROTECT(ax = allocArray(VECSXP, dim));
	    setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
	    setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
	}
	else {
	    PROTECT(ax = allocVector(VECSXP, length(x)));
	    setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
	}
	for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
	    SET_VECTOR_ELT(ax, i++, CAR(px));
    }
    else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));

    /* This is the actual subsetting code. */
    /* The separation of arrays and matrices is purely an optimization. */

    if(nsubs < 2) {
	SEXP dim = getAttrib(x, R_DimSymbol);
	int ndim = length(dim);
	PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg),
				   call));
	/* one-dimensional arrays went through here, and they should
	   have their dimensions dropped only if the result has
	   length one and drop == TRUE
	*/
	if(ndim == 1) {
	    SEXP attr, attrib, nattrib;
	    int len = length(ans);

	    if(!drop || len > 1) {
		// must grab these before the dim is set.
		SEXP nm = PROTECT(getAttrib(ans, R_NamesSymbol));
		PROTECT(attr = allocVector(INTSXP, 1));
		INTEGER(attr)[0] = length(ans);
		setAttrib(ans, R_DimSymbol, attr);
		if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
		    /* reinstate dimnames, include names of dimnames */
		    PROTECT(nattrib = duplicate(attrib));
		    SET_VECTOR_ELT(nattrib, 0, nm);
		    setAttrib(ans, R_DimNamesSymbol, nattrib);
		    setAttrib(ans, R_NamesSymbol, R_NilValue);
		    UNPROTECT(1);
		}
		UNPROTECT(2);
	    }
	}
    } else {
	if (nsubs != length(getAttrib(x, R_DimSymbol)))
	    errorcall(call, _("incorrect number of dimensions"));
	if (nsubs == 2)
	    ans = MatrixSubset(ax, subs, call, drop);
	else
	    ans = ArraySubset(ax, subs, call, drop);
	PROTECT(ans);
    }

    /* Note: we do not coerce back to pair-based lists. */
    /* They are "defunct" in this version of R. */

    if (type == LANGSXP) {
	ax = ans;
	PROTECT(ans = allocList(LENGTH(ax)));
	if ( LENGTH(ax) > 0 )
	    SET_TYPEOF(ans, LANGSXP);
	for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
	    SETCAR(px, VECTOR_ELT(ax, i++));
	setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
	setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
	setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
	SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
    }
    else {
	PROTECT(ans);
    }
    if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */
	setAttrib(ans, R_TspSymbol, R_NilValue);
#ifdef _S4_subsettable
	if(!IS_S4_OBJECT(x))
#endif
	    setAttrib(ans, R_ClassSymbol, R_NilValue);
    }
    UNPROTECT(4);
    return ans;
}
SEXP R_valid_sgCMatrix(SEXP x) {
    if (!inherits(x, "sgCMatrix"))
	error("'x' not of class sgCMatrix");
    int i, k, f, l;
    SEXP px, ix, dx;

    px = getAttrib(x, install("p"));
    ix = getAttrib(x, install("i"));
    dx = getAttrib(x, install("Dim"));
    
    if (isNull(px) || isNull(ix) || isNull(dx))
	return mkString("slot p, i, or Dim is NULL");

    if (TYPEOF(px) != INTSXP || TYPEOF(ix) != INTSXP || TYPEOF(dx) != INTSXP)
	return mkString("slot p, i, or Dim not of storage type integer");

    if (LENGTH(dx) != 2 || INTEGER(dx)[0] < 0 || INTEGER(dx)[1] < 0)
	return mkString("slot Dim invalid");

    if (INTEGER(dx)[1] != LENGTH(px)-1)
	return mkString("slot p and Dim do not conform");

    f = l = INTEGER(px)[0];
    if (f != 0)
	return mkString("slot p invalid");

    for (i = 1; i < LENGTH(px); i++) {
	l = INTEGER(px)[i];
	if (l < f)
	    return mkString("slot p invalid");
	f = l;
    }
    if (l != LENGTH(ix))
	return mkString("slot p and i do not conform");

    if (l > 0) {
	f = l = INTEGER(ix)[0];
	for (i = 1; i < LENGTH(ix); i++) {
	    k = INTEGER(ix)[i];
	    if (k < f)
		f = k;
	    else
	    if (k > l)
		l = k;
	}
	if (f < 0 || l > INTEGER(dx)[0]-1)
	    return mkString("slot i invalid");
    }

    ix = getAttrib(x, install("Dimnames"));

    if (LENGTH(ix) != 2 || TYPEOF(ix) != VECSXP)
	return mkString("slot Dimnames invalid");

    px = VECTOR_ELT(ix, 0);
    if (!isNull(px)) {
	if (TYPEOF(px) != STRSXP)
	    return mkString("slot Dimnames invalid");
	if (LENGTH(px) != INTEGER(dx)[0])
	    return mkString("slot Dim and Dimnames do not conform");
    }

    px = VECTOR_ELT(ix, 1);
    if (!isNull(px)) {
	if (TYPEOF(px) != STRSXP)
	    return mkString("slot Dimnames invalid");
	if (LENGTH(px) != INTEGER(dx)[1])
	    return mkString("slot Dim and Dimnames do not conform");
    }

    return ScalarLogical(TRUE);
}
示例#7
0
文件: ring_r.c 项目: drknexus/ring
SEXP R_ring_buffer_empty(SEXP extPtr) {
  return ScalarLogical(ring_buffer_empty(ring_buffer_get(extPtr, 1)));
}
示例#8
0
文件: probProfit.c 项目: FranSal/LSPM
SEXP prob_profit ( SEXP beg, SEXP end, SEXP lsp,
        SEXP horizon, SEXP sample )
{
  /* Arguments:
   *   beg      First permutation index value
   *   end      Last permutation index value
   *   val      Profit target (percent)
   *   horizon  Horizon over which to determine probability
   *   hpr      Holding period returns
   *   prob     Probability of each HPR
   *   sample   If sample=0, run all permutations
   *            else run 'end - beg' random permutations
   *   replace  boolean (not implemented, always replace)
   */

  int P=0;  /* PROTECT counter */
  int i, j;  /* loop counters */

  /* extract lsp components */
  //double *d_event   = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 0)))); P++;
  double *d_prob    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 1)))); P++;
  //double *d_fval    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 2)))); P++;
  //double *d_maxloss = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 3)))); P++;
  double *d_zval    = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 4)))); P++;

  /* Get values from pointers */
  double i_beg = asReal(beg)-1;  /* zero-based */
  double i_end = asReal(end)-1;  /* zero-based */
  double i_sample = asReal(sample);
  int i_horizon = asInteger(horizon);

  /* initialize result object and pointer */
  SEXP result;
  PROTECT(result = allocVector(REALSXP, 2)); P++;
  double *d_result = REAL(result);

  /* initialize portfolio HPR object */
  SEXP phpr;

  double I; int J;
  double nr = nrows(VECTOR_ELT(lsp, 1));
  double passProb = 0;
  double sumProb = 0;
  double *d_phpr = NULL;

  /* does the lsp object have non-zero z values? */
  int using_z = (d_zval[0]==0 && d_zval[1]==0) ? 0 : 1;

  /* initialize object to hold permutation locations */
  SEXP perm;
  PROTECT(perm = allocVector(INTSXP, i_horizon)); P++;
  int *i_perm = INTEGER(perm);

  /* if lsp object contains z-values of zero, calculate HPR before
   * running permutations */
  if( !using_z ) {
    PROTECT(phpr = hpr(lsp, ScalarLogical(TRUE), R_NilValue)); P++;
    d_phpr = REAL(phpr);
  }

  /* Initialize R's random number generator (read in .Random.seed) */
  if(i_sample > 0) GetRNGstate();

  double probPerm;  /* proability of this permutation */
  double t0hpr;     /* this period's (t = 0) HPR */
  double t1hpr;     /* last period's (t = 1) HPR */
  double target = 1+d_zval[2];
    
  /* Loop over each permutation index */
  for(i=i_beg; i<=i_end; i++) {

    /* check for user-requested interrupt */
    if( i % 10000 == 999 ) R_CheckUserInterrupt();

    probPerm = 1;  /* proability of this permutation */
    t0hpr = 1;     /* this period's (t = 0) HPR */
    t1hpr = 1;     /* last period's (t = 1) HPR */
    
    /* if sampling, get a random permutation between 0 and nPr-1,
     * else use the current index value. */
    I = (i_sample > 0) ? ( unif_rand() * (i_sample-1) ) : i;

    /* set the permutation locations for index 'I' */
    for(j=i_horizon; j--;) {
      i_perm[j] = (long)fmod(I/pow(nr,j),nr);
    }
    /* Keep track of this permutation's probability */
    for(j=i_horizon; j--;) {
      probPerm *= d_prob[i_perm[j]];
    }
    /* if lsp object contains non-zero z values, calculate HPR for
     * each permutation */
    if( using_z ) {
      /* call lspm::hpr and assign pointer */
      PROTECT(phpr = hpr(lsp, ScalarLogical(TRUE), perm));
      d_phpr = REAL(phpr);
    }

    /* loop over permutation locations */
    for(j=0; j<i_horizon; j++) {
      /* if using_z, phpr has 'i_horizon' elements, else it has
       * 'nr' elements */
      J = using_z ? j : i_perm[j];
      t1hpr *= d_phpr[J];  /* New portfolio balance */
    }
    if( using_z ) UNPROTECT(1);  /* UNPROTECT phpr */
    /* If this permutation hit its target return,
     * add its probability to the total. */
    if( t1hpr >= target ) {
      passProb += probPerm;
    }
    /* Total probability of all permutations */
    sumProb += probPerm;
  }
  if(i_sample > 0) PutRNGstate();  /* Write out .Random.seed */

  /* Store results */
  d_result[0] = passProb;
  d_result[1] = sumProb;

  UNPROTECT(P);
  return result;
}
/* backend for the all.equal() function for bn objects. */
SEXP all_equal(SEXP target, SEXP current) {

int nnodes = 0,  narcs = 0;
int *t = NULL, *c = NULL;
SEXP tnodes, cnodes, cmatch, tarcs, carcs, thash, chash;

  /* get the node set of each network. */
  tnodes = getAttrib(getListElement(target, "nodes"), R_NamesSymbol);
  cnodes = getAttrib(getListElement(current, "nodes"), R_NamesSymbol);

  /* first check: node sets must have the same size. */
  if (length(tnodes) != length(cnodes))
    return mkString("Different number of nodes");

  /* store for future use. */
  nnodes = length(tnodes);

  /* second check: node sets must contain the same node labels.  */
  PROTECT(cmatch = match(tnodes, cnodes, 0));
  c = INTEGER(cmatch);
  /* sorting takes care of different node orderings. */
  R_isort(c, nnodes);

  /* check that every node in the first network is also present in the
   * second one; this is enough because the node sets have the same size
   * and the nodes in each set are guaranteed to be unique. */
  for (int i = 0; i < nnodes; i++) {

    if (c[i] != i + 1) {

      UNPROTECT(1);

      return mkString("Different node sets");

    }/*THEN*/

  }/*FOR*/

  UNPROTECT(1);

  /* get the node set of each network. */
  tarcs = getListElement(target, "arcs");
  carcs = getListElement(current, "arcs");

  /* third check: arc sets must have the same size. */
  if (length(tarcs) != length(carcs))
    return mkString("Different number of directed/undirected arcs");

  /* store for future use. */
  narcs = length(tarcs)/2;

  /* fourth check:  arcs sets must contain the same arcs. */
  if (narcs > 0) {

    /* compute the numeric hashes of both arc sets (against the same
     * node set to make comparisons meaningful) and sort them. */
    PROTECT(thash = arc_hash(tarcs, tnodes, FALSE, TRUE));
    PROTECT(chash = arc_hash(carcs, tnodes, FALSE, TRUE));
    /* dereference the resulting integer vectors. */
    t = INTEGER(thash);
    c = INTEGER(chash);
    /* sorting takes care of different arc orderings. */
    R_isort(t, narcs);
    R_isort(c, narcs);

    /* compare the integer vectors as generic memory areas. */
    if (memcmp(t, c, narcs * sizeof(int))) {

      UNPROTECT(2);

      return mkString("Different arc sets");

    }/*THEN*/

    UNPROTECT(2);

  }/*THEN*/

  /* all checks completed successfully, returning TRUE. */
  return ScalarLogical(TRUE);

}/*ALL_EQUAL*/
示例#10
0
文件: slot.c 项目: csilles/cxxr
SEXP R_hasSlot(SEXP obj, SEXP name)
{
    return ScalarLogical(R_has_slot(obj, name));
}
示例#11
0
文件: lm.c 项目: lovmoy/r-source
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol)
{
    SEXP ans, ansnames;
    SEXP qr, coefficients, residuals, effects, pivot, qraux;
    int n, ny = 0, p, rank, nprotect = 4, pivoted = 0;
    double rtol = asReal(tol), *work;


    int *dims = INTEGER(getAttrib(x, R_DimSymbol));
    n = dims[0]; p = dims[1];
    if(n) ny = LENGTH(y)/n;  /* n x ny, or a vector */

    /* These lose attributes, so do after we have extracted dims */
    if (TYPEOF(x) != REALSXP) {
	PROTECT(x = coerceVector(x, REALSXP)); 
	nprotect++;
    }
    if (TYPEOF(y) != REALSXP) {
	PROTECT(y = coerceVector(y, REALSXP));
	nprotect++;
    }

    double *rptr = REAL(x);
    for (R_xlen_t i = 0 ; i < XLENGTH(x) ; i++)
	if(!R_FINITE(rptr[i])) error("NA/NaN/Inf in 'x'");
    
    rptr = REAL(y);
    for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++)
	if(!R_FINITE(rptr[i])) error("NA/NaN/Inf in 'y'");

    PROTECT(ans = allocVector(VECSXP, 9));
    ansnames = allocVector(STRSXP, 9);
    setAttrib(ans, R_NamesSymbol, ansnames);
    SET_STRING_ELT(ansnames, 0, mkChar("qr"));
    SET_STRING_ELT(ansnames, 1, mkChar("coefficients"));
    SET_STRING_ELT(ansnames, 2, mkChar("residuals"));
    SET_STRING_ELT(ansnames, 3, mkChar("effects"));
    SET_STRING_ELT(ansnames, 4, mkChar("rank"));
    SET_STRING_ELT(ansnames, 5, mkChar("pivot"));
    SET_STRING_ELT(ansnames, 6, mkChar("qraux"));
    SET_STRING_ELT(ansnames, 7, mkChar("tol"));
    SET_STRING_ELT(ansnames, 8, mkChar("pivoted"));
    SET_VECTOR_ELT(ans, 0, qr = duplicate(x));
    if (ny > 1) coefficients = allocMatrix(REALSXP, p, ny);
    else coefficients = allocVector(REALSXP, p);
    PROTECT(coefficients);
    SET_VECTOR_ELT(ans, 1, coefficients);
    SET_VECTOR_ELT(ans, 2, residuals = duplicate(y));
    SET_VECTOR_ELT(ans, 3, effects = duplicate(y));
    PROTECT(pivot = allocVector(INTSXP, p));
    int *ip = INTEGER(pivot);
    for(int i = 0; i < p; i++) ip[i] = i+1;
    SET_VECTOR_ELT(ans, 5, pivot);
    PROTECT(qraux = allocVector(REALSXP, p));
    SET_VECTOR_ELT(ans, 6, qraux);
    SET_VECTOR_ELT(ans, 7, tol);
   
    work = (double *) R_alloc(2 * p, sizeof(double));
    F77_CALL(dqrls)(REAL(qr), &n, &p, REAL(y), &ny, &rtol,
		    REAL(coefficients), REAL(residuals), REAL(effects),
		    &rank, INTEGER(pivot), REAL(qraux), work);
    SET_VECTOR_ELT(ans, 4, ScalarInteger(rank));
    for(int i = 0; i < p; i++)
	if(ip[i] != i+1) { pivoted = 1; break; }
    SET_VECTOR_ELT(ans, 8, ScalarLogical(pivoted));
    UNPROTECT(nprotect);
    
    return ans;
}
示例#12
0
/* a single step of the optimized hill climbing (one arc addition/removal/reversal). */
SEXP hc_opt_step(SEXP amat, SEXP nodes, SEXP added, SEXP cache, SEXP reference,
    SEXP wlmat, SEXP blmat, SEXP nparents, SEXP maxp, SEXP debug) {

int nnodes = length(nodes), i = 0, j = 0;
int *am = NULL, *ad = NULL, *w = NULL, *b = NULL, debuglevel = isTRUE(debug);
int counter = 0, update = 1, from = 0, to = 0, *path = NULL, *scratch = NULL;
double *cache_value = NULL, temp = 0, max = 0, tol = MACHINE_TOL;
double *mp = REAL(maxp), *np = REAL(nparents);
SEXP bestop;

  /* allocate and initialize the return value (use FALSE as a canary value). */
  PROTECT(bestop = allocVector(VECSXP, 3));
  setAttrib(bestop, R_NamesSymbol, mkStringVec(3, "op", "from", "to"));

  /* allocate and initialize a dummy FALSE object. */
  SET_VECTOR_ELT(bestop, 0, ScalarLogical(FALSE));

  /* allocate buffers for c_has_path(). */
  path = Calloc1D(nnodes, sizeof(int));
  scratch = Calloc1D(nnodes, sizeof(int));

  /* save pointers to the numeric/integer matrices. */
  cache_value = REAL(cache);
  ad = INTEGER(added);
  am = INTEGER(amat);
  w = INTEGER(wlmat);
  b = INTEGER(blmat);

  if (debuglevel > 0) {

     /* count how may arcs are to be tested. */
     for (i = 0; i < nnodes * nnodes; i++)
       counter += ad[i];

     Rprintf("----------------------------------------------------------------\n");
     Rprintf("* trying to add one of %d arcs.\n", counter);

  }/*THEN*/

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

    for (j = 0; j < nnodes; j++) {

      /* nothing to see, move along. */
      if (ad[CMC(i, j, nnodes)] == 0)
        continue;

      /* retrieve the score delta from the cache. */
      temp = cache_value[CMC(i, j, nnodes)];

      if (debuglevel > 0) {

        Rprintf("  > trying to add %s -> %s.\n", NODE(i), NODE(j));
        Rprintf("    > delta between scores for nodes %s %s is %lf.\n",
          NODE(i), NODE(j), temp);

      }/*THEN*/

      /* this score delta is the best one at the moment, so add the arc if it
       * does not introduce cycles in the graph. */
      if (temp - max > tol) {

        if (c_has_path(j, i, am, nnodes, nodes, FALSE, FALSE, path, scratch,
              FALSE)) {

          if (debuglevel > 0)
            Rprintf("    > not adding, introduces cycles in the graph.\n");

          continue;

        }/*THEN*/

        if (debuglevel > 0)
          Rprintf("    @ adding %s -> %s.\n", NODE(i), NODE(j));

        /* update the return value. */
        bestop_update(bestop, "set", NODE(i), NODE(j));
        /* store the node indices to update the reference scores. */
        from = i;
        to = j;

        /* update the threshold score delta. */
        max = temp;

      }/*THEN*/

    }/*FOR*/

  }/*FOR*/

  if (debuglevel > 0) {

     /* count how may arcs are to be tested. */
     for (i = 0, counter = 0; i < nnodes * nnodes; i++)
       counter += am[i] * (1 - w[i]);

     Rprintf("----------------------------------------------------------------\n");
     Rprintf("* trying to remove one of %d arcs.\n", counter);

  }/*THEN*/

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

    for (j = 0; j < nnodes; j++) {

      /* nothing to see, move along. */
      if (am[CMC(i, j, nnodes)] == 0)
        continue;

      /* whitelisted arcs are not to be removed, ever. */
      if (w[CMC(i, j, nnodes)] == 1)
        continue;

      /* retrieve the score delta from the cache. */
      temp = cache_value[CMC(i, j, nnodes)];

      if (debuglevel > 0) {

        Rprintf("  > trying to remove %s -> %s.\n", NODE(i), NODE(j));
        Rprintf("    > delta between scores for nodes %s %s is %lf.\n",
          NODE(i), NODE(j), temp);

      }/*THEN*/

      if (temp - max > tol) {

        if (debuglevel > 0)
          Rprintf("    @ removing %s -> %s.\n", NODE(i), NODE(j));

        /* update the return value. */
        bestop_update(bestop, "drop", NODE(i), NODE(j));
        /* store the node indices to update the reference scores. */
        from = i;
        to = j;

        /* update the threshold score delta. */
        max = temp;

      }/*THEN*/

    }/*FOR*/

  }/*FOR*/

  if (debuglevel > 0) {

     /* count how may arcs are to be tested. */
     for (i = 0, counter = 0; i < nnodes; i++)
       for (j = 0; j < nnodes; j++)
         counter += am[CMC(i, j, nnodes)] * (1 - b[CMC(j, i, nnodes)]);

     Rprintf("----------------------------------------------------------------\n");
     Rprintf("* trying to reverse one of %d arcs.\n", counter);

  }/*THEN*/

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

    for (j = 0; j < nnodes; j++) {

      /* nothing to see, move along. */
      if (am[CMC(i, j, nnodes)] == 0)
        continue;

      /* don't reverse an arc if the one in the opposite direction is
       * blacklisted, ever. */
      if (b[CMC(j, i, nnodes)] == 1)
        continue;

      /* do not reverse an arc if that means violating the limit on the
       * maximum number of parents. */
      if (np[i] >= *mp)
        continue;

      /* retrieve the score delta from the cache. */
      temp = cache_value[CMC(i, j, nnodes)] + cache_value[CMC(j, i, nnodes)];
      /* nuke small values and negative zeroes. */
      if (fabs(temp) < tol) temp = 0;

      if (debuglevel > 0) {

        Rprintf("  > trying to reverse %s -> %s.\n", NODE(i), NODE(j));
        Rprintf("    > delta between scores for nodes %s %s is %lf.\n",
          NODE(i), NODE(j), temp);

      }/*THEN*/

      if (temp - max > tol) {

        if (c_has_path(i, j, am, nnodes, nodes, FALSE, TRUE, path, scratch,
              FALSE)) {

          if (debuglevel > 0)
            Rprintf("    > not reversing, introduces cycles in the graph.\n");

          continue;

        }/*THEN*/

        if (debuglevel > 0)
          Rprintf("    @ reversing %s -> %s.\n", NODE(i), NODE(j));

        /* update the return value. */
        bestop_update(bestop, "reverse", NODE(i), NODE(j));
        /* store the node indices to update the reference scores. */
        from = i;
        to = j;
        /* both nodes' reference scores must be updated. */
        update = 2;

        /* update the threshold score delta. */
        max = temp;

      }/*THEN*/

    }/*FOR*/

  }/*FOR*/

  /* update the reference scores. */
  REAL(reference)[to] += cache_value[CMC(from, to, nnodes)];
  if (update == 2)
    REAL(reference)[from] += cache_value[CMC(to, from, nnodes)];

  Free1D(path);
  Free1D(scratch);

  UNPROTECT(1);

  return bestop;

}/*HC_OPT_STEP*/
示例#13
0
/* This is a primitive (with no arguments) */
SEXP attribute_hidden do_interactive(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    return ScalarLogical( (R_Interactive) ? 1 : 0 );
}
示例#14
0
SEXP R_initMethodDispatch(SEXP envir)
{
    if(envir && !isNull(envir))
	Methods_Namespace = envir;
    if(!Methods_Namespace)
	Methods_Namespace = R_GlobalEnv;
    if(initialized)
	return(envir);

    s_dot_Methods = install(".Methods");
    s_skeleton = install("skeleton");
    s_expression = install("expression");
    s_function = install("function");
    s_getAllMethods = install("getAllMethods");
    s_objectsEnv = install("objectsEnv");
    s_MethodsListSelect = install("MethodsListSelect");
    s_sys_dot_frame = install("sys.frame");
    s_sys_dot_call = install("sys.call");
    s_sys_dot_function = install("sys.function");
    s_generic = install("generic");
    s_generic_dot_skeleton = install("generic.skeleton");
    s_subset_gets = install("[<-");
    s_element_gets = install("[[<-");
    s_argument = install("argument");
    s_allMethods = install("allMethods");

    R_FALSE = ScalarLogical(FALSE);
    R_PreserveObject(R_FALSE);
    R_TRUE = ScalarLogical(TRUE);
    R_PreserveObject(R_TRUE);

    /* some strings (NOT symbols) */
    s_missing = mkString("missing");
    setAttrib(s_missing, R_PackageSymbol, mkString("methods"));
    R_PreserveObject(s_missing);
    s_base = mkString("base");
    R_PreserveObject(s_base);
    /*  Initialize method dispatch, using the static */
    R_set_standardGeneric_ptr(
	(table_dispatch_on ? R_dispatchGeneric : R_standardGeneric)
	, Methods_Namespace);
    R_set_quick_method_check(
	(table_dispatch_on ? R_quick_dispatch : R_quick_method_check));

    /* Some special lists of primitive skeleton calls.
       These will be promises under lazy-loading.
    */
    PROTECT(R_short_skeletons =
	    findVar(install(".ShortPrimitiveSkeletons"),
		    Methods_Namespace));
    if(TYPEOF(R_short_skeletons) == PROMSXP)
	R_short_skeletons = eval(R_short_skeletons, Methods_Namespace);
    R_PreserveObject(R_short_skeletons);
    UNPROTECT(1);
    PROTECT(R_empty_skeletons =
	    findVar(install(".EmptyPrimitiveSkeletons"),
		    Methods_Namespace));
    if(TYPEOF(R_empty_skeletons) == PROMSXP)
	R_empty_skeletons = eval(R_empty_skeletons, Methods_Namespace);
    R_PreserveObject(R_empty_skeletons);
    UNPROTECT(1);
    if(R_short_skeletons == R_UnboundValue ||
       R_empty_skeletons == R_UnboundValue)
	error(_("could not find the skeleton calls for 'methods' (package detached?): expect very bad things to happen"));
    f_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 0);
    fgets_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 1);
    f_x_skeleton = VECTOR_ELT(R_empty_skeletons, 0);
    fgets_x_skeleton = VECTOR_ELT(R_empty_skeletons, 1);
    init_loadMethod();
    initialized = 1;
    return(envir);
}
示例#15
0
SEXP lapack_qr(SEXP Xin, SEXP tl)
{
    SEXP ans, Givens, Gcpy, nms, pivot, qraux, X;
    int i, n, nGivens = 0, p, trsz, *Xdims, rank;
    double rcond = 0., tol = asReal(tl), *work;

    if (!(isReal(Xin) & isMatrix(Xin)))
	error(_("X must be a real (numeric) matrix"));
    if (tol < 0.) error(_("tol, given as %g, must be non-negative"), tol);
    if (tol > 1.) error(_("tol, given as %g, must be <= 1"), tol);
    ans = PROTECT(allocVector(VECSXP,5));
    SET_VECTOR_ELT(ans, 0, X = duplicate(Xin));
    Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
    n = Xdims[0]; p = Xdims[1];
    SET_VECTOR_ELT(ans, 2, qraux = allocVector(REALSXP, (n < p) ? n : p));
    SET_VECTOR_ELT(ans, 3, pivot = allocVector(INTSXP, p));
    for (i = 0; i < p; i++) INTEGER(pivot)[i] = i + 1;
    trsz = (n < p) ? n : p;	/* size of triangular part of decomposition */
    rank = trsz;
    Givens = PROTECT(allocVector(VECSXP, rank - 1));
    setAttrib(ans, R_NamesSymbol, nms = allocVector(STRSXP, 5));
    SET_STRING_ELT(nms, 0, mkChar("qr"));
    SET_STRING_ELT(nms, 1, mkChar("rank"));
    SET_STRING_ELT(nms, 2, mkChar("qraux"));
    SET_STRING_ELT(nms, 3, mkChar("pivot"));
    SET_STRING_ELT(nms, 4, mkChar("Givens"));
    if (n > 0 && p > 0) {
	int  info, *iwork, lwork;
	double *xpt = REAL(X), tmp;

	lwork = -1;
	F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), &tmp, &lwork, &info);
	if (info)
	    error(_("First call to dgeqrf returned error code %d"), info);
	lwork = (int) tmp;
	work = (double *) R_alloc((lwork < 3*trsz) ? 3*trsz : lwork,
				  sizeof(double));
	F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), work, &lwork, &info);
	if (info)
	    error(_("Second call to dgeqrf returned error code %d"), info);
	iwork = (int *) R_alloc(trsz, sizeof(int));
	F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
			 work, iwork, &info);
	if (info)
	    error(_("Lapack routine dtrcon returned error code %d"), info);
	while (rcond < tol) {	/* check diagonal elements */
	    double minabs = (xpt[0] < 0.) ? -xpt[0]: xpt[0];
	    int jmin = 0;
	    for (i = 1; i < rank; i++) {
		double el = xpt[i*(n+1)];
		el = (el < 0.) ? -el: el;
		if (el < minabs) {
		    jmin = i;
		    minabs = el;
		}
	    }
	    if (jmin < (rank - 1)) {
		SET_VECTOR_ELT(Givens, nGivens, getGivens(xpt, n, jmin, rank));
		nGivens++;
	    }
	    rank--;
	    F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
			     work, iwork, &info);
	    if (info)
		error(_("Lapack routine dtrcon returned error code %d"), info);
	}
    }
    SET_VECTOR_ELT(ans, 4, Gcpy = allocVector(VECSXP, nGivens));
    for (i = 0; i < nGivens; i++)
	SET_VECTOR_ELT(Gcpy, i, VECTOR_ELT(Givens, i));
    SET_VECTOR_ELT(ans, 1, ScalarInteger(rank));
    setAttrib(ans, install("useLAPACK"), ScalarLogical(1));
    setAttrib(ans, install("rcond"), ScalarReal(rcond));
    UNPROTECT(2);
    return ans;
}
示例#16
0
文件: fork.c 项目: krlmlr/r-source
SEXP mc_select_children(SEXP sTimeout, SEXP sWhich) 
{
    int maxfd = 0, sr, zombies = 0;
    unsigned int wlen = 0, wcount = 0;
    SEXP res;
    int *res_i, *which = 0;
    child_info_t *ci = children;
    fd_set fs;
    struct timeval tv = { 0, 0 }, *tvp = &tv;
    if (isReal(sTimeout) && LENGTH(sTimeout) == 1) {
	double tov = asReal(sTimeout);
	if (tov < 0.0) tvp = 0; /* Note: I'm not sure we really should allow this .. */
	else {
	    tv.tv_sec = (int) tov;
	    tv.tv_usec = (int) ((tov - ((double) tv.tv_sec)) * 1000000.0);
	}
    }
    if (TYPEOF(sWhich) == INTSXP && LENGTH(sWhich)) {
	which = INTEGER(sWhich);
	wlen = LENGTH(sWhich);
    }
    clean_zombies();

    FD_ZERO(&fs);
    while (ci && ci->pid) {
	if (ci->pfd == -1) zombies++;
	if (ci->pfd > maxfd) maxfd = ci->pfd;
	if (ci->pfd > 0) {
	    if (which) { /* check for the FD only if it's on the list */
		unsigned int k = 0;
		while (k < wlen) 
		    if (which[k++] == ci->pid) { 
			FD_SET(ci->pfd, &fs);
			wcount++;
			break; 
		    }
	    } else FD_SET(ci->pfd, &fs);
	}
	ci = ci -> next;
    }
    /* if there are any closed children, remove them - don't bother otherwise */
    if (zombies) rm_closed();

#ifdef MC_DEBUG
    Dprintf("select_children: maxfd=%d, wlen=%d, wcount=%d, zombies=%d, timeout=%d:%d\n", maxfd, wlen, wcount, zombies, (int)tv.tv_sec, (int)tv.tv_usec);
#endif

    if (maxfd == 0 || (wlen && !wcount)) 
	return R_NilValue; /* NULL signifies no children to tend to */

    sr = select(maxfd + 1, &fs, 0, 0, tvp);
#ifdef MC_DEBUG
    Dprintf("  sr = %d\n", sr);
#endif
    if (sr < 0) {
	/* we can land here when a child terminated due to arriving SIGCHLD.
	   For simplicity we treat this as timeout. The alernative would be to
	   go back to select, but potentially this could lead to a much longer
	   total timeout */
	if (errno == EINTR)
	    return ScalarLogical(TRUE);

	warning(_("error '%s' in select"), strerror(errno));
	return ScalarLogical(FALSE); /* FALSE on select error */
    }
    if (sr < 1) return ScalarLogical(1); /* TRUE on timeout */
    ci = children;
    maxfd = 0;
    while (ci && ci->pid) { /* pass 1 - count the FDs (in theory not
			       necessary since that's what select
			       should have returned)  */
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) maxfd++;
	ci = ci -> next;
    }
    ci = children;
#ifdef MC_DEBUG
    Dprintf(" - read select %d children: ", maxfd);
#endif
    res = allocVector(INTSXP, maxfd);
    res_i = INTEGER(res);
    while (ci && ci->pid) { /* pass 2 - fill the array */
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) (res_i++)[0] = ci->pid;
#ifdef MC_DEBUG
	if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) Dprintf("%d ", ci->pid);
#endif
	ci = ci -> next;
    }
#ifdef MC_DEBUG
    Dprintf("\n");
#endif
    return res;
}
示例#17
0
文件: base.c 项目: Maxsl/r-source
static SEXP baseCallback(GEevent task, pGEDevDesc dd, SEXP data)
{
    GESystemDesc *sd;
    baseSystemState *bss, *bss2;
    SEXP result = R_NilValue;

    switch (task) {
    case GE_FinaliseState:
	/* called from unregisterOne */
	sd = dd->gesd[baseRegisterIndex];
	free(sd->systemSpecific);
	sd->systemSpecific = NULL;
	break;
    case GE_InitState:
    {
	/* called from registerOne */
	pDevDesc dev;
	GPar *ddp;
	sd = dd->gesd[baseRegisterIndex];
	dev = dd->dev;
	bss = sd->systemSpecific = malloc(sizeof(baseSystemState));
        /* Bail out if necessary */
        if (!bss) return result;
	/* Make sure initialized, or valgrind may complain. */
        memset(bss, 0, sizeof(baseSystemState));
	ddp = &(bss->dp);
	GInit(ddp);
	/* For some things, the device sets the starting value at least. */
	ddp->ps = dev->startps;
	ddp->col = ddp->fg = dev->startcol;
	ddp->bg = dev->startfill;
	ddp->font = dev->startfont;
	ddp->lty = dev->startlty;
	ddp->gamma = dev->startgamma;
	/* Initialise the gp settings too: formerly in addDevice. */
	copyGPar(ddp, &(bss->gp));
	GReset(dd);
	/*
	 * The device has not yet received any base output
	 */
	bss->baseDevice = FALSE;
        /* Indicate success */
        result = R_BlankString;
	break;
    }
    case GE_CopyState:
    {
	/* called from GEcopyDisplayList */
	pGEDevDesc curdd = GEcurrentDevice();
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	bss2 = curdd->gesd[baseRegisterIndex]->systemSpecific;
	copyGPar(&(bss->dpSaved), &(bss2->dpSaved));
	restoredpSaved(curdd);
	copyGPar(&(bss2->dp), &(bss2->gp));
	GReset(curdd);
	break;
    }
    case GE_SaveState:
	/* called from GEinitDisplayList */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	copyGPar(&(bss->dp), &(bss->dpSaved));
	break;
    case GE_RestoreState:
	/* called from GEplayDisplayList */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	restoredpSaved(dd);
	copyGPar(&(bss->dp), &(bss->gp));
	GReset(dd);
	break;
    case GE_SaveSnapshotState:
	/* called from GEcreateSnapshot */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	/* Changed from INTSXP in 2.7.0: but saved graphics lists
	   are protected by an R version number */
	PROTECT(result = allocVector(RAWSXP, sizeof(GPar)));
	copyGPar(&(bss->dpSaved), (GPar*) RAW(result));
	UNPROTECT(1);
	break;
    case GE_RestoreSnapshotState:
	/* called from GEplaySnapshot */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	copyGPar((GPar*) RAW(data), &(bss->dpSaved));
	restoredpSaved(dd);
	copyGPar(&(bss->dp), &(bss->gp));
	GReset(dd);
	break;
    case GE_CheckPlot:
	/* called from GEcheckState:
	   Check that the current plotting state is "valid"
	 */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	result = ScalarLogical(bss->baseDevice ?
			       (bss->gp.state == 1) && bss->gp.valid :
			       TRUE);
	break;
    case GE_ScalePS:
    {
	/* called from GEhandleEvent in devWindows.c */
	GPar *ddp, *ddpSaved;
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	ddp = &(bss->dp);
	ddpSaved = &(bss->dpSaved);
	if (isReal(data) && LENGTH(data) == 1) {
	    double rf = REAL(data)[0];
	    ddp->scale *= rf;
	    /* Modify the saved settings so this effects display list too */
	    ddpSaved->scale *= rf;
	} else
	  error("event 'GE_ScalePS' requires a single numeric value");
	break;
    }
    }
    return result;
}
示例#18
0
文件: fork.c 项目: krlmlr/r-source
SEXP mc_rm_child(SEXP sPid) 
{
    int pid = asInteger(sPid);
    return ScalarLogical(rm_child_(pid));
}
示例#19
0
SEXP Riproc_recv_model(SEXP ytime, SEXP ysender, SEXP yreceiver,
		       SEXP xtime, SEXP xsender, SEXP xreceiver,
		       SEXP factors, SEXP variables, SEXP nsend, SEXP nrecv,
		       SEXP loops)
{
	struct properties p;
	struct history hx, hy;
	struct design s, r;
	struct design2 d;
	struct terms_object tm;
	const struct message *msgs;
	size_t nmsg;
	size_t iter, dim, nc, ntot, rank;
	size_t ncextra;
	struct recv_fit fit;
	const struct recv_loglik *ll;
	const struct recv_model *model;
	const struct constr *constr;
	const double *beta, *nu;
	double dev;
	SEXP names;
	SEXP ret = NULL_USER_OBJECT;
	int k;
	int err = 0;

	err = get_properties(nsend, nrecv, loops, &p);
	if (err < 0)
		goto properties_fail;

	history_init(&hy, p.nsend, p.nrecv);
	err = get_history(ytime, ysender, yreceiver, &hy);
	if (err < 0)
		goto yhistory_fail;

	history_init(&hx, p.nsend, p.nrecv);
	err = get_history(xtime, xsender, xreceiver, &hx);
	if (err < 0)
		goto xhistory_fail;

	design_init(&s, &hx, p.nsend);
	design_init(&r, &hx, p.nrecv);
	design2_init(&d, &hx, p.nsend, p.nrecv);

	err = get_terms_object(factors, variables, &s, &r, &d, &tm);
	if (err < 0)
		goto terms_fail;

	history_get_messages(&hy, &msgs, &nmsg);

	recv_fit_init(&fit, &r, &d, p.exclude_loops, msgs, nmsg, NULL, NULL);

	ncextra = recv_fit_extra_constr_count(&fit);
	if (ncextra)
		warning("adding %zd %s to make parameters identifiable\n",
			ncextra, ncextra == 1 ? "constraint" : "constraints");

	err = do_fit(&fit, NULL, NULL, &iter);
	if (err < 0)
		goto fit_fail;

	constr = recv_fit_constr(&fit);
	nc = constr_count(constr);
	ll = recv_fit_loglik(&fit);
	ntot = recv_loglik_count(ll);
	model = recv_loglik_model(ll);
	beta = (recv_model_params(model))->recv.traits; /* HACK */
	nu = recv_fit_duals(&fit);
	dim = recv_model_dim(model);
	rank = dim - nc;
	dev = recv_loglik_dev(ll);

	PROTECT(ret = NEW_LIST(16));
	PROTECT(names = NEW_CHARACTER(16));
	SET_NAMES(ret, names);
	k = 0;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("coefficients"));
	SET_VECTOR_ELT(ret, k, alloc_vector_copy(beta, dim));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("duals"));
	SET_VECTOR_ELT(ret, k, alloc_vector_copy(nu, nc));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("constraints"));
	SET_VECTOR_ELT(ret, k, alloc_matrix_copy(constr_all_wts(constr), nc, dim));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("constraint.values"));
	SET_VECTOR_ELT(ret, k, alloc_vector_copy(constr_all_vals(constr), nc));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("rank"));
	SET_VECTOR_ELT(ret, k, ScalarInteger((int)rank));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("deviance"));
	SET_VECTOR_ELT(ret, k, ScalarReal(dev));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("aic"));
	SET_VECTOR_ELT(ret, k, ScalarReal(dev + (double) 2 * rank));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("null.deviance"));
	SET_VECTOR_ELT(ret, k, ScalarReal(recv_fit_dev0(&fit)));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("iter"));
	SET_VECTOR_ELT(ret, k, ScalarInteger((int)iter));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("df.residual"));
	SET_VECTOR_ELT(ret, k, ScalarReal((double)(ntot - rank)));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("df.null"));
	SET_VECTOR_ELT(ret, k, ScalarReal((double)ntot));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("converged"));
	SET_VECTOR_ELT(ret, k, ScalarLogical(TRUE));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("names"));
	SET_VECTOR_ELT(ret, k, alloc_term_labels(&tm.terms));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("perm"));
	SET_VECTOR_ELT(ret, k, alloc_terms_permute(&tm.terms, &r, &d));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("score"));
	SET_VECTOR_ELT(ret, k, alloc_score(ll));
	k++;

	SET_STRING_ELT(names, k, COPY_TO_USER_STRING("imat"));
	SET_VECTOR_ELT(ret, k, alloc_imat(&fit));
	k++;

	UNPROTECT(2);


fit_fail:
	recv_fit_deinit(&fit);
terms_fail:
	design2_deinit(&d);
	design_deinit(&r);
	design_deinit(&s);
xhistory_fail:
	history_deinit(&hx);
yhistory_fail:
	history_deinit(&hy);
properties_fail:
	return ret;
}
示例#20
0
文件: fork.c 项目: krlmlr/r-source
SEXP mc_is_child() 
{
    return ScalarLogical(is_master ? FALSE : TRUE);
}
示例#21
0
SEXP gribr_is_null_ptr (SEXP gribr_ptr) {
  return ScalarLogical(!R_ExternalPtrAddr(gribr_ptr));
}
示例#22
0
文件: fork.c 项目: krlmlr/r-source
/* NA = query, TRUE/FALSE = set R_Interactive accordingly */
SEXP mc_interactive(SEXP sWhat) {
    int what = asInteger(sWhat);
    if (what != NA_INTEGER)
	R_Interactive = what;
    return ScalarLogical(R_Interactive);
}
示例#23
0
SEXP devdisplaylist(SEXP args)
{
    pGEDevDesc gdd = GEcurrentDevice();
    return ScalarLogical(gdd->displayListOn);
}
示例#24
0
static SEXP Julia_R_Scalar(jl_value_t *Var)
{
  SEXP ans = R_NilValue;
  double tmpfloat;
  //most common type is here
  if (jl_is_int32(Var))
  {
    PROTECT(ans = ScalarInteger(jl_unbox_int32(Var)));
    UNPROTECT(1);
  }
  else if (jl_is_int64(Var))
  {
    tmpfloat=(double)jl_unbox_int64(Var);
    if (inInt32Range(tmpfloat))
     PROTECT(ans = ScalarInteger((int32_t)jl_unbox_int64(Var)));
    else
     PROTECT(ans = ScalarReal(tmpfloat)); 
    UNPROTECT(1);
  }
  //more integer type
  if (jl_is_uint32(Var))
  {
    tmpfloat=(double)jl_unbox_uint32(Var);
    if (inInt32Range(tmpfloat))
     PROTECT(ans = ScalarInteger((int32_t)jl_unbox_uint32(Var)));
    else
    PROTECT(ans = ScalarReal(tmpfloat));
    UNPROTECT(1);
  }
  else if (jl_is_uint64(Var))
  {
    tmpfloat=(double)jl_unbox_int64(Var);
    if (inInt32Range(tmpfloat))
     PROTECT(ans = ScalarInteger((int32_t)jl_unbox_uint64(Var)));
    else
    PROTECT(ans = ScalarReal(tmpfloat));
    UNPROTECT(1);
  }
  else if (jl_is_float64(Var))
  {
    PROTECT(ans = ScalarReal(jl_unbox_float64(Var)));
    UNPROTECT(1);
  }
  else if (jl_is_float32(Var))
  {
    PROTECT(ans = ScalarReal(jl_unbox_float32(Var)));
    UNPROTECT(1);
  }
  else if (jl_is_bool(Var))
  {
    PROTECT(ans = ScalarLogical(jl_unbox_bool(Var)));
    UNPROTECT(1);
  }
  else if (jl_is_int8(Var))
  {
    PROTECT(ans = ScalarInteger(jl_unbox_int8(Var)));
    UNPROTECT(1);
  }
  else if (jl_is_uint8(Var))
  {
    PROTECT(ans = ScalarInteger(jl_unbox_uint8(Var)));
    UNPROTECT(1);
  }
  else if (jl_is_int16(Var))
  {
    PROTECT(ans = ScalarInteger(jl_unbox_int16(Var)));
    UNPROTECT(1);
  }
  else if (jl_is_uint16(Var))
  {
    PROTECT(ans = ScalarInteger(jl_unbox_uint16(Var)));
    UNPROTECT(1);
  }
  else if (jl_is_utf8_string(Var))
  {
    PROTECT(ans = allocVector(STRSXP, 1));
    SET_STRING_ELT(ans, 0, mkCharCE(jl_string_data(Var), CE_UTF8));
    UNPROTECT(1);
  }
  else if (jl_is_ascii_string(Var))
  {
    PROTECT(ans = ScalarString(mkChar(jl_string_data(Var))));
    UNPROTECT(1);
  }
  return ans;
}
示例#25
0
文件: print.c 项目: Vladimir84/rcc
SEXP do_visibleflag(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    return ScalarLogical(R_Visible);
}
示例#26
0
SEXP attribute_hidden c_is_integerish(SEXP x, SEXP tolerance) {
    return ScalarLogical(isIntegerish(x, REAL_RO(tolerance)[0], FALSE));
}
示例#27
0
SEXP pBunchKaufman_validate(SEXP obj)
{
    return ScalarLogical(1);
}
示例#28
0
SEXP pollSocket(SEXP sockets_, SEXP events_, SEXP timeout_) {
    SEXP result;
    
    if(TYPEOF(timeout_) != INTSXP) {
        error("poll timeout must be an integer.");
    }

    if(TYPEOF(sockets_) != VECSXP || LENGTH(sockets_) == 0) {
        error("A non-empy list of sockets is required as first argument.");
    }

    int nsock = LENGTH(sockets_);
    PROTECT(result = allocVector(VECSXP, nsock));

    if (TYPEOF(events_) != VECSXP) {
        error("event list must be a list of strings or a list of vectors of strings.");
    }
    if(LENGTH(events_) != nsock) {
        error("event list must be the same length as socket list.");
    }

    zmq_pollitem_t *pitems = (zmq_pollitem_t*)R_alloc(nsock, sizeof(zmq_pollitem_t));
    if (pitems == NULL) {
        error("failed to allocate memory for zmq_pollitem_t array.");
    }

    try {
        for (int i = 0; i < nsock; i++) {
            zmq::socket_t* socket = reinterpret_cast<zmq::socket_t*>(checkExternalPointer(VECTOR_ELT(sockets_, i), "zmq::socket_t*"));
            pitems[i].socket = (void*)*socket;
            pitems[i].events = rzmq_build_event_bitmask(VECTOR_ELT(events_, i));
        }

        int rc = zmq::poll(pitems, nsock, *INTEGER(timeout_));

        if(rc >= 0) {
            for (int i = 0; i < nsock; i++) {
                SEXP events, names;

                // Pre count number of polled events so we can
                // allocate appropriately sized lists.
                short eventcount = 0;
                if (pitems[i].events & ZMQ_POLLIN) eventcount++;
                if (pitems[i].events & ZMQ_POLLOUT) eventcount++;
                if (pitems[i].events & ZMQ_POLLERR) eventcount++;

                PROTECT(events = allocVector(VECSXP, eventcount));
                PROTECT(names = allocVector(VECSXP, eventcount));

                eventcount = 0;
                if (pitems[i].events & ZMQ_POLLIN) {
                    SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLIN));
                    SET_VECTOR_ELT(names, eventcount, mkChar("read"));
                    eventcount++;
                }

                if (pitems[i].events & ZMQ_POLLOUT) {
                    SET_VECTOR_ELT(names, eventcount, mkChar("write"));

                    SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLOUT));
                    eventcount++;
                }

                if (pitems[i].events & ZMQ_POLLERR) {
                    SET_VECTOR_ELT(names, eventcount, mkChar("error"));
                    SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLERR));
                }
                setAttrib(events, R_NamesSymbol, names);
                SET_VECTOR_ELT(result, i, events);
            }
        } else {
            error("polling zmq sockets failed.");
        }
    } catch(std::exception& e) {
        error(e.what());
    }
    // Release the result list (1), and per socket
    // events lists with associated names (2*nsock).
    UNPROTECT(1 + 2*nsock);
    return result;
}
示例#29
0
SEXP SVD_validate(SEXP obj)
{
    return ScalarLogical(1);
}
示例#30
0
/* browser(text = "", condition = NULL, expr = TRUE, skipCalls = 0L)
 * ------- but also called from ./eval.c */
SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    RCNTXT *saveToplevelContext;
    RCNTXT *saveGlobalContext;
    RCNTXT thiscontext, returncontext, *cptr;
    int savestack, browselevel;
    SEXP ap, topExp, argList;

    /* argument matching */
    PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
    SET_TAG(ap,  install("text"));
    SET_TAG(CDR(ap), install("condition"));
    SET_TAG(CDDR(ap), install("expr"));
    SET_TAG(CDDDR(ap), install("skipCalls"));
    argList = matchArgs(ap, args, call);
    UNPROTECT(1);
    PROTECT(argList);
    /* substitute defaults */
    if(CAR(argList) == R_MissingArg)
	SETCAR(argList, mkString(""));
    if(CADR(argList) == R_MissingArg)
	SETCAR(CDR(argList), R_NilValue);
    if(CADDR(argList) == R_MissingArg) 
	SETCAR(CDDR(argList), ScalarLogical(1));
    if(CADDDR(argList) == R_MissingArg) 
	SETCAR(CDDDR(argList), ScalarInteger(0));

    /* return if 'expr' is not TRUE */
    if( !asLogical(CADDR(argList)) ) {
        UNPROTECT(1);
        return R_NilValue;
    }

    /* Save the evaluator state information */
    /* so that it can be restored on exit. */

    browselevel = countContexts(CTXT_BROWSER, 1);
    savestack = R_PPStackTop;
    PROTECT(topExp = R_CurrentExpr);
    saveToplevelContext = R_ToplevelContext;
    saveGlobalContext = R_GlobalContext;

    if (!RDEBUG(rho)) {
        int skipCalls = asInteger(CADDDR(argList));
	cptr = R_GlobalContext;
	while ( ( !(cptr->callflag & CTXT_FUNCTION) || skipCalls--) 
		&& cptr->callflag )
	    cptr = cptr->nextcontext;
	Rprintf("Called from: ");
	int tmp = asInteger(GetOption(install("deparse.max.lines"), R_BaseEnv));
	if(tmp != NA_INTEGER && tmp > 0) R_BrowseLines = tmp;
        if( cptr != R_ToplevelContext ) {
	    PrintValueRec(cptr->call, rho);
	    SET_RDEBUG(cptr->cloenv, 1);
        } else
            Rprintf("top level \n");

	R_BrowseLines = 0;
    }

    R_ReturnedValue = R_NilValue;

    /* Here we establish two contexts.  The first */
    /* of these provides a target for return */
    /* statements which a user might type at the */
    /* browser prompt.  The (optional) second one */
    /* acts as a target for error returns. */

    begincontext(&returncontext, CTXT_BROWSER, call, rho,
		 R_BaseEnv, argList, R_NilValue);
    if (!SETJMP(returncontext.cjmpbuf)) {
	begincontext(&thiscontext, CTXT_RESTART, R_NilValue, rho,
		     R_BaseEnv, R_NilValue, R_NilValue);
	if (SETJMP(thiscontext.cjmpbuf)) {
	    SET_RESTART_BIT_ON(thiscontext.callflag);
	    R_ReturnedValue = R_NilValue;
	    R_Visible = FALSE;
	}
	R_GlobalContext = &thiscontext;
	R_InsertRestartHandlers(&thiscontext, TRUE);
	R_ReplConsole(rho, savestack, browselevel+1);
	endcontext(&thiscontext);
    }
    endcontext(&returncontext);

    /* Reset the interpreter state. */

    R_CurrentExpr = topExp;
    UNPROTECT(1);
    R_PPStackTop = savestack;
    UNPROTECT(1);
    R_CurrentExpr = topExp;
    R_ToplevelContext = saveToplevelContext;
    R_GlobalContext = saveGlobalContext;
    return R_ReturnedValue;
}