SEXP R_mpc_div(SEXP e1, SEXP e2) {
/* N.B. We always use signed integers for e2 given R's type system. */
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_div(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_div_ui(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
mpc_div_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else if (Rf_isInteger(e1)) {
if (Rf_inherits(e2, "mpc")) {
/* TODO: sign issue here. mpc_ui_div is
* unsigned, mult -1 if needed by asnwer? */
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpc_ui_div(*z, INTEGER(e1)[0], *z2,
Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else if (Rf_isNumeric(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
mpc_fr_div(*z, x, *z2, Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else {
Rf_error("Invalid operands for mpc division.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP R_mpc_pow(SEXP e1, SEXP e2) {
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_pow(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_pow_si(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_pow_d(*z, *z1, REAL(e2)[0], Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc power.");
}
} else {
Rf_error("Invalid first operand for MPC power.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
/* R_mpc - Create an MPC S3 object for arbitrary precision complex numbers.
*
* We currently use external pointers for performance reasons, which
* means that we can't allocVector a list of length(n) MPC objects,
* and instead must instantiate them one at a time, that a caller can
* put into a list if they want, but not a vector.
*
* Args:
* n - An integer, numeric, or complex number to convert to an MPC.
* sprec - The number of bits of precision to use, e.g. 52 for doubles.
*/
SEXP R_mpc(SEXP n, SEXP sprec) {
/* TODO: INTEGER returns 32bit integer but mpfr_prec_t may be
* 64bit. This is based on how mpfr was compiled. Therefore we
* could add this as a configure check? */
mpfr_prec_t prec = INTEGER(sprec)[0];
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
mpc_init2(*z, prec);
if (Rf_isInteger(n)) {
mpc_set_d(*z, INTEGER(n)[0], Rmpc_get_rounding());
} else if (Rf_isNumeric(n)) {
mpc_set_d(*z, REAL(n)[0], Rmpc_get_rounding());
} else if (Rf_isComplex(n)) {
mpc_set_d_d(*z, COMPLEX(n)[0].r, COMPLEX(n)[0].i,
Rmpc_get_rounding());
} else if (Rf_isString(n)) {
mpc_set_str(*z, CHAR(STRING_ELT(n, 0)), 10,
Rmpc_get_rounding());
} else {
Rf_error("Unsupported type conversion to MPC.");
}
return(MakeMPC(z));
}
inline R_adjacency_list(SEXP num_verts_in,
SEXP num_edges_in,
SEXP R_edges_in,
SEXP R_weights_in)
: Base(Rf_asInteger(num_verts_in))
{
if (!Rf_isNumeric(R_weights_in)) error("R_weights_in should be Numeric");
if (!Rf_isInteger(R_edges_in)) error("R_edges_in should be integer");
int NE = Rf_asInteger(num_edges_in);
int* edges_in = INTEGER(R_edges_in);
if (Rf_isReal(R_weights_in)) {
if (boost::is_integral<R_weight_type>::value)
error("R_weights_in should be integer");
else {
double* weights_in = REAL(R_weights_in);
for (int i = 0; i < NE ; i++, edges_in += 2, weights_in++) {
boost::add_edge(*edges_in, *(edges_in+1),
*weights_in, *this);
}
}
} else {
int* weights_in = INTEGER(R_weights_in);
for (int i = 0; i < NE ; i++, edges_in += 2, weights_in++) {
boost::add_edge(*edges_in, *(edges_in+1), *weights_in, *this);
}
}
}
/**
* Construct Container from R cobject
* @param rstr R object
*
* if you want nrecycle > n, call set_nrecycle
*/
StriContainerListInt::StriContainerListInt(SEXP rstr)
{
this->data = NULL;
if (isNull(rstr)) {
this->init_Base(1, 1, true);
this->data = new IntVec[this->n]; // 1 vector, NA/NULL
if (!this->data) throw StriException(MSG__MEM_ALLOC_ERROR);
}
else if (Rf_isInteger(rstr)) {
this->init_Base(1, 1, true);
this->data = new IntVec[this->n];
if (!this->data) throw StriException(MSG__MEM_ALLOC_ERROR);
this->data[0].initialize((const int*)INTEGER(rstr), LENGTH(rstr)); // shallow copy
}
else // if (Rf_isVectorList(rstr)) -- args already checked
{
R_len_t nv = LENGTH(rstr);
this->init_Base(nv, nv, true);
this->data = new IntVec[this->n];
if (!this->data) throw StriException(MSG__MEM_ALLOC_ERROR);
for (R_len_t i=0; i<this->n; ++i) {
SEXP cur = VECTOR_ELT(rstr, i);
if (!isNull(cur))
this->data[i].initialize((const int*)INTEGER(cur), LENGTH(cur)); // shallow copy
// else leave as-is, i.e. NULL/NA
}
}
}
std::vector<int> ToIntVector(SEXP r_int_vector) {
if (!Rf_isInteger(r_int_vector)) {
report_error("Argument to ToIntVector must be a vector of integers.");
}
int *values = INTEGER(r_int_vector);
int length = Rf_length(r_int_vector);
return std::vector<int>(values, values + length);
}
/** Convert from UTF-32
*
* @param vec integer vector or list with integer vectors
* @return character vector
*
* @version 0.1 (Marek Gagolewski)
*/
SEXP stri_enc_fromutf32(SEXP vec)
{
if (Rf_isVectorList(vec)) {
R_len_t n = LENGTH(vec);
R_len_t bufsize = 0;
for (R_len_t i=0; i<n; ++i) {
SEXP cur = VECTOR_ELT(vec, i);
if (isNull(cur))
continue;
if (!Rf_isInteger(cur)) // this cannot be treated with stri_prepare_arg*, as vec may be a mem-shared object
Rf_error(MSG__ARG_EXPECTED_INTEGER_NO_COERCION, "vec[[i]]"); // error() allowed here
if (LENGTH(cur) > bufsize) bufsize = LENGTH(cur);
}
bufsize = U8_MAX_LENGTH*bufsize+1;
char* buf = new char[bufsize]; // no call to error() between new and delete -> OK
SEXP ret;
PROTECT(ret = Rf_allocVector(STRSXP, n));
for (R_len_t i=0; i<n; ++i) {
SEXP cur = VECTOR_ELT(vec, i);
if (isNull(cur)) {
SET_STRING_ELT(ret, i, NA_STRING);
continue;
}
R_len_t chars = stri__enc_fromutf32(INTEGER(cur), LENGTH(cur), buf, bufsize);
if (chars < 0)
SET_STRING_ELT(ret, i, NA_STRING);
else
SET_STRING_ELT(ret, i, Rf_mkCharLenCE(buf, chars, CE_UTF8));
}
delete [] buf;
UNPROTECT(1);
return ret;
}
else {
vec = stri_prepare_arg_integer(vec, "vec"); // integer vector
SEXP ret;
PROTECT(ret = Rf_allocVector(STRSXP, 1));
int* data = INTEGER(vec);
R_len_t ndata = LENGTH(vec);
R_len_t bufsize = U8_MAX_LENGTH*ndata+1;
char* buf = new char[bufsize]; // no call to error() between new and delete -> OK
R_len_t chars = stri__enc_fromutf32(data, ndata, buf, bufsize);
if (chars < 0)
SET_STRING_ELT(ret, 0, NA_STRING);
else
SET_STRING_ELT(ret, 0, Rf_mkCharLenCE(buf, chars, CE_UTF8));
delete [] buf;
UNPROTECT(1);
return ret;
}
}
inline R_adjacency_list(SEXP num_verts_in,
SEXP num_edges_in,
SEXP R_edges_in)
: Base(Rf_asInteger(num_verts_in))
{
if (!Rf_isInteger(R_edges_in)) error("R_edges_in should be integer");
int NE = Rf_asInteger(num_edges_in);
int* edges_in = INTEGER(R_edges_in);
for (int i = 0; i < NE ; i++, edges_in += 2) {
boost::add_edge(*edges_in, *(edges_in+1), 1, *this);
}
}
/**
* Compare elements in 2 character vectors, with collation
*
* @param e1 character vector
* @param e2 character vector
* @param opts_collator passed to stri__ucol_open()
* @param type [internal] vector of length 2,
* type[0]: 0 for ==, -1 for < and 1 for >,
* type[1]: 0 or 1 (whether to negate the results)
*
* @return logical vector
*
* @version 0.2-1 (Marek Gagolewski, 2014-03-19)
*
* @version 0.2-3 (Marek Gagolewski, 2014-05-07)
* opts_collator == NA no longer allowed
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_cmp_logical(SEXP e1, SEXP e2, SEXP opts_collator, SEXP type)
{
// we'll perform a collator-based cmp
// type is an internal arg, check manually, error() allowed here
if (!Rf_isInteger(type) || LENGTH(type) != 2)
Rf_error(MSG__INCORRECT_INTERNAL_ARG);
int _type = INTEGER(type)[0];
int _negate = INTEGER(type)[1];
if (_type > 1 || _type < -1 || _negate < 0 || _negate > 1)
Rf_error(MSG__INCORRECT_INTERNAL_ARG);
PROTECT(e1 = stri_prepare_arg_string(e1, "e1")); // prepare string argument
PROTECT(e2 = stri_prepare_arg_string(e2, "e2")); // prepare string argument
// call stri__ucol_open after prepare_arg:
// if prepare_arg had failed, we would have a mem leak
UCollator* col = NULL;
col = stri__ucol_open(opts_collator);
STRI__ERROR_HANDLER_BEGIN(2)
R_len_t vectorize_length = stri__recycling_rule(true, 2, LENGTH(e1), LENGTH(e2));
StriContainerUTF8 e1_cont(e1, vectorize_length);
StriContainerUTF8 e2_cont(e2, vectorize_length);
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(LGLSXP, vectorize_length));
int* ret_tab = LOGICAL(ret);
for (R_len_t i = 0; i < vectorize_length; ++i)
{
if (e1_cont.isNA(i) || e2_cont.isNA(i)) {
ret_tab[i] = NA_LOGICAL;
continue;
}
R_len_t cur1_n = e1_cont.get(i).length();
const char* cur1_s = e1_cont.get(i).c_str();
R_len_t cur2_n = e2_cont.get(i).length();
const char* cur2_s = e2_cont.get(i).c_str();
// with collation
UErrorCode status = U_ZERO_ERROR;
ret_tab[i] = (_type == (int)ucol_strcollUTF8(col,
cur1_s, cur1_n, cur2_s, cur2_n, &status
));
STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */})
if (_negate)
ret_tab[i] = !ret_tab[i];
}
/**
* Compare elements in 2 character vectors, without collation
*
* @param e1 character vector
* @param e2 character vector
* @param type [internal] integer; 0 or 1 (whether to negate the results)
*
* @return logical vector
*
* @version 0.2-3 (Marek Gagolewski, 2014-05-07)
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_cmp_codepoints(SEXP e1, SEXP e2, SEXP type)
{
// type is an internal arg, check manually, error() allowed here
if (!Rf_isInteger(type) || LENGTH(type) != 1)
Rf_error(MSG__INCORRECT_INTERNAL_ARG);
int _negate = INTEGER(type)[0];
if (_negate < 0 || _negate > 1)
Rf_error(MSG__INCORRECT_INTERNAL_ARG);
PROTECT(e1 = stri_prepare_arg_string(e1, "e1")); // prepare string argument
PROTECT(e2 = stri_prepare_arg_string(e2, "e2")); // prepare string argument
STRI__ERROR_HANDLER_BEGIN(2)
R_len_t vectorize_length = stri__recycling_rule(true, 2, LENGTH(e1), LENGTH(e2));
StriContainerUTF8 e1_cont(e1, vectorize_length);
StriContainerUTF8 e2_cont(e2, vectorize_length);
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(LGLSXP, vectorize_length));
int* ret_tab = LOGICAL(ret);
for (R_len_t i = 0; i < vectorize_length; ++i)
{
if (e1_cont.isNA(i) || e2_cont.isNA(i)) {
ret_tab[i] = NA_LOGICAL;
continue;
}
R_len_t cur1_n = e1_cont.get(i).length();
const char* cur1_s = e1_cont.get(i).c_str();
R_len_t cur2_n = e2_cont.get(i).length();
const char* cur2_s = e2_cont.get(i).c_str();
if (cur1_n != cur2_n) // different number of bytes => not equal
ret_tab[i] = FALSE;
else
ret_tab[i] = (memcmp(cur1_s, cur2_s, cur1_n) == 0);
if (_negate)
ret_tab[i] = !ret_tab[i];
}
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END({/* no-op on err */})
}
/* R_mpc_cmp - Comparison function for MPC objects.
*
* Ops.mpc.R includes code to coerce complex numbers or numerics from
* e2 into MPC objects for this comparison since the MPC library only
* supports comparison against other MPC objects or integers.
*
* Arguments:
* e1: SEXP for an mpc type.
* e2: SEXP for an mpc type, or integer.
* Return value:
* True if e1 == e2.
*/
SEXP R_mpc_cmp(SEXP e1, SEXP e2) {
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
return(Rf_ScalarInteger(mpc_cmp(*z1, *z2)));
} else if (Rf_isInteger(e2)) {
return(Rf_ScalarInteger(mpc_cmp_si(*z1,
INTEGER(e2)[0])));
} else {
Rf_error("Invalid operand for mpc cmp.");
}
} else {
Rf_error("Invalid operand for mpc cmp.");
}
}
int RcppParams::getIntValue(std::string name) {
std::map<std::string,int>::iterator iter = pmap.find(name);
if (iter == pmap.end()) {
std::string mesg = "RcppParams::getIntValue: no such name: ";
throw std::range_error(mesg+name);
}
int posn = iter->second;
SEXP elt = VECTOR_ELT(_params,posn);
if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
std::string mesg = "RcppParams::getIntValue: must be scalar: ";
throw std::range_error(mesg+name);
}
if (Rf_isInteger(elt))
return INTEGER(elt)[0];
else if (Rf_isReal(elt))
return (int)REAL(elt)[0];
else {
std::string mesg = "RcppParams::getIntValue: invalid value for: ";
throw std::range_error(mesg+name);
}
return 0; // never get here
}
SEXP R_mpc_add(SEXP e1, SEXP e2) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpfr_prec_t real_prec, imag_prec;
Rmpc_get_max_prec(&real_prec, &imag_prec, *z1, *z2);
mpc_init3(*z, real_prec, imag_prec);
mpc_add(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_add_ui(*z, *z1, INTEGER(e2)[0], Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpfr_t x;
mpfr_init2(x, 53);
// We use GMP_RNDN rather than MPFR_RNDN for compatibility
// with mpfr 2.4.x and earlier as well as more modern versions.
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
/* Max of mpc precision z2 and 53 from e2. */
Rprintf("Precision: %d\n", mpc_get_prec(*z1));
mpc_init2(*z, max(mpc_get_prec(*z1), 53));
mpc_add_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
/* TODO(mstokely): Add support for mpfr types here. */
free(z);
Rf_error("Invalid second operand for mpc addition.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP R_mpc_sub(SEXP e1, SEXP e2) {
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
if (Rf_inherits(e1, "mpc")) {
Rprintf("It's an mpc");
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_sub(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_sub_ui(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
Rprintf("Precision: %d\n", mpc_get_prec(*z1));
mpc_init2(*z, max(mpc_get_prec(*z1), 53));
mpc_sub_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operand 2 of MPC subtraction.");
}
} else if (Rf_isInteger(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpc_ui_sub(*z, INTEGER(e1)[0], *z2,
Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operands for MPC subtraction.");
}
} else if (Rf_isNumeric(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e1)[0], GMP_RNDN);
mpc_fr_sub(*z, x, *z2, Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operands for MPC subtraction.");
}
} else {
/* TODO(mstokely): Add support for mpfr types here. */
Rprintf("It's unknown");
free(z);
Rf_error("Invalid second operand for mpc subtraction.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
/**
* Pad a string
*
* vectorized over str, length and pad
* if str or pad or length is NA the result will be NA
*
* @param str character vector
* @param min_length integer vector
* @param side [internal int]
* @param pad character vector
* @param use_length single logical value
* @return character vector
*
* @version 0.1-?? (Bartlomiej Tartanus)
*
* @version 0.2-2 (Marek Gagolewski, 2014-04-20)
* use stri_error_handler, pad should be a single code point, not byte
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*
* @version 0.5-1 (Marek Gagolewski, 2015-04-22)
* `use_length` arg added,
* second argument renamed `width`
*/
SEXP stri_pad(SEXP str, SEXP width, SEXP side, SEXP pad, SEXP use_length)
{
// this is an internal arg, check manually, error() allowed here
if (!Rf_isInteger(side) || LENGTH(side) != 1)
Rf_error(MSG__INCORRECT_INTERNAL_ARG);
int _side = INTEGER(side)[0];
if (_side < 0 || _side > 2)
Rf_error(MSG__INCORRECT_INTERNAL_ARG);
bool use_length_val = stri__prepare_arg_logical_1_notNA(use_length, "use_length");
PROTECT(str = stri_prepare_arg_string(str, "str"));
PROTECT(width = stri_prepare_arg_integer(width, "width"));
PROTECT(pad = stri_prepare_arg_string(pad, "pad"));
// side = stri_prepare_arg_string(side, "side");
// const char* side_opts[] = {"left", "right", "both", NULL};
R_len_t str_length = LENGTH(str);
R_len_t width_length = LENGTH(width);
// R_len_t side_length = LENGTH(side);
R_len_t pad_length = LENGTH(pad);
R_len_t vectorize_length = stri__recycling_rule(true, 3,
str_length, width_length, /*side_length, */ pad_length);
STRI__ERROR_HANDLER_BEGIN(3)
StriContainerUTF8 str_cont(str, vectorize_length);
StriContainerInteger width_cont(width, vectorize_length);
// StriContainerUTF8 side_cont(side, vectorize_length);
StriContainerUTF8 pad_cont(pad, vectorize_length);
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(STRSXP, vectorize_length));
String8buf buf(0); // TODO: prealloc
for (R_len_t i=0; i<vectorize_length; ++i) {
if (str_cont.isNA(i) || pad_cont.isNA(i)
|| /*side_cont.isNA(i) ||*/ width_cont.isNA(i)) {
SET_STRING_ELT(ret, i, NA_STRING);
continue;
}
// get the current string
R_len_t str_cur_n = str_cont.get(i).length();
const char* str_cur_s = str_cont.get(i).c_str();
R_len_t str_cur_width;
// get the width/length of padding code point(s)
R_len_t pad_cur_n = pad_cont.get(i).length();
const char* pad_cur_s = pad_cont.get(i).c_str();
R_len_t pad_cur_width;
if (use_length_val) {
pad_cur_width = 1;
str_cur_width = str_cont.get(i).countCodePoints();
R_len_t k = 0;
UChar32 pad_cur = 0;
U8_NEXT(pad_cur_s, k, pad_cur_n, pad_cur);
if (pad_cur <= 0 || k < pad_cur_n)
throw StriException(MSG__NOT_EQ_N_CODEPOINTS, "pad", 1);
}
else {
pad_cur_width = stri__width_string(pad_cur_s, pad_cur_n);
str_cur_width = stri__width_string(str_cur_s, str_cur_n);
if (pad_cur_width != 1)
throw StriException(MSG__NOT_EQ_N_WIDTH, "pad", 1);
}
// get the minimal width
R_len_t width_cur = width_cont.get(i);
if (str_cur_width >= width_cur) {
// no padding at all
SET_STRING_ELT(ret, i, str_cont.toR(i));
continue;
}
R_len_t padnum = width_cur-str_cur_width;
buf.resize(str_cur_n+padnum*pad_cur_n, false);
char* buftmp = buf.data();
R_len_t k = 0;
switch(_side) {
case 0: // left
for (k=0; k<padnum; ++k) {
memcpy(buftmp, pad_cur_s, pad_cur_n);
buftmp += pad_cur_n;
}
memcpy(buftmp, str_cur_s, str_cur_n);
buftmp += str_cur_n;
break;
case 1: // right
memcpy(buftmp, str_cur_s, str_cur_n);
buftmp += str_cur_n;
for (k=0; k<padnum; ++k) {
memcpy(buftmp, pad_cur_s, pad_cur_n);
buftmp += pad_cur_n;
}
break;
case 2: // both
for (k=0; k<padnum/2; ++k) {
memcpy(buftmp, pad_cur_s, pad_cur_n);
buftmp += pad_cur_n;
}
memcpy(buftmp, str_cur_s, str_cur_n);
buftmp += str_cur_n;
for (; k<padnum; ++k) {
memcpy(buftmp, pad_cur_s, pad_cur_n);
buftmp += pad_cur_n;
}
break;
}
SET_STRING_ELT(ret, i, Rf_mkCharLenCE(buf.data(), (int)(buftmp-buf.data()), CE_UTF8));
}
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}
