/* 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); }
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; }
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); }
/* 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; }
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; }
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); }
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 */ }
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; } }
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); }
/* 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; }
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; }
/* 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; }
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++) {
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; }
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; }
RVector::RVector(SEXP vector) : size_(XLENGTH(vector)), capacity_(XLENGTH(vector)), vector(vector) { assert(TYPEOF(vector) == VECSXP); R_PreserveObject(vector); }
/* 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; }
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; } } } }
/* ----- 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(). */
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; }
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; }
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; }
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; }
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; }
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); }
/* 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; }
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 */ }
/* 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; }
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; }
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; }