SEXP Rsockread(SEXP ssock, SEXP smaxlen) { if (length(ssock) != 1) error("invalid 'socket' argument"); int sock = asInteger(ssock), maxlen = asInteger(smaxlen); char buf[maxlen+1], *abuf[1]; abuf[0] = buf; if(!initialized) internet_Init(); if(initialized > 0) (*ptr->sockread)(&sock, abuf, &maxlen); else error(_("socket routines cannot be loaded")); return Rf_ScalarString(mkCharLen(buf, maxlen)); }
SEXP Rsocklisten(SEXP ssock) { if (length(ssock) != 1) error("invalid 'socket' argument"); int sock = asInteger(ssock), len = 256; char buf[257], *abuf[1]; abuf[0] = buf; if(!initialized) internet_Init(); if(initialized > 0) (*ptr->socklisten)(&sock, abuf, &len); else error(_("socket routines cannot be loaded")); SEXP ans = PROTECT(ScalarInteger(sock)); // The socket being listened on SEXP host = PROTECT(Rf_ScalarString(mkChar(buf))); setAttrib(ans, install("host"), host); UNPROTECT(2); return ans; }
/** * Get all available ICU charsets and their aliases (elems 2,3,...) * * @return R list object; element name == ICU charset canonical name; * elements are character vectors (aliases) * * @version 0.1-?? (Marek Gagolewski) * * @version 0.2-1 (Marek Gagolewski) * use StriUcnv; make StriException-friendly * * @version 0.3-1 (Marek Gagolewski, 2014-11-04) * Issue #112: str_prepare_arg* retvals were not PROTECTed from gc */ SEXP stri_enc_list() { R_len_t c = (R_len_t)ucnv_countAvailable(); STRI__ERROR_HANDLER_BEGIN(0) SEXP ret; SEXP names; STRI__PROTECT(ret = Rf_allocVector(VECSXP, c)); STRI__PROTECT(names = Rf_allocVector(STRSXP, c)); for (R_len_t i=0; i<c; ++i) { const char* canonical_name = ucnv_getAvailableName(i); if (!canonical_name) { SET_STRING_ELT(names, i, NA_STRING); continue; } SET_STRING_ELT(names, i, Rf_mkChar(canonical_name)); UErrorCode status = U_ZERO_ERROR; R_len_t ci = (R_len_t)ucnv_countAliases(canonical_name, &status); if (U_FAILURE(status) || ci <= 0) SET_VECTOR_ELT(ret, i, Rf_ScalarString(NA_STRING)); else { SEXP aliases; STRI__PROTECT(aliases = Rf_allocVector(STRSXP, ci)); for (R_len_t j=0; j<ci; ++j) { status = U_ZERO_ERROR; const char* alias = ucnv_getAlias(canonical_name, j, &status); if (U_FAILURE(status) || !alias) SET_STRING_ELT(aliases, j, NA_STRING); else SET_STRING_ELT(aliases, j, Rf_mkChar(alias)); } SET_VECTOR_ELT(ret, i, aliases); STRI__UNPROTECT(1); } } Rf_setAttrib(ret, R_NamesSymbol, names); STRI__UNPROTECT_ALL return ret; STRI__ERROR_HANDLER_END({/* no special action on error */}) }
SEXP extract_impl(SEXP x, SEXP index, SEXP missing) { if (!Rf_isVector(x)) { Rf_errorcall(R_NilValue, "`x` must be a vector (not a %s)", Rf_type2char(TYPEOF(x))); } if (TYPEOF(index) != VECSXP) { Rf_errorcall(R_NilValue, "`index` must be a vector (not a %s)", Rf_type2char(TYPEOF(index))); } int n = Rf_length(index); for (int i = 0; i < n; ++i) { SEXP index_i = VECTOR_ELT(index, i); int offset = find_offset(x, index_i, i); if (offset < 0) return missing; switch(TYPEOF(x)) { case NILSXP: return missing; case LGLSXP: x = Rf_ScalarLogical(LOGICAL(x)[offset]); break; case INTSXP: x = Rf_ScalarInteger(INTEGER(x)[offset]); break; case REALSXP: x = Rf_ScalarReal(REAL(x)[offset]); break; case STRSXP: x = Rf_ScalarString(STRING_ELT(x, offset)); break; case VECSXP: x = VECTOR_ELT(x, offset); break; default: Rf_errorcall(R_NilValue, "Don't know how to index object of type %s at level %i", Rf_type2char(TYPEOF(x)), i + 1 ); } } return x; }
static SEXP rpf_paramInfo_wrapper(SEXP r_spec, SEXP r_paramNum) { if (Rf_length(r_spec) < RPF_ISpecCount) Rf_error("Item spec must be of length %d, not %d", RPF_ISpecCount, Rf_length(r_spec)); double *spec = REAL(r_spec); int id = spec[RPF_ISpecID]; if (id < 0 || id >= Glibrpf_numModels) Rf_error("Item model %d out of range", id); int pnum = Rf_asInteger(r_paramNum); int numParam = (*Glibrpf_model[id].numParam)(spec); if (pnum < 0 || pnum >= numParam) Rf_error("Item model %d has %d parameters", id, numParam); const char *type; double upper, lower; (*Glibrpf_model[id].paramInfo)(spec, pnum, &type, &upper, &lower); int len = 3; SEXP names, ans; Rf_protect(names = Rf_allocVector(STRSXP, len)); Rf_protect(ans = Rf_allocVector(VECSXP, len)); int lx = 0; SET_STRING_ELT(names, lx, Rf_mkChar("type")); SET_VECTOR_ELT(ans, lx, Rf_ScalarString(Rf_mkChar(type))); SET_STRING_ELT(names, ++lx, Rf_mkChar("upper")); SET_VECTOR_ELT(ans, lx, Rf_ScalarReal(std::isfinite(upper)? upper : NA_REAL)); SET_STRING_ELT(names, ++lx, Rf_mkChar("lower")); SET_VECTOR_ELT(ans, lx, Rf_ScalarReal(std::isfinite(lower)? lower : NA_REAL)); Rf_namesgets(ans, names); UNPROTECT(2); return ans; }
SEXP find_password(SEXP svc, SEXP usr, SEXP new_pwd, SEXP quiet, SEXP del) { SEXP res; OSStatus status; SecKeychainRef kc = NULL; /* default */ SecKeychainItemRef kci; const char *un, *sn; char *svc_name; void *pwd; UInt32 pwd_len = 0; int l; int silent = Rf_asInteger(quiet) == 1; int do_rm = Rf_asInteger(del) == 1; int modify = 0; if (TYPEOF(svc) != STRSXP || LENGTH(svc) != 1) Rf_error("Invalid service name"); if (new_pwd != R_NilValue && (TYPEOF(new_pwd) != STRSXP || LENGTH(new_pwd) != 1)) Rf_error("Invalid password"); if (new_pwd != R_NilValue || do_rm) modify = 1; if (usr == R_NilValue) { un = getlogin(); if (!un) Rf_error("Unable to get current user name via getlogin()"); } else { if (TYPEOF(usr) != STRSXP || LENGTH(usr) != 1) Rf_error("Invalid user name (must be a character vector of length one)"); un = Rf_translateCharUTF8(STRING_ELT(usr, 0)); } sn = Rf_translateCharUTF8(STRING_ELT(svc, 0)); l = strlen(sn); if (l > sizeof(buf) - 16) { svc_name = (char*) malloc(l + 16); if (!svc_name) Rf_error("Cannot allocate memory for service name"); } else svc_name = buf; /* we are enforcing R.keychain. prefix to avoid abuse to access other system keys */ strcpy(svc_name, SEC_PREFIX); strcat(svc_name, sn); status = SecKeychainFindGenericPassword(kc, strlen(svc_name), svc_name, strlen(un), un, &pwd_len, &pwd, modify ? &kci : NULL); if (svc_name != buf) free(svc_name); if (silent && status == errSecItemNotFound) return R_NilValue; chk_status(status, "find"); res = PROTECT(Rf_ScalarString(Rf_mkCharLenCE(pwd, pwd_len, CE_UTF8))); /* FIXME: we'll leak if the above fails in R */ SecKeychainItemFreeContent(NULL, pwd); if (do_rm) { status = SecKeychainItemDelete(kci); chk_status(status, "delete"); } else if (new_pwd != R_NilValue) { /* set a new one */ const char *np = Rf_translateCharUTF8(STRING_ELT(new_pwd, 0)); status = SecKeychainItemModifyContent(kci, NULL, strlen(np), np); chk_status(status, "modify"); } UNPROTECT(1); return res; }
SEXP flatten_impl(SEXP x) { if (TYPEOF(x) != VECSXP) { stop_bad_type(x, "a list", NULL, ".x"); } int m = Rf_length(x); // Determine output size and check type int n = 0; int has_names = 0; SEXP x_names = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); for (int j = 0; j < m; ++j) { SEXP x_j = VECTOR_ELT(x, j); if (!is_vector(x_j) && x_j != R_NilValue) { stop_bad_element_type(x_j, j + 1, "a vector", NULL, ".x"); } n += Rf_length(x_j); if (!has_names) { if (!Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) { // Sub-element is named has_names = 1; } else if (Rf_length(x_j) == 1 && !Rf_isNull(x_names)) { // Element is a "scalar" and has name in parent SEXP name = STRING_ELT(x_names, j); if (name != NA_STRING && strcmp(CHAR(name), "") != 0) has_names = 1; } } } SEXP out = PROTECT(Rf_allocVector(VECSXP, n)); SEXP names = PROTECT(Rf_allocVector(STRSXP, n)); if (has_names) Rf_setAttrib(out, R_NamesSymbol, names); int i = 0; for (int j = 0; j < m; ++j) { SEXP x_j = VECTOR_ELT(x, j); int n_j = Rf_length(x_j); SEXP names_j = PROTECT(Rf_getAttrib(x_j, R_NamesSymbol)); int has_names_j = !Rf_isNull(names_j); for (int k = 0; k < n_j; ++k, ++i) { switch(TYPEOF(x_j)) { case LGLSXP: SET_VECTOR_ELT(out, i, Rf_ScalarLogical(LOGICAL(x_j)[k])); break; case INTSXP: SET_VECTOR_ELT(out, i, Rf_ScalarInteger(INTEGER(x_j)[k])); break; case REALSXP: SET_VECTOR_ELT(out, i, Rf_ScalarReal(REAL(x_j)[k])); break; case CPLXSXP: SET_VECTOR_ELT(out, i, Rf_ScalarComplex(COMPLEX(x_j)[k])); break; case STRSXP: SET_VECTOR_ELT(out, i, Rf_ScalarString(STRING_ELT(x_j, k))); break; case RAWSXP: SET_VECTOR_ELT(out, i, Rf_ScalarRaw(RAW(x_j)[k])); break; case VECSXP: SET_VECTOR_ELT(out, i, VECTOR_ELT(x_j, k)); break; default: Rf_error("Internal error: `flatten_impl()` should have failed earlier"); } if (has_names) { if (has_names_j) { SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar("")); } else if (n_j == 1) { SET_STRING_ELT(names, i, !Rf_isNull(x_names) ? STRING_ELT(x_names, j) : Rf_mkChar("")); } } if (i % 1024 == 0) R_CheckUserInterrupt(); } UNPROTECT(1); } UNPROTECT(3); return out; }
/** Get localized time zone info * * @param tz single string or NULL * @param locale single string or NULL * @param display_type single string * @return list * * @version 0.5-1 (Marek Gagolewski, 2014-12-24) * * @version 0.5-1 (Marek Gagolewski, 2015-03-01) * new out: WindowsID, NameDaylight, new in: display_type */ SEXP stri_timezone_info(SEXP tz, SEXP locale, SEXP display_type) { TimeZone* curtz = stri__prepare_arg_timezone(tz, "tz", R_NilValue); const char* qloc = stri__prepare_arg_locale(locale, "locale", true); /* this is R_alloc'ed */ const char* dtype_str = stri__prepare_arg_string_1_notNA(display_type, "display_type"); /* this is R_alloc'ed */ const char* dtype_opts[] = { "short", "long", "generic_short", "generic_long", "gmt_short", "gmt_long", "common", "generic_location", NULL}; int dtype_cur = stri__match_arg(dtype_str, dtype_opts); TimeZone::EDisplayType dtype; switch (dtype_cur) { case 0: dtype = TimeZone::SHORT; break; case 1: dtype = TimeZone::LONG; break; case 2: dtype = TimeZone::SHORT_GENERIC; break; case 3: dtype = TimeZone::LONG_GENERIC; break; case 4: dtype = TimeZone::SHORT_GMT; break; case 5: dtype = TimeZone::LONG_GMT; break; case 6: dtype = TimeZone::SHORT_COMMONLY_USED; break; case 7: dtype = TimeZone::GENERIC_LOCATION; break; default: Rf_error(MSG__INCORRECT_MATCH_OPTION, "display_type"); break; } const R_len_t infosize = 6; SEXP vals; PROTECT(vals = Rf_allocVector(VECSXP, infosize)); for (int i=0; i<infosize; ++i) SET_VECTOR_ELT(vals, i, R_NilValue); R_len_t curidx = -1; ++curidx; UnicodeString val_ID; curtz->getID(val_ID); SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_ID)); ++curidx; UnicodeString val_name; curtz->getDisplayName(false, dtype, Locale::createFromName(qloc), val_name); SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_name)); ++curidx; if ((bool)curtz->useDaylightTime()) { UnicodeString val_name2; curtz->getDisplayName(true, dtype, Locale::createFromName(qloc), val_name2); SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_name2)); } else SET_VECTOR_ELT(vals, curidx, Rf_ScalarString(NA_STRING)); ++curidx; UnicodeString val_windows; UErrorCode status = U_ZERO_ERROR; #if U_ICU_VERSION_MAJOR_NUM>=52 TimeZone::getWindowsID(val_ID, val_windows, status); // Stable since ICU 52 #endif if (U_SUCCESS(status) && val_windows.length() > 0) SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_windows)); else SET_VECTOR_ELT(vals, curidx, Rf_ScalarString(NA_STRING)); ++curidx; SET_VECTOR_ELT(vals, curidx, Rf_ScalarReal(curtz->getRawOffset()/1000.0/3600.0)); ++curidx; SET_VECTOR_ELT(vals, curidx, Rf_ScalarLogical((bool)curtz->useDaylightTime())); delete curtz; stri__set_names(vals, infosize, "ID", "Name", "Name.Daylight", "Name.Windows", "RawOffset", "UsesDaylightTime"); UNPROTECT(1); return vals; }
SEXP transpose_impl(SEXP x, SEXP names_template) { if (TYPEOF(x) != VECSXP) Rf_errorcall(R_NilValue, "`.l` is not a list (%s)", Rf_type2char(TYPEOF(x))); int n = Rf_length(x); if (n == 0) { return Rf_allocVector(VECSXP, 0); } int has_template = !Rf_isNull(names_template); SEXP x1 = VECTOR_ELT(x, 0); if (!Rf_isVector(x1)) Rf_errorcall(R_NilValue, "Element 1 is not a vector (%s)", Rf_type2char(TYPEOF(x1))); int m = has_template ? Rf_length(names_template) : Rf_length(x1); // Create space for output SEXP out = PROTECT(Rf_allocVector(VECSXP, m)); SEXP names1 = Rf_getAttrib(x, R_NamesSymbol); for (int j = 0; j < m; ++j) { SEXP xj = PROTECT(Rf_allocVector(VECSXP, n)); if (!Rf_isNull(names1)) { Rf_setAttrib(xj, R_NamesSymbol, names1); } SET_VECTOR_ELT(out, j, xj); UNPROTECT(1); } SEXP names2 = has_template ? names_template : Rf_getAttrib(x1, R_NamesSymbol); if (!Rf_isNull(names2)) { Rf_setAttrib(out, R_NamesSymbol, names2); } // Fill output for (int i = 0; i < n; ++i) { SEXP xi = VECTOR_ELT(x, i); if (!Rf_isVector(xi)) Rf_errorcall(R_NilValue, "Element %i is not a vector (%s)", i + 1, Rf_type2char(TYPEOF(x1))); // find mapping between names and index. Use -1 to indicate not found SEXP names_i = Rf_getAttrib(xi, R_NamesSymbol); SEXP index; if (!Rf_isNull(names2) && !Rf_isNull(names_i)) { index = PROTECT(Rf_match(names_i, names2, 0)); // Rf_match returns 1-based index; convert to 0-based for C for (int i = 0; i < m; ++i) { INTEGER(index)[i] = INTEGER(index)[i] - 1; } } else { index = PROTECT(Rf_allocVector(INTSXP, m)); int mi = Rf_length(xi); if (m != mi) { Rf_warningcall(R_NilValue, "Element %i has length %i not %i", i + 1, mi, m); } for (int i = 0; i < m; ++i) { INTEGER(index)[i] = (i < mi) ? i : -1; } } int* pIndex = INTEGER(index); for (int j = 0; j < m; ++j) { int pos = pIndex[j]; if (pos == -1) continue; switch(TYPEOF(xi)) { case LGLSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarLogical(LOGICAL(xi)[pos])); break; case INTSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarInteger(INTEGER(xi)[pos])); break; case REALSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarReal(REAL(xi)[pos])); break; case STRSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarString(STRING_ELT(xi, pos))); break; case VECSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, VECTOR_ELT(xi, pos)); break; default: Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(xi))); } } UNPROTECT(1); } UNPROTECT(1); return out; }
/** Fetch information on an encoding * * @param enc either NULL or "" for default encoding, * or one string with encoding name * @return R list object with many components (see R doc for details) * * @version 0.1-?? (Marek Gagolewski) * * @version 0.2-1 (Marek Gagolewski) * use StriUcnv; make StriException-friendly * * @version 0.3-1 (Marek Gagolewski, 2014-11-04) * Issue #112: str_prepare_arg* retvals were not PROTECTed from gc */ SEXP stri_enc_info(SEXP enc) { const char* selected_enc = stri__prepare_arg_enc(enc, "enc", true/*default ok*/); /* this is R_alloc'ed */ STRI__ERROR_HANDLER_BEGIN(0) StriUcnv uconv_obj(selected_enc); //uconv_obj.setCallBackSubstitute(); // restore default callbacks (no warning) UConverter* uconv = uconv_obj.getConverter(false); UErrorCode status = U_ZERO_ERROR; // get the list of available standards vector<const char*> standards = StriUcnv::getStandards(); R_len_t standards_n = (R_len_t)standards.size(); // alloc output list SEXP vals; SEXP names; const int nval = standards_n+2+5; STRI__PROTECT(names = Rf_allocVector(STRSXP, nval)); SET_STRING_ELT(names, 0, Rf_mkChar("Name.friendly")); SET_STRING_ELT(names, 1, Rf_mkChar("Name.ICU")); for (R_len_t i=0; i<standards_n; ++i) { if (standards[i]) SET_STRING_ELT(names, i+2, Rf_mkChar((string("Name.")+standards[i]).c_str())); } SET_STRING_ELT(names, nval-5, Rf_mkChar("ASCII.subset")); SET_STRING_ELT(names, nval-4, Rf_mkChar("Unicode.1to1")); SET_STRING_ELT(names, nval-3, Rf_mkChar("CharSize.8bit")); SET_STRING_ELT(names, nval-2, Rf_mkChar("CharSize.min")); SET_STRING_ELT(names, nval-1, Rf_mkChar("CharSize.max")); STRI__PROTECT(vals = Rf_allocVector(VECSXP, nval)); // get canonical (ICU) name status = U_ZERO_ERROR; const char* canname = ucnv_getName(uconv, &status); if (U_FAILURE(status) || !canname) { SET_VECTOR_ELT(vals, 1, Rf_ScalarString(NA_STRING)); Rf_warning(MSG__ENC_ERROR_GETNAME); } else { SET_VECTOR_ELT(vals, 1, stri__make_character_vector_char_ptr(1, canname)); // friendly name const char* frname = StriUcnv::getFriendlyName(canname); if (frname) SET_VECTOR_ELT(vals, 0, stri__make_character_vector_char_ptr(1, frname)); else SET_VECTOR_ELT(vals, 0, Rf_ScalarString(NA_STRING)); // has ASCII as its subset? SET_VECTOR_ELT(vals, nval-5, Rf_ScalarLogical((int)uconv_obj.hasASCIIsubset())); // min,max character size, is 8bit? int mincharsize = (int)ucnv_getMinCharSize(uconv); int maxcharsize = (int)ucnv_getMaxCharSize(uconv); int is8bit = (mincharsize==1 && maxcharsize == 1); SET_VECTOR_ELT(vals, nval-3, Rf_ScalarLogical(is8bit)); SET_VECTOR_ELT(vals, nval-2, Rf_ScalarInteger(mincharsize)); SET_VECTOR_ELT(vals, nval-1, Rf_ScalarInteger(maxcharsize)); // is there a one-to-one correspondence with Unicode? if (!is8bit) SET_VECTOR_ELT(vals, nval-4, Rf_ScalarLogical(NA_LOGICAL)); else SET_VECTOR_ELT(vals, nval-4, Rf_ScalarLogical((int)uconv_obj.is1to1Unicode())); // other standard names for (R_len_t i=0; i<standards_n; ++i) { if (!standards[i]) continue; status = U_ZERO_ERROR; const char* stdname = ucnv_getStandardName(canname, standards[i], &status); if (U_FAILURE(status) || !stdname) SET_VECTOR_ELT(vals, i+2, Rf_ScalarString(NA_STRING)); else SET_VECTOR_ELT(vals, i+2, stri__make_character_vector_char_ptr(1, stdname)); } } Rf_setAttrib(vals, R_NamesSymbol, names); STRI__UNPROTECT_ALL return vals; STRI__ERROR_HANDLER_END({/* no special action on error */}) }
// adapted from https://github.com/armgong/RJulia/blob/master/src/R_Julia.c SEXP jr_scalar(jl_value_t *tt) { SEXP ans = R_NilValue; double z; // float64, int64, int32 are most common, so put them in the front if (jl_is_float64(tt)) { PROTECT(ans = Rf_ScalarReal(jl_unbox_float64(tt))); UNPROTECT(1); } else if (jl_is_int32(tt)) { PROTECT(ans = Rf_ScalarInteger(jl_unbox_int32(tt))); UNPROTECT(1); } else if (jl_is_int64(tt)) { z = (double)jl_unbox_int64(tt); if (in_int32_range(z)) PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_int64(tt))); else PROTECT(ans = Rf_ScalarReal(z)); UNPROTECT(1); } else if (jl_is_bool(tt)) { PROTECT(ans = Rf_ScalarLogical(jl_unbox_bool(tt))); UNPROTECT(1); } else if (jl_is_int8(tt)) { PROTECT(ans = Rf_ScalarInteger(jl_unbox_int8(tt))); UNPROTECT(1); } else if (jl_is_uint8(tt)) { PROTECT(ans = Rf_ScalarInteger(jl_unbox_uint8(tt))); UNPROTECT(1); } else if (jl_is_int16(tt)) { PROTECT(ans = Rf_ScalarInteger(jl_unbox_int16(tt))); UNPROTECT(1); } else if (jl_is_uint16(tt)) { PROTECT(ans = Rf_ScalarInteger(jl_unbox_uint16(tt))); UNPROTECT(1); } else if (jl_is_uint32(tt)) { z = (double)jl_unbox_uint32(tt); if (in_int32_range(z)) PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_uint32(tt))); else PROTECT(ans = Rf_ScalarReal(z)); UNPROTECT(1); } else if (jl_is_uint64(tt)) { z = (double)jl_unbox_int64(tt); if (in_int32_range(z)) PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_uint64(tt))); else PROTECT(ans = Rf_ScalarReal(z)); UNPROTECT(1); } else if (jl_is_float32(tt)) { PROTECT(ans = Rf_ScalarReal(jl_unbox_float32(tt))); UNPROTECT(1); } else if (jl_is_utf8_string(tt)) { PROTECT(ans = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(ans, 0, Rf_mkCharCE(jl_string_data(tt), CE_UTF8)); UNPROTECT(1); } else if (jl_is_ascii_string(tt)) { PROTECT(ans = Rf_ScalarString(Rf_mkChar(jl_string_data(tt)))); UNPROTECT(1); } return ans; }
/** Date-time artithmetic * * @param time * @param value * @param units * @param tz * @param locale * * @return POSIXst * * @version 0.5-1 (Marek Gagolewski, 2014-12-30) * @version 0.5-1 (Marek Gagolewski, 2015-03-06) tz arg added */ SEXP stri_datetime_add(SEXP time, SEXP value, SEXP units, SEXP tz, SEXP locale) { PROTECT(time = stri_prepare_arg_POSIXct(time, "time")); PROTECT(value = stri_prepare_arg_integer(value, "value")); if (!isNull(tz)) PROTECT(tz = stri_prepare_arg_string_1(tz, "tz")); else PROTECT(tz); /* needed to set tzone attrib */ R_len_t vectorize_length = stri__recycling_rule(true, 2, LENGTH(time), LENGTH(value)); const char* units_val = stri__prepare_arg_string_1_notNA(units, "units"); const char* units_opts[] = {"years", "months", "weeks", "days", "hours", "minutes", "seconds", "milliseconds", NULL}; int units_cur = stri__match_arg(units_val, units_opts); const char* locale_val = stri__prepare_arg_locale(locale, "locale", true); TimeZone* tz_val = stri__prepare_arg_timezone(tz, "tz", true/*allowdefault*/); Calendar* cal = NULL; STRI__ERROR_HANDLER_BEGIN(3) StriContainerDouble time_cont(time, vectorize_length); StriContainerInteger value_cont(value, vectorize_length); UCalendarDateFields units_field; switch (units_cur) { case 0: units_field = UCAL_YEAR; break; case 1: units_field = UCAL_MONTH; break; case 2: units_field = UCAL_WEEK_OF_YEAR; break; case 3: units_field = UCAL_DAY_OF_MONTH; break; case 4: units_field = UCAL_HOUR_OF_DAY; break; case 5: units_field = UCAL_MINUTE; break; case 6: units_field = UCAL_SECOND; break; case 7: units_field = UCAL_MILLISECOND; break; default: throw StriException(MSG__INCORRECT_MATCH_OPTION, "units"); } UErrorCode status = U_ZERO_ERROR; cal = Calendar::createInstance(locale_val, status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) cal->adoptTimeZone(tz_val); tz_val = NULL; /* The Calendar takes ownership of the TimeZone. */ SEXP ret; STRI__PROTECT(ret = Rf_allocVector(REALSXP, vectorize_length)); double* ret_val = REAL(ret); for (R_len_t i=0; i<vectorize_length; ++i) { if (time_cont.isNA(i) || value_cont.isNA(i)) { ret_val[i] = NA_REAL; continue; } status = U_ZERO_ERROR; cal->setTime((UDate)(time_cont.get(i)*1000.0), status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) status = U_ZERO_ERROR; cal->add(units_field, value_cont.get(i), status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) status = U_ZERO_ERROR; ret_val[i] = ((double)cal->getTime(status))/1000.0; STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) } if (!isNull(tz)) Rf_setAttrib(ret, Rf_ScalarString(Rf_mkChar("tzone")), tz); stri__set_class_POSIXct(ret); if (tz_val) { delete tz_val; tz_val = NULL; } if (cal) { delete cal; cal = NULL; } STRI__UNPROTECT_ALL return ret; STRI__ERROR_HANDLER_END({ if (tz_val) { delete tz_val; tz_val = NULL; } if (cal) { delete cal; cal = NULL; } }) }
/** Word wrap text * * @param str character vector * @param width single integer * @param cost_exponent single double * @param indent single integer * @param exdent single integer * @param prefix single string * @param initial single string * @param locale locale identifier or NULL for default locale * @param use_length single logical value * * @return list * * @version 0.1-?? (Bartek Tartanus) * * @version 0.2-2 (Marek Gagolewski, 2014-04-27) * single function for wrap_greedy and wrap_dynamic * (dispatch inside); * use BreakIterator * * @version 0.3-1 (Marek Gagolewski, 2014-11-04) * Issue #112: str_prepare_arg* retvals were not PROTECTed from gc * * @version 0.4-1 (Marek Gagolewski, 2014-12-06) * new args: indent, exdent, prefix, initial * * @version 0.5-1 (Marek Gagolewski, 2014-12-19) * #133 allow width <= 0 * * @version 0.5-1 (Marek Gagolewski, 2015-02-28) * don't trim so many white spaces at the end of each word (normalize arg does that) * #139: allow a "whitespace" break iterator * * @version 0.5-1 (Marek Gagolewski, 2015-04-23) * `use_length` arg added * * * @version 0.5-1 (Marek Gagolewski, 2015-06-09) * BIGSKIP: no more CHARSXP on out on "" input */ SEXP stri_wrap(SEXP str, SEXP width, SEXP cost_exponent, SEXP indent, SEXP exdent, SEXP prefix, SEXP initial, SEXP whitespace_only, SEXP use_length, SEXP locale) { bool use_length_val = stri__prepare_arg_logical_1_notNA(use_length, "use_length"); double exponent_val = stri__prepare_arg_double_1_notNA(cost_exponent, "cost_exponent"); bool whitespace_only_val = stri__prepare_arg_logical_1_notNA(whitespace_only, "whitespace_only"); int width_val = stri__prepare_arg_integer_1_notNA(width, "width"); if (width_val <= 0) width_val = 0; int indent_val = stri__prepare_arg_integer_1_notNA(indent, "indent"); if (indent_val < 0) Rf_error(MSG__EXPECTED_POSITIVE, "indent"); int exdent_val = stri__prepare_arg_integer_1_notNA(exdent, "exdent"); if (exdent_val < 0) Rf_error(MSG__EXPECTED_POSITIVE, "exdent"); const char* qloc = stri__prepare_arg_locale(locale, "locale", true); /* this is R_alloc'ed */ Locale loc = Locale::createFromName(qloc); PROTECT(str = stri_prepare_arg_string(str, "str")); PROTECT(prefix = stri_prepare_arg_string_1(prefix, "prefix")); PROTECT(initial = stri_prepare_arg_string_1(initial, "initial")); BreakIterator* briter = NULL; UText* str_text = NULL; STRI__ERROR_HANDLER_BEGIN(3) UErrorCode status = U_ZERO_ERROR; briter = BreakIterator::createLineInstance(loc, status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) R_len_t str_length = LENGTH(str); StriContainerUTF8_indexable str_cont(str, str_length); StriContainerUTF8 prefix_cont(prefix, 1); StriContainerUTF8 initial_cont(initial, 1); // prepare indent/exdent/prefix/initial stuff: // 1st line, 1st para (i==0, u==0): initial+indent // nth line, 1st para (i==0, u> 0): prefix +exdent // 1st line, nth para (i> 0, u==0): prefix +indent // nth line, nth para (i> 0, u> 0): prefix +exdent StriWrapLineStart ii(initial_cont.get(0), indent_val); StriWrapLineStart pi(prefix_cont.get(0), indent_val); StriWrapLineStart pe(prefix_cont.get(0), exdent_val); status = U_ZERO_ERROR; //Unicode Newline Guidelines - Unicode Technical Report #13 UnicodeSet uset_linebreaks(UnicodeString::fromUTF8("[\\u000A-\\u000D\\u0085\\u2028\\u2029]"), status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) uset_linebreaks.freeze(); status = U_ZERO_ERROR; UnicodeSet uset_whitespaces(UnicodeString::fromUTF8("\\p{White_space}"), status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) uset_whitespaces.freeze(); SEXP ret; STRI__PROTECT(ret = Rf_allocVector(VECSXP, str_length)); for (R_len_t i = 0; i < str_length; ++i) { if (str_cont.isNA(i) || prefix_cont.isNA(0) || initial_cont.isNA(0)) { SET_VECTOR_ELT(ret, i, stri__vector_NA_strings(1)); continue; } status = U_ZERO_ERROR; const char* str_cur_s = str_cont.get(i).c_str(); R_len_t str_cur_n = str_cont.get(i).length(); str_text = utext_openUTF8(str_text, str_cur_s, str_cont.get(i).length(), &status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) status = U_ZERO_ERROR; briter->setText(str_text, status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) // all right, first let's generate a list of places at which we may do line breaks deque< R_len_t > occurrences_list; // this could be an R_len_t queue R_len_t match = briter->first(); while (match != BreakIterator::DONE) { if (!whitespace_only_val) occurrences_list.push_back(match); else { if (match > 0 && match < str_cur_n) { UChar32 c; U8_GET((const uint8_t*)str_cur_s, 0, match-1, str_cur_n, c); if (uset_whitespaces.contains(c)) occurrences_list.push_back(match); } else occurrences_list.push_back(match); } match = briter->next(); } R_len_t noccurrences = (R_len_t)occurrences_list.size(); // number of boundaries if (noccurrences <= 1) { // no match (1 boundary == 0) SET_VECTOR_ELT(ret, i, Rf_ScalarString(str_cont.toR(i))); continue; } // the number of "words" is: R_len_t nwords = noccurrences - 1; // convert occurrences_list to a vector // in order to obtain end positions (in a string) of each "words", // noting that occurrences_list.at(0) == 0 #ifndef NDEBUG if (occurrences_list.at(0) != 0) throw StriException("NDEBUG: stri_wrap: (occurrences_list.at(0) != 0)"); #endif std::vector<R_len_t> end_pos_orig(nwords); deque<R_len_t>::iterator iter = ++(occurrences_list.begin()); for (R_len_t j = 0; iter != occurrences_list.end(); ++iter, ++j) { end_pos_orig[j] = (*iter); // this is a UTF-8 index } // now: // we'll get the total widths/number of code points in each "word" std::vector<R_len_t> widths_orig(nwords); // we'll get the total widths/number of code points without trailing whitespaces std::vector<R_len_t> widths_trim(nwords); // we'll get the end positions without trailing whitespaces std::vector<R_len_t> end_pos_trim(nwords); // detect line endings (fail on a match) UChar32 c = 0; R_len_t j = 0; R_len_t cur_block = 0; R_len_t cur_width_orig = 0; R_len_t cur_width_trim = 0; R_len_t cur_count_orig = 0; R_len_t cur_count_trim = 0; R_len_t cur_end_pos_trim = 0; while (j < str_cur_n) { R_len_t jlast = j; U8_NEXT(str_cur_s, j, str_cur_n, c); if (c < 0) // invalid utf-8 sequence throw StriException(MSG__INVALID_UTF8); if (uset_linebreaks.contains(c)) throw StriException(MSG__NEWLINE_FOUND); cur_width_orig += stri__width_char(c); ++cur_count_orig; if (uset_whitespaces.contains(c)) { // OLD: trim all white spaces from the end: // ++cur_count_trim; // [we have the normalize arg for that] // NEW: trim just one white space at the end: cur_width_trim = stri__width_char(c); cur_count_trim = 1; cur_end_pos_trim = jlast; } else { cur_width_trim = 0; cur_count_trim = 0; cur_end_pos_trim = j; } if (j >= str_cur_n || end_pos_orig[cur_block] <= j) { // we'll start a new block in a moment if (use_length_val) { widths_orig[cur_block] = cur_count_orig; widths_trim[cur_block] = cur_count_orig-cur_count_trim; } else { widths_orig[cur_block] = cur_width_orig; widths_trim[cur_block] = cur_width_orig-cur_width_trim; } end_pos_trim[cur_block] = cur_end_pos_trim; cur_block++; cur_width_orig = 0; cur_width_trim = 0; cur_count_orig = 0; cur_count_trim = 0; cur_end_pos_trim = j; } } // do wrap std::deque<R_len_t> wrap_after; // wrap line after which word in {0..nwords-1}? if (exponent_val <= 0.0) { stri__wrap_greedy(wrap_after, nwords, width_val, widths_orig, widths_trim, (use_length_val)?((i==0)?ii.count:pi.count):((i==0)?ii.width:pi.width), (use_length_val)?pe.count:pe.width); } else { stri__wrap_dynamic(wrap_after, nwords, width_val, exponent_val, widths_orig, widths_trim, (use_length_val)?((i==0)?ii.count:pi.count):((i==0)?ii.width:pi.width), (use_length_val)?pe.count:pe.width); } // wrap_after.size() line breaks => wrap_after.size()+1 lines R_len_t nlines = (R_len_t)wrap_after.size()+1; R_len_t last_pos = 0; SEXP ans; STRI__PROTECT(ans = Rf_allocVector(STRSXP, nlines)); deque<R_len_t>::iterator iter_wrap = wrap_after.begin(); for (R_len_t u = 0; iter_wrap != wrap_after.end(); ++iter_wrap, ++u) { R_len_t wrap_after_cur = *iter_wrap; R_len_t cur_pos = end_pos_trim[wrap_after_cur]; std::string cs; if (i == 0 && u == 0) cs = ii.str; else if (i > 0 && u == 0) cs = pi.str; else cs = pe.str; cs.append(str_cur_s+last_pos, cur_pos-last_pos); SET_STRING_ELT(ans, u, Rf_mkCharLenCE(cs.c_str(), cs.size(), CE_UTF8)); last_pos = end_pos_orig[wrap_after_cur]; } // last line goes here: std::string cs; if (i == 0 && nlines-1 == 0) cs = ii.str; else if (i > 0 && nlines-1 == 0) cs = pi.str; else cs = pe.str; cs.append(str_cur_s+last_pos, end_pos_trim[nwords-1]-last_pos); SET_STRING_ELT(ans, nlines-1, Rf_mkCharLenCE(cs.c_str(), cs.size(), CE_UTF8)); SET_VECTOR_ELT(ret, i, ans); STRI__UNPROTECT(1); } if (briter) { delete briter; briter = NULL; } if (str_text) { utext_close(str_text); str_text = NULL; } STRI__UNPROTECT_ALL return ret; STRI__ERROR_HANDLER_END({ if (briter) { delete briter; briter = NULL; } if (str_text) { utext_close(str_text); str_text = NULL; } }) }
/** * Parse date-time objects * * @param str * @param format * @param tz * @param lenient * @param locale * * @return character vector * * @version 0.5-1 (Marek Gagolewski, 2015-01-08) * @version 0.5-1 (Marek Gagolewski, 2015-01-11) lenient arg added * @version 0.5-1 (Marek Gagolewski, 2015-02-22) use tz * @version 0.5-1 (Marek Gagolewski, 2015-03-01) set tzone attrib on retval */ SEXP stri_datetime_parse(SEXP str, SEXP format, SEXP lenient, SEXP tz, SEXP locale) { PROTECT(str = stri_prepare_arg_string(str, "str")); const char* locale_val = stri__prepare_arg_locale(locale, "locale", true); const char* format_val = stri__prepare_arg_string_1_notNA(format, "format"); bool lenient_val = stri__prepare_arg_logical_1_notNA(lenient, "lenient"); if (!isNull(tz)) PROTECT(tz = stri_prepare_arg_string_1(tz, "tz")); else PROTECT(tz); /* needed to set tzone attrib */ // "format" may be one of: const char* format_opts[] = { "date_full", "date_long", "date_medium", "date_short", "date_relative_full", "date_relative_long", "date_relative_medium", "date_relative_short", "time_full", "time_long", "time_medium", "time_short", "time_relative_full", "time_relative_long", "time_relative_medium", "time_relative_short", "datetime_full", "datetime_long", "datetime_medium", "datetime_short", "datetime_relative_full", "datetime_relative_long", "datetime_relative_medium", "datetime_relative_short", NULL}; int format_cur = stri__match_arg(format_val, format_opts); TimeZone* tz_val = stri__prepare_arg_timezone(tz, "tz", true/*allowdefault*/); Calendar* cal = NULL; DateFormat* fmt = NULL; STRI__ERROR_HANDLER_BEGIN(2) R_len_t vectorize_length = LENGTH(str); StriContainerUTF16 str_cont(str, vectorize_length); UnicodeString format_str(format_val); UErrorCode status = U_ZERO_ERROR; if (format_cur >= 0) { DateFormat::EStyle style = DateFormat::kNone; switch (format_cur % 8) { case 0: style = DateFormat::kFull; break; case 1: style = DateFormat::kLong; break; case 2: style = DateFormat::kMedium; break; case 3: style = DateFormat::kShort; break; case 4: style = DateFormat::kFullRelative; break; case 5: style = DateFormat::kLongRelative; break; case 6: style = DateFormat::kMediumRelative; break; case 7: style = DateFormat::kShortRelative; break; default: style = DateFormat::kNone; break; } /* ICU 54.1: Relative time styles are not currently supported. */ switch (format_cur / 8) { case 0: fmt = DateFormat::createDateInstance(style, Locale::createFromName(locale_val)); break; case 1: fmt = DateFormat::createTimeInstance((DateFormat::EStyle)(style & ~DateFormat::kRelative), Locale::createFromName(locale_val)); break; case 2: fmt = DateFormat::createDateTimeInstance(style, (DateFormat::EStyle)(style & ~DateFormat::kRelative), Locale::createFromName(locale_val)); break; default: fmt = NULL; break; } } else fmt = new SimpleDateFormat(format_str, Locale::createFromName(locale_val), status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) status = U_ZERO_ERROR; cal = Calendar::createInstance(locale_val, status); STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) cal->adoptTimeZone(tz_val); tz_val = NULL; /* The Calendar takes ownership of the TimeZone. */ cal->setLenient(lenient_val); SEXP ret; STRI__PROTECT(ret = Rf_allocVector(REALSXP, vectorize_length)); for (R_len_t i=0; i<vectorize_length; ++i) { if (str_cont.isNA(i)) { REAL(ret)[i] = NA_REAL; continue; } status = U_ZERO_ERROR; ParsePosition pos; fmt->parse(str_cont.get(i), *cal, pos); if (pos.getErrorIndex() >= 0) REAL(ret)[i] = NA_REAL; else { status = U_ZERO_ERROR; REAL(ret)[i] = ((double)cal->getTime(status))/1000.0; if (U_FAILURE(status)) REAL(ret)[i] = NA_REAL; } } if (!isNull(tz)) Rf_setAttrib(ret, Rf_ScalarString(Rf_mkChar("tzone")), tz); stri__set_class_POSIXct(ret); if (tz_val) { delete tz_val; tz_val = NULL; } if (fmt) { delete fmt; fmt = NULL; } if (cal) { delete cal; cal = NULL; } STRI__UNPROTECT_ALL return ret; STRI__ERROR_HANDLER_END({ if (tz_val) { delete tz_val; tz_val = NULL; } if (fmt) { delete fmt; fmt = NULL; } if (cal) { delete cal; cal = NULL; } }) }