示例#1
0
/* x = array of double values
 * y = array of double values
 * length = length of y
 * output = array of double values (new y values)
 */
SEXP C_lowerConvexHull(SEXP x, SEXP y) {
  SEXP output;
  /* TODO: replace by R_xlen_t in R 3.0.0 */
  R_xlen_t n, i, j, k=0;
  int* nodes;
  double m, c;

  PROTECT(x=coerceVector(x, REALSXP));
  PROTECT(y=coerceVector(y, REALSXP));
  n=XLENGTH(x);

  PROTECT(output=allocVector(REALSXP, n));
  /* TODO: replace by R_xlen_t in R 3.0.0 */
  /* allocate vector - error handling is done by R */
  nodes=(int*) Calloc((size_t) n, int);

  double* xx=REAL(x);
  double* xy=REAL(y);
  double* xo=REAL(output);

  /* find lower convex hull */
  for (i=0; i<n; ++i) {
    while (k > 1 && !left(xx[nodes[k-2]], xy[nodes[k-2]],
                          xx[nodes[k-1]], xy[nodes[k-1]], xx[i], xy[i])) {
            k-=1;
    }
    nodes[k]=i;
    k+=1;
  }

  /* build linear function y=mx+c to calculate values between nodes */
  for (i=0; i<k; ++i) {
    m=(xy[nodes[i+1]]-xy[nodes[i]])/(xx[nodes[i+1]]-xx[nodes[i]]);
    c=xy[nodes[i]]-m*xx[nodes[i]];

    for (j=nodes[i]; j<nodes[i+1]; ++j) {
      xo[j]=m*xx[j]+c;
    }
  }

  xo[n-1]=xy[n-1];

  Free(nodes);
  UNPROTECT(3);

  return(output);
}
示例#2
0
文件: printvector.c 项目: mirror/r
void printVector(SEXP x, int indx, int quote)
{
/* print R vector x[];	if(indx) print indices; if(quote) quote strings */
    R_xlen_t n;

    if ((n = XLENGTH(x)) != 0) {
	R_xlen_t n_pr = (n <= R_print.max +1) ? n : R_print.max;
	/* '...max +1'  ==> will omit at least 2 ==> plural in msg below */
	switch (TYPEOF(x)) {
	case LGLSXP:
	    printLogicalVector(LOGICAL(x), n_pr, indx);
	    break;
	case INTSXP:
	    printIntegerVector(INTEGER(x), n_pr, indx);
	    break;
	case REALSXP:
	    printRealVector(REAL(x), n_pr, indx);
	    break;
	case STRSXP:
	    if (quote)
		printStringVector(STRING_PTR(x), n_pr, '"', indx);
	    else
		printStringVector(STRING_PTR(x), n_pr, 0, indx);
	    break;
	case CPLXSXP:
	    printComplexVector(COMPLEX(x), n_pr, indx);
	    break;
	case RAWSXP:
	    printRawVector(RAW(x), n_pr, indx);
	    break;
	}
	if(n_pr < n)
		Rprintf(" [ reached getOption(\"max.print\") -- omitted %d entries ]\n",
			n - n_pr);
    }
    else
#define PRINT_V_0						\
	switch (TYPEOF(x)) {					\
	case LGLSXP:	Rprintf("logical(0)\n");	break;	\
	case INTSXP:	Rprintf("integer(0)\n");	break;	\
	case REALSXP:	Rprintf("numeric(0)\n");	break;	\
	case CPLXSXP:	Rprintf("complex(0)\n");	break;	\
	case STRSXP:	Rprintf("character(0)\n");	break;	\
	case RAWSXP:	Rprintf("raw(0)\n");		break;	\
	}
	PRINT_V_0;
}
示例#3
0
void copyMatrix(SEXP s, SEXP t, Rboolean byrow)
{
    int nr = nrows(s), nc = ncols(s);
    R_xlen_t nt = XLENGTH(t);

    if (byrow) {
	switch (TYPEOF(s)) {
	case STRSXP:
	    FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
		SET_STRING_ELT(s, didx, STRING_ELT(t, sidx));
	    break;
	case LGLSXP:
	    FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
		LOGICAL(s)[didx] = LOGICAL(t)[sidx];
	    break;
	case INTSXP:
	    FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
		INTEGER(s)[didx] = INTEGER(t)[sidx];
	    break;
	case REALSXP:
	    FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
		REAL(s)[didx] = REAL(t)[sidx];
	    break;
	case CPLXSXP:
	    FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
		COMPLEX(s)[didx] = COMPLEX(t)[sidx];
	    break;
	case EXPRSXP:
	case VECSXP:
	    FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
		SET_VECTOR_ELT(s, didx, VECTOR_ELT(t, sidx));
	    break;
	case RAWSXP:
	    FILL_MATRIX_BYROW_ITERATE(0, nr, nc, nt)
		RAW(s)[didx] = RAW(t)[sidx];
	    break;
	default:
	    UNIMPLEMENTED_TYPE("copyMatrix", s);
	}
    }
    else
	copyVector(s, t);
}
示例#4
0
文件: character.c 项目: kalibera/rexp
/* primitive */
SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, ans;
    R_xlen_t i, len;

    checkArity(op, args);
    check1argX(args, call);

    if (isFactor(CAR(args)))
	error(_("'%s' requires a character vector"), "nzchar()");
    PROTECT(x = coerceVector(CAR(args), STRSXP));
    if (!isString(x))
	error(_("'%s' requires a character vector"), "nzchar()");
    len = XLENGTH(x);
    PROTECT(ans = allocVector(LGLSXP, len));
    for (i = 0; i < len; i++)
	LOGICAL(ans)[i] = LENGTH(STRING_ELT(x, i)) > 0;
    UNPROTECT(2);
    return ans;
}
示例#5
0
int inla_R_funcall2(int *n_out, double **x_out, const char *function, const char *tag, int n, double *x)
{
	/*
	 * Call function(tag,x), where x is a double vector of length n. output is 'x_out' with length 'n_out'
	 */

	inla_R_init();
#pragma omp critical
	{
		if (R_debug)
			fprintf(stderr, "R-interface[%1d]: funcall2: function [%s] tag [%s] n [%1d]\n",
			omp_get_thread_num(), function, tag, n);

		int error, i;
		SEXP yy, xx, result, e;

		PROTECT(yy = mkString((tag ? tag : "<<<NoTag>>>")));
		PROTECT(xx = allocVector(REALSXP, n));
		for(i=0; i<n; i++) {
			REAL(xx)[i] = x[i];
		}
		if (tag) {
			PROTECT(e = lang3(install(function), yy, xx));
		} else {
			PROTECT(e = lang2(install(function), xx));
		}
		PROTECT(result = R_tryEval(e, R_GlobalEnv, &error));
		if (error){
			fprintf(stderr, "\n *** ERROR *** Calling R-function [%s] with tag [%s] and [%1d] arguments\n",
				function, tag, n);
			exit(1);
		}
		*n_out = (int) XLENGTH(result);
		*x_out = (double *) calloc((size_t) *n_out, sizeof(double)); /* otherwise I'' use the R-version... */
		for(i = 0; i< *n_out; i++) {
			(*x_out)[i] = REAL(result)[i];
		}
		UNPROTECT(4);
	}
	return INLA_OK;
}
示例#6
0
文件: character.c 项目: kalibera/rexp
SEXP attribute_hidden do_abbrev(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, ans;
    R_xlen_t i, len;
    int minlen;
    Rboolean warn = FALSE;
    const char *s;
    const void *vmax;

    checkArity(op,args);
    x = CAR(args);

    if (!isString(x))
	error(_("the first argument must be a character vector"));
    len = XLENGTH(x);

    PROTECT(ans = allocVector(STRSXP, len));
    minlen = asInteger(CADR(args));
    vmax = vmaxget();
    for (i = 0 ; i < len ; i++) {
	if (STRING_ELT(x, i) == NA_STRING)
	    SET_STRING_ELT(ans, i, NA_STRING);
	else {
	    s = translateChar(STRING_ELT(x, i));
	    if(strlen(s) > minlen) {
		warn = warn | !strIsASCII(s);
		R_AllocStringBuffer(strlen(s), &cbuff);
		SET_STRING_ELT(ans, i, stripchars(s, minlen));
	    } else SET_STRING_ELT(ans, i, mkChar(s));
	}
	vmaxset(vmax);
    }
    if (warn) warning(_("abbreviate used with non-ASCII chars"));
    DUPLICATE_ATTRIB(ans, x);
    /* This copied the class, if any */
    R_FreeStringBufferL(&cbuff);
    UNPROTECT(1);
    return(ans);
}
示例#7
0
SEXP attribute_hidden complex_unary(ARITHOP_TYPE code, SEXP s1, SEXP call)
{
    R_xlen_t i, n;
    SEXP ans;

    switch(code) {
    case PLUSOP:
	return s1;
    case MINUSOP:
	ans = NO_REFERENCES(s1) ? s1 : duplicate(s1);
	n = XLENGTH(s1);
	for (i = 0; i < n; i++) {
	    Rcomplex x = COMPLEX(s1)[i];
	    COMPLEX(ans)[i].r = -x.r;
	    COMPLEX(ans)[i].i = -x.i;
	}
	return ans;
    default:
	errorcall(call, _("invalid complex unary operator"));
    }
    return R_NilValue; /* -Wall */
}
示例#8
0
文件: list.cpp 项目: csilles/cxxr
static void namewalk(SEXP s, NameWalkData *d)
{
    SEXP name;

    switch(TYPEOF(s)) {
    case SYMSXP:
	name = PRINTNAME(s);
	/* skip blank symbols */
	if(CHAR(name)[0] == '\0') goto ignore;
	if(d->ItemCounts < d->MaxCount) {
	    if(d->StoreValues) {
		if(d->UniqueNames) {
		    for(int j = 0 ; j < d->ItemCounts ; j++) {
			if(STRING_ELT(d->ans, j) == name)
			    goto ignore;
		    }
		}
		SET_STRING_ELT(d->ans, d->ItemCounts, name);
	    }
	    d->ItemCounts++;
	}
    ignore:
	break;
    case LANGSXP:
	if(!d->IncludeFunctions) s = CDR(s);
	while(s != R_NilValue) {
	    namewalk(CAR(s), d);
	    s = CDR(s);
	}
	break;
    case EXPRSXP:
	for(R_xlen_t i = 0 ; i < XLENGTH(s) ; i++)
	    namewalk(XVECTOR_ELT(s, i), d);
	break;
    default:
	/* it seems the intention is to do nothing here! */
	break;
    }
}
示例#9
0
文件: fork.c 项目: krlmlr/r-source
SEXP mc_send_child_stdin(SEXP sPid, SEXP what) 
{
    int pid = asInteger(sPid);
    if (!is_master) 
	error(_("only the master process can send data to a child process"));
    if (TYPEOF(what) != RAWSXP) error("what must be a raw vector");
    child_info_t *ci = children;
    while (ci) {
	if (ci->pid == pid) break;
	ci = ci -> next;
    }
    if (!ci) error(_("child %d does not exist"), pid);
    R_xlen_t  len = XLENGTH(what);
    unsigned char *b = RAW(what);
     unsigned int fd = ci -> sifd;
    for (R_xlen_t i = 0; i < len;) {
	ssize_t n = write(fd, b + i, len - i);
	if (n < 1) error(_("write error"));
	i += n;
    }
    return ScalarLogical(1);
}
示例#10
0
/* primitive */
SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, ans;
    int nargs = length(args);

    // checkArity(op, args);  .Primitive()  &  may have 1 or 2 args now
    if (nargs < 1 || nargs > 2)
	errorcall(call,
		  ngettext("%d argument passed to '%s' which requires %d to %d",
			   "%d arguments passed to '%s' which requires %d to %d",
			   (unsigned long) nargs),
		  nargs, PRIMNAME(op), 1, 2);
    check1arg(args, call, "x");

    if (isFactor(CAR(args)))
	error(_("'%s' requires a character vector"), "nzchar()");
    PROTECT(x = coerceVector(CAR(args), STRSXP));
    if (!isString(x))
	error(_("'%s' requires a character vector"), "nzchar()");

    int keepNA = FALSE; // the default
    if(nargs > 1) {
	keepNA = asLogical(CADR(args));
	if (keepNA == NA_LOGICAL) keepNA = FALSE;
    }
    R_xlen_t i, len = XLENGTH(x);
    PROTECT(ans = allocVector(LGLSXP, len));
    if (keepNA)
	for (i = 0; i < len; i++) {
	    SEXP sxi = STRING_ELT(x, i);
	    LOGICAL(ans)[i] = (sxi == NA_STRING) ? NA_LOGICAL : LENGTH(sxi) > 0;
	}
    else
	for (i = 0; i < len; i++)
	    LOGICAL(ans)[i] = LENGTH(STRING_ELT(x, i)) > 0;
    UNPROTECT(2);
    return ans;
}
示例#11
0
文件: array.c 项目: kalibera/rexp
SEXP attribute_hidden do_earg_matrix(SEXP call, SEXP op, SEXP arg_vals, SEXP arg_snr, SEXP arg_snc, SEXP arg_byrow, 
    SEXP arg_dimnames, SEXP arg_miss_nr, SEXP arg_miss_nc, SEXP rho)
{
    SEXP vals, ans, snr, snc, dimnames;
    int nr = 1, nc = 1, byrow, miss_nr, miss_nc;
    R_xlen_t lendat;

    vals = arg_vals;
    switch(TYPEOF(vals)) {
	case LGLSXP:
	case INTSXP:
	case REALSXP:
	case CPLXSXP:
	case STRSXP:
	case RAWSXP:
	case EXPRSXP:
	case VECSXP:
	    break;
	default:
	    error(_("'data' must be of a vector type, was '%s'"),
		type2char(TYPEOF(vals)));
    }
    lendat = XLENGTH(vals);
    snr = arg_snr;
    snc = arg_snc;
    byrow = asLogical(arg_byrow);
    if (byrow == NA_INTEGER)
	error(_("invalid '%s' argument"), "byrow");
    dimnames = arg_dimnames;
    miss_nr = asLogical(arg_miss_nr);
    miss_nc = asLogical(arg_miss_nc);

    if (!miss_nr) {
	if (!isNumeric(snr)) error(_("non-numeric matrix extent"));
	nr = asInteger(snr);
	if (nr == NA_INTEGER)
	    error(_("invalid 'nrow' value (too large or NA)"));
	if (nr < 0)
	    error(_("invalid 'nrow' value (< 0)"));
    }
    if (!miss_nc) {
	if (!isNumeric(snc)) error(_("non-numeric matrix extent"));
	nc = asInteger(snc);
	if (nc == NA_INTEGER)
	    error(_("invalid 'ncol' value (too large or NA)"));
	if (nc < 0)
	    error(_("invalid 'ncol' value (< 0)"));
    }
    if (miss_nr && miss_nc) {
	if (lendat > INT_MAX) error("data is too long");
	nr = (int) lendat;
    } else if (miss_nr) {
	if (lendat > (double) nc * INT_MAX) error("data is too long");
	// avoid division by zero
	if (nc == 0) {
	    if (lendat) error(_("nc = 0 for non-null data"));
	    else nr = 0;
	} else
	    nr = (int) ceil((double) lendat / (double) nc);
    } else if (miss_nc) {
	if (lendat > (double) nr * INT_MAX) error("data is too long");
	// avoid division by zero
	if (nr == 0) {
	    if (lendat) error(_("nr = 0 for non-null data"));
	    else nc = 0;
	} else
	    nc = (int) ceil((double) lendat / (double) nr);
    }

    if(lendat > 0) {
	R_xlen_t nrc = (R_xlen_t) nr * nc;
	if (lendat > 1 && nrc % lendat != 0) {
	    if (((lendat > nr) && (lendat / nr) * nr != lendat) ||
		((lendat < nr) && (nr / lendat) * lendat != nr))
		warning(_("data length [%d] is not a sub-multiple or multiple of the number of rows [%d]"), lendat, nr);
	    else if (((lendat > nc) && (lendat / nc) * nc != lendat) ||
		     ((lendat < nc) && (nc / lendat) * lendat != nc))
		warning(_("data length [%d] is not a sub-multiple or multiple of the number of columns [%d]"), lendat, nc);
	}
	else if ((lendat > 1) && (nrc == 0)){
	    warning(_("data length exceeds size of matrix"));
	}
    }

#ifndef LONG_VECTOR_SUPPORT
    if ((double)nr * (double)nc > INT_MAX)
	error(_("too many elements specified"));
#endif

    PROTECT(ans = allocMatrix(TYPEOF(vals), nr, nc));
    if(lendat) {
	if (isVector(vals))
	    copyMatrix(ans, vals, byrow);
	else
	    copyListMatrix(ans, vals, byrow);
    } else if (isVector(vals)) { /* fill with NAs */
	R_xlen_t N = (R_xlen_t) nr * nc, i;
	switch(TYPEOF(vals)) {
	case STRSXP:
	    for (i = 0; i < N; i++)
		SET_STRING_ELT(ans, i, NA_STRING);
	    break;
	case LGLSXP:
	    for (i = 0; i < N; i++)
		LOGICAL(ans)[i] = NA_LOGICAL;
	    break;
	case INTSXP:
	    for (i = 0; i < N; i++)
		INTEGER(ans)[i] = NA_INTEGER;
	    break;
	case REALSXP:
	    for (i = 0; i < N; i++)
		REAL(ans)[i] = NA_REAL;
	    break;
	case CPLXSXP:
	    {
		Rcomplex na_cmplx;
		na_cmplx.r = NA_REAL;
		na_cmplx.i = 0;
		for (i = 0; i < N; i++)
		    COMPLEX(ans)[i] = na_cmplx;
	    }
	    break;
	case RAWSXP:
	    memset(RAW(ans), 0, N);
	    break;
	default:
	    /* don't fill with anything */
	    ;
	}
    }
    if(!isNull(dimnames)&& length(dimnames) > 0)
	ans = dimnamesgets(ans, dimnames);
    UNPROTECT(1);
    return ans;
}
示例#12
0
文件: seq.c 项目: kalibera/rexp
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, x, times = R_NilValue /* -Wall */;
    int each = 1, nprotect = 3;
    R_xlen_t i, lx, len = NA_INTEGER, nt;
    static SEXP do_rep_formals = NULL;

    /* includes factors, POSIX[cl]t, Date */
    if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
	return(ans);

    /* This has evaluated all the non-missing arguments into ans */
    PROTECT(args = ans);

    /* This is a primitive, and we have not dispatched to a method
       so we manage the argument matching ourselves.  We pretend this is
       rep(x, times, length.out, each, ...)
    */
    if (do_rep_formals == NULL) {
        do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
        R_PreserveObject(do_rep_formals);
        SET_TAG(do_rep_formals, R_XSymbol);
        SET_TAG(CDR(do_rep_formals), install("times"));
        SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
        SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
        SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
    }
    PROTECT(args = matchArgs(do_rep_formals, args, call));

    x = CAR(args);
    /* supported in R 2.15.x */
    if (TYPEOF(x) == LISTSXP)
	errorcall(call, "replication of pairlists is defunct");

    lx = xlength(x);

    double slen = asReal(CADDR(args));
    if (R_FINITE(slen)) {
	if(slen < 0)
	    errorcall(call, _("invalid '%s' argument"), "length.out");
	len = (R_xlen_t) slen;
    } else {
	len = asInteger(CADDR(args));
	if(len != NA_INTEGER && len < 0)
	    errorcall(call, _("invalid '%s' argument"), "length.out");
    }
    if(length(CADDR(args)) != 1)
	warningcall(call, _("first element used of '%s' argument"), 
		    "length.out");

    each = asInteger(CADDDR(args));
    if(each != NA_INTEGER && each < 0)
	errorcall(call, _("invalid '%s' argument"), "each");
    if(length(CADDDR(args)) != 1)
	warningcall(call, _("first element used of '%s' argument"), "each");
    if(each == NA_INTEGER) each = 1;

    if(lx == 0) {
	if(len > 0 && x == R_NilValue) 
	    warningcall(call, "'x' is NULL so the result will be NULL");
	SEXP a;
	PROTECT(a = duplicate(x));
	if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
	UNPROTECT(3);
	return a;
    }
    if (!isVector(x))
	errorcall(call, "attempt to replicate an object of type '%s'",
		  type2char(TYPEOF(x)));

    /* So now we know x is a vector of positive length.  We need to
       replicate it, and its names if it has them. */

    /* First find the final length using 'times' and 'each' */
    if(len != NA_INTEGER) { /* takes precedence over times */
	nt = 1;
    } else {
	R_xlen_t sum = 0;
	if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
	else PROTECT(times = coerceVector(CADR(args), INTSXP));
	nprotect++;
	nt = XLENGTH(times);
	if(nt != 1 && nt != lx * each)
	    errorcall(call, _("invalid '%s' argument"), "times");
	if(nt == 1) {
	    int it = INTEGER(times)[0];
	    if (it == NA_INTEGER || it < 0)
		errorcall(call, _("invalid '%s' argument"), "times");
	    len = lx * it * each;
	} else {
	    for(i = 0; i < nt; i++) {
		int it = INTEGER(times)[i];
		if (it == NA_INTEGER || it < 0)
		    errorcall(call, _("invalid '%s' argument"), "times");
		sum += it;
	    }
            len = sum;
	}
    }

    if(len > 0 && each == 0)
	errorcall(call, _("invalid '%s' argument"), "each");

    SEXP xn = getNamesAttrib(x);

    PROTECT(ans = rep4(x, times, len, each, nt));
    if (length(xn) > 0)
	setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));

#ifdef _S4_rep_keepClass
    if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
	setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
	SET_S4_OBJECT(ans);
    }
#endif
    UNPROTECT(nprotect);
    return ans;
}
示例#13
0
SEXP attribute_hidden do_makenames(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP arg, ans;
    R_xlen_t i, n;
    int l, allow_;
    char *p, *tmp = NULL, *cbuf;
    const char *This;
    Rboolean need_prefix;
    const void *vmax;

    checkArity(op ,args);
    arg = CAR(args);
    if (!isString(arg))
	error(_("non-character names"));
    n = XLENGTH(arg);
    allow_ = asLogical(CADR(args));
    if (allow_ == NA_LOGICAL)
	error(_("invalid '%s' value"), "allow_");
    PROTECT(ans = allocVector(STRSXP, n));
    vmax = vmaxget();
    for (i = 0 ; i < n ; i++) {
	This = translateChar(STRING_ELT(arg, i));
	l = (int) strlen(This);
	/* need to prefix names not beginning with alpha or ., as
	   well as . followed by a number */
	need_prefix = FALSE;
	if (mbcslocale && This[0]) {
	    int nc = l, used;
	    wchar_t wc;
	    mbstate_t mb_st;
	    const char *pp = This;
	    mbs_init(&mb_st);
	    used = (int) Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st);
	    pp += used; nc -= used;
	    if (wc == L'.') {
		if (nc > 0) {
		    Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st);
		    if (iswdigit(wc))  need_prefix = TRUE;
		}
	    } else if (!iswalpha(wc)) need_prefix = TRUE;
	} else {
	    if (This[0] == '.') {
		if (l >= 1 && isdigit(0xff & (int) This[1])) need_prefix = TRUE;
	    } else if (!isalpha(0xff & (int) This[0])) need_prefix = TRUE;
	}
	if (need_prefix) {
	    tmp = Calloc(l+2, char);
	    strcpy(tmp, "X");
	    strcat(tmp, translateChar(STRING_ELT(arg, i)));
	} else {
	    tmp = Calloc(l+1, char);
	    strcpy(tmp, translateChar(STRING_ELT(arg, i)));
	}
	if (mbcslocale) {
	    /* This cannot lengthen the string, so safe to overwrite it.
	       Would also be possible a char at a time.
	     */
	    int nc = (int) mbstowcs(NULL, tmp, 0);
	    wchar_t *wstr = Calloc(nc+1, wchar_t), *wc;
	    if (nc >= 0) {
		mbstowcs(wstr, tmp, nc+1);
		for (wc = wstr; *wc; wc++) {
		    if (*wc == L'.' || (allow_ && *wc == L'_'))
			/* leave alone */;
		    else if (!iswalnum((int)*wc)) *wc = L'.';
		    /* If it changes into dot here,
		     * length will become short on mbcs.
		     * The name which became short will contain garbage.
		     * cf.
		     *   >  make.names(c("\u30fb"))
		     *   [1] "X.\0"
		     */
		}
		wcstombs(tmp, wstr, strlen(tmp)+1);
		Free(wstr);
	    } else error(_("invalid multibyte string %d"), i+1);
	} else {
	    for (p = tmp; *p; p++) {
示例#14
0
文件: subset.c 项目: jagdeesh109/RRO
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx, SEXP call)
{
    R_xlen_t i, ii, n, nx;
    int mode, mi;
    SEXP tmp, tmp2;
    mode = TYPEOF(x);
    mi = TYPEOF(indx);
    n = XLENGTH(indx);
    nx = xlength(x);
    tmp = result;

    if (x == R_NilValue)
	return x;

    for (i = 0; i < n; i++) {
	switch(mi) {
	case REALSXP:
	    if(!R_FINITE(REAL(indx)[i])) ii = NA_INTEGER;
	    else ii = (R_xlen_t) (REAL(indx)[i] - 1);
	    break;
	default:
	    ii = INTEGER(indx)[i];
	    if (ii != NA_INTEGER) ii--;
	}
	switch (mode) {
	    /* NA_INTEGER < 0, so some of this is redundant */
	case LGLSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		LOGICAL(result)[i] = LOGICAL(x)[ii];
	    else
		LOGICAL(result)[i] = NA_INTEGER;
	    break;
	case INTSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		INTEGER(result)[i] = INTEGER(x)[ii];
	    else
		INTEGER(result)[i] = NA_INTEGER;
	    break;
	case REALSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		REAL(result)[i] = REAL(x)[ii];
	    else
		REAL(result)[i] = NA_REAL;
	    break;
	case CPLXSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER) {
		COMPLEX(result)[i] = COMPLEX(x)[ii];
	    } else {
		COMPLEX(result)[i].r = NA_REAL;
		COMPLEX(result)[i].i = NA_REAL;
	    }
	    break;
	case STRSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		SET_STRING_ELT(result, i, STRING_ELT(x, ii));
	    else
		SET_STRING_ELT(result, i, NA_STRING);
	    break;
	case VECSXP:
	case EXPRSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
	    else
		SET_VECTOR_ELT(result, i, R_NilValue);
	    break;
	case LISTSXP:
	    /* cannot happen: pairlists are coerced to lists */
	case LANGSXP:
#ifdef LONG_VECTOR_SUPPORT
	    if (ii > R_SHORT_LEN_MAX)
		error("invalid subscript for pairlist");
#endif
	    if (0 <= ii && ii < nx && ii != NA_INTEGER) {
		tmp2 = nthcdr(x, (int) ii);
		SETCAR(tmp, CAR(tmp2));
		SET_TAG(tmp, TAG(tmp2));
	    }
	    else
		SETCAR(tmp, R_NilValue);
	    tmp = CDR(tmp);
	    break;
	case RAWSXP:
	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
		RAW(result)[i] = RAW(x)[ii];
	    else
		RAW(result)[i] = (Rbyte) 0;
	    break;
	default:
	    errorcall(call, R_MSG_ob_nonsub, type2char(mode));
	}
    }
    return result;
}
示例#15
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;
}
示例#16
0
RVector::RVector(SEXP vector)
    : size_(XLENGTH(vector)), capacity_(XLENGTH(vector)), vector(vector) {
    assert(TYPEOF(vector) == VECSXP);
    R_PreserveObject(vector);
}
示例#17
0
文件: subset.c 项目: jagdeesh109/RRO
/* This is for all cases with a single index, including 1D arrays and
   matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
    R_xlen_t n;
    int mode;
    R_xlen_t stretch = 1;
    SEXP indx, result, attrib, nattrib;

    if (s == R_MissingArg) return duplicate(x);

    PROTECT(s);
    attrib = getAttrib(x, R_DimSymbol);

    /* Check to see if we have special matrix subscripting. */
    /* If we do, make a real subscript vector and protect it. */

    if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
        if (isString(s)) {
            s = strmat2intmat(s, GetArrayDimnames(x), call);
            UNPROTECT(1);
            PROTECT(s);
        }
        if (isInteger(s) || isReal(s)) {
            s = mat2indsub(attrib, s, call);
            UNPROTECT(1);
            PROTECT(s);
        }
    }

    /* Convert to a vector of integer subscripts */
    /* in the range 1:length(x). */

    PROTECT(indx = makeSubscript(x, s, &stretch, call));
    n = XLENGTH(indx);

    /* Allocate the result. */

    mode = TYPEOF(x);
    /* No protection needed as ExtractSubset does not allocate */
    result = allocVector(mode, n);
    if (mode == VECSXP || mode == EXPRSXP)
	/* we do not duplicate the values when extracting the subset,
	   so to be conservative mark the result as NAMED = 2 */
	SET_NAMED(result, 2);

    PROTECT(result = ExtractSubset(x, result, indx, call));
    if (result != R_NilValue) {
	if (
	    ((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
	    ( /* here we might have an array.  Use row names if 1D */
		isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
		(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
		(attrib = GetRowNames(attrib)) != R_NilValue
		)
	    ) {
	    PROTECT(attrib);
	    nattrib = allocVector(TYPEOF(attrib), n);
	    PROTECT(nattrib); /* seems unneeded */
	    nattrib = ExtractSubset(attrib, nattrib, indx, call);
	    setAttrib(result, R_NamesSymbol, nattrib);
	    UNPROTECT(2); /* attrib, nattrib */
	}
	if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
	    TYPEOF(attrib) == VECSXP) {
	    nattrib = allocVector(VECSXP, n);
	    PROTECT(nattrib); /* seems unneeded */
	    nattrib = ExtractSubset(attrib, nattrib, indx, call);
	    setAttrib(result, R_SrcrefSymbol, nattrib);
	    UNPROTECT(1);
	}
	/* FIXME:  this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
	if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
	    setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
	    SET_S4_OBJECT(result);
	}
#endif
    }
    UNPROTECT(3);
    return result;
}
示例#18
0
void CodeVerifier::verifyFunctionLayout(SEXP sexp, InterpreterInstance* ctx) {
    if (TYPEOF(sexp) != EXTERNALSXP)
        Rf_error("RIR Verifier: Invalid SEXPTYPE");
    Function* f = Function::unpack(sexp);

    // get the code objects
    std::vector<Code*> objs;
    objs.push_back(f->body());
    for (size_t i = 0; i < f->numArgs; ++i)
        if (f->defaultArg(i))
            objs.push_back(f->defaultArg(i));

    if (f->size > XLENGTH(sexp))
        Rf_error("RIR Verifier: Reported size must be smaller than the size of "
                 "the vector");

    // check that the call instruction has proper arguments and number of
    // instructions is valid
    while (!objs.empty()) {
        auto c = objs.back();
        objs.pop_back();

        if (c->info.magic != CODE_MAGIC)
            Rf_error("RIR Verifier: Invalid code magic number");
        if (c->src == 0)
            Rf_error("RIR Verifier: Code must have AST");
        unsigned oldo = c->stackLength;
        calculateAndVerifyStack(c);
        if (oldo != c->stackLength)
            Rf_error("RIR Verifier: Invalid stack layout reported");

        if (((uintptr_t)(c + 1) + pad4(c->codeSize) +
             c->srcLength * sizeof(Code::SrclistEntry)) == 0)
            Rf_error("RIR Verifier: Invalid code length reported");

        Opcode* cptr = c->code();
        Opcode* start = cptr;
        Opcode* end = start + c->codeSize;
        while (true) {
            if (cptr > end)
                Rf_error("RIR Verifier: Bytecode overflow");
            BC cur = BC::decode(cptr, c);
            switch (hasSources(cur.bc)) {
            case Sources::Required:
                if (c->getSrcIdxAt(cptr, true) == 0)
                    Rf_error("RIR Verifier: Source required but not found");
                break;
            case Sources::NotNeeded:
                if (c->getSrcIdxAt(cptr, true) != 0)
                    Rf_error("RIR Verifier: Sources not needed but stored");
                break;
            case Sources::May: {
            }
            }
            if (*cptr == Opcode::br_ || *cptr == Opcode::brobj_ ||
                *cptr == Opcode::brtrue_ || *cptr == Opcode::brfalse_) {
                int off = *reinterpret_cast<int*>(cptr + 1);
                if (cptr + cur.size() + off < start ||
                    cptr + cur.size() + off > end)
                    Rf_error("RIR Verifier: Branch outside closure");
            }
            if (*cptr == Opcode::ldvar_) {
                unsigned* argsIndex = reinterpret_cast<Immediate*>(cptr + 1);
                if (*argsIndex >= cp_pool_length(ctx))
                    Rf_error("RIR Verifier: Invalid arglist index");
                SEXP sym = cp_pool_at(ctx, *argsIndex);
                if (TYPEOF(sym) != SYMSXP)
                    Rf_error("RIR Verifier: LdVar binding not a symbol");
                if (!(strlen(CHAR(PRINTNAME(sym)))))
                    Rf_error("RIR Verifier: LdVar empty binding name");
            }
            if (*cptr == Opcode::promise_) {
                unsigned* promidx = reinterpret_cast<Immediate*>(cptr + 1);
                objs.push_back(c->getPromise(*promidx));
            }
            if (*cptr == Opcode::ldarg_) {
                unsigned idx = *reinterpret_cast<Immediate*>(cptr + 1);
                if (idx >= MAX_ARG_IDX)
                    Rf_error("RIR Verifier: Loading out of index argument");
            }
            if (*cptr == Opcode::call_implicit_ ||
                *cptr == Opcode::named_call_implicit_) {
                uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);

                for (size_t i = 0, e = nargs; i != e; ++i) {
                    uint32_t offset = cur.callExtra().immediateCallArguments[i];
                    if (offset == MISSING_ARG_IDX || offset == DOTS_ARG_IDX)
                        continue;
                    objs.push_back(c->getPromise(offset));
                }
                if (*cptr == Opcode::named_call_implicit_) {
                    for (size_t i = 0, e = nargs; i != e; ++i) {
                        uint32_t offset = cur.callExtra().callArgumentNames[i];
                        if (offset) {
                            SEXP name = cp_pool_at(ctx, offset);
                            if (TYPEOF(name) != SYMSXP && name != R_NilValue)
                                Rf_error("RIR Verifier: Calling target not a "
                                         "symbol");
                        }
                    }
                }
            }
            if (*cptr == Opcode::named_call_) {
                uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);
                for (size_t i = 0, e = nargs; i != e; ++i) {
                    uint32_t offset = cur.callExtra().callArgumentNames[i];
                    if (offset) {
                        SEXP name = cp_pool_at(ctx, offset);
                        if (TYPEOF(name) != SYMSXP && name != R_NilValue)
                            Rf_error(
                                "RIR Verifier: Calling target not a symbol");
                    }
                }
            }
            if (*cptr == Opcode::mk_env_ || *cptr == Opcode::mk_stub_env_) {
                uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);
                for (size_t i = 0, e = nargs; i != e; ++i) {
                    uint32_t offset = cur.mkEnvExtra().names[i];
                    SEXP name = cp_pool_at(ctx, offset);
                    if (TYPEOF(name) != SYMSXP)
                        Rf_error(
                            "RIR Verifier: environment argument not a symbol");
                }
            }

            cptr += cur.size();
            if (cptr == start + c->codeSize) {
                if (!(cur.isJmp() && cur.immediate.offset < 0) &&
                    !(cur.isExit()))
                    Rf_error("RIR Verifier: Last opcode should jump backwards "
                             "or exit");
                break;
            }
        }
    }
}
示例#19
0
/* ----- gather ----- */
SEXP spmd_gather_integer(SEXP R_send_data, SEXP R_recv_data,
		SEXP R_rank_dest, SEXP R_comm){
#ifdef LONG_VECTOR_SUPPORT
	SEXP R_buff_data;
	int *C_send_data = INTEGER(R_send_data),
	    *C_recv_data = INTEGER(R_recv_data),
	    *C_recv_data_fix = INTEGER(R_recv_data),
	    *C_buff_data,
	    *C_buff_data_fix;
	R_xlen_t C_length_send_data = XLENGTH(R_send_data),
	         C_length_send_data_fix = XLENGTH(R_send_data);
	int C_rank_dest = INTEGER(R_rank_dest)[0],
	    C_comm = INTEGER(R_comm)[0], C_comm_size, C_comm_rank, i;

	if(C_length_send_data > SPMD_SHORT_LEN_MAX){
		/* R_send_data is a long vector, so is R_recv_data. */

		/* Since C_recv_data is not contiguious, use extra buffer to
		   store chunk data for MPI calls. */
		MPI_Comm_size(comm[C_comm], &C_comm_size);
		MPI_Comm_rank(comm[C_comm], &C_comm_rank);
		if(C_comm_rank == C_rank_dest){
			PROTECT(R_buff_data = allocVector(INTSXP,
				(R_xlen_t) C_comm_size *
				(R_xlen_t) SPMD_SHORT_LEN_MAX));
		} else{
			PROTECT(R_buff_data = allocVector(INTSXP, 1));
		}
		C_buff_data = INTEGER(R_buff_data);
		C_buff_data_fix = INTEGER(R_buff_data);

		/* Loop through all. */
		while(C_length_send_data > SPMD_SHORT_LEN_MAX){
			#if (MPI_LONG_DEBUG & 1) == 1
				if(C_comm_rank == C_rank_dest){
					Rprintf("C_length_send_data: %ld\n",
						C_length_send_data);
				}
			#endif

			/* Send C_send_data out to C_buff_data. */
			spmd_errhandler(MPI_Gather(C_send_data,
				SPMD_SHORT_LEN_MAX,
				MPI_INT, C_buff_data, SPMD_SHORT_LEN_MAX,
				MPI_INT, C_rank_dest, comm[C_comm]));
			C_send_data = C_send_data + SPMD_SHORT_LEN_MAX;

			/* Memory copy from C_buff_data to C_recv_data. */
			if(C_comm_rank == C_rank_dest){
				for(i = 0; i < C_comm_size; i++){
					memcpy(C_recv_data, C_buff_data,
						SPMD_SHORT_LEN_MAX *
						sizeof(int));
					C_recv_data = C_recv_data +
						C_length_send_data_fix;
					C_buff_data = C_buff_data +
						SPMD_SHORT_LEN_MAX;
				}
				C_recv_data_fix = C_recv_data_fix +
					SPMD_SHORT_LEN_MAX;
				C_recv_data = C_recv_data_fix;
			}
			C_buff_data = C_buff_data_fix;
			C_length_send_data = C_length_send_data -
				SPMD_SHORT_LEN_MAX;
		}

		/* Remainder. */
		if(C_length_send_data > 0){
			#if (MPI_LONG_DEBUG & 1) == 1
				if(C_comm_rank == C_rank_dest){
					Rprintf("C_length_send_data: %ld\n",
						C_length_send_data);
				}
			#endif

			/* Send C_send_data out to C_buff_data. */
			spmd_errhandler(MPI_Gather(C_send_data,
				(int) C_length_send_data,
				MPI_INT, C_buff_data, (int) C_length_send_data,
				MPI_INT, C_rank_dest, comm[C_comm]));

			/* Memory copy from C_buff_data to C_recv_data. */
			if(C_comm_rank == C_rank_dest){
				for(i = 0; i < C_comm_size; i++){
					memcpy(C_recv_data, C_buff_data,
						(int) C_length_send_data *
						sizeof(int));
					C_recv_data = C_recv_data +
						C_length_send_data_fix;
					C_buff_data = C_buff_data +
						C_length_send_data;
				}
			}
		}

		UNPROTECT(1);
	} else{
		/* It doesn't matter if R_recv_data is a long vector or not,
		   since pointer address is already long int.*/
		spmd_errhandler(MPI_Gather(C_send_data,
			(int) C_length_send_data,
			MPI_INT, C_recv_data, (int) C_length_send_data,
			MPI_INT, C_rank_dest, comm[C_comm]));
	}
#else
	int C_length_send_data = LENGTH(R_send_data);
	spmd_errhandler(MPI_Gather(INTEGER(R_send_data), C_length_send_data,
		MPI_INT, INTEGER(R_recv_data), C_length_send_data,
		MPI_INT, INTEGER(R_rank_dest)[0], comm[INTEGER(R_comm)[0]]));
#endif
	return(R_recv_data);
} /* End of spmd_gather_integer(). */
示例#20
0
文件: character.c 项目: kalibera/rexp
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP d, s, x, stype;
    R_xlen_t i, len;
    int allowNA;
    size_t ntype;
    int nc;
    const char *type;
    const char *xi;
    wchar_t *wc;
    const void *vmax;

    checkArity(op, args);
    if (isFactor(CAR(args)))
	error(_("'%s' requires a character vector"), "nchar()");
    PROTECT(x = coerceVector(CAR(args), STRSXP));
    if (!isString(x))
	error(_("'%s' requires a character vector"), "nchar()");
    len = XLENGTH(x);
    stype = CADR(args);
    if (!isString(stype) || LENGTH(stype) != 1)
	error(_("invalid '%s' argument"), "type");
    type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
    ntype = strlen(type);
    if (ntype == 0) error(_("invalid '%s' argument"), "type");
    allowNA = asLogical(CADDR(args));
    if (allowNA == NA_LOGICAL) allowNA = 0;

    PROTECT(s = allocVector(INTSXP, len));
    vmax = vmaxget();
    for (i = 0; i < len; i++) {
	SEXP sxi = STRING_ELT(x, i);
	if (sxi == NA_STRING) {
	    INTEGER(s)[i] = 2;
	    continue;
	}
	if (strncmp(type, "bytes", ntype) == 0) {
	    INTEGER(s)[i] = LENGTH(sxi);
	} else if (strncmp(type, "chars", ntype) == 0) {
	    if (IS_UTF8(sxi)) { /* assume this is valid */
		const char *p = CHAR(sxi);
		nc = 0;
		for( ; *p; p += utf8clen(*p)) nc++;
		INTEGER(s)[i] = nc;
	    } else if (IS_BYTES(sxi)) {
		if (!allowNA) /* could do chars 0 */
		    error(_("number of characters is not computable for element %d in \"bytes\" encoding"), i+1);
		INTEGER(s)[i] = NA_INTEGER;
	    } else if (mbcslocale) {
		nc = (int) mbstowcs(NULL, translateChar(sxi), 0);
		if (!allowNA && nc < 0)
		    error(_("invalid multibyte string %d"), i+1);
		INTEGER(s)[i] = nc >= 0 ? nc : NA_INTEGER;
	    } else
		INTEGER(s)[i] = (int) strlen(translateChar(sxi));
	} else if (strncmp(type, "width", ntype) == 0) {
	    if (IS_UTF8(sxi)) { /* assume this is valid */
		const char *p = CHAR(sxi);
		wchar_t wc1;
		nc = 0;
		for( ; *p; p += utf8clen(*p)) {
		    utf8toucs(&wc1, p);
		    nc += Ri18n_wcwidth(wc1);
		}
		INTEGER(s)[i] = nc;
	    } else if (IS_BYTES(sxi)) {
		if (!allowNA) /* could do width 0 */
		    error(_("width is not computable for element %d in \"bytes\" encoding"), i+1);
		INTEGER(s)[i] = NA_INTEGER;
	    } else if (mbcslocale) {
		xi = translateChar(sxi);
		nc = (int) mbstowcs(NULL, xi, 0);
		if (nc >= 0) {
		    wc = (wchar_t *) R_AllocStringBuffer((nc+1)*sizeof(wchar_t), &cbuff);

		    mbstowcs(wc, xi, nc + 1);
		    INTEGER(s)[i] = Ri18n_wcswidth(wc, 2147483647);
		    if (INTEGER(s)[i] < 1) INTEGER(s)[i] = nc;
		} else if (allowNA)
		    error(_("invalid multibyte string %d"), i+1);
		else
		    INTEGER(s)[i] = NA_INTEGER;
	    } else
		INTEGER(s)[i] = (int) strlen(translateChar(sxi));
	} else
	    error(_("invalid '%s' argument"), "type");
	vmaxset(vmax);
    }
    R_FreeStringBufferL(&cbuff);
    if ((d = getNamesAttrib(x)) != R_NilValue)
	setAttrib(s, R_NamesSymbol, d);
    if ((d = getDimAttrib(x)) != R_NilValue)
	setAttrib(s, R_DimSymbol, d);
    if ((d = getDimNamesAttrib(x)) != R_NilValue)
	setAttrib(s, R_DimNamesSymbol, d);
    UNPROTECT(2);
    return s;
}
示例#21
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;
}
示例#22
0
SEXP attribute_hidden complex_binary(ARITHOP_TYPE code, SEXP s1, SEXP s2)
{
    R_xlen_t i,i1, i2, n, n1, n2;
    SEXP ans;

    /* Note: "s1" and "s2" are protected in the calling code. */
    n1 = XLENGTH(s1);
    n2 = XLENGTH(s2);
     /* S4-compatibility change: if n1 or n2 is 0, result is of length 0 */
    if (n1 == 0 || n2 == 0) return(allocVector(CPLXSXP, 0));

    n = (n1 > n2) ? n1 : n2;
    ans = R_allocOrReuseVector(s1, s2, CPLXSXP, n);
    PROTECT(ans);

    switch (code) {
    case PLUSOP:
	mod_iterate(n1, n2, i1, i2) {
	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    Rcomplex x1 = COMPLEX(s1)[i1], x2 = COMPLEX(s2)[i2];
	    COMPLEX(ans)[i].r = x1.r + x2.r;
	    COMPLEX(ans)[i].i = x1.i + x2.i;
	}
	break;
    case MINUSOP:
	mod_iterate(n1, n2, i1, i2) {
	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    Rcomplex x1 = COMPLEX(s1)[i1], x2 = COMPLEX(s2)[i2];
	    COMPLEX(ans)[i].r = x1.r - x2.r;
	    COMPLEX(ans)[i].i = x1.i - x2.i;
	}
	break;
    case TIMESOP:
	mod_iterate(n1, n2, i1, i2) {
	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    SET_C99_COMPLEX(COMPLEX(ans), i,
			    C99_COMPLEX2(s1, i1) * C99_COMPLEX2(s2, i2));
	}
	break;
    case DIVOP:
	mod_iterate(n1, n2, i1, i2) {
	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    SET_C99_COMPLEX(COMPLEX(ans), i,
			    C99_COMPLEX2(s1, i1) / C99_COMPLEX2(s2, i2));
	}
	break;
    case POWOP:
	mod_iterate(n1, n2, i1, i2) {
	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    SET_C99_COMPLEX(COMPLEX(ans), i,
			    mycpow(C99_COMPLEX2(s1, i1), C99_COMPLEX2(s2, i2)));
	}
	break;
    default:
	error(_("unimplemented complex operation"));
    }
    UNPROTECT(1);

    /* quick return if there are no attributes */
    if (ATTRIB(s1) == R_NilValue && ATTRIB(s2) == R_NilValue)
	return ans;

    /* Copy attributes from longer argument. */

    if (ans != s2 && n == n2 && ATTRIB(s2) != R_NilValue)
        copyMostAttrib(s2, ans);
    if (ans != s1 && n == n1 && ATTRIB(s1) != R_NilValue)
        copyMostAttrib(s1, ans); /* Done 2nd so s1's attrs overwrite s2's */

    return ans;
}
示例#23
0
文件: clahe.c 项目: aoles/EBImage
SEXP clahe (SEXP x, SEXP _uiNrX, SEXP _uiNrY, SEXP _uiNrBins, SEXP _fCliplimit, SEXP _keepRange) {
  int nx, ny, nz, i, j;
  unsigned int uiNrX, uiNrY, uiNrBins;
  float fCliplimit;
  int keepRange;
  double *src, *tgt;
  SEXP res;
  
  kz_pixel_t min = 0, max = uiNR_OF_GREY-1;
  kz_pixel_t *img;
  
  double maxPixelValue = uiNR_OF_GREY-1;
  
  PROTECT( res = allocVector(REALSXP, XLENGTH(x)) );
  DUPLICATE_ATTRIB(res, x);
  
  nx = INTEGER(GET_DIM(x))[0];
  ny = INTEGER(GET_DIM(x))[1];
  nz = getNumberOfFrames(x, 0);
  
  uiNrX = INTEGER(_uiNrX)[0];
  uiNrY = INTEGER(_uiNrY)[0];
  uiNrBins = INTEGER(_uiNrBins)[0];
  fCliplimit = REAL(_fCliplimit)[0];
  keepRange = LOGICAL(_keepRange)[0];
  
  img = R_Calloc(nx*ny, kz_pixel_t);
  
  // process channels separately
  for(j = 0; j < nz; j++) {
    src = &(REAL(x)[j*nx*ny]);
    tgt = &(REAL(res)[j*nx*ny]);
    
    if (keepRange) {
      min = uiNR_OF_GREY-1;
      max = 0;
    }
    
    // convert frame to CLAHE-compatible format
    for (i = 0; i < nx*ny; i++) {
      double el = src[i];
      
      // clip
      if (el < 0.0) el = 0;
      else if (el > 1.0) el = 1.0;
      // convert to int
      kz_pixel_t nel = (kz_pixel_t) round(el * maxPixelValue);
      
      if (keepRange) {
        if (nel < min) min = nel;
        if (nel > max) max = nel;
      }
      
      img[i] = nel;
    }
    
    int val = CLAHE (img, (unsigned int) nx, (unsigned int) ny,
                     min, max, uiNrX, uiNrY, uiNrBins, fCliplimit);
    
    // translate internal error codes
    switch (val) {
    case -1:
      error("# of regions x-direction too large");
      break;
    case -2:
      error("# of regions y-direction too large");
      break;
    case -3:
      error("x-resolution no multiple of 'nx'");
      break;
    case -4:
      error("y-resolution no multiple of 'ny'");
      break;
    case -5:
      error("maximum too large");
      break;
    case -6:
      error("minimum equal or larger than maximum");
      break;
    case -7:
      error("at least 4 contextual regions required");
      break;
    case -8:
      error("not enough memory! (try reducing 'bins')");
      break;
    }
    
    // convert back to [0:1] range
    for (i = 0; i < nx*ny; i++) {
      tgt[i] = (double) img[i] / maxPixelValue;
    }
  }
  
  R_Free(img);
  
  UNPROTECT(1);
  
  return res;
}
示例#24
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;
}
示例#25
0
SEXP df_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
            SEXP sWhat, SEXP sColNames, SEXP sSkip, SEXP sNlines, SEXP sQuote) {
    char sep;
    int nsep, use_ncol, resilient, ncol;
    long i, j, k, m, len, nmsep_flag, skip, quoteLen;
    unsigned long nrow;
    char num_buf[48];
    const char *c, *c2, *sraw = 0, *send = 0, *quoteChars;
    long nlines = asLong(sNlines, -1);

    SEXP sOutput, tmp, sOutputNames, st, clv;

    /* Parse inputs */
    sep = CHAR(STRING_ELT(sSep, 0))[0];
    nsep = (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0) ? ((int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0))) : -1;

    nmsep_flag = (nsep > 0);
    use_ncol = asInteger(sNcol);
    resilient = asInteger(sResilient);
    ncol = use_ncol; /* NOTE: "character" is prepended by the R code if nmsep is TRUE,
                        so ncol *does* include the key column */
    skip = asLong(sSkip, 0);

    /* parse quote information */
    quoteChars = CHAR(STRING_ELT(sQuote, 0));
    quoteLen = strlen(quoteChars);

    /* count non-NA columns */
    for (i = 0; i < use_ncol; i++)
	if (TYPEOF(VECTOR_ELT(sWhat,i)) == NILSXP) ncol--;

    /* check input */
    if (TYPEOF(s) == RAWSXP) {
	nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s);
	sraw = (const char*) RAW(s);
	send = sraw + XLENGTH(s);
	if (nrow >= skip) {
	    unsigned long slen = XLENGTH(s);
	    nrow = nrow - skip;
	    i = 0;
	    while (i < skip && (sraw = memchr(sraw, '\n', slen))) { sraw++; i++; }
	} else {
	    nrow = 0;
	    sraw = send;
	}
    } else if (TYPEOF(s) == STRSXP) {
	nrow = XLENGTH(s);
	if (nrow >= skip) {
	    nrow -= skip;
	} else {
	    skip = nrow;
	    nrow = 0;
	}
    } else
	Rf_error("invalid input to split - must be a raw or character vector");

    if (nlines >= 0 && nrow > nlines) nrow = nlines;

    /* allocate result */
    PROTECT(sOutput = allocVector(VECSXP, ncol));

    /* set names */
    setAttrib(sOutput, R_NamesSymbol, sOutputNames = allocVector(STRSXP, ncol));

    if (nrow > INT_MAX)
	Rf_warning("R currently doesn't support large data frames, but we have %lu rows, returning a named list instead", nrow);
    else {
	/* set automatic row names */
	PROTECT(tmp = allocVector(INTSXP, 2));
	INTEGER(tmp)[0] = NA_INTEGER;
	INTEGER(tmp)[1] = -nrow;
	setAttrib(sOutput, R_RowNamesSymbol, tmp);
	UNPROTECT(1);

	/* set class */
	classgets(sOutput, mkString("data.frame"));
    }

    /* Create SEXP for each element of the output */
    j = 0;
    for (i = 0; i < use_ncol; i++) {
      if (TYPEOF(VECTOR_ELT(sWhat,i)) != NILSXP) /* copy col.name */
        SET_STRING_ELT(sOutputNames, j, STRING_ELT(sColNames, i));

      switch (TYPEOF(VECTOR_ELT(sWhat,i))) {
      case LGLSXP:
      case INTSXP:
      case REALSXP:
      case CPLXSXP:
      case STRSXP:
      case RAWSXP:
        SET_VECTOR_ELT(sOutput, j++, allocVector(TYPEOF(VECTOR_ELT(sWhat,i)), nrow));
        break;

      case VECSXP:
        SET_VECTOR_ELT(sOutput, j++, st = allocVector(REALSXP, nrow));
        clv = PROTECT(allocVector(STRSXP, 2));
        SET_STRING_ELT(clv, 0, mkChar("POSIXct"));
        SET_STRING_ELT(clv, 1, mkChar("POSIXt"));
        setAttrib(st, R_ClassSymbol, clv);
        /* this is somewhat a security precaution such that users
           don't get surprised -- if there is no TZ R will
           render it in local time - which is correct but
           may confuse people that didn't use GMT to start with */
        setAttrib(st, install("tzone"), mkString("GMT"));
        UNPROTECT(1);
        break;

      case NILSXP:
        break;

      default:
        Rf_error("Unsupported input to what %u.", TYPEOF(VECTOR_ELT(sWhat,i)));
        break;
      }
    }

    /* Cycle through the rows and extract the data */
    for (k = 0; k < nrow; k++) {
      const char *l = 0, *le;
      if (TYPEOF(s) == RAWSXP) {
          l = sraw;
          le = memchr(l, '\n', send - l);
          if (!le) le = send;
          sraw = le + 1;
          if (*(le - 1) == '\r' ) le--; /* account for DOS-style '\r\n' */
      } else {
          l = CHAR(STRING_ELT(s, k + skip));
          le = l + strlen(l); /* probably lame, but using strings is way inefficient anyway ;) */
      }
      if (nmsep_flag) {
          c = memchr(l, nsep, le - l);
          if (c) {
            SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, Rf_mkCharLen(l, c - l));
            l = c + 1;
          } else
            SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, R_BlankString);
      }

      i = nmsep_flag;
      j = nmsep_flag;
      while (l < le) {
        if (!(c = memchr(l, sep, le - l)))
          c = le;

        if (i >= use_ncol) {
          if (resilient) break;
          Rf_error("line %lu: too many input columns (expected %u)", k, use_ncol);
        }

        switch(TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
        case LGLSXP:
          len = (int) (c - l);
          if (len > sizeof(num_buf) - 1)
              len = sizeof(num_buf) - 1;
          memcpy(num_buf, l, len);
          num_buf[len] = 0;
          int tr = StringTrue(num_buf), fa = StringFalse(num_buf);
          LOGICAL(VECTOR_ELT(sOutput, j))[k] = (tr || fa) ? tr : NA_INTEGER;
          j++;
          break;

        case INTSXP:
          len = (int) (c - l);
          /* watch for overflow and truncate -- should we warn? */
          if (len > sizeof(num_buf) - 1)
              len = sizeof(num_buf) - 1;
          memcpy(num_buf, l, len);
          num_buf[len] = 0;
          INTEGER(VECTOR_ELT(sOutput, j))[k] = Strtoi(num_buf, 10);
          j++;
          break;

        case REALSXP:
          len = (int) (c - l);
          /* watch for overflow and truncate -- should we warn? */
          if (len > sizeof(num_buf) - 1)
              len = sizeof(num_buf) - 1;
          memcpy(num_buf, l, len);
          num_buf[len] = 0;
          REAL(VECTOR_ELT(sOutput, j))[k] = R_atof(num_buf);
          j++;
          break;

        case CPLXSXP:
          len = (int) (c - l);
          /* watch for overflow and truncate -- should we warn? */
          if (len > sizeof(num_buf) - 1)
              len = sizeof(num_buf) - 1;
          memcpy(num_buf, l, len);
          num_buf[len] = 0;
          COMPLEX(VECTOR_ELT(sOutput, j))[k] = strtoc(num_buf, TRUE);
          j++;
          break;

        case STRSXP:
          c2 = c;
          if (quoteLen) {
            for (m = 0; m < quoteLen; m++) {
              if (*l == quoteChars[m]) {
                l++;
                if (!(c2 = memchr(l, quoteChars[m], le - l))) {
                  Rf_error("End of line within quoted string.");
                } else {
                  if (!(c = memchr(c2, (unsigned char) sep, le - c2)))
                    c = le;
                }
              }
            }
          }
          SET_STRING_ELT(VECTOR_ELT(sOutput, j), k, Rf_mkCharLen(l, c2 - l));
          j++;
          break;

        case RAWSXP:
          len = (int) (c - l);
          /* watch for overflow and truncate -- should we warn? */
          if (len > sizeof(num_buf) - 1)
              len = sizeof(num_buf) - 1;
          memcpy(num_buf, l, len);
          num_buf[len] = 0;
          RAW(VECTOR_ELT(sOutput, j))[k] = strtoraw(num_buf);
          j++;
          break;

        case VECSXP:
          REAL(VECTOR_ELT(sOutput, j))[k] = parse_ts(l, c);
          j++;
        }

        l = c + 1;
        i++;
      }

      /* fill-up unused columns */
      while (i < use_ncol) {
          switch (TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
          case LGLSXP:
            LOGICAL(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
            break;

          case INTSXP:
            INTEGER(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
            break;

          case REALSXP:
          case VECSXP:
            REAL(VECTOR_ELT(sOutput, j++))[k] = NA_REAL;
            break;

          case CPLXSXP:
            COMPLEX(VECTOR_ELT(sOutput, j))[k].r = NA_REAL;
            COMPLEX(VECTOR_ELT(sOutput, j++))[k].i = NA_REAL;
            break;

          case STRSXP:
            SET_STRING_ELT(VECTOR_ELT(sOutput, j++), k, R_NaString);
            break;

          case RAWSXP:
            RAW(VECTOR_ELT(sOutput, j))[k] = (Rbyte) 0;
            break;
          }
          i++;
      }
    }

    UNPROTECT(1); /* sOutput */
    return(sOutput);
}
示例#26
0
文件: seq.c 项目: kalibera/rexp
/* to match seq.default */
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans = R_NilValue /* -Wall */, tmp, from, to, by, len, along;
    int nargs = length(args), lf;
    Rboolean One = nargs == 1;
    R_xlen_t i, lout = NA_INTEGER;
    static SEXP do_seq_formals = NULL;    

    if (DispatchOrEval(call, op, R_SeqCharSXP, args, rho, &ans, 0, 1))
	return(ans);

    /* This is a primitive and we manage argument matching ourselves.
       We pretend this is
       seq(from, to, by, length.out, along.with, ...)
    */
    if (do_seq_formals == NULL) {
        do_seq_formals = CONS(R_NilValue, CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)));
        R_PreserveObject(do_seq_formals);
        tmp = do_seq_formals;
        SET_TAG(tmp, install("from")); tmp = CDR(tmp);
        SET_TAG(tmp, install("to")); tmp = CDR(tmp);
        SET_TAG(tmp, install("by")); tmp = CDR(tmp);
        SET_TAG(tmp, R_LengthOutSymbol); tmp = CDR(tmp);
        SET_TAG(tmp, R_AlongWithSymbol); tmp = CDR(tmp);
        SET_TAG(tmp, R_DotsSymbol);
    }
    
    PROTECT(args = matchArgs(do_seq_formals, args, call));

    from = CAR(args); args = CDR(args);
    to = CAR(args); args = CDR(args);
    by = CAR(args); args = CDR(args);
    len = CAR(args); args = CDR(args);
    along = CAR(args);

    if(One && from != R_MissingArg) {
	lf = length(from);
	if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
	    double rfrom = asReal(from);
	    if (!R_FINITE(rfrom))
		errorcall(call, "'from' cannot be NA, NaN or infinite");
	    ans = seq_colon(1.0, rfrom, call);
	}
	else if (lf)
	    ans = seq_colon(1.0, (double)lf, call);
	else
	    ans = allocVector(INTSXP, 0);
	goto done;
    }
    if(along != R_MissingArg) {
	lout = XLENGTH(along);
	if(One) {
	    ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
	    goto done;
	}
    } else if(len != R_MissingArg && len != R_NilValue) {
	double rout = asReal(len);
	if(ISNAN(rout) || rout <= -0.5)
	    errorcall(call, _("'length.out' must be a non-negative number"));
	if(length(len) != 1)
	    warningcall(call, _("first element used of '%s' argument"), 
			"length.out");
	lout = (R_xlen_t) ceil(rout);
    }

    if(lout == NA_INTEGER) {
	double rfrom = asReal(from), rto = asReal(to), rby = asReal(by), *ra;
	if(from == R_MissingArg) rfrom = 1.0;
	else if(length(from) != 1) error("'from' must be of length 1");
	if(to == R_MissingArg) rto = 1.0;
	else if(length(to) != 1) error("'to' must be of length 1");
	if (!R_FINITE(rfrom))
	    errorcall(call, "'from' cannot be NA, NaN or infinite");
	if (!R_FINITE(rto))
	    errorcall(call, "'to' cannot be NA, NaN or infinite");
	if(by == R_MissingArg)
	    ans = seq_colon(rfrom, rto, call);
	else {
	    if(length(by) != 1) error("'by' must be of length 1");
	    double del = rto - rfrom, n, dd;
	    R_xlen_t nn;
	    if(!R_FINITE(rfrom))
		errorcall(call, _("'from' must be finite"));
	    if(!R_FINITE(rto))
		errorcall(call, _("'to' must be finite"));
	    if(del == 0.0 && rto == 0.0) {
		ans = to;
		goto done;
	    }
	    /* printf("from = %f, to = %f, by = %f\n", rfrom, rto, rby); */
	    n = del/rby;
	    if(!R_FINITE(n)) {
		if(del == 0.0 && rby == 0.0) {
		    ans = from;
		    goto done;
		} else
		    errorcall(call, _("invalid '(to - from)/by' in 'seq'"));
	    }
	    dd = fabs(del)/fmax2(fabs(rto), fabs(rfrom));
	    if(dd < 100 * DBL_EPSILON) {
		ans = from;
		goto done;
	    }
#ifdef LONG_VECTOR_SUPPORT
	    if(n > 100 * (double) INT_MAX)
#else
	    if(n > (double) INT_MAX)
#endif
		errorcall(call, _("'by' argument is much too small"));
	    if(n < - FEPS)
		errorcall(call, _("wrong sign in 'by' argument"));
	    if(TYPEOF(from) == INTSXP &&
	       TYPEOF(to) == INTSXP &&
	       TYPEOF(by) == INTSXP) {
		int *ia, ifrom = asInteger(from), iby = asInteger(by);
		/* With the current limits on integers and FEPS
		   reduced below 1/INT_MAX this is the same as the
		   next, so this is future-proofing against longer integers.
		*/
		/* seq.default gives integer result from
		   from + (0:n)*by
		*/
		nn = (R_xlen_t) n;
		ans = allocVector(INTSXP, nn+1);
		ia = INTEGER(ans);
		for(i = 0; i <= nn; i++)
		    ia[i] = (int)(ifrom + i * iby);
	    } else {
		nn = (int)(n + FEPS);
		ans = allocVector(REALSXP, nn+1);
		ra = REAL(ans);
		for(i = 0; i <= nn; i++)
		    ra[i] = rfrom + (double)i * rby;
		/* Added in 2.9.0 */
		if (nn > 0)
		    if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
			ra[nn] = rto;
	    }
	}
    } else if (lout == 0) {
	ans = allocVector(INTSXP, 0);
    } else if (One) {
	ans = seq_colon(1.0, (double)lout, call);
    } else if (by == R_MissingArg) {
	double rfrom = asReal(from), rto = asReal(to), rby;
	if(to == R_MissingArg) rto = rfrom + (double)lout - 1;
	if(from == R_MissingArg) rfrom = rto - (double)lout + 1;
	if(!R_FINITE(rfrom))
	    errorcall(call, _("'from' must be finite"));
	if(!R_FINITE(rto))
	    errorcall(call, _("'to' must be finite"));
	ans = allocVector(REALSXP, lout);
	if(lout > 0) REAL(ans)[0] = rfrom;
	if(lout > 1) REAL(ans)[lout - 1] = rto;
	if(lout > 2) {
	    rby = (rto - rfrom)/(double)(lout - 1);
	    for(i = 1; i < lout-1; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		REAL(ans)[i] = rfrom + (double)i*rby;
	    }
	}
    } else if (to == R_MissingArg) {
	double rfrom = asReal(from), rby = asReal(by), rto;
	if(from == R_MissingArg) rfrom = 1.0;
	if(!R_FINITE(rfrom))
	    errorcall(call, _("'from' must be finite"));
	if(!R_FINITE(rby))
	    errorcall(call, _("'by' must be finite"));
	rto = rfrom + (double)(lout-1)*rby;
	if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
	   && rto <= INT_MAX && rto >= INT_MIN) {
	    ans = allocVector(INTSXP, lout);
	    for(i = 0; i < lout; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
	    }
	} else {
	    ans = allocVector(REALSXP, lout);
	    for(i = 0; i < lout; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		REAL(ans)[i] = rfrom + (double)i*rby;
	    }
	}
    } else if (from == R_MissingArg) {
	double rto = asReal(to), rby = asReal(by),
	    rfrom = rto - (double)(lout-1)*rby;
	if(!R_FINITE(rto))
	    errorcall(call, _("'to' must be finite"));
	if(!R_FINITE(rby))
	    errorcall(call, _("'by' must be finite"));
	if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
	   && rto <= INT_MAX && rto >= INT_MIN) {
	    ans = allocVector(INTSXP, lout);
	    for(i = 0; i < lout; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
	    }
	} else {
	    ans = allocVector(REALSXP, lout);
	    for(i = 0; i < lout; i++) {
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
	    }
	}
    } else
	errorcall(call, _("too many arguments"));

done:
    UNPROTECT(1);
    return ans;
}
示例#27
0
文件: array.c 项目: kalibera/rexp
SEXP attribute_hidden do_earg_transpose(SEXP call, SEXP op, SEXP arg_x, SEXP rho)
{
    SEXP a, r, dims, dimnames, dimnamesnames = R_NilValue,
	ndimnamesnames, rnames, cnames;
    int ldim, ncol = 0, nrow = 0;
    R_xlen_t len = 0;

    a = arg_x;

    if (isVector(a)) {
	dims = getDimAttrib(a);
	ldim = length(dims);
	rnames = R_NilValue;
	cnames = R_NilValue;
	switch(ldim) {
	case 0:
	    len = nrow = LENGTH(a);
	    ncol = 1;
	    rnames = getNamesAttrib(a);
	    dimnames = rnames;/* for isNull() below*/
	    break;
	case 1:
	    len = nrow = LENGTH(a);
	    ncol = 1;
	    dimnames = getDimNamesAttrib(a);
	    if (dimnames != R_NilValue) {
		rnames = VECTOR_ELT(dimnames, 0);
		dimnamesnames = getNamesAttrib(dimnames);
	    }
	    break;
	case 2:
	    ncol = ncols(a);
	    nrow = nrows(a);
	    len = XLENGTH(a);
	    dimnames = getDimNamesAttrib(a);
	    if (dimnames != R_NilValue) {
		rnames = VECTOR_ELT(dimnames, 0);
		cnames = VECTOR_ELT(dimnames, 1);
		dimnamesnames = getNamesAttrib(dimnames);
	    }
	    break;
	default:
	    goto not_matrix;
	}
    }
    else
	goto not_matrix;
    PROTECT(r = allocVector(TYPEOF(a), len));
    R_xlen_t i, j, l_1 = len-1;
    switch (TYPEOF(a)) {
    case LGLSXP:
    case INTSXP:
	// filling in columnwise, "accessing row-wise":
        for (i = 0, j = 0; i < len; i++, j += nrow) {
            if (j > l_1) j -= l_1;
            INTEGER(r)[i] = INTEGER(a)[j];
        }
        break;
    case REALSXP:
        for (i = 0, j = 0; i < len; i++, j += nrow) {
            if (j > l_1) j -= l_1;
            REAL(r)[i] = REAL(a)[j];
        }
        break;
    case CPLXSXP:
        for (i = 0, j = 0; i < len; i++, j += nrow) {
            if (j > l_1) j -= l_1;
            COMPLEX(r)[i] = COMPLEX(a)[j];
        }
        break;
    case STRSXP:
        for (i = 0, j = 0; i < len; i++, j += nrow) {
            if (j > l_1) j -= l_1;
            SET_STRING_ELT(r, i, STRING_ELT(a,j));
        }
        break;
    case VECSXP:
        for (i = 0, j = 0; i < len; i++, j += nrow) {
            if (j > l_1) j -= l_1;
            SET_VECTOR_ELT(r, i, VECTOR_ELT(a,j));
        }
        break;
    case RAWSXP:
        for (i = 0, j = 0; i < len; i++, j += nrow) {
            if (j > l_1) j -= l_1;
            RAW(r)[i] = RAW(a)[j];
        }
        break;
    default:
        UNPROTECT(1);
        goto not_matrix;
    }
    PROTECT(dims = allocVector(INTSXP, 2));
    INTEGER(dims)[0] = ncol;
    INTEGER(dims)[1] = nrow;
    setAttrib(r, R_DimSymbol, dims);
    UNPROTECT(1);
    /* R <= 2.2.0: dropped list(NULL,NULL) dimnames :
     * if(rnames != R_NilValue || cnames != R_NilValue) */
    if(!isNull(dimnames)) {
	PROTECT(dimnames = allocVector(VECSXP, 2));
	SET_VECTOR_ELT(dimnames, 0, cnames);
	SET_VECTOR_ELT(dimnames, 1, rnames);
	if(!isNull(dimnamesnames)) {
	    PROTECT(ndimnamesnames = allocVector(VECSXP, 2));
	    SET_VECTOR_ELT(ndimnamesnames, 1, STRING_ELT(dimnamesnames, 0));
	    SET_VECTOR_ELT(ndimnamesnames, 0,
			   (ldim == 2) ? STRING_ELT(dimnamesnames, 1):
			   R_BlankString);
	    setAttrib(dimnames, R_NamesSymbol, ndimnamesnames);
	    UNPROTECT(1);
	}
	setAttrib(r, R_DimNamesSymbol, dimnames);
	UNPROTECT(1);
    }
    copyMostAttrib(a, r);
    UNPROTECT(1);
    return r;
 not_matrix:
    error(_("argument is not a matrix"));
    return call;/* never used; just for -Wall */
}
示例#28
0
/* iconv(x, from, to, sub, mark) */
SEXP attribute_hidden do_iconv(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, x = CAR(args), si;
    void * obj;
    const char *inbuf;
    char *outbuf;
    const char *sub;
    size_t inb, outb, res;
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
    Rboolean isRawlist = FALSE;

    checkArity(op, args);
    if(isNull(x)) {  /* list locales */
#ifdef HAVE_ICONVLIST
	cnt = 0;
	iconvlist(count_one, NULL);
	PROTECT(ans = allocVector(STRSXP, cnt));
	cnt = 0;
	iconvlist(write_one, (void *)ans);
#else
	PROTECT(ans = R_NilValue);
#endif
    } else {
	int mark, toRaw;
	const char *from, *to;
	Rboolean isLatin1 = FALSE, isUTF8 = FALSE;

	args = CDR(args);
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
	    error(_("invalid '%s' argument"), "from");
	from = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
	args = CDR(args);
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
	    error(_("invalid '%s' argument"), "to");
	to = CHAR(STRING_ELT(CAR(args), 0));
	args = CDR(args);
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
	    error(_("invalid '%s' argument"), "sub");
	if(STRING_ELT(CAR(args), 0) == NA_STRING) sub = NULL;
	else sub = translateChar(STRING_ELT(CAR(args), 0));
	args = CDR(args);
	mark = asLogical(CAR(args));
	if(mark == NA_LOGICAL)
	    error(_("invalid '%s' argument"), "mark");	
	args = CDR(args);
	toRaw = asLogical(CAR(args));
	if(toRaw == NA_LOGICAL)
	    error(_("invalid '%s' argument"), "toRaw");	
	/* some iconv's allow "UTF8", but libiconv does not */
	if(streql(from, "UTF8") || streql(from, "utf8") ) from = "UTF-8";
	if(streql(to, "UTF8") || streql(to, "utf8") ) to = "UTF-8";
	/* Should we do something about marked CHARSXPs in 'from = ""'? */
	if(streql(to, "UTF-8")) isUTF8 = TRUE;
	if(streql(to, "latin1") || streql(to, "ISO_8859-1")
	    || streql(to, "CP1252")) isLatin1 = TRUE;
	if(streql(to, "") && known_to_be_latin1) isLatin1 = TRUE;
	if(streql(to, "") && known_to_be_utf8) isUTF8 = TRUE;
	obj = Riconv_open(to, from);
	if(obj == (iconv_t)(-1))
#ifdef Win32
	    error(_("unsupported conversion from '%s' to '%s' in codepage %d"), 
		  from, to, localeCP);
#else
	    error(_("unsupported conversion from '%s' to '%s'"), from, to);
#endif
	isRawlist = (TYPEOF(x) == VECSXP);
	if(isRawlist) {
	    if(toRaw)
		PROTECT(ans = duplicate(x));
	    else {
		PROTECT(ans = allocVector(STRSXP, LENGTH(x)));
		DUPLICATE_ATTRIB(ans, x);
	    }
	} else {   
	    if(TYPEOF(x) != STRSXP)
		error(_("'x' must be a character vector"));
	    if(toRaw) {
		PROTECT(ans = allocVector(VECSXP, LENGTH(x)));
		DUPLICATE_ATTRIB(ans, x);
	    } else 
		PROTECT(ans = duplicate(x));
	}
	R_AllocStringBuffer(0, &cbuff);  /* 0 -> default */
	for(R_xlen_t i = 0; i < XLENGTH(x); i++) {
	    if (isRawlist) {
		si = VECTOR_ELT(x, i);
		if (TYPEOF(si) == NILSXP) {
		    if (!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
		    continue;
		} else if (TYPEOF(si) != RAWSXP)
		    error(_("'x' must be a list of NULL or raw vectors"));
	    } else {
		si = STRING_ELT(x, i);
		if (si == NA_STRING) {
		    if(!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
		    continue;
		}
	    }
	top_of_loop:
	    inbuf = isRawlist ? (const char *) RAW(si) : CHAR(si); 
	    inb = LENGTH(si);
	    outbuf = cbuff.data; outb = cbuff.bufsize - 1;
	    /* First initialize output */
	    Riconv (obj, NULL, NULL, &outbuf, &outb);
	next_char:
	    /* Then convert input  */
	    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
	    *outbuf = '\0';
	    /* other possible error conditions are incomplete
	       and invalid multibyte chars */
	    if(res == -1 && errno == E2BIG) {
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
		goto top_of_loop;
	    } else if(res == -1 && sub && 
		      (errno == EILSEQ || errno == EINVAL)) {
		/* it seems this gets thrown for non-convertible input too */
		if(strcmp(sub, "byte") == 0) {
		    if(outb < 5) {
			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
			goto top_of_loop;
		    }
		    snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
		    outbuf += 4; outb -= 4;
		} else {
		    size_t j;
		    if(outb < strlen(sub)) {
			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
			goto top_of_loop;
		    }
		    memcpy(outbuf, sub, j = strlen(sub));
		    outbuf += j;
		    outb -= j;
		}
		inbuf++; inb--;
		goto next_char;
	    }

	    if(toRaw) {
		if(res != -1 && inb == 0) {
		    size_t nout = cbuff.bufsize - 1 - outb;
		    SEXP el = allocVector(RAWSXP, nout);
		    memcpy(RAW(el), cbuff.data, nout);
		    SET_VECTOR_ELT(ans, i, el);
		} /* otherwise is already NULL */
	    } else {
		if(res != -1 && inb == 0) {
		    cetype_t ienc = CE_NATIVE;
		    
		    size_t nout = cbuff.bufsize - 1 - outb;
		    if(mark) {
			if(isLatin1) ienc = CE_LATIN1;
			else if(isUTF8) ienc = CE_UTF8;
		    }
		    SET_STRING_ELT(ans, i, 
				   mkCharLenCE(cbuff.data, (int) nout, ienc));
		} else SET_STRING_ELT(ans, i, NA_STRING);
	    }
	}
	Riconv_close(obj);
	R_FreeStringBuffer(&cbuff);
    }
    UNPROTECT(1);
    return ans;
}
示例#29
0
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, y = R_NilValue;	/* -Wall*/
    R_xlen_t i, n;

    checkArity(op, args);
    check1arg(args, call, "z");
    if (DispatchGroup("Complex", call, op, args, env, &x))
	return x;
    x = CAR(args);
    if (isComplex(x)) {
	n = XLENGTH(x);
	switch(PRIMVAL(op)) {
	case 1:	/* Re */
	    y = allocVector(REALSXP, n);
	    for(i = 0 ; i < n ; i++)
		REAL(y)[i] = COMPLEX(x)[i].r;
	    break;
	case 2:	/* Im */
	    y = allocVector(REALSXP, n);
	    for(i = 0 ; i < n ; i++)
		REAL(y)[i] = COMPLEX(x)[i].i;
	    break;
	case 3:	/* Mod */
	case 6:	/* abs */
	    y = allocVector(REALSXP, n);
	    for(i = 0 ; i < n ; i++)
#if HAVE_CABS
		REAL(y)[i] = cabs(C99_COMPLEX2(x, i));
#else
		REAL(y)[i] = hypot(COMPLEX(x)[i].r, COMPLEX(x)[i].i);
#endif
	    break;
	case 4:	/* Arg */
	    y = allocVector(REALSXP, n);
	    for(i = 0 ; i < n ; i++)
#if HAVE_CARG
		REAL(y)[i] = carg(C99_COMPLEX2(x, i));
#else
		REAL(y)[i] = atan2(COMPLEX(x)[i].i, COMPLEX(x)[i].r);
#endif
	    break;
	case 5:	/* Conj */
	    y = NO_REFERENCES(x) ? x : allocVector(CPLXSXP, n);
	    for(i = 0 ; i < n ; i++) {
		COMPLEX(y)[i].r = COMPLEX(x)[i].r;
		COMPLEX(y)[i].i = -COMPLEX(x)[i].i;
	    }
	    break;
	}
    }
    else if(isNumeric(x)) { /* so no complex numbers involved */
	n = XLENGTH(x);
	if(isReal(x)) PROTECT(x);
	else PROTECT(x = coerceVector(x, REALSXP));
        y = NO_REFERENCES(x) ? x : allocVector(REALSXP, n);

	switch(PRIMVAL(op)) {
	case 1:	/* Re */
	case 5:	/* Conj */
	    for(i = 0 ; i < n ; i++)
		REAL(y)[i] = REAL(x)[i];
	    break;
	case 2:	/* Im */
	    for(i = 0 ; i < n ; i++)
		REAL(y)[i] = 0.0;
	    break;
	case 4:	/* Arg */
	    for(i = 0 ; i < n ; i++)
		if(ISNAN(REAL(x)[i]))
		    REAL(y)[i] = REAL(x)[i];
		else if (REAL(x)[i] >= 0)
		    REAL(y)[i] = 0;
		else
		    REAL(y)[i] = M_PI;
	    break;
	case 3:	/* Mod */
	case 6:	/* abs */
	    for(i = 0 ; i < n ; i++)
		REAL(y)[i] = fabs(REAL(x)[i]);
	    break;
	}
	UNPROTECT(1);
    }
    else errorcall(call, _("non-numeric argument to function"));

    if (x != y && ATTRIB(x) != R_NilValue) {
        PROTECT(x);
        PROTECT(y);
        DUPLICATE_ATTRIB(y, x);
        UNPROTECT(2);
    }
    return y;
}
示例#30
0
文件: array.c 项目: kalibera/rexp
SEXP DropDims(SEXP x)
{
    SEXP dims, dimnames, newnames = R_NilValue;
    int i, n, ndims;

    PROTECT(x);
    dims = getDimAttrib(x);
    dimnames = getDimNamesAttrib(x);

    /* Check that dropping will actually do something. */
    /* (1) Check that there is a "dim" attribute. */

    if (dims == R_NilValue) {
	UNPROTECT(1);
	return x;
    }
    ndims = LENGTH(dims);

    /* (2) Check whether there are redundant extents */
    n = 0;
    for (i = 0; i < ndims; i++)
	if (INTEGER(dims)[i] != 1) n++;
    if (n == ndims) {
	UNPROTECT(1);
	return x;
    }

    if (n <= 1) {
	/* We have reduced to a vector result.
	   If that has length one, it is ambiguous which dimnames to use,
	   so use it if there is only one (as from R 2.7.0).
	 */
	if (dimnames != R_NilValue) {
	    if(XLENGTH(x) != 1) {
		for (i = 0; i < LENGTH(dims); i++) {
		    if (INTEGER(dims)[i] != 1) {
			newnames = VECTOR_ELT(dimnames, i);
			break;
		    }
		}
	    } else { /* drop all dims: keep names if unambiguous */
		int cnt;
		for(i = 0, cnt = 0; i < LENGTH(dims); i++)
		    if(VECTOR_ELT(dimnames, i) != R_NilValue) cnt++;
		if(cnt == 1)
		    for (i = 0; i < LENGTH(dims); i++) {
			newnames = VECTOR_ELT(dimnames, i);
			if(newnames != R_NilValue) break;
		    }
	    }
	}
	PROTECT(newnames);
	setAttrib(x, R_DimNamesSymbol, R_NilValue);
	setAttrib(x, R_DimSymbol, R_NilValue);
	setAttrib(x, R_NamesSymbol, newnames);
	/* FIXME: the following is desirable, but pointless as long as
	   subset.c & others have a contrary version that leaves the
	   S4 class in, incorrectly, in the case of vectors.  JMC
	   3/3/09 */
/* 	if(IS_S4_OBJECT(x)) {/\* no longer valid subclass of array or
 	matrix *\/ */
/* 	    setAttrib(x, R_ClassSymbol, R_NilValue); */
/* 	    UNSET_S4_OBJECT(x); */
/* 	} */
	UNPROTECT(1);
    } else {
	/* We have a lower dimensional array. */
	SEXP newdims, dnn, newnamesnames = R_NilValue;
	dnn = getNamesAttrib(dimnames);
	PROTECT(newdims = allocVector(INTSXP, n));
	for (i = 0, n = 0; i < ndims; i++)
	    if (INTEGER(dims)[i] != 1)
		INTEGER(newdims)[n++] = INTEGER(dims)[i];
	if (!isNull(dimnames)) {
	    int havenames = 0;
	    for (i = 0; i < ndims; i++)
		if (INTEGER(dims)[i] != 1 &&
		    VECTOR_ELT(dimnames, i) != R_NilValue)
		    havenames = 1;
	    if (havenames) {
		PROTECT(newnames = allocVector(VECSXP, n));
		PROTECT(newnamesnames = allocVector(STRSXP, n));
		for (i = 0, n = 0; i < ndims; i++) {
		    if (INTEGER(dims)[i] != 1) {
			if(!isNull(dnn))
			    SET_STRING_ELT(newnamesnames, n,
					   STRING_ELT(dnn, i));
			SET_VECTOR_ELT(newnames, n++, VECTOR_ELT(dimnames, i));
		    }
		}
	    }
	    else dimnames = R_NilValue;
	}
	PROTECT(dimnames);
	setAttrib(x, R_DimNamesSymbol, R_NilValue);
	setAttrib(x, R_DimSymbol, newdims);
	if (dimnames != R_NilValue)
	{
	    if(!isNull(dnn))
		setAttrib(newnames, R_NamesSymbol, newnamesnames);
	    setAttrib(x, R_DimNamesSymbol, newnames);
	    UNPROTECT(2);
	}
	UNPROTECT(2);
    }
    UNPROTECT(1);
    return x;
}