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; }
})
}
