SEXP mc_children()
{
rm_closed();
child_info_t *ci = children;
unsigned int count = 0;
while (ci && ci->pid > 0) {
count++;
ci = ci->next;
}
SEXP res = allocVector(INTSXP, count);
if (count) {
int *pids = INTEGER(res);
ci = children;
while (ci && ci->pid > 0) {
(pids++)[0] = ci->pid;
ci = ci->next;
}
/* in theory signals can flag a pid as closed in the
meantime, we may end up with fewer children than
expected - highly unlikely but possible */
if (pids - INTEGER(res) < LENGTH(res)) {
R_len_t len = (R_len_t) (pids - INTEGER(res));
PROTECT(res);
res = lengthgets(res, len);
UNPROTECT(1);
}
}
return res;
}
/*
#define xts_IndexSymbol install("index")
#define xts_ClassSymbol install(".CLASS")
#define xts_IndexFormatSymbol install(".indexFORMAT")
#define xts_IndexClassSymbol install(".indexCLASS")
#define xts_ATTRIB(x) coerceVector(do_xtsAttributes(x),LISTSXP)
*/
SEXP do_xtsAttributes(SEXP x)
{
SEXP a, values, names;
int i=0, P=0;
a = ATTRIB(x);
if(length(a) <= 0)
return R_NilValue;
PROTECT(a); P++; /* all attributes */
PROTECT(values = allocVector(VECSXP, length(a))); P++;
PROTECT(names = allocVector(STRSXP, length(a))); P++;
/*
CAR gets the first element of the dotted pair list
CDR gets the rest of the dotted pair list
TAG gets the symbol/name of the first element of dotted pair list
*/
for( /* a=ATTRIB(a) */; a != R_NilValue; a = CDR(a) ) {
if(TAG(a) != xts_IndexSymbol &&
TAG(a) != xts_ClassSymbol &&
TAG(a) != xts_IndexFormatSymbol &&
TAG(a) != xts_IndexClassSymbol &&
TAG(a) != xts_IndexTZSymbol &&
TAG(a) != R_ClassSymbol &&
TAG(a) != R_DimSymbol &&
TAG(a) != R_DimNamesSymbol &&
TAG(a) != R_NamesSymbol)
{
SET_VECTOR_ELT(values, i, CAR(a));
SET_STRING_ELT(names, i, PRINTNAME(TAG(a)));
i++;
}
}
if(i == 0) {
UNPROTECT(P);
return R_NilValue;
}
/* truncate list back to i-size */
PROTECT(values = lengthgets(values, i)); P++;
PROTECT(names = lengthgets(names, i)); P++;
setAttrib(values, R_NamesSymbol, names);
UNPROTECT(P);
return values;
}
SEXP ar2ma(SEXP ar, SEXP npsi)
{
ar = PROTECT(coerceVector(ar, REALSXP));
int p = LENGTH(ar), ns = asInteger(npsi), ns1 = ns + p + 1;
SEXP psi = PROTECT(allocVector(REALSXP, ns1));
artoma(p, REAL(ar), REAL(psi), ns1);
SEXP ans = lengthgets(psi, ns);
UNPROTECT(2);
return ans;
}
static BOOL CALLBACK EnumWindowsProc(HWND handle, LPARAM param)
{
char title[1024];
if (IsWindowVisible(handle)) {
if (EnumProcessId) { /* restrict to R windows only */
DWORD processId;
GetWindowThreadProcessId(handle, &processId);
if (processId != EnumProcessId) return TRUE;
}
if (!EnumMinimized && IsIconic(handle)) return TRUE;
if (EnumCount >= length(EnumResult)) {
int newlen = 2*length(EnumResult);
REPROTECT(EnumResult = lengthgets(EnumResult, newlen), EnumIndex);
setAttrib(EnumResult, R_NamesSymbol,
lengthgets(getAttrib(EnumResult, R_NamesSymbol), newlen));
}
SET_VECTOR_ELT(EnumResult, EnumCount, R_MakeExternalPtr(handle,R_NilValue,R_NilValue));
if (GetWindowText(handle, title, 1024))
SET_STRING_ELT(getAttrib(EnumResult, R_NamesSymbol), EnumCount, mkChar(title));
EnumCount++;
}
return TRUE;
}
SEXP isoreg(SEXP y)
{
int n = LENGTH(y), i, ip, known, n_ip;
double tmp, slope;
SEXP yc, yf, iKnots, ans;
const char *anms[] = {"y", "yc", "yf", "iKnots", ""};
/* unneeded: y = coerceVector(y, REALSXP); */
PROTECT(ans = mkNamed(VECSXP, anms));
SET_VECTOR_ELT(ans, 0, y);
SET_VECTOR_ELT(ans, 1, yc = allocVector(REALSXP, n+1));
SET_VECTOR_ELT(ans, 2, yf = allocVector(REALSXP, n));
SET_VECTOR_ELT(ans, 3, iKnots= allocVector(INTSXP, n));
/* yc := cumsum(0,y) */
REAL(yc)[0] = 0.;
tmp = 0.;
for (i = 0; i < n; i++) {
tmp += REAL(y)[i];
REAL(yc)[i + 1] = tmp;
}
known = 0; ip = 0, n_ip = 0;
do {
slope = R_PosInf;/*1e+200*/
for (i = known + 1; i <= n; i++) {
tmp = (REAL(yc)[i] - REAL(yc)[known]) / (i - known);
if (tmp < slope) {
slope = tmp;
ip = i;
}
}/* tmp := max{i= kn+1,.., n} slope(p[kn] -> p[i]) and
* ip = argmax{...}... */
INTEGER(iKnots)[n_ip++] = ip;
for (i = known; i < ip; i++)
REAL(yf)[i] = (REAL(yc)[ip] - REAL(yc)[known]) / (ip - known);
} while ((known = ip) < n);
if (n_ip < n)
SET_VECTOR_ELT(ans, 3, lengthgets(iKnots, n_ip));
UNPROTECT(1);
return(ans);
}
// called from package MatrixModels's R code
SEXP dgCMatrix_qrsol(SEXP x, SEXP y, SEXP ord)
{
/* FIXME: extend this to work in multivariate case, i.e. y a matrix with > 1 column ! */
SEXP ycp = PROTECT((TYPEOF(y) == REALSXP) ?
duplicate(y) : coerceVector(y, REALSXP));
CSP xc = AS_CSP(x); /* <--> x may be dgC* or dtC* */
int order = asInteger(ord);
#ifdef _not_yet_do_FIXME__
const char *nms[] = {"L", "coef", "Xty", "resid", ""};
SEXP ans = PROTECT(Rf_mkNamed(VECSXP, nms));
#endif
R_CheckStack();
if (order < 0 || order > 3)
error(_("dgCMatrix_qrsol(., order) needs order in {0,..,3}"));
/* --> cs_amd() --- order 0: natural, 1: Chol, 2: LU, 3: QR */
if (LENGTH(ycp) != xc->m)
error(_("Dimensions of system to be solved are inconsistent"));
/* FIXME? Note that qr_sol() would allow *under-determined systems;
* In general, we'd need LENGTH(ycp) = max(n,m)
* FIXME also: multivariate y (see above)
*/
if (xc->m < xc->n || xc->n <= 0)
error(_("dgCMatrix_qrsol(<%d x %d>-matrix) requires a 'tall' rectangular matrix"),
xc->m, xc->n);
/* cs_qrsol(): Tim Davis (2006) .. "8.2 Using a QR factorization", p.136f , calling
* ------- cs_sqr(order, ..), see p.76 */
/* MM: FIXME: write our *OWN* version of - the first case (m >= n) - of cs_qrsol()
* --------- which will (1) work with a *multivariate* y
* (2) compute coefficients properly, not overwriting RHS
*/
if (!cs_qrsol(order, xc, REAL(ycp)))
/* return value really is 0 or 1 - no more info there */
error(_("cs_qrsol() failed inside dgCMatrix_qrsol()"));
/* Solution is only in the first part of ycp -- cut its length back to n : */
ycp = lengthgets(ycp, (R_len_t) xc->n);
UNPROTECT(1);
return ycp;
}
SEXP attribute_hidden do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, ans;
checkArity(op, args);
check1arg(args, call, "x");
x = CAR(args);
if (PRIMVAL(op)) { /* xlength<- */
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
return xlengthgets(x, len);
}
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
if (len < 0) error(_("invalid value"));
if (len > R_LEN_T_MAX) {
#ifdef LONG_VECTOR_SUPPORT
return xlengthgets(x, len);
#else
error(_("vector size specified is too large"));
return x; /* -Wall */
#endif
}
return lengthgets(x, (R_len_t) len);
}
SEXP getWindowsHandles(SEXP which, SEXP minimized)
{
PROTECT_WITH_INDEX(EnumResult = allocVector(VECSXP, 8), &EnumIndex);
setAttrib(EnumResult, R_NamesSymbol, allocVector(STRSXP, 8));
EnumCount = 0;
const char * w;
w = CHAR(STRING_ELT(which, 0));
EnumMinimized = asLogical(minimized);
if (strcmp(w, "R") == 0) EnumProcessId = GetCurrentProcessId();
else EnumProcessId = 0;
if (ismdi() && EnumProcessId)
EnumChildWindows(GetParent(getHandle(RConsole)), EnumWindowsProc, 0);
else
EnumWindows(EnumWindowsProc, 0);
EnumResult = lengthgets(EnumResult, EnumCount);
UNPROTECT(1);
return EnumResult;
}
SEXP graph_bitarray_subGraph(SEXP bits, SEXP _subIndx) {
SEXP _dim = getAttrib(bits,install("bitdim")),
sgVec, btlen, btdim, btcnt, _ftSetPos, res, namesres;
int dim, subLen, prevSetPos = 0, sgSetIndx = 0,
linIndx = 0, col, subgBitLen, subgBytes,
*subIndx, *ftSetPos, edgeCount = 0, ftLen = 256;
PROTECT_INDEX pidx;
unsigned char *bytes = (unsigned char *) RAW(bits), *sgBits;
dim = INTEGER(_dim)[0];
subIndx = INTEGER(_subIndx);
subLen = length(_subIndx);
subgBitLen = subLen * subLen;
subgBytes = subgBitLen / 8;
if ((subgBitLen % 8) != 0) {
subgBytes++;
}
PROTECT(sgVec = allocVector(RAWSXP, subgBytes));
sgBits = RAW(sgVec);
memset(sgBits, 0, subgBytes);
/* TODO: in many cases, this will be more than we need, we should
also use the number of edges in the input as a starting point.
*/
_ftSetPos = allocVector(INTSXP, ftLen); /* FIXME: need better guess */
PROTECT_WITH_INDEX(_ftSetPos, &pidx);
ftSetPos = INTEGER(_ftSetPos);
for (col = 0; col < subLen; col++) {
int col_idx_dim = ((subIndx[col] - 1) * dim) - 1;
int row = 0;
while (row < subLen) {
int setPos = col_idx_dim + subIndx[row];
unsigned char v = bytes[setPos / 8];
if (v != 0 && v & (1 << (setPos % 8))) {
int curSetPos = setPos,
m = prevSetPos;
while (m < curSetPos) {
unsigned char tempV = bytes[m / 8];
if (tempV == 0) {
m += 8;
} else {
if (tempV & (1 << (m % 8))) edgeCount++;
m++;
}
}
prevSetPos = curSetPos + 1;
edgeCount++; /* current edge */
if (sgSetIndx == ftLen) {
ftLen *= 2;
if (ftLen > subgBitLen) ftLen = subgBitLen;
REPROTECT(_ftSetPos = lengthgets(_ftSetPos, ftLen), pidx);
ftSetPos = INTEGER(_ftSetPos);
}
ftSetPos[sgSetIndx] = edgeCount;
sgSetIndx++;
sgBits[linIndx / 8] |= (1 << (linIndx % 8));
}
linIndx++;
row++;
}
}
REPROTECT(_ftSetPos = lengthgets(_ftSetPos, sgSetIndx), pidx);
PROTECT(btlen = ScalarInteger(subgBitLen));
PROTECT(btcnt = ScalarInteger(sgSetIndx));
PROTECT(btdim = allocVector(INTSXP, 2));
INTEGER(btdim)[0] = subLen;
INTEGER(btdim)[1] = subLen;
setAttrib(sgVec, install("bitlen"), btlen);
setAttrib(sgVec, install("bitdim"), btdim);
setAttrib(sgVec, install("nbitset"), btcnt);
PROTECT(res = allocVector(VECSXP, 2));
SET_VECTOR_ELT(res, 0, _ftSetPos);
SET_VECTOR_ELT(res, 1, sgVec);
PROTECT(namesres = allocVector(STRSXP, 2));
SET_STRING_ELT(namesres, 0, mkChar("setPos"));
SET_STRING_ELT(namesres, 1, mkChar("bitVec"));
setAttrib(res, R_NamesSymbol, namesres);
UNPROTECT(7);
return res;
}
/* {{{ rberkeley_dbcursor_get */
SEXP rberkeley_dbcursor_get (SEXP _dbc,
SEXP _key,
SEXP _data,
SEXP _flags,
SEXP _n /* non-API flag */)
{
DBC *dbc;
DBT key, data;
u_int32_t flags;
int i, n, ret, P=0;
flags = (u_int32_t)INTEGER(_flags)[0];
n = (INTEGER(_n)[0] < 0) ? 100 : INTEGER(_n)[0]; /* this should be _all_ data */
dbc = R_ExternalPtrAddr(_dbc);
if(R_ExternalPtrTag(_dbc) != install("DBC") || dbc == NULL)
error("invalid 'dbc' handle");
memset(&key, 0, sizeof(DBT));
memset(&data, 0, sizeof(DBT));
SEXP Keys, Data, results;
PROTECT(Keys = allocVector(VECSXP, n)); P++;
PROTECT(Data = allocVector(VECSXP, n)); P++;
PROTECT(results = allocVector(VECSXP, n)); P++;
/*
Two scenarios for DBcursor->get calls:
(1) key and data are SPECIFIED <OR> key is SPECIFIED, data is EMPTY
(2) key and data are EMPTY
We must handle these seperately in order
to return a sensible result
*/
if( (!isNull(_key) &&
!isNull(_data)) || !isNull(_key) ) {
/* need to handle cases where multiple results
can be returned. Possibly given that flag
we can instead use the last if-else branch */
key.data = (unsigned char *)RAW(_key);
key.size = length(_key);
if(!isNull(_data)) {
data.data = (unsigned char *)RAW(_data);
data.size = length(_data);
}
ret = dbc->get(dbc, &key, &data, flags);
if(ret == 0) {
SEXP KeyData;
PROTECT(KeyData = allocVector(VECSXP, 2));P++;
SEXP rawkey;
PROTECT(rawkey = allocVector(RAWSXP, key.size));
memcpy(RAW(rawkey), key.data, key.size);
SET_VECTOR_ELT(KeyData, 0, rawkey);
UNPROTECT(1);
SEXP rawdata;
PROTECT(rawdata = allocVector(RAWSXP, data.size));
memcpy(RAW(rawdata), data.data, data.size);
SET_VECTOR_ELT(KeyData, 1, rawdata);
UNPROTECT(1);
SEXP KeyDataNames;
PROTECT(KeyDataNames = allocVector(STRSXP,2)); P++;
SET_STRING_ELT(KeyDataNames, 0, mkChar("key"));
SET_STRING_ELT(KeyDataNames, 1, mkChar("data"));
setAttrib(KeyData, R_NamesSymbol, KeyDataNames);
SET_VECTOR_ELT(results, 0, KeyData);
PROTECT(results = lengthgets(results, 1)); P++;
}
} else
if(isNull(_key) && isNull(_data)) {
for(i = 0; i < n; i++) {
ret = dbc->get(dbc, &key, &data, flags);
if(ret == 0) {
SEXP KeyData;
PROTECT(KeyData = allocVector(VECSXP, 2));
SEXP rawkey;
PROTECT(rawkey = allocVector(RAWSXP, key.size));
memcpy(RAW(rawkey), key.data, key.size);
SET_VECTOR_ELT(KeyData, 0, rawkey);
SEXP rawdata;
PROTECT(rawdata = allocVector(RAWSXP, data.size));
memcpy(RAW(rawdata), data.data, data.size);
SET_VECTOR_ELT(KeyData, 1, rawdata);
SEXP KeyDataNames;
PROTECT(KeyDataNames = allocVector(STRSXP,2));
SET_STRING_ELT(KeyDataNames, 0, mkChar("key"));
SET_STRING_ELT(KeyDataNames, 1, mkChar("data"));
setAttrib(KeyData, R_NamesSymbol, KeyDataNames);
SET_VECTOR_ELT(results, i, KeyData);
UNPROTECT(4); /* KeyDataNames, rawdata, rawkey, KeyData */
} else { /* end of data */
if(i == 0) { /* no results */
UNPROTECT(P);
return ScalarInteger(ret);
}
/* truncate the keys and data to the i-size found */
PROTECT(results = lengthgets(results, i)); P++;
break;
}
}
}
UNPROTECT(P);
return results;
}
SEXP non_duplicates (SEXP x_, SEXP fromLast_) {
int fromLast = asLogical(fromLast_),
i, d=0,
len = length(x_);
int *x_int;
double *x_real;
SEXP duplicates;
int *duplicates_int;
/* need to reprotect lengthgets() result before returning */
PROTECT_INDEX idx;
PROTECT_WITH_INDEX(duplicates = allocVector(INTSXP, len), &idx);
duplicates_int = INTEGER(duplicates);
if(!fromLast) { /* keep first observation */
duplicates_int[0] = ++d;
switch(TYPEOF(x_)) {
case INTSXP:
x_int = INTEGER(x_);
for(i=1; i < len-1; i++) {
if( x_int[i-1] != x_int[i]) {
#ifdef DEBUG
Rprintf("i=%i: x[i-1]=%i, x[i]=%i\n",i,x_int[i-1],x_int[i]);
#endif
duplicates_int[d++] = i+1;
}
}
break;
case REALSXP:
x_real = REAL(x_);
for(i=1; i < len; i++) {
/*
if( x_real[i-1] == x_real[i])
duplicates_int[d++] = (int)(-1*(i+1));
*/
if( x_real[i-1] != x_real[i])
duplicates_int[d++] = i+1;
}
break;
default:
error("only numeric types supported");
break;
}
} else { /* keep last observation */
switch(TYPEOF(x_)) {
case INTSXP:
x_int = INTEGER(x_);
for(i=1; i < len; i++) {
if( x_int[i-1] != x_int[i])
duplicates_int[d++] = i;
}
break;
case REALSXP:
x_real = REAL(x_);
for(i=1; i < len; i++) {
if( x_real[i-1] != x_real[i])
duplicates_int[d++] = i;
}
break;
default:
error("only numeric types supported");
break;
}
duplicates_int[d++] = len;
}
REPROTECT(duplicates = lengthgets(duplicates, d), idx);
UNPROTECT(1);
return(duplicates);
}
SEXP readSlicePorStream(SEXP porStream, SEXP what, SEXP s_vars, SEXP s_cases, SEXP s_types){
porStreamBuf *b = get_porStreamBuf(porStream);
PROTECT(s_vars = coerceVector(s_vars,LGLSXP));
PROTECT(s_cases = coerceVector(s_cases,LGLSXP));
PROTECT(s_types = coerceVector(s_types,INTSXP));
int nvar = length(s_types);
int ncases = length(s_cases);
int *types = INTEGER(s_types);
if(LENGTH(s_vars)!=nvar) error("\'s_vars\' argument has wrong length");
int ii,i,j,k, m=0, n = 0;
for(j = 0; j < nvar; j++) m+=LOGICAL(s_vars)[j];
for(i = 0; i < ncases; i++) n+=LOGICAL(s_cases)[i];
SEXP x, y, data;
char *charbuf;
int charbuflen = 0;
PROTECT(data = allocVector(VECSXP,m));
k = 0;
for(j = 0; j < nvar; j++){
if(types[j] > charbuflen) charbuflen = types[j];
if(LOGICAL(s_vars)[j]){
if(types[j]==0)
SET_VECTOR_ELT(data,k,allocVector(REALSXP,n));
else {
SET_VECTOR_ELT(data,k,allocVector(STRSXP,n));
}
k++;
}
}
charbuf = R_alloc(charbuflen+1,sizeof(char));
ii = 0;
for(i = 0; i < ncases; i++){
if(atEndPorStream(b) || (b->pos < 80 && b->buf[b->pos] == 'Z')){
int new_length = ii;
for(j = 0; j < m; j++){
x = VECTOR_ELT(data,j);
SET_VECTOR_ELT(data,j,lengthgets(x,new_length));
}
n = new_length;
break;
}
if(LOGICAL(s_cases)[i]){
k = 0;
for(j = 0; j < nvar; j++){
if(atEndPorStream(b)) {
printPorStreamBuf(b);
warning("\nPremature end of data");
}
if(types[j]==0){
if(LOGICAL(s_vars)[j]){
REAL(VECTOR_ELT(data,k))[ii] = readDoublePorStream1(b);
k++;
}
else {
readDoublePorStream1(b);
}
}
else {
if(LOGICAL(s_vars)[j]){
SET_STRING_ELT(VECTOR_ELT(data,k), ii,
mkChar(readCHARPorStream(b,charbuf,types[j])));
k++;
}
else {
readCHARPorStream(b,charbuf,types[j]);
}
}
}
ii++;
}
else {
for(j = 0; j < nvar; j++){
if(atEndPorStream(b)) {
printPorStreamBuf(b);
error("\nPremature end of data");
}
if(types[j]==0) readDoublePorStream1(b);
else readCHARPorStream(b,charbuf,types[j]);
}
}
}
k = 0;
for(j = 0; j < nvar; j++){
if(LOGICAL(s_vars)[j]){
x = VECTOR_ELT(what,j);
y = VECTOR_ELT(data,k);
copyMostAttrib(x,y);
k++;
}
}
UNPROTECT(4);
return data;
}
static SEXP
read_SPSS_PORT(const char *filename)
{
struct file_handle *fh = fh_get_handle_by_filename(filename);
struct pfm_read_info inf;
struct dictionary *dict = pfm_read_dictionary(fh, &inf);
SEXP ans = PROTECT(allocVector(VECSXP, dict->nvar));
SEXP ans_names = PROTECT(allocVector(STRSXP, dict->nvar));
union value *case_vals;
int i;
int ncases = 0;
int N = 10;
int nval = 0;
int nvar_label;
SEXP val_labels;
SEXP variable_labels;
SEXP miss_labels; int have_miss = 0;
/* Set the fv and lv elements of all variables in the
dictionary. */
for (i = 0; i < dict->nvar; i++) {
struct variable *v = dict->var[i];
v->fv = nval;
nval += v->nv;
}
dict->nval = nval;
if (!nval)
error(_("nval is 0"));
case_vals = (union value *) R_alloc(dict->nval, sizeof(union value));
for (i = 0; i < dict->nvar; i++) {
struct variable *v = dict->var[i];
if (v->get.fv == -1)
continue;
SET_STRING_ELT(ans_names, i, mkChar(dict->var[i]->name));
if (v->type == NUMERIC) {
SET_VECTOR_ELT(ans, i, allocVector(REALSXP, N));
} else {
SET_VECTOR_ELT(ans, i, allocVector(STRSXP, N));
case_vals[v->fv].c =
(unsigned char *) R_alloc(v->width + 1, 1);
((char *) &case_vals[v->fv].c[0])[v->width] = '\0';
}
}
while(pfm_read_case(fh, case_vals, dict)) {
if (ncases == N) {
N *= 2;
for (i = 0; i < dict->nvar; i++) {
SEXP elt = VECTOR_ELT(ans, i);
elt = lengthgets(elt, N);
SET_VECTOR_ELT(ans, i, elt);
}
}
for (i = 0; i < dict->nvar; i++) {
struct variable *v = dict->var[i];
if (v->get.fv == -1)
continue;
if (v->type == NUMERIC) {
REAL(VECTOR_ELT(ans, i))[ncases] = case_vals[v->fv].f;
} else {
SET_STRING_ELT(VECTOR_ELT(ans, i), ncases,
mkChar((char *)case_vals[v->fv].c));
}
}
++ncases;
}
if (N != ncases) {
for (i = 0; i < dict->nvar; i++) {
SEXP elt = VECTOR_ELT(ans, i);
elt = lengthgets(elt, ncases);
SET_VECTOR_ELT(ans, i, elt);
}
}
fh_close_handle(fh);
/* get all the value labels */
PROTECT(val_labels = getSPSSvaluelabels(dict));
namesgets(val_labels, ans_names);
setAttrib(ans, install("label.table"), val_labels);
UNPROTECT(1);
/* get SPSS variable labels */
PROTECT(variable_labels = allocVector(STRSXP, dict->nvar));
nvar_label = 0;
for (i = 0; i < dict->nvar; i++) {
char *lab = dict->var[i]->label;
if (lab != NULL) {
nvar_label++;
SET_STRING_ELT(variable_labels, i, mkChar(lab));
}
}
if (nvar_label > 0) {
namesgets(variable_labels, ans_names);
setAttrib(ans, install("variable.labels"), variable_labels);
}
UNPROTECT(1);
/* report missingness */
PROTECT(miss_labels = getSPSSmissing(dict, &have_miss));
if(have_miss) {
namesgets(miss_labels, duplicate(ans_names));
setAttrib(ans, install("missings"), miss_labels);
}
UNPROTECT(1);
free_dictionary(dict);
setAttrib(ans, R_NamesSymbol, ans_names);
UNPROTECT(2);
return ans;
}
SEXP readfixedsubset(SEXP s_file, SEXP what, SEXP s_vars, SEXP s_cases, SEXP s_start, SEXP s_stop){
FILE *f = rofile_FILE(s_file);
PROTECT(s_vars = coerceVector(s_vars,LGLSXP));
PROTECT(s_cases = coerceVector(s_cases,LGLSXP));
PROTECT(s_start = coerceVector(s_start,INTSXP));
PROTECT(s_stop = coerceVector(s_stop,INTSXP));
if(LENGTH(s_start) != LENGTH(s_stop)) error("start and stop must have equal length");
if(LENGTH(s_vars) != LENGTH(s_stop)) error("vars argument has wrong length");
int m = 0, n = 0;
int nvar = LENGTH(what);
int ncases = LENGTH(s_cases);
int ii,i,j,k;
for(i = 0; i < LENGTH(s_cases); i++) n += LOGICAL(s_cases)[i];
for(j = 0; j < LENGTH(s_vars); j++) m += LOGICAL(s_vars)[j];
int *start = INTEGER(s_start);
int *stop = INTEGER(s_stop);
int max_lenline = stop[nvar-1];
char *buffer = R_alloc(max_lenline+3,1);
char *item, *currdata;
SEXP data;
PROTECT(data = allocVector(VECSXP,m));
SEXP x, y;
int *length = (int *) R_alloc(nvar,sizeof(int));
int maxlen = 0;
k = 0;
for(j = 0; j < nvar; j++){
length[j] = stop[j] - start[j] + 1;
if(LOGICAL(s_vars)[j]){
if(maxlen < length[j]) maxlen = length[j];
x = VECTOR_ELT(what,j);
SET_VECTOR_ELT(data,k,lengthgets(x,n));
k++;
}
}
item = R_alloc(maxlen+1,1);
ii = 0;
for(i = 0; i < ncases; i++){
memset(buffer,0,max_lenline+3);
buffer = fgets(buffer,max_lenline+3,f);
#ifdef DEBUG
Rprintf("Requested line length: %d\n",max_lenline);
Rprintf("Actual line length: %d\n",strlen(buffer));
Rprintf("Buffer: >>%s<<\n",buffer);
#endif
if(strlen(buffer)< max_lenline) {
int new_length = i;
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(data,j);
SET_VECTOR_ELT(data,j,lengthgets(x,new_length));
}
n = new_length;
break;
}
if(LOGICAL(s_cases)[i]){
currdata = buffer;
k = 0;
for(j = 0; j < nvar; j++){
currdata = buffer + start[j]-1;
if(LOGICAL(s_vars)[j]){
x = VECTOR_ELT(data,k);
memset(item,0,maxlen+1);
memcpy(item,currdata,length[j]);
trim(item,length[j]);
#ifdef DEBUG
Rprintf("Item: >>%s<<\n",item);
#endif
#undef DEBUG
if(TYPEOF(x)==INTSXP)
INTEGER(x)[ii] = _R_atoi(item);
else if (TYPEOF(x)==REALSXP)
REAL(x)[ii] = _R_atof(item);
else
SET_STRING_ELT(x,ii,mkChar(item));
k++;
}
}
ii++;
}
}
k = 0;
for(j = 0; j < nvar; j++){
if(LOGICAL(s_vars)[j]){
x = VECTOR_ELT(what,j);
y = VECTOR_ELT(data,k);
copyMostAttrib(x,y);
k++;
}
}
UNPROTECT(5);
return data;
}
SEXP readDataPorStream(SEXP porStream, SEXP what, SEXP s_n, SEXP s_types){
#ifdef DEBUG
Rprintf("\n############################");
Rprintf("\n#readDataPorStream");
Rprintf("\n############################");
#endif
porStreamBuf *b = get_porStreamBuf(porStream);
int n = asInteger(s_n);
#ifdef DEBUG
Rprintf("\nRequired number of cases: %d",n);
Rprintf("\nBuffer contents: |%s|",b->buf);
Rprintf("\nLine: %d",b->line);
Rprintf("\nPosition: %d",b->pos);
Rprintf("\nBuffer remainder: %s",b->buf + b->pos);
#endif
PROTECT(s_types = coerceVector(s_types,INTSXP));
int nvar = length(s_types);
int *types = INTEGER(s_types);
SEXP x, y, data;
char *charbuf;
int charbuflen = 0;
PROTECT(data = allocVector(VECSXP,nvar));
int i,j;
for(j = 0; j < nvar; j++){
if(types[j]==0)
SET_VECTOR_ELT(data,j,allocVector(REALSXP,n));
else {
SET_VECTOR_ELT(data,j,allocVector(STRSXP,n));
if(types[j] > charbuflen) charbuflen = types[j];
}
}
charbuf = R_alloc(charbuflen+1,sizeof(char));
#ifdef DEBUG
// PrintValue(data);
#endif
for(i = 0; i < n; i++){
if(atEndPorStream(b) || (b->pos < 80 && b->buf[b->pos] == 'Z')){
#ifdef DEBUG
Rprintf("\nReached end of cases at i=%d",i);
#endif
int new_length = i;
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(data,j);
SET_VECTOR_ELT(data,j,lengthgets(x,new_length));
}
n = new_length;
break;
}
#ifdef DEBUG
Rprintf("\nCase number: %d\n",i);
#endif
for(j = 0; j < nvar; j++){
if(atEndPorStream(b)) {
printPorStreamBuf(b);
warning("\nPremature end of data");
break;
}
#ifdef DEBUG
PrintValue(VECTOR_ELT(data,j));
#endif
if(types[j]==0) REAL(VECTOR_ELT(data,j))[i] = readDoublePorStream1(b);
else SET_STRING_ELT(VECTOR_ELT(data,j), i,
mkChar(readCHARPorStream(b,charbuf,types[j])));
#ifdef DEBUG
if(i<3 && types[j]>0)
PrintValue(STRING_ELT(VECTOR_ELT(data,j),i));
#endif
}
}
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(what,j);
y = VECTOR_ELT(data,j);
copyMostAttrib(x,y);
}
UNPROTECT(2);
return data;
}
SEXP readfixed(SEXP s_file, SEXP what, SEXP s_nlines, SEXP s_start, SEXP s_stop){
PROTECT(s_start = coerceVector(s_start,INTSXP));
PROTECT(s_stop = coerceVector(s_stop,INTSXP));
FILE *f = rofile_FILE(s_file);
if(LENGTH(s_start) != LENGTH(s_stop)) error("start and stop must have equal length");
int n = asInteger(s_nlines);
int nvar = LENGTH(s_start);
int *start = INTEGER(s_start);
int *stop = INTEGER(s_stop);
int max_lenline = stop[nvar-1];
char *buffer = R_alloc(max_lenline+3,1);
char *item, *currdata;
SEXP data;
PROTECT(data=allocVector(VECSXP,nvar));
int i,j;
int *length = (int *) R_alloc(nvar,sizeof(int));
int maxlen = 0;
SEXP x,y;
for(j = 0; j < nvar; j++){
length[j] = stop[j] - start[j] + 1;
if(maxlen < length[j]) maxlen = length[j];
x = VECTOR_ELT(what,j);
SET_VECTOR_ELT(data,j,lengthgets(x,n));
}
item = R_alloc(maxlen+1,1);
#undef DEBUG
#ifdef DEBUG
Rprintf("Requested number of lines: %d\n",n);
#endif
for(i = 0; i < n; i++){
memset(buffer,0,max_lenline+3);
buffer = fgets(buffer,max_lenline+3,f);
#ifdef DEBUG
Rprintf("Requested line length: %d\n",max_lenline);
Rprintf("Actual line length: %d\n",strlen(buffer));
if(i == 0)
Rprintf("Buffer: >>%s<<\n",buffer);
#endif
if(strlen(buffer)< max_lenline) {
int new_length = i;
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(data,j);
SET_VECTOR_ELT(data,j,lengthgets(x,new_length));
}
n = new_length;
break;
}
currdata = buffer;
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(data,j);
currdata = buffer + start[j]-1;
memset(item,0,maxlen+1);
memcpy(item,currdata,length[j]);
trim(item,length[j]);
#undef DEBUG
if(TYPEOF(x)==INTSXP)
INTEGER(x)[i] = _R_atoi(item);
else if (TYPEOF(x)==REALSXP)
REAL(x)[i] = _R_atof(item);
else
SET_STRING_ELT(x,i,mkChar(item));
}
}
for(j = 0; j < nvar; j++){
x = VECTOR_ELT(what,j);
y = VECTOR_ELT(data,j);
copyMostAttrib(x,y);
}
UNPROTECT(3);
return data;
}
//SEXP do_rbind_xts (SEXP x, SEXP y, SEXP env) {{{
SEXP do_rbind_xts (SEXP x, SEXP y, SEXP dup)
{
int nrx, ncx, nry, ncy, truelen, len;
int no_duplicate = LOGICAL(dup)[0];
int i, j, ij, ij_x, ij_y, xp=1, yp=1, add_y=0;
int P=0; // PROTECT counter
int mode;
SEXP result, xindex, yindex, newindex;
int *int_result=NULL, *int_x=NULL, *int_y=NULL;
int *int_newindex=NULL, *int_xindex=NULL, *int_yindex=NULL;
double *real_result=NULL, *real_x=NULL, *real_y=NULL;
double *real_newindex=NULL, *real_xindex=NULL, *real_yindex=NULL;
nrx = nrows(x);
ncx = ncols(x);
nry = nrows(y);
ncy = ncols(y);
truelen = len = nrx + nry;
if( isNull(x) || isNull(y) ) {
/* Handle NULL values by returning non-null object */
if(!isNull(x)) return x;
return y;
}
if( !isXts(x) ) {
PROTECT( x = tryXts(x) ); P++;
}
if( !isXts(y) ) {
PROTECT( y = tryXts(y) ); P++;
}
/* need to convert different types of x and y if needed */
if( TYPEOF(x) != TYPEOF(y) ) {
warning("mismatched types: converting objects to numeric"); // FIXME not working!!!????
PROTECT(x = coerceVector(x, REALSXP)); P++;
PROTECT(y = coerceVector(y, REALSXP)); P++;
}
mode = TYPEOF(x);
if(ncx != ncy)
error("data must have same number of columns to bind by row");
PROTECT(xindex = getAttrib(x, xts_IndexSymbol)); P++;
PROTECT(yindex = getAttrib(y, xts_IndexSymbol)); P++;
if( TYPEOF(xindex) != TYPEOF(yindex) )
{
PROTECT(xindex = coerceVector(xindex, REALSXP)); P++;
PROTECT(yindex = coerceVector(yindex, REALSXP)); P++;
}
#ifdef RBIND_APPEND
if(TYPEOF(xindex)==REALSXP) {
if(REAL(xindex)[length(xindex)-1] < REAL(yindex)[0]) {
UNPROTECT(P);
return rbind_append(x,y);
}
} else
if(TYPEOF(xindex)==INTSXP) {
if(INTEGER(xindex)[length(xindex)-1] < INTEGER(yindex)[0]) {
UNPROTECT(P);
return rbind_append(x,y);
}
}
#endif
PROTECT(newindex = allocVector(TYPEOF(xindex), len)); P++;
PROTECT(result = allocVector(TYPEOF(x), len * ncx)); P++;
copyMostAttrib(xindex, newindex);
switch( TYPEOF(x) ) {
case INTSXP:
int_x = INTEGER(x);
int_y = INTEGER(y);
int_result = INTEGER(result);
break;
case REALSXP:
real_x = REAL(x);
real_y = REAL(y);
real_result = REAL(result);
break;
default:
break;
}
/*
if( TYPEOF(xindex) == REALSXP ) {
if(REAL(xindex)[nrx-1] < REAL(yindex)[0]) {
memcpy(REAL(newindex), REAL(xindex), sizeof(double) * nrx);
memcpy(REAL(newindex)+nrx, REAL(yindex), sizeof(double) * nry);
switch(TYPEOF(x)) {
case INTSXP:
memcpy(INTEGER(result), INTEGER(x), sizeof(int) * (nrx*ncx));
memcpy(INTEGER(result)+(nrx*ncx), INTEGER(y), sizeof(int) * (nry*ncy));
break;
case REALSXP:
memcpy(REAL(result), REAL(x), sizeof(double) * (nrx*ncx));
memcpy(REAL(result)+(nrx*ncx), REAL(y), sizeof(double) * (nry*ncy));
break;
default:
break;
}
UNPROTECT(P);
return(result);
}
} else {
}
*/
/*
The main body of code to follow branches based on the type
of index, removing the need to test at each position.
*/
if( TYPEOF(xindex) == REALSXP ) {
real_newindex = REAL(newindex);
real_xindex = REAL(xindex);
real_yindex = REAL(yindex);
for( i = 0; i < len; i++ ) {
if( i >= truelen ) {
break;
} else
if( xp > nrx ) {
real_newindex[ i ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
} else
if( yp > nry ) {
real_newindex[ i ] = real_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( real_xindex[ xp-1 ] == real_yindex[ yp-1 ] ) {
if( real_xindex[ xp-1 ] < real_xindex[ xp ] )
add_y = 1; /* add y values only if next xindex is new */
if(no_duplicate) {
add_y = 0;
truelen--;
}
real_newindex[ i ] = real_xindex[ xp-1 ];
if(add_y) real_newindex[ i+ 1 ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
if(add_y) LOGICAL(result)[ ij+1 ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
if(add_y) int_result[ ij+1 ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
if(add_y) real_result[ ij+1 ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
if(add_y) COMPLEX(result)[ ij+1 ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
if(add_y) SET_STRING_ELT(result, ij+1, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
xp++;
if(no_duplicate || add_y) {
yp++;
if(!no_duplicate) i++; // need to increase i as we now have filled in 2 values
add_y = 0;
}
} else
if( real_xindex[ xp-1 ] < real_yindex[ yp-1 ] ) {
real_newindex[ i ] = real_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( real_xindex[ xp-1 ] > real_yindex[ yp-1 ] ) {
real_newindex[ i ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
}
}
} else
if( TYPEOF(xindex) == INTSXP ) {
int_newindex = INTEGER(newindex);
int_xindex = INTEGER(xindex);
int_yindex = INTEGER(yindex);
for(i = 0; i < len; i++) {
/*Rprintf("xp:%i, yp:%i, i:%i\n",xp,yp,i);*/
if( i >= truelen ) {
break;
} else
if( xp > nrx ) {
int_newindex[ i ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
} else
if( yp > nry ) {
int_newindex[ i ] = int_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( int_xindex[ xp-1 ] == int_yindex[ yp-1 ] ) {
if( int_xindex[ xp-1 ] < int_xindex[ xp ] )
add_y = 1;
if(no_duplicate) {
add_y = 0;
truelen--;
}
int_newindex[ i ] = int_xindex[ xp-1 ];
if(add_y) int_newindex[ i+1 ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
if(add_y) LOGICAL(result)[ ij+1 ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
if(add_y) int_result[ ij+1 ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
if(add_y) real_result[ ij+1 ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
if(add_y) COMPLEX(result)[ ij+1 ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
if(add_y) SET_STRING_ELT(result, ij+1, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
xp++;
if(no_duplicate || add_y) {
yp++;
if(!no_duplicate) i++; // need to increase i as we now have filled in 2 values
add_y = 0;
}
} else
if( int_xindex[ xp-1 ] < int_yindex[ yp-1 ] ) {
int_newindex[ i ] = int_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( int_xindex[ xp-1 ] > int_yindex[ yp-1 ] ) {
int_newindex[ i ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
}}
}
if(truelen != len) {
PROTECT(result = lengthgets(result, truelen * ncx)); P++; /* reset length */
}
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SEXP dim;
PROTECT(dim = allocVector(INTSXP, 2));
INTEGER(dim)[0] = truelen;
INTEGER(dim)[1] = INTEGER(getAttrib(x, R_DimSymbol))[1];
UNPROTECT(1);
setAttrib(result, R_DimSymbol, dim);
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
if(truelen != len) {
PROTECT(newindex = lengthgets(newindex, truelen)); P++;
}
setAttrib(result, xts_IndexSymbol, newindex);
setAttrib(result, xts_IndexClassSymbol, getAttrib(x, xts_IndexClassSymbol));
setAttrib(result, xts_IndexTZSymbol, getAttrib(x, xts_IndexTZSymbol));
setAttrib(result, xts_IndexFormatSymbol, getAttrib(x, xts_IndexFormatSymbol));
setAttrib(result, xts_ClassSymbol, getAttrib(x, xts_ClassSymbol));
copy_xtsAttributes(x, result);
UNPROTECT(P);
return result;
} //}}}