SEXP fft(SEXP z, SEXP inverse)
{
SEXP d;
int i, inv, maxf, maxmaxf, maxmaxp, maxp, n, ndims, nseg, nspn;
double *work;
int *iwork;
switch (TYPEOF(z)) {
case INTSXP:
case LGLSXP:
case REALSXP:
z = coerceVector(z, CPLXSXP);
break;
case CPLXSXP:
if (NAMED(z)) z = duplicate(z);
break;
default:
error(_("non-numeric argument"));
}
PROTECT(z);
/* -2 for forward transform, complex values */
/* +2 for backward transform, complex values */
inv = asLogical(inverse);
if (inv == NA_INTEGER || inv == 0)
inv = -2;
else
inv = 2;
if (LENGTH(z) > 1) {
if (isNull(d = getAttrib(z, R_DimSymbol))) { /* temporal transform */
n = length(z);
fft_factor(n, &maxf, &maxp);
if (maxf == 0)
error(_("fft factorization error"));
work = (double*)R_alloc(4 * maxf, sizeof(double));
iwork = (int*)R_alloc(maxp, sizeof(int));
fft_work(&(COMPLEX(z)[0].r), &(COMPLEX(z)[0].i),
1, n, 1, inv, work, iwork);
}
else { /* spatial transform */
maxmaxf = 1;
maxmaxp = 1;
ndims = LENGTH(d);
/* do whole loop just for error checking and maxmax[fp] .. */
for (i = 0; i < ndims; i++) {
if (INTEGER(d)[i] > 1) {
fft_factor(INTEGER(d)[i], &maxf, &maxp);
if (maxf == 0)
error(_("fft factorization error"));
if (maxf > maxmaxf)
maxmaxf = maxf;
if (maxp > maxmaxp)
maxmaxp = maxp;
}
}
work = (double*)R_alloc(4 * maxmaxf, sizeof(double));
iwork = (int*)R_alloc(maxmaxp, sizeof(int));
nseg = LENGTH(z);
n = 1;
nspn = 1;
for (i = 0; i < ndims; i++) {
if (INTEGER(d)[i] > 1) {
nspn *= n;
n = INTEGER(d)[i];
nseg /= n;
fft_factor(n, &maxf, &maxp);
fft_work(&(COMPLEX(z)[0].r), &(COMPLEX(z)[0].i),
nseg, n, nspn, inv, work, iwork);
}
}
}
}
UNPROTECT(1);
return z;
}
/* Set elements of a dbvector. When the new value is NA, the original element
deleted from the table.
*/
SEXP set(SEXP x, SEXP index, SEXP value)
{
SEXP ans = R_NilValue;
rdbVector *origInfo, *info;
unsigned int len, i;
unsigned int *_index;
origInfo = getInfo(x);
/* check value type */
if (!(isInteger(value)||isReal(value)||isComplex(value)))
{
error("wrong value type");
}
/* connect to database */
MYSQL *sqlconn = NULL;
int success = connectToLocalDB(&sqlconn);
if(!success || sqlconn == NULL)
{
error("cannot connect to local db\n");
return ans;
}
/* convert index to int */
if (isInteger(index))
{
len = length(index);
Rprintf(" integer length %d\n",len);
_index = calloc(len, sizeof(unsigned int));
_index = INTEGER(index);
}
else if (isReal(index))
{
len = length(index);
_index = calloc(len, sizeof(unsigned int));
for (i=0;i<len;i++)
_index[i] = (unsigned int)REAL(index)[i];
}
else if (IS_DBVECTOR(index))
{
rdbVector *iinfo = getInfo(index);
if (iinfo->sxp_type != INTSXP && iinfo->sxp_type != REALSXP && iinfo->sxp_type!=LGLSXP) {
mysql_close(sqlconn);
error("index must be of logical, integer or numeric type");
}
int settype = origInfo->sxp_type * 100 + TYPEOF(value);
if (iinfo->sxp_type == LGLSXP){
switch(settype)
{
case 1010: /* logical, logical */
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setLogicElementsWithLogic(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1013: /* logical, int */
x = duplicateOrConvert(x, convertLogicToInteger, sqlconn, 1);
info = getInfo(x);
setIntElementsWithLogic(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1014: /* logical, real */
x = duplicateOrConvert(x, convertLogicToDouble, sqlconn, 1);
info = getInfo(x);
setDoubleElementsWithLogic(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1313: /* int,int*/
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setIntElementsWithLogic(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1314: /* int,real */
x = duplicateOrConvert(x, convertIntegerToDouble, sqlconn, 1);
info = getInfo(x);
setDoubleElementsWithLogic(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1315: /* int, cplx */
x = duplicateOrConvert(x,convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setComplexElementsWithLogic(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
case 1413:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setDoubleElementsWithLogic(sqlconn, info, iinfo, REAL(coerceVector(value,REALSXP)), length(value));
break;
case 1414:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setDoubleElementsWithLogic(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1415:
x = duplicateOrConvert(x, convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setComplexElementsWithLogic(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
case 1513:
case 1514:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setComplexElementsWithLogic(sqlconn, info, iinfo, COMPLEX(coerceVector(value,CPLXSXP)), length(value));
break;
case 1515:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setComplexElementsWithLogic(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
default:
error("Setting elements of this type of dbvector is not supported");
break;
}
}
else { /* int or real type index */
switch(settype)
{
case 1010: /* logical, logical */
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setLogicElementsWDBVector(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1013: /* logical, int */
x = duplicateOrConvert(x, convertLogicToInteger, sqlconn, 1);
info = getInfo(x);
setIntElementsWDBVector(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1014: /* logical, real */
x = duplicateOrConvert(x, convertLogicToDouble, sqlconn, 1);
info = getInfo(x);
setDoubleElementsWDBVector(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1313: /* int,int*/
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setIntElementsWDBVector(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1314: /* int,real */
x = duplicateOrConvert(x, convertIntegerToDouble, sqlconn, 1);
info = getInfo(x);
setDoubleElementsWDBVector(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1315: /* int, cplx */
x = duplicateOrConvert(x,convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setComplexElementsWDBVector(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
case 1413:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setDoubleElementsWDBVector(sqlconn, info, iinfo, REAL(coerceVector(value,REALSXP)), length(value));
break;
case 1414:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setDoubleElementsWDBVector(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1415:
x = duplicateOrConvert(x, convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setComplexElementsWDBVector(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
case 1513:
case 1514:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setComplexElementsWDBVector(sqlconn, info, iinfo, COMPLEX(coerceVector(value,CPLXSXP)), length(value));
break;
case 1515:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setComplexElementsWDBVector(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
default:
error("Setting elements of this type of dbvector is not supported");
break;
}
} /* end if */
mysql_close(sqlconn);
free(_index);
/* info has possibly been updated */
rdbVector *temp = (rdbVector*)R_ExternalPtrAddr(R_do_slot(x,install("ext")));
temp->isView = info->isView;
temp->refCounter = info->refCounter;
return x;
}
/* detect type */
int settype = origInfo->sxp_type *100 + TYPEOF(value);
switch(settype)
{
case 1010: /* logical, logical */
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseLogicElements(sqlconn, info, _index, len, INTEGER(value), length(value));
break;
case 1013: /* logical, int */
x = duplicateOrConvert(x, convertLogicToInteger, sqlconn, 1);
info = getInfo(x);
setSparseIntElements(sqlconn, info, _index, len, INTEGER(value), length(value));
break;
case 1014: /* logical, real */
x = duplicateOrConvert(x, convertLogicToDouble, sqlconn, 1);
info = getInfo(x);
setSparseDoubleElements(sqlconn, info, _index, len, REAL(value), length(value));
break;
case 1313: /* int,int*/
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseIntElements(sqlconn, info, _index, len, INTEGER(value), length(value));
break;
case 1314: /* int,real */
x = duplicateOrConvert(x, convertIntegerToDouble, sqlconn, 1);
info = getInfo(x);
setSparseDoubleElements(sqlconn, info, _index, len, REAL(value), length(value));
break;
case 1315: /* int, cplx */
x = duplicateOrConvert(x,convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setSparseComplexElements(sqlconn, info, _index, len, COMPLEX(value), length(value));
break;
case 1413:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseDoubleElements(sqlconn, info, _index, len, REAL(coerceVector(value,REALSXP)), length(value));
break;
case 1414:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseDoubleElements(sqlconn, info, _index, len, REAL(value), length(value));
break;
case 1415:
x = duplicateOrConvert(x, convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setSparseComplexElements(sqlconn, info, _index, len, COMPLEX(value), length(value));
break;
case 1513:
case 1514:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseComplexElements(sqlconn, info, _index, len, COMPLEX(coerceVector(value,CPLXSXP)), length(value));
break;
case 1515:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseComplexElements(sqlconn, info, _index, len, COMPLEX(value), length(value));
break;
default:
error("Setting elements of this type of dbvector is not supported");
break;
}
mysql_close(sqlconn);
free(_index);
/* info has possibly been updated */
rdbVector *temp = (rdbVector*)R_ExternalPtrAddr(R_do_slot(x,install("ext")));
temp->isView = info->isView;
temp->refCounter = info->refCounter;
return x;
}
static void test_psd(){
rand_t rstat;
int seed=4;
double r0=0.2;
double dx=1./64;
long N=1024;
long nx=N;
long ny=N;
long ratio=1;
long xskip=nx*(ratio-1)/2;
long yskip=ny*(ratio-1)/2;
long nframe=512;
seed_rand(&rstat, seed);
if(1){
map_t *atm=mapnew(nx+1, ny+1, dx,dx, NULL);
cmat *hat=cnew(nx*ratio, ny*ratio);
//cfft2plan(hat, -1);
dmat *hattot=dnew(nx*ratio, ny*ratio);
for(long i=0; i<nframe; i++){
info2("%ld of %ld\n", i, nframe);
for(long j=0; j<(nx+1)*(ny+1); j++){
atm->p[j]=randn(&rstat);
}
fractal_do((dmat*)atm, dx, r0,L0,ninit);
czero(hat);
for(long iy=0; iy<ny; iy++){
for(long ix=0; ix<nx; ix++){
IND(hat,ix+xskip,iy+yskip)=IND(atm,ix,iy);
}
}
cfftshift(hat);
cfft2i(hat, -1);
cabs22d(&hattot, 1, hat, 1);
}
dscale(hattot, 1./nframe);
dfftshift(hattot);
writebin(hattot, "PSD_fractal");
}
{
dmat *spect=turbpsd(nx, ny, dx, r0, 100, 0, 0.5);
writebin(spect, "spect");
cmat *hat=cnew(nx*ratio, ny*ratio);
//cfft2plan(hat, -1);
dmat *hattot=dnew(nx*ratio, ny*ratio);
cmat *atm=cnew(nx, ny);
//cfft2plan(atm, -1);
dmat *atmr=dnew(atm->nx, atm->ny);
dmat *atmi=dnew(atm->nx, atm->ny);
cmat* phat=hat;
dmat* patmr=atmr;
dmat* patmi=atmi;
for(long ii=0; ii<nframe; ii+=2){
info2("%ld of %ld\n", ii, nframe);
for(long i=0; i<atm->nx*atm->ny; i++){
atm->p[i]=COMPLEX(randn(&rstat), randn(&rstat))*spect->p[i];
}
cfft2(atm, -1);
for(long i=0; i<atm->nx*atm->ny; i++){
atmr->p[i]=creal(atm->p[i]);
atmi->p[i]=cimag(atm->p[i]);
}
czero(hat);
for(long iy=0; iy<ny; iy++){
for(long ix=0; ix<nx; ix++){
IND(phat,ix+xskip,iy+yskip)=IND(patmr,ix,iy);
}
}
cfftshift(hat);
cfft2i(hat, -1);
cabs22d(&hattot, 1, hat, 1);
czero(hat);
for(long iy=0; iy<ny; iy++){
for(long ix=0; ix<nx; ix++){
IND(phat,ix+xskip,iy+yskip)=IND(patmi,ix,iy);
}
}
cfftshift(hat);
cfft2i(hat, -1);
cabs22d(&hattot, 1, hat, 1);
}
dscale(hattot, 1./nframe);
dfftshift(hattot);
writebin(hattot, "PSD_fft");
}
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; // -Wall
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
dim_v = getAttrib(value, R_DimSymbol);
array_value = CXXRCONSTRUCT(Rboolean, (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1));
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(ind = allocVector(INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
val = eval(R_fcall, rho);
if (NAMED(val))
val = duplicate(val);
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
bool okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
default:
Rf_error(_("Internal error: unexpected SEXPTYPE"));
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
for (int j = 0; j < commonLen; j++) {
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(val)[j]; break;
case REALSXP: REAL(ans)[i*commonLen + j] = REAL(val)[j]; break;
case INTSXP: INTEGER(ans)[i*commonLen + j] = INTEGER(val)[j]; break;
case LGLSXP: LOGICAL(ans)[i*commonLen + j] = LOGICAL(val)[j]; break;
case RAWSXP: RAW(ans)[i*commonLen + j] = RAW(val)[j]; break;
case STRSXP: SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(val, j)); break;
case VECSXP: SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(val, j)); break;
default:
error(_("type '%s' is not supported"), type2char(commonType));
}
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = int( n); // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
SEXP
RGDAL_GetRasterData(SEXP sxpRasterBand,
SEXP sxpRegion,
SEXP sxpDimOut,
SEXP sxpInterleave) {
GDALRasterBand *pRasterBand = getGDALRasterPtr(sxpRasterBand);
GDALDataType eGDALType = GDT_Int32;
SEXPTYPE uRType = INTSXP;
switch(pRasterBand->GetRasterDataType()) {
case GDT_Byte:
case GDT_UInt16:
case GDT_Int16:
case GDT_UInt32:
case GDT_Int32:
uRType = INTSXP;
eGDALType = GDAL_INTEGER_TYPE;
break;
case GDT_Float32:
case GDT_Float64:
uRType = REALSXP;
eGDALType = GDAL_FLOAT_TYPE;
break;
case GDT_CInt16:
case GDT_CInt32:
case GDT_CFloat32:
case GDT_CFloat64:
uRType = CPLXSXP;
eGDALType = GDAL_COMPLEX_TYPE;
break;
default:
error("Raster data type unknown\n");
break;
}
// Create matrix transposed
int pc=0;
SEXP sRStorage;
PROTECT(sRStorage = allocMatrix(uRType,
INTEGER(sxpDimOut)[1],
INTEGER(sxpDimOut)[0])); pc++;
// replication for 2.4.0 RSB 20060726
switch(uRType) {
case INTSXP:
if(pRasterBand->RasterIO(GF_Read,
INTEGER(sxpRegion)[1] - 1,
INTEGER(sxpRegion)[0] - 1,
INTEGER(sxpRegion)[3],
INTEGER(sxpRegion)[2],
(void *)INTEGER(sRStorage),
INTEGER(sxpDimOut)[1],
INTEGER(sxpDimOut)[0],
eGDALType,
INTEGER(sxpInterleave)[0],
INTEGER(sxpInterleave)[1])
== CE_Failure)
error("Failure during raster IO\n");
break;
case REALSXP:
if(pRasterBand->RasterIO(GF_Read,
INTEGER(sxpRegion)[1] - 1,
INTEGER(sxpRegion)[0] - 1,
INTEGER(sxpRegion)[3],
INTEGER(sxpRegion)[2],
(void *)REAL(sRStorage),
INTEGER(sxpDimOut)[1],
INTEGER(sxpDimOut)[0],
eGDALType,
INTEGER(sxpInterleave)[0],
INTEGER(sxpInterleave)[1])
== CE_Failure)
error("Failure during raster IO\n");
break;
case CPLXSXP:
if(pRasterBand->RasterIO(GF_Read,
INTEGER(sxpRegion)[1] - 1,
INTEGER(sxpRegion)[0] - 1,
INTEGER(sxpRegion)[3],
INTEGER(sxpRegion)[2],
(void *)COMPLEX(sRStorage),
INTEGER(sxpDimOut)[1],
INTEGER(sxpDimOut)[0],
eGDALType,
INTEGER(sxpInterleave)[0],
INTEGER(sxpInterleave)[1])
== CE_Failure)
error("Failure during raster IO\n");
break;
default:
error("Raster data type unknown\n");
break;
}
int hasNoDataValue;
double noDataValue = pRasterBand->GetNoDataValue(&hasNoDataValue);
int i;
if (hasNoDataValue) {
switch(uRType) {
case INTSXP:
for (i = 0; i < LENGTH(sRStorage); ++i)
if (INTEGER(sRStorage)[i] == (int) noDataValue) {
INTEGER(sRStorage)[i] = NA_INTEGER;
}
break;
case REALSXP:
switch(pRasterBand->GetRasterDataType()) {
case GDT_Float32:
for (i = 0; i < LENGTH(sRStorage); ++i)
if (REAL(sRStorage)[i] == (double) ((float) noDataValue)) {
REAL(sRStorage)[i] = NA_REAL;
}
break;
case GDT_Float64:
for (i = 0; i < LENGTH(sRStorage); ++i)
if (REAL(sRStorage)[i] == (double) (noDataValue)) {
REAL(sRStorage)[i] = NA_REAL;
}
break;
default:
error("Raster data type unknown\n");
break;
}
break;
default:
warning("Output data values = %f are invalid\n", noDataValue);
break;
}
}
UNPROTECT(pc);
return(sRStorage);
}
/* rep_len(x, len), also used for rep.int() with scalar 'times' */
static SEXP rep3(SEXP s, R_xlen_t ns, R_xlen_t na)
{
R_xlen_t i, j;
SEXP a;
PROTECT(a = allocVector(TYPEOF(s), na));
// i % ns is slow, especially with long R_xlen_t
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
LOGICAL(a)[i++] = LOGICAL(s)[j++];
}
break;
case INTSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
INTEGER(a)[i++] = INTEGER(s)[j++];
}
break;
case REALSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
REAL(a)[i++] = REAL(s)[j++];
}
break;
case CPLXSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
COMPLEX(a)[i++] = COMPLEX(s)[j++];
}
break;
case RAWSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
RAW(a)[i++] = RAW(s)[j++];
}
break;
case STRSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
SET_STRING_ELT(a, i++, STRING_ELT(s, j++));
}
break;
case VECSXP:
case EXPRSXP:
for (i = 0, j = 0; i < na;) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (j >= ns) j = 0;
SET_VECTOR_ELT(a, i++, lazy_duplicate(VECTOR_ELT(s, j++)));
}
break;
default:
UNIMPLEMENTED_TYPE("rep3", s);
}
UNPROTECT(1);
return a;
}
/**
Setup the detector transfer functions. See maos/setup_powfs.c
*/
static void setup_powfs_dtf(POWFS_S *powfs, const PARMS_S* parms){
const int npowfs=parms->maos.npowfs;
for(int ipowfs=0; ipowfs<npowfs; ipowfs++){
const int ncomp=parms->maos.ncomp[ipowfs];
const int ncomp2=ncomp>>1;
const int embfac=parms->maos.embfac[ipowfs];
const int pixpsa=parms->skyc.pixpsa[ipowfs];
const double pixtheta=parms->skyc.pixtheta[ipowfs];
const double blur=parms->skyc.pixblur[ipowfs]*pixtheta;
const double e0=exp(-2*M_PI*M_PI*blur*blur);
const double dxsa=parms->maos.dxsa[ipowfs];
const double pixoffx=parms->skyc.pixoffx[ipowfs];
const double pixoffy=parms->skyc.pixoffy[ipowfs];
const double pxo=-(pixpsa/2-0.5+pixoffx)*pixtheta;
const double pyo=-(pixpsa/2-0.5+pixoffy)*pixtheta;
loc_t *loc_ccd=mksqloc(pixpsa, pixpsa, pixtheta, pixtheta, pxo, pyo);
powfs[ipowfs].dtf=mycalloc(parms->maos.nwvl,DTF_S);
for(int iwvl=0; iwvl<parms->maos.nwvl; iwvl++){
const double wvl=parms->maos.wvl[iwvl];
const double dtheta=wvl/(dxsa*embfac);
const double pdtheta=pixtheta*pixtheta/(dtheta*dtheta);
const double du=1./(dtheta*ncomp);
const double du2=du*du;
const double dupth=du*pixtheta;
cmat *nominal=cnew(ncomp,ncomp);
//cfft2plan(nominal,-1);
//cfft2plan(nominal,1);
cmat* pn=nominal;
const double theta=0;
const double ct=cos(theta);
const double st=sin(theta);
for(int iy=0; iy<ncomp; iy++){
int jy=iy-ncomp2;
for(int ix=0; ix<ncomp; ix++){
int jx=ix-ncomp2;
double ir=ct*jx+st*jy;
double ia=-st*jx+ct*jy;
IND(pn,ix,iy)=sinc(ir*dupth)*sinc(ia*dupth)
*pow(e0,ir*ir*du2)*pow(e0,ia*ia*du2)
*pdtheta;
}
}
if(parms->skyc.fnpsf1[ipowfs]){
warning("powfs %d has additional otf to be multiplied\n", ipowfs);
dcell *psf1c=dcellread("%s", parms->skyc.fnpsf1[ipowfs]);
dmat *psf1=NULL;
if(psf1c->nx == 1){
psf1=dref(psf1c->p[0]);
}else if(psf1c->nx==parms->maos.nwvl){
psf1=dref(psf1c->p[iwvl]);
}else{
error("skyc.fnpsf1 has wrong dimension\n");
}
dcellfree(psf1c);
if(psf1->ny!=2){
error("skyc.fnpsf1 has wrong dimension\n");
}
dmat *psf1x=dnew_ref(psf1->nx, 1, psf1->p);
dmat *psf1y=dnew_ref(psf1->nx, 1, psf1->p+psf1->nx);
dmat *psf2x=dnew(ncomp*ncomp, 1);
for(int iy=0; iy<ncomp; iy++){
int jy=iy-ncomp2;
for(int ix=0; ix<ncomp; ix++){
int jx=ix-ncomp2;
psf2x->p[ix+iy*ncomp]=sqrt(jx*jx+jy*jy)*dtheta;
}
}
info("powfs %d, iwvl=%d, dtheta=%g\n", ipowfs, iwvl, dtheta*206265000);
writebin(psf2x, "powfs%d_psf2x_%d", ipowfs,iwvl);
dmat *psf2=dinterp1(psf1x, psf1y, psf2x, 0);
normalize_sum(psf2->p, psf2->nx*psf2->ny, 1);
psf2->nx=ncomp; psf2->ny=ncomp;
writebin(psf2, "powfs%d_psf2_%d", ipowfs,iwvl);
cmat *otf2=cnew(ncomp, ncomp);
//cfft2plan(otf2, -1);
ccpd(&otf2, psf2);//peak in center
cfftshift(otf2);//peak in corner
cfft2(otf2, -1);
cfftshift(otf2);//peak in center
writebin(otf2, "powfs%d_otf2_%d", ipowfs, iwvl);
writebin(nominal, "powfs%d_dtf%d_nominal_0",ipowfs,iwvl);
for(int i=0; i<ncomp*ncomp; i++){
nominal->p[i]*=otf2->p[i];
}
writebin(nominal, "powfs%d_dtf%d_nominal_1",ipowfs,iwvl);
dfree(psf1x);
dfree(psf1y);
dfree(psf2x);
dfree(psf1);
cfree(otf2);
dfree(psf2);
}
cfftshift(nominal);//peak in corner
cfft2(nominal,-1);
cfftshift(nominal);//peak in center
cfft2i(nominal,1);
warning_once("double check nominal for off centered skyc.fnpsf1\n");
/*This nominal will multiply to OTF with peak in corner. But after
inverse fft, peak will be in center*/
ccp(&powfs[ipowfs].dtf[iwvl].nominal, nominal);
cfree(nominal);
loc_t *loc_psf=mksqloc(ncomp, ncomp, dtheta, dtheta, -ncomp2*dtheta, -ncomp2*dtheta);
powfs[ipowfs].dtf[iwvl].si=mkh(loc_psf,loc_ccd,0,0,1);
locfree(loc_psf);
if(parms->skyc.dbg){
writebin(powfs[ipowfs].dtf[iwvl].nominal,
"%s/powfs%d_dtf%d_nominal",dirsetup,ipowfs,iwvl);
writebin(powfs[ipowfs].dtf[iwvl].si,
"%s/powfs%d_dtf%d_si",dirsetup,ipowfs,iwvl);
}
powfs[ipowfs].dtf[iwvl].U=cnew(ncomp,1);
dcomplex *U=powfs[ipowfs].dtf[iwvl].U->p;
for(int ix=0; ix<ncomp; ix++){
int jx=ix<ncomp2?ix:(ix-ncomp);
U[ix]=COMPLEX(0, -2.*M_PI*jx*du);
}
}/*iwvl */
locfree(loc_ccd);
}/*ipowfs */
}
/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */
SEXP attribute_hidden do_matprod(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int ldx, ldy, nrx, ncx, nry, ncy, mode;
SEXP x = CAR(args), y = CADR(args), xdims, ydims, ans;
Rboolean sym;
if (PRIMVAL(op) == 0 && /* %*% is primitive, the others are .Internal() */
(IS_S4_OBJECT(x) || IS_S4_OBJECT(y))
&& R_has_methods(op)) {
SEXP s, value;
/* Remove argument names to ensure positional matching */
for(s = args; s != R_NilValue; s = CDR(s)) SET_TAG(s, R_NilValue);
value = R_possible_dispatch(call, op, args, rho, FALSE);
if (value) return value;
}
sym = isNull(y);
if (sym && (PRIMVAL(op) > 0)) y = x;
if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) )
errorcall(call, _("requires numeric/complex matrix/vector arguments"));
xdims = getAttrib(x, R_DimSymbol);
ydims = getAttrib(y, R_DimSymbol);
ldx = length(xdims);
ldy = length(ydims);
if (ldx != 2 && ldy != 2) { /* x and y non-matrices */
// for crossprod, allow two cases: n x n ==> (1,n) x (n,1); 1 x n = (n, 1) x (1, n)
if (PRIMVAL(op) == 1 && LENGTH(x) == 1) {
nrx = ncx = nry = 1;
ncy = LENGTH(y);
}
else {
nry = LENGTH(y);
ncy = 1;
if (PRIMVAL(op) == 0) {
nrx = 1;
ncx = LENGTH(x);
if(ncx == 1) { // y as row vector
ncy = nry;
nry = 1;
}
}
else {
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldx != 2) { /* x not a matrix */
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
nrx = 0;
ncx = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(x) == nry) { /* x as row vector */
nrx = 1;
ncx = nry; /* == LENGTH(x) */
}
else if (nry == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(x) == nry) { /* x is a col vector */
nrx = nry; /* == LENGTH(x) */
ncx = 1;
}
/* else if (nry == 1) ... not being too tolerant
to treat x as row vector, as t(x) *is* row vector */
}
else { /* tcrossprod */
if (LENGTH(x) == ncy) { /* x as row vector */
nrx = 1;
ncx = ncy; /* == LENGTH(x) */
}
else if (ncy == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldy != 2) { /* y not a matrix */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = 0;
ncy = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(y) == ncx) { /* y as col vector */
nry = ncx;
ncy = 1;
}
else if (ncx == 1) { /* y as row vector */
nry = 1;
ncy = LENGTH(y);
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(y) == nrx) { /* y is a col vector */
nry = nrx;
ncy = 1;
} else if (nrx == 1) { // y as row vector
nry = 1;
ncy = LENGTH(y);
}
}
else { // tcrossprod
if (nrx == 1) { // y as row vector
nry = 1;
ncy = LENGTH(y);
}
else { // y is a col vector
nry = LENGTH(y);
ncy = 1;
}
}
}
else { /* x and y matrices */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
}
/* nr[ow](.) and nc[ol](.) are now defined for x and y */
if (PRIMVAL(op) == 0) {
/* primitive, so use call */
if (ncx != nry)
errorcall(call, _("non-conformable arguments"));
}
else if (PRIMVAL(op) == 1) {
if (nrx != nry)
error(_("non-conformable arguments"));
}
else {
if (ncx != ncy)
error(_("non-conformable arguments"));
}
if (isComplex(CAR(args)) || isComplex(CADR(args)))
mode = CPLXSXP;
else
mode = REALSXP;
SETCAR(args, coerceVector(CAR(args), mode));
SETCADR(args, coerceVector(CADR(args), mode));
if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */
PROTECT(ans = allocMatrix(mode, nrx, ncy));
if (mode == CPLXSXP)
cmatprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else
matprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2 || ncx == 1) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
#define YDIMS_ET_CETERA \
if (ydims != R_NilValue) { \
if (ldy == 2) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \
dny = getAttrib(ydims, R_NamesSymbol); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \
} else if (nry == 1) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \
dny = getAttrib(ydims, R_NamesSymbol); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \
} \
} \
\
/* We sometimes attach a dimnames attribute \
* whose elements are all NULL ... \
* This is ugly but causes no real damage. \
* Now (2.1.0 ff), we don't anymore: */ \
if (VECTOR_ELT(dimnames,0) != R_NilValue || \
VECTOR_ELT(dimnames,1) != R_NilValue) { \
if (dnx != R_NilValue || dny != R_NilValue) \
setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \
setAttrib(ans, R_DimNamesSymbol, dimnames); \
} \
UNPROTECT(2)
YDIMS_ET_CETERA;
}
}
else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */
PROTECT(ans = allocMatrix(mode, ncx, ncy));
if (mode == CPLXSXP)
if(sym)
ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
else
ccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else {
if(sym)
symcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans));
else
crossprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
}
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
}
}
YDIMS_ET_CETERA;
}
}
else { /* op == 2: tcrossprod() */
PROTECT(ans = allocMatrix(mode, nrx, nry));
if (mode == CPLXSXP)
if(sym)
tccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CAR(args)), nry, ncy, COMPLEX(ans));
else
tccrossprod(COMPLEX(CAR(args)), nrx, ncx,
COMPLEX(CADR(args)), nry, ncy, COMPLEX(ans));
else {
if(sym)
symtcrossprod(REAL(CAR(args)), nrx, ncx, REAL(ans));
else
tcrossprod(REAL(CAR(args)), nrx, ncx,
REAL(CADR(args)), nry, ncy, REAL(ans));
}
PROTECT(xdims = getAttrib(CAR(args), R_DimNamesSymbol));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getAttrib(CADR(args), R_DimNamesSymbol));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getAttrib(xdims, R_NamesSymbol);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
if (ydims != R_NilValue) {
if (ldy == 2) {
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0));
dny = getAttrib(ydims, R_NamesSymbol);
if(!isNull(dny))
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0));
}
}
if (VECTOR_ELT(dimnames,0) != R_NilValue ||
VECTOR_ELT(dimnames,1) != R_NilValue) {
if (dnx != R_NilValue || dny != R_NilValue)
setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
setAttrib(ans, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
}
UNPROTECT(3);
return ans;
}
SEXP attribute_hidden do_transpose(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP a, r, dims, dimnames, dimnamesnames = R_NilValue,
ndimnamesnames, rnames, cnames;
int ldim, ncol = 0, nrow = 0;
R_xlen_t len = 0;
checkArity(op, args);
a = CAR(args);
if (isVector(a)) {
dims = getAttrib(a, R_DimSymbol);
ldim = length(dims);
rnames = R_NilValue;
cnames = R_NilValue;
switch(ldim) {
case 0:
len = nrow = LENGTH(a);
ncol = 1;
rnames = getAttrib(a, R_NamesSymbol);
dimnames = rnames;/* for isNull() below*/
break;
case 1:
len = nrow = LENGTH(a);
ncol = 1;
dimnames = getAttrib(a, R_DimNamesSymbol);
if (dimnames != R_NilValue) {
rnames = VECTOR_ELT(dimnames, 0);
dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
}
break;
case 2:
ncol = ncols(a);
nrow = nrows(a);
len = XLENGTH(a);
dimnames = getAttrib(a, R_DimNamesSymbol);
if (dimnames != R_NilValue) {
rnames = VECTOR_ELT(dimnames, 0);
cnames = VECTOR_ELT(dimnames, 1);
dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
}
break;
default:
goto not_matrix;
}
}
else
goto not_matrix;
PROTECT(r = allocVector(TYPEOF(a), len));
R_xlen_t i, j, l_1 = len-1;
switch (TYPEOF(a)) {
case LGLSXP:
case INTSXP:
// filling in columnwise, "accessing row-wise":
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
INTEGER(r)[i] = INTEGER(a)[j];
}
break;
case REALSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
REAL(r)[i] = REAL(a)[j];
}
break;
case CPLXSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
COMPLEX(r)[i] = COMPLEX(a)[j];
}
break;
case STRSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
SET_STRING_ELT(r, i, STRING_ELT(a,j));
}
break;
case VECSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
SET_VECTOR_ELT(r, i, VECTOR_ELT(a,j));
}
break;
case RAWSXP:
for (i = 0, j = 0; i < len; i++, j += nrow) {
if (j > l_1) j -= l_1;
RAW(r)[i] = RAW(a)[j];
}
break;
default:
UNPROTECT(1);
goto not_matrix;
}
PROTECT(dims = allocVector(INTSXP, 2));
INTEGER(dims)[0] = ncol;
INTEGER(dims)[1] = nrow;
setAttrib(r, R_DimSymbol, dims);
UNPROTECT(1);
/* R <= 2.2.0: dropped list(NULL,NULL) dimnames :
* if(rnames != R_NilValue || cnames != R_NilValue) */
if(!isNull(dimnames)) {
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 0, cnames);
SET_VECTOR_ELT(dimnames, 1, rnames);
if(!isNull(dimnamesnames)) {
PROTECT(ndimnamesnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(ndimnamesnames, 1, STRING_ELT(dimnamesnames, 0));
SET_VECTOR_ELT(ndimnamesnames, 0,
(ldim == 2) ? STRING_ELT(dimnamesnames, 1):
R_BlankString);
setAttrib(dimnames, R_NamesSymbol, ndimnamesnames);
UNPROTECT(1);
}
setAttrib(r, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
copyMostAttrib(a, r);
UNPROTECT(1);
return r;
not_matrix:
error(_("argument is not a matrix"));
return call;/* never used; just for -Wall */
}
SEXP mat_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
SEXP sWhat, SEXP sSkip, SEXP sNlines, SEXP sQuote) {
unsigned int ncol = 1, np = 0, resilient = asInteger(sResilient);
unsigned long nrow, i, k, N, len, quoteLen;
int use_ncol = asInteger(sNcol);
int nsep = -1;
long skip = asLong(sSkip, 0);
long nlines = asLong(sNlines, -1);
SEXP res, rnam;
char sep;
char num_buf[48];
/* sraw/send is only used for raw vector parsing, but we have to set it to 0
to make gcc happy which cannot figure out that it's actually unused */
const char *c, *c2, *sraw = 0, *send = 0, *l, *le, *quoteChars;
/* parse sep input */
if (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0)
nsep = (int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0));
if (TYPEOF(sSep) != STRSXP || LENGTH(sSep) < 1)
Rf_error("invalid separator");
sep = CHAR(STRING_ELT(sSep, 0))[0];
/* parse quote information */
quoteChars = CHAR(STRING_ELT(sQuote, 0));
quoteLen = strlen(quoteChars);
/* check the input data */
if (TYPEOF(s) == RAWSXP) {
nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s);
sraw = (const char*) RAW(s);
send = sraw + XLENGTH(s);
if (nrow >= skip) {
unsigned long slen = XLENGTH(s);
nrow = nrow - skip;
i = 0;
while (i < skip && (sraw = memchr(sraw, '\n', slen))) { sraw++; i++; }
} else {
nrow = 0;
sraw = send;
}
} else if (TYPEOF(s) == STRSXP) {
nrow = LENGTH(s);
if (nrow >= skip) {
nrow -= skip;
} else {
skip = nrow;
nrow = 0;
}
} else {
Rf_error("invalid input to split - must be a raw or character vector");
}
if (nlines >= 0 && nrow > nlines) nrow = nlines;
/* If no rows left, return an empty matrix */
if (!nrow) {
if (np) UNPROTECT(np);
return allocMatrix(TYPEOF(sWhat), 0, 0);
}
/* count number of columns */
if (use_ncol < 1) {
if (TYPEOF(s) == RAWSXP) {
c = sraw;
le = memchr(sraw, '\n', send - sraw);
if (TYPEOF(sWhat) == STRSXP && quoteLen) {
ncol = 0;
while(1)
{
ncol++;
for (k = 0; k < quoteLen; k++) {
if (*c == quoteChars[k]) {
c++;
if (! (c = memchr(c, quoteChars[k], le - c)))
Rf_error("End of line within quote string on line 1; cannot determine num columns!");
break; /* note: breaks inner 'for' loop, not 'if' statement */
}
}
if (!(c = (memchr(c, (unsigned char) sep, le - c))))
break;
c++;
}
} else {
ncol = 1;
while ((c = memchr(c, (unsigned char) sep, le - c))) { ncol++; c++; }
}
} else {
c = CHAR(STRING_ELT(s, 0));
if (TYPEOF(sWhat) == STRSXP && quoteLen) {
ncol = 0;
while(1)
{
ncol++;
for (k = 0; k < quoteLen; k++) {
if (*c == quoteChars[k]) {
c++;
if (!(c = strchr(c, quoteChars[k])))
Rf_error("End of line within quote string on line 1; cannot determine num columns!");
break; /* note: breaks inner 'for' loop, not 'if' statement */
}
}
if (!(c = (strchr(c, sep))))
break;
c++;
}
} else {
while ((c = strchr(c, sep))) { ncol++; c++; }
}
}
/* if sep and nsep are the same then the first "column" is the key and not the column */
if (nsep == (int) (unsigned char) sep) ncol--;
} else ncol = use_ncol;
/* allocate space for the result */
N = ncol * nrow;
switch(TYPEOF(sWhat)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
res = PROTECT(allocMatrix(TYPEOF(sWhat), nrow, ncol));
break;
default:
Rf_error("Unsupported input to what.");
break;
}
if (nsep >= 0) {
SEXP dn;
setAttrib(res, R_DimNamesSymbol, (dn = allocVector(VECSXP, 2)));
SET_VECTOR_ELT(dn, 0, (rnam = allocVector(STRSXP, nrow)));
}
np++;
/* cycle over the rows and parse the data */
for (i = 0; i < nrow; i++) {
int j = i;
/* find the row of data */
if (TYPEOF(s) == RAWSXP) {
l = sraw;
le = memchr(l, '\n', send - l);
if (!le) le = send;
sraw = le + 1;
if (*(le - 1) == '\r' ) le--; /* account for DOS-style '\r\n' */
} else {
l = CHAR(STRING_ELT(s, i + skip));
le = l + strlen(l);
}
/* if nsep, load rowname */
if (nsep >= 0) {
c = memchr(l, nsep, le - l);
if (c) {
SET_STRING_ELT(rnam, i, Rf_mkCharLen(l, c - l));
l = c + 1;
} else
SET_STRING_ELT(rnam, i, R_BlankString);
}
/* now split the row into elements */
while (l < le) {
if (!(c = memchr(l, sep, le - l)))
c = le;
if (j >= N) {
if (resilient) break;
Rf_error("line %lu: too many columns (expected %u)", (unsigned long)(i + 1), ncol);
}
switch(TYPEOF(sWhat)) {
case LGLSXP:
len = (int) (c - l);
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
int tr = StringTrue(num_buf), fa = StringFalse(num_buf);
LOGICAL(res)[j] = (tr || fa) ? tr : NA_INTEGER;
break;
case INTSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
INTEGER(res)[j] = Strtoi(num_buf, 10);
break;
case REALSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
REAL(res)[j] = R_atof(num_buf);
break;
case CPLXSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
COMPLEX(res)[j] = strtoc(num_buf, TRUE);
break;
case STRSXP:
c2 = c;
if (quoteLen) {
for (k = 0; k < quoteLen; k++) {
if (*l == quoteChars[k]) {
l++;
if (!(c2 = memchr(l, quoteChars[k], le - l))) {
Rf_warning("End of line within quoted string!");
c = c2 = le;
} else {
if (!(c = memchr(c2, (unsigned char) sep, le - c2)))
c = le;
}
}
}
}
SET_STRING_ELT(res, j, Rf_mkCharLen(l, c2 - l));
break;
case RAWSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
RAW(res)[j] = strtoraw(num_buf);
break;
}
l = c + 1;
j += nrow;
}
/* fill up unused columns with NAs */
while (j < N) {
switch (TYPEOF(sWhat)) {
case LGLSXP:
LOGICAL(res)[j] = NA_INTEGER;
break;
case INTSXP:
INTEGER(res)[j] = NA_INTEGER;
break;
case REALSXP:
REAL(res)[j] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(res)[j].r = NA_REAL;
COMPLEX(res)[j].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(res, j, R_NaString);
break;
case RAWSXP:
RAW(res)[j] = (Rbyte) 0;
break;
}
j += nrow;
}
}
UNPROTECT(np);
return res;
}
SEXP attribute_hidden do_matrix(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP vals, ans, snr, snc, dimnames;
int nr = 1, nc = 1, byrow, miss_nr, miss_nc;
R_xlen_t lendat;
checkArity(op, args);
vals = CAR(args); args = CDR(args);
switch(TYPEOF(vals)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
case EXPRSXP:
case VECSXP:
break;
default:
error(_("'data' must be of a vector type, was '%s'"),
type2char(TYPEOF(vals)));
}
lendat = XLENGTH(vals);
snr = CAR(args); args = CDR(args);
snc = CAR(args); args = CDR(args);
byrow = asLogical(CAR(args)); args = CDR(args);
if (byrow == NA_INTEGER)
error(_("invalid '%s' argument"), "byrow");
dimnames = CAR(args);
args = CDR(args);
miss_nr = asLogical(CAR(args)); args = CDR(args);
miss_nc = asLogical(CAR(args));
if (!miss_nr) {
if (!isNumeric(snr)) error(_("non-numeric matrix extent"));
nr = asInteger(snr);
if (nr == NA_INTEGER)
error(_("invalid 'nrow' value (too large or NA)"));
if (nr < 0)
error(_("invalid 'nrow' value (< 0)"));
}
if (!miss_nc) {
if (!isNumeric(snc)) error(_("non-numeric matrix extent"));
nc = asInteger(snc);
if (nc == NA_INTEGER)
error(_("invalid 'ncol' value (too large or NA)"));
if (nc < 0)
error(_("invalid 'ncol' value (< 0)"));
}
if (miss_nr && miss_nc) {
if (lendat > INT_MAX) error("data is too long");
nr = (int) lendat;
} else if (miss_nr) {
if (lendat > (double) nc * INT_MAX) error("data is too long");
// avoid division by zero
if (nc == 0) {
if (lendat) error(_("nc = 0 for non-null data"));
else nr = 0;
} else
nr = (int) ceil((double) lendat / (double) nc);
} else if (miss_nc) {
if (lendat > (double) nr * INT_MAX) error("data is too long");
// avoid division by zero
if (nr == 0) {
if (lendat) error(_("nr = 0 for non-null data"));
else nc = 0;
} else
nc = (int) ceil((double) lendat / (double) nr);
}
if(lendat > 0) {
R_xlen_t nrc = (R_xlen_t) nr * nc;
if (lendat > 1 && nrc % lendat != 0) {
if (((lendat > nr) && (lendat / nr) * nr != lendat) ||
((lendat < nr) && (nr / lendat) * lendat != nr))
warning(_("data length [%d] is not a sub-multiple or multiple of the number of rows [%d]"), lendat, nr);
else if (((lendat > nc) && (lendat / nc) * nc != lendat) ||
((lendat < nc) && (nc / lendat) * lendat != nc))
warning(_("data length [%d] is not a sub-multiple or multiple of the number of columns [%d]"), lendat, nc);
}
else if ((lendat > 1) && (nrc == 0)){
warning(_("data length exceeds size of matrix"));
}
}
#ifndef LONG_VECTOR_SUPPORT
if ((double)nr * (double)nc > INT_MAX)
error(_("too many elements specified"));
#endif
PROTECT(ans = allocMatrix(TYPEOF(vals), nr, nc));
if(lendat) {
if (isVector(vals))
copyMatrix(ans, vals, byrow);
else
copyListMatrix(ans, vals, byrow);
} else if (isVector(vals)) { /* fill with NAs */
R_xlen_t N = (R_xlen_t) nr * nc, i;
switch(TYPEOF(vals)) {
case STRSXP:
for (i = 0; i < N; i++)
SET_STRING_ELT(ans, i, NA_STRING);
break;
case LGLSXP:
for (i = 0; i < N; i++)
LOGICAL(ans)[i] = NA_LOGICAL;
break;
case INTSXP:
for (i = 0; i < N; i++)
INTEGER(ans)[i] = NA_INTEGER;
break;
case REALSXP:
for (i = 0; i < N; i++)
REAL(ans)[i] = NA_REAL;
break;
case CPLXSXP:
{
Rcomplex na_cmplx;
na_cmplx.r = NA_REAL;
na_cmplx.i = 0;
for (i = 0; i < N; i++)
COMPLEX(ans)[i] = na_cmplx;
}
break;
case RAWSXP:
memset(RAW(ans), 0, N);
break;
default:
/* don't fill with anything */
;
}
}
if(!isNull(dimnames)&& length(dimnames) > 0)
ans = dimnamesgets(ans, dimnames);
UNPROTECT(1);
return ans;
}
// (C) ceeboo 2013/12
//
// Wrapper for simple triplet matrix which runs in constant
// memory.
SEXP _col_apply_stm(SEXP a) {
a = CDR(a);
if (length(a) < 2)
error("invalid number of arguments");
SEXP x = CAR(a);
if (!inherits(x, "simple_triplet_matrix") || _valid_stm(x))
error("'x' not of class 'simple_triplet_matrix'");
if (!isFunction(CADR(a)))
error("invalid function parameter");
int n, m, *_ix, *_jx, *_nx, *_px;
SEXP vx, z, r;
vx = VECTOR_ELT(x, 2);
n = INTEGER(VECTOR_ELT(x, 3))[0];
m = INTEGER(VECTOR_ELT(x, 4))[0];
z = PROTECT(allocVector(TYPEOF(vx), n));
a = PROTECT(LCONS(CADR(a), LCONS(z, CDDR(a))));
switch(TYPEOF(vx)) {
case LGLSXP:
case INTSXP:
memset(INTEGER(z), 0, sizeof(int) * n);
break;
case REALSXP:
memset(REAL(z), 0, sizeof(double) * n);
break;
case RAWSXP:
memset(RAW(z), 0, sizeof(char) * n);
break;
case CPLXSXP:
memset(COMPLEX(z), 0, sizeof(Rcomplex) * n);
break;
case EXPRSXP:
case VECSXP:
for (int i = 0; i < n; i++)
SET_VECTOR_ELT(z, i, R_NilValue);
break;
case STRSXP:
for (int i = 0; i < n; i++)
SET_STRING_ELT(z, i, R_BlankString);
break;
default:
error("type of 'v' not supported");
}
// Map blocks of equal column indexes
_jx = INTEGER(VECTOR_ELT(x, 1)); // column indexes
_nx = INTEGER(PROTECT(allocVector(INTSXP, m + 1)));
memset(_nx, 0, sizeof(int) * (m + 1));
for (int k = 0; k < LENGTH(vx); k++)
_nx[_jx[k]]++;
for (int k = 1; k < m + 1; k++)
_nx[k] += _nx[k-1];
_px = INTEGER(PROTECT(allocVector(INTSXP, LENGTH(vx))));
_nx -= 1; // one-based R indexing
for (int k = 0; k < LENGTH(vx); k++) {
_px[_nx[_jx[k]]] = k;
_nx[_jx[k]]++;
}
// Reset
_nx += 1;
for (int k = m; k > 0; k--)
_nx[k] = _nx[k-1];
_nx[0] = 0;
_ix = INTEGER(VECTOR_ELT(x, 0)); // row indexes
r = PROTECT(allocVector(VECSXP, m));
int f, fl;
f = fl = _nx[0];
for (int i = 1; i < m + 1; i++) {
int l = _nx[i];
// (Re)set values
switch(TYPEOF(vx)) {
case LGLSXP:
case INTSXP:
for (int k = fl; k < f; k++)
INTEGER(z)[_px[k]] = 0;
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
INTEGER(z)[i] = INTEGER(vx)[p];
_px[k] = i;
}
break;
case REALSXP:
for (int k = fl; k < f; k++)
REAL(z)[_px[k]] = 0.0;
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
REAL(z)[i] = REAL(vx)[p];
_px[k] = i;
}
break;
case RAWSXP:
for (int k = fl; k < f; k++)
RAW(z)[_px[k]] = (char) 0;
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
RAW(z)[i] = RAW(vx)[p];
_px[k] = i;
}
break;
case CPLXSXP:
for (int k = fl; k < f; k++) {
static Rcomplex c;
COMPLEX(z)[_px[k]] = c;
}
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
COMPLEX(z)[i] = COMPLEX(vx)[p];
_px[k] = i;
}
break;
case EXPRSXP:
case VECSXP:
for (int k = fl; k < f; k++)
SET_VECTOR_ELT(z, _px[k], R_NilValue);
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
SET_VECTOR_ELT(z, i, VECTOR_ELT(vx, p));
_px[k] = i;
}
break;
case STRSXP:
for (int k = fl; k < f; k++)
SET_STRING_ELT(z, _px[k], R_BlankString);
for (int k = f; k < l; k++) {
int p = _px[k],
i = _ix[p] - 1;
SET_STRING_ELT(z, i, STRING_ELT(vx, p));
_px[k] = i;
}
break;
default:
error("type of 'v' not supported");
}
SEXP s = eval(a, R_GlobalEnv);
if (s == z) // identity, print, ...
SET_VECTOR_ELT(r, i - 1, duplicate(s));
else
SET_VECTOR_ELT(r, i - 1, s);
fl = f;
f = l;
}
UNPROTECT(5);
return r;
}
static void store(SEXP buf, SEXP what, R_xlen_t i) {
char stbuf[128];
switch (TYPEOF(what)) {
case LGLSXP:
{
int v;
if ((v = INTEGER(what)[i]) == NA_INTEGER)
dybuf_add(buf, "NA", 2);
else
dybuf_add1(buf, v ? 'T' : 'F');
break;
}
case INTSXP:
{
int v;
if ((v = INTEGER(what)[i]) == NA_INTEGER)
dybuf_add(buf, "NA", 2);
else {
v = snprintf(stbuf, sizeof(stbuf), "%d", INTEGER(what)[i]);
dybuf_add(buf, stbuf, v);
}
break;
}
case REALSXP:
{
double v;
if (ISNA((v = REAL(what)[i])))
dybuf_add(buf, "NA", 2);
else {
int n = snprintf(stbuf, sizeof(stbuf), "%.15g", v);
dybuf_add(buf, stbuf, n);
}
break;
}
case CPLXSXP:
{
double v;
if (ISNA((v = COMPLEX(what)[i].r)))
dybuf_add(buf, "NA", 2);
else {
int n = snprintf(stbuf, sizeof(stbuf), "%.15g%+.15gi",
v, COMPLEX(what)[i].i);
dybuf_add(buf, stbuf, n);
}
break;
}
case STRSXP:
{
/* FIXME: should we supply an option how to represent NA strings? */
if (STRING_ELT(what, i) == R_NaString)
dybuf_add(buf, "NA", 2);
else {
/* FIXME: should we use a defined encoding? */
const char *c = CHAR(STRING_ELT(what, i));
dybuf_add(buf, c, strlen(c));
}
break;
}
case RAWSXP:
{
int n = snprintf(stbuf, sizeof(stbuf), "%02x", RAW(what)[i]);
dybuf_add(buf, stbuf, n);
break;
}
}
}
SEXP attribute_hidden do_cum(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, t, ans;
R_xlen_t i, n;
checkArity(op, args);
if (DispatchGroup("Math", call, op, args, env, &ans))
return ans;
if (isComplex(CAR(args))) {
t = CAR(args);
n = XLENGTH(t);
PROTECT(s = allocVector(CPLXSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
UNPROTECT(1);
if(n == 0) return s;
for (i = 0 ; i < n ; i++) {
COMPLEX(s)[i].r = NA_REAL;
COMPLEX(s)[i].i = NA_REAL;
}
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return ccumsum(t, s);
break;
case 2: /* cumprod */
return ccumprod(t, s);
break;
case 3: /* cummax */
errorcall(call, _("'cummax' not defined for complex numbers"));
break;
case 4: /* cummin */
errorcall(call, _("'cummin' not defined for complex numbers"));
break;
default:
errorcall(call, "unknown cumxxx function");
}
} else if( ( isInteger(CAR(args)) || isLogical(CAR(args)) ) &&
PRIMVAL(op) != 2) {
PROTECT(t = coerceVector(CAR(args), INTSXP));
n = XLENGTH(t);
PROTECT(s = allocVector(INTSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
if(n == 0) {
UNPROTECT(2); /* t, s */
return s;
}
for(i = 0 ; i < n ; i++) INTEGER(s)[i] = NA_INTEGER;
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
ans = icumsum(t,s);
break;
case 3: /* cummax */
ans = icummax(t,s);
break;
case 4: /* cummin */
ans = icummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
ans = R_NilValue;
}
UNPROTECT(2); /* t, s */
return ans;
} else {
PROTECT(t = coerceVector(CAR(args), REALSXP));
n = XLENGTH(t);
PROTECT(s = allocVector(REALSXP, n));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
UNPROTECT(2);
if(n == 0) return s;
for(i = 0 ; i < n ; i++) REAL(s)[i] = NA_REAL;
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return cumsum(t,s);
break;
case 2: /* cumprod */
return cumprod(t,s);
break;
case 3: /* cummax */
return cummax(t,s);
break;
case 4: /* cummin */
return cummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
return R_NilValue; /* for -Wall */
}
SEXP zoo_lag (SEXP x, SEXP _k, SEXP _pad)
{
#ifdef ZOO_DEBUG
Rprintf("zoo_lag\n");
#endif
SEXP result;
int i,j;
double *result_real=NULL;
int *result_int=NULL;
int k=INTEGER(_k)[0] * -1; /* -1 is zoo convention */
int k_positive = (k > 0) ? 1 : 0;
int nr = nrows(x);
int nc = ncols(x);
int P=0;
int PAD = INTEGER(coerceVector(_pad,INTSXP))[0];
if(k > nr)
error("abs(k) must be less than nrow(x)");
if(k < 0 && -1*k > nr)
error("abs(k) must be less than nrow(x)");
PROTECT(result = allocVector(TYPEOF(x),
length(x) - (PAD ? 0 : abs(k)*nc))); P++;
int nrr;
if(length(result) > 0)
nrr = (int)(length(result)/nc);
else /* handle zero-length objects */
nrr = nr - (PAD ? 0 : abs(k));
if(k_positive) {
switch(TYPEOF(x)) {
case REALSXP:
result_real = REAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_real[i+(j*nrr)] = NA_REAL;
memcpy(&REAL(result)[k+(j*nrr)],
&REAL(x)[(j*nrr)],
(nrr-k) * sizeof(double));
} else {
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[(j*nr)], /* original data need the original 'nr' offset */
nrr * sizeof(double));
}
}
break;
case INTSXP:
result_int = INTEGER(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&INTEGER(result)[k+(j*nrr)],
&INTEGER(x)[(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[(j*nr)],
nrr * sizeof(int));
}
}
break;
case LGLSXP:
result_int = LOGICAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&LOGICAL(result)[k+(j*nrr)],
&LOGICAL(x)[(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[(j*nr)],
nrr * sizeof(int));
}
}
break;
case CPLXSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++) {
COMPLEX(result)[i+(j*nrr)].r = NA_REAL;
COMPLEX(result)[i+(j*nrr)].i = NA_REAL;
}
memcpy(&COMPLEX(result)[k+(j*nrr)],
&COMPLEX(x)[(j*nrr)],
(nrr-k) * sizeof(Rcomplex));
} else {
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[(j*nr)],
nrr * sizeof(Rcomplex));
}
}
break;
case RAWSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
RAW(result)[i+(j*nrr)] = (Rbyte) 0;
memcpy(&RAW(result)[k+(j*nrr)],
&RAW(x)[(j*nrr)],
(nrr-k) * sizeof(Rbyte));
} else {
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[(j*nr)],
nrr * sizeof(Rbyte));
}
}
break;
case STRSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = 0; i < k; i++)
SET_STRING_ELT(result, i+(j*nrr), NA_STRING);
for(i = 0; i < nrr-k; i++)
SET_STRING_ELT(result, k+i+j*nrr, STRING_ELT(x, i+j*nrr));
} else {
for(i = 0; i < nrr; i++)
SET_STRING_ELT(result, i+j*nrr, STRING_ELT(x, i+j*nr));
}
}
break;
default:
error("unsupported type");
break;
}
} else
if(!k_positive) {
k = abs(k);
switch(TYPEOF(x)) {
case REALSXP:
result_real = REAL(result);
for(j =0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_real[i+(j*nrr)] = NA_REAL;
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[k+(j*nrr)],
(nrr-k) * sizeof(double));
} else {
memcpy(&REAL(result)[(j*nrr)],
&REAL(x)[k+(j*nr)],
nrr * sizeof(double));
}
}
break;
case INTSXP:
result_int = INTEGER(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[k+(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&INTEGER(result)[(j*nrr)],
&INTEGER(x)[k+(j*nr)],
nrr * sizeof(int));
}
}
break;
case LGLSXP:
result_int = LOGICAL(result);
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
result_int[i+(j*nrr)] = NA_INTEGER;
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[k+(j*nrr)],
(nrr-k) * sizeof(int));
} else {
memcpy(&LOGICAL(result)[(j*nrr)],
&LOGICAL(x)[k+(j*nr)],
nrr * sizeof(int));
}
}
break;
case CPLXSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++) {
COMPLEX(result)[i+(j*nrr)].r = NA_REAL;
COMPLEX(result)[i+(j*nrr)].i = NA_REAL;
}
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[k+(j*nrr)],
(nrr-k) * sizeof(Rcomplex));
} else {
memcpy(&COMPLEX(result)[(j*nrr)],
&COMPLEX(x)[k+(j*nr)],
nrr * sizeof(Rcomplex));
}
}
break;
case RAWSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
RAW(result)[i+(j*nrr)] = (Rbyte) 0;
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[k+(j*nrr)],
(nrr-k) * sizeof(Rbyte));
} else {
memcpy(&RAW(result)[(j*nrr)],
&RAW(x)[k+(j*nr)],
nrr * sizeof(Rbyte));
}
}
break;
case STRSXP:
for(j = 0; j < nc; j++) {
if(PAD) {
for(i = nr-k; i < nr; i++)
SET_STRING_ELT(result, i+(j*nrr), NA_STRING);
for(i = 0; i < nrr-k; i++)
SET_STRING_ELT(result, i+(j*nrr), STRING_ELT(x, k+i+(j*nrr)));
} else {
for(i = 0; i < nr-k; i++)
SET_STRING_ELT(result, i+(j*nrr), STRING_ELT(x, k+i+(j*nr)));
}
}
break;
default:
error("unsupported type");
break;
}
}
copyMostAttrib(x,result);
if(!PAD) {
// likely unneeded as copyMostAttrib will cover
// setAttrib(result, install("index"), getAttrib(x, install("index")));
//} else {
SEXP index, newindex;
PROTECT(index = getAttrib(x, install("index"))); P++;
if(IS_S4_OBJECT(index)) {
/* should make this
1) generic for any S4 object if possible
2) test for timeDate as this is important
*/
if(STRING_ELT(getAttrib(index, R_ClassSymbol),0)!=mkChar("timeDate"))
error("'S4' objects must be of class 'timeDate'");
index = GET_SLOT(index, install("Data"));
}
PROTECT(newindex = allocVector(TYPEOF(index), nrr)); P++;
switch(TYPEOF(index)) {
case REALSXP:
if(k_positive) {
memcpy(REAL(newindex), &REAL(index)[k], nrr * sizeof(double));
} else {
memcpy(REAL(newindex), REAL(index), nrr * sizeof(double));
}
break;
case INTSXP:
if(k_positive) {
memcpy(INTEGER(newindex), &INTEGER(index)[k], nrr * sizeof(int));
} else {
memcpy(INTEGER(newindex), INTEGER(index), nrr * sizeof(int));
}
break;
default:
break;
}
if(IS_S4_OBJECT(getAttrib(x, install("index")))) {
/* need to assure that this is timeDate */
SEXP tmp = PROTECT(getAttrib(x, install("index"))); P++;
SEXP class = PROTECT(MAKE_CLASS("timeDate")); P++;
SEXP timeDate = PROTECT(NEW_OBJECT(class)); P++;
copyMostAttrib(index,newindex);
SET_SLOT(timeDate,install("Data"),newindex);
SEXP format = PROTECT(GET_SLOT(tmp, install("format"))); P++;
SET_SLOT(timeDate,install("format"), format);
SEXP finCenter = PROTECT(GET_SLOT(tmp, install("FinCenter"))); P++;
SET_SLOT(timeDate,install("FinCenter"), finCenter);
setAttrib(result, install("index"), timeDate);
} else {
static bool _convert(CVECTOR *_object, GB_TYPE type, GB_VALUE *conv)
{
if (THIS)
{
if (!COMPLEX(THIS))
{
switch (type)
{
case GB_T_FLOAT:
conv->_float.value = gsl_blas_dnrm2(VEC(THIS));
return FALSE;
case GB_T_SINGLE:
conv->_single.value = gsl_blas_dnrm2(VEC(THIS));
return FALSE;
case GB_T_INTEGER:
case GB_T_SHORT:
case GB_T_BYTE:
conv->_integer.value = gsl_blas_dnrm2(VEC(THIS));
return FALSE;
case GB_T_LONG:
conv->_long.value = gsl_blas_dnrm2(VEC(THIS));
return FALSE;
case GB_T_STRING:
case GB_T_CSTRING:
conv->_string.value.addr = _to_string(THIS, type == GB_T_CSTRING);
conv->_string.value.start = 0;
conv->_string.value.len = GB.StringLength(conv->_string.value.addr);
return FALSE;
default:
break;
}
}
else
{
switch (type)
{
case GB_T_FLOAT:
conv->_float.value = gsl_blas_dznrm2(CVEC(THIS));
return FALSE;
case GB_T_SINGLE:
conv->_single.value = gsl_blas_dznrm2(CVEC(THIS));
return FALSE;
case GB_T_INTEGER:
case GB_T_SHORT:
case GB_T_BYTE:
conv->_integer.value = gsl_blas_dznrm2(CVEC(THIS));
return FALSE;
case GB_T_LONG:
conv->_long.value = gsl_blas_dznrm2(CVEC(THIS));
return FALSE;
case GB_T_STRING:
case GB_T_CSTRING:
conv->_string.value.addr = _to_string(THIS, type == GB_T_CSTRING);
conv->_string.value.start = 0;
conv->_string.value.len = GB.StringLength(conv->_string.value.addr);
return FALSE;
default:
break;
}
}
// Vector ---> Float[]
if ((type == GB.FindClass("Float[]") || type == CLASS_Polynomial) && !COMPLEX(THIS))
{
GB_ARRAY a;
int i;
double *data;
GB.Array.New(&a, GB_T_FLOAT, SIZE(THIS));
data = (double *)GB.Array.Get(a, 0);
for(i = 0; i < SIZE(THIS); i++)
data[i] = gsl_vector_get(VEC(THIS), i);
conv->_object.value = a;
if (type != CLASS_Polynomial)
return FALSE;
}
// Vector ---> Complex[]
else if (type == GB.FindClass("Complex[]") || type == CLASS_Polynomial)
{
GB_ARRAY a;
int i;
void **data;
CCOMPLEX *c;
GB.Array.New(&a, CLASS_Complex, SIZE(THIS));
data = (void **)GB.Array.Get(a, 0);
for(i = 0; i < SIZE(THIS); i++)
{
c = COMPLEX_create(COMPLEX(THIS) ? gsl_vector_complex_get(CVEC(THIS), i) : gsl_complex_rect(gsl_vector_get(VEC(THIS), i), 0));
data[i] = c;
GB.Ref(c);
}
conv->_object.value = a;
if (type != CLASS_Polynomial)
return FALSE;
}
else
return TRUE;
// Vector ---> Polynomial
if (type == CLASS_Polynomial)
{
void *unref = conv->_object.value;
GB.Ref(unref); // Will be unref by the next GB.Conv()
POLYNOMIAL_convert(FALSE, type, conv);
GB.Unref(&unref); // Will be unref by the next GB.Conv()
//GB.Conv(conv, type);
//GB.UnrefKeep(&conv->_object.value, FALSE); // Will be ref again after the current GB.Conv()
return FALSE;
}
}
else if (type >= GB_T_OBJECT)
{
if (GB.Is(conv->_object.value, CLASS_Array))
{
GB_ARRAY array = (GB_ARRAY)conv->_object.value;
int size = GB.Array.Count(array);
CVECTOR *v;
int i;
GB_VALUE temp;
void *data;
GB_TYPE atype = GB.Array.Type(array);
// Float[] Integer[] ... ---> Vector
if (atype > GB_T_BOOLEAN && atype <= GB_T_FLOAT)
{
v = VECTOR_create(size, FALSE, FALSE);
for (i = 0; i < size; i++)
{
data = GB.Array.Get(array, i);
GB.ReadValue(&temp, data, atype);
GB.Conv(&temp, GB_T_FLOAT);
gsl_vector_set(VEC(v), i, temp._float.value);
}
conv->_object.value = v;
return FALSE;
}
// Variant[] ---> Vector
else if (atype == GB_T_VARIANT)
{
CCOMPLEX *c;
v = VECTOR_create(size, TRUE, FALSE);
for (i = 0; i < size; i++)
{
GB.ReadValue(&temp, GB.Array.Get(array, i), atype);
GB.BorrowValue(&temp);
GB.Conv(&temp, CLASS_Complex);
c = temp._object.value;
if (c)
gsl_vector_complex_set(CVEC(v), i, c->number);
else
gsl_vector_complex_set(CVEC(v), i, COMPLEX_zero);
GB.ReleaseValue(&temp);
}
conv->_object.value = v;
return FALSE;
}
// Complex[] ---> Vector
else if (atype == CLASS_Complex)
{
CCOMPLEX *c;
v = VECTOR_create(size, TRUE, FALSE);
for (i = 0; i < size; i++)
{
c = *((CCOMPLEX **)GB.Array.Get(array, i));
if (c)
gsl_vector_complex_set(CVEC(v), i, c->number);
else
gsl_vector_complex_set(CVEC(v), i, COMPLEX_zero);
}
conv->_object.value = v;
return FALSE;
}
}
// Float Integer... ---> Vector
else if (type > GB_T_BOOLEAN && type <= GB_T_FLOAT)
{
CVECTOR *v = VECTOR_create(1, FALSE, FALSE);
if (type == GB_T_FLOAT)
gsl_vector_set(VEC(v), 0, conv->_float.value);
else if (type == GB_T_SINGLE)
gsl_vector_set(VEC(v), 0, conv->_single.value);
else
gsl_vector_set(VEC(v), 0, conv->_integer.value);
conv->_object.value = v;
return FALSE;
}
// Complex ---> Vector
else if (type == CLASS_Complex)
{
CCOMPLEX *c = (CCOMPLEX *)conv->_object.value;
CVECTOR *v = VECTOR_create(1, TRUE, FALSE);
gsl_vector_complex_set(CVEC(v), 0, c->number);
conv->_object.value = v;
return FALSE;
}
}
return TRUE;
}
/* rep.int(x, times) for a vector times */
static SEXP rep2(SEXP s, SEXP ncopy)
{
R_xlen_t i, na, nc, n;
int j;
SEXP a, t;
PROTECT(t = coerceVector(ncopy, INTSXP));
nc = xlength(ncopy);
na = 0;
for (i = 0; i < nc; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i] < 0)
error(_("invalid '%s' value"), "times");
na += INTEGER(t)[i];
}
/* R_xlen_t ni = NINTERRUPT, ratio;
if(nc > 0) {
ratio = na/nc; // average no of replications
if (ratio > 1000U) ni = 1000U;
} */
PROTECT(a = allocVector(TYPEOF(s), na));
n = 0;
switch (TYPEOF(s)) {
case LGLSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
LOGICAL(a)[n++] = LOGICAL(s)[i];
}
break;
case INTSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
INTEGER(a)[n++] = INTEGER(s)[i];
}
break;
case REALSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
REAL(a)[n++] = REAL(s)[i];
}
break;
case CPLXSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
COMPLEX(a)[n++] = COMPLEX(s)[i];
}
break;
case STRSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
SET_STRING_ELT(a, n++, STRING_ELT(s, i));
}
break;
case VECSXP:
case EXPRSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
SEXP elt = lazy_duplicate(VECTOR_ELT(s, i));
for (j = 0; j < INTEGER(t)[i]; j++)
SET_VECTOR_ELT(a, n++, elt);
if (j > 1) SET_NAMED(elt, 2);
}
break;
case RAWSXP:
for (i = 0; i < nc; i++) {
// if ((i+1) % ni == 0) R_CheckUserInterrupt();
for (j = 0; j < INTEGER(t)[i]; j++)
RAW(a)[n++] = RAW(s)[i];
}
break;
default:
UNIMPLEMENTED_TYPE("rep2", s);
}
UNPROTECT(2);
return a;
}
static SEXP lunary(SEXP call, SEXP op, SEXP arg)
{
SEXP x, dim, dimnames, names;
R_xlen_t i, len;
len = XLENGTH(arg);
if (!isLogical(arg) && !isNumber(arg) && !isRaw(arg)) {
/* For back-compatibility */
if (!len) return allocVector(LGLSXP, 0);
errorcall(call, _("invalid argument type"));
}
if (isLogical(arg) || isRaw(arg))
x = PROTECT(duplicate(arg)); // copy all attributes in this case
else {
x = PROTECT(allocVector(isRaw(arg) ? RAWSXP : LGLSXP, len));
PROTECT(names = getAttrib(arg, R_NamesSymbol));
PROTECT(dim = getAttrib(arg, R_DimSymbol));
PROTECT(dimnames = getAttrib(arg, R_DimNamesSymbol));
if(names != R_NilValue) setAttrib(x, R_NamesSymbol, names);
if(dim != R_NilValue) setAttrib(x, R_DimSymbol, dim);
if(dimnames != R_NilValue) setAttrib(x, R_DimNamesSymbol, dimnames);
UNPROTECT(3);
}
switch(TYPEOF(arg)) {
case LGLSXP:
for (i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(x)[i] = (LOGICAL(arg)[i] == NA_LOGICAL) ?
NA_LOGICAL : LOGICAL(arg)[i] == 0;
}
break;
case INTSXP:
for (i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(x)[i] = (INTEGER(arg)[i] == NA_INTEGER) ?
NA_LOGICAL : INTEGER(arg)[i] == 0;
}
break;
case REALSXP:
for (i = 0; i < len; i++){
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(x)[i] = ISNAN(REAL(arg)[i]) ?
NA_LOGICAL : REAL(arg)[i] == 0;
}
break;
case CPLXSXP:
for (i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(x)[i] = (ISNAN(COMPLEX(arg)[i].r) || ISNAN(COMPLEX(arg)[i].i))
? NA_LOGICAL : (COMPLEX(arg)[i].r == 0. && COMPLEX(arg)[i].i == 0.);
}
break;
case RAWSXP:
for (i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
RAW(x)[i] = 0xFF ^ RAW(arg)[i];
}
break;
default:
UNIMPLEMENTED_TYPE("lunary", arg);
}
UNPROTECT(1);
return x;
}
/* rep(), allowing for both times and each */
static SEXP rep4(SEXP x, SEXP times, R_xlen_t len, int each, R_xlen_t nt)
{
SEXP a;
R_xlen_t lx = xlength(x);
R_xlen_t i, j, k, k2, k3, sum;
// faster code for common special case
if (each == 1 && nt == 1) return rep3(x, lx, len);
PROTECT(a = allocVector(TYPEOF(x), len));
switch (TYPEOF(x)) {
case LGLSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
LOGICAL(a)[i] = LOGICAL(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
LOGICAL(a)[k2++] = LOGICAL(x)[i];
if(k2 == len) goto done;
}
}
}
break;
case INTSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(a)[i] = INTEGER(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
INTEGER(a)[k2++] = INTEGER(x)[i];
if(k2 == len) goto done;
}
}
}
break;
case REALSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(a)[i] = REAL(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
REAL(a)[k2++] = REAL(x)[i];
if(k2 == len) goto done;
}
}
}
break;
case CPLXSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
COMPLEX(a)[i] = COMPLEX(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
COMPLEX(a)[k2++] = COMPLEX(x)[i];
if(k2 == len) goto done;
}
}
}
break;
case STRSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_STRING_ELT(a, i, STRING_ELT(x, (i/each) % lx));
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
SET_STRING_ELT(a, k2++, STRING_ELT(x, i));
if(k2 == len) goto done;
}
}
}
break;
case VECSXP:
case EXPRSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
SET_VECTOR_ELT(a, i, VECTOR_ELT(x, (i/each) % lx));
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
SET_VECTOR_ELT(a, k2++, VECTOR_ELT(x, i));
if(k2 == len) goto done;
}
}
}
break;
case RAWSXP:
if(nt == 1)
for(i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
RAW(a)[i] = RAW(x)[(i/each) % lx];
}
else {
for(i = 0, k = 0, k2 = 0; i < lx; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
for(k3 = 0; k3 < sum; k3++) {
RAW(a)[k2++] = RAW(x)[i];
if(k2 == len) goto done;
}
}
}
break;
default:
UNIMPLEMENTED_TYPE("rep4", x);
}
done:
UNPROTECT(1);
return a;
}
SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop) //SEXP s, SEXP call, int drop)
{
SEXP attr, result, dim;
int nr, nc, nrs, ncs;
int i, j, ii, jj, ij, iijj;
int mode;
int *int_x=NULL, *int_result=NULL, *int_newindex=NULL, *int_index=NULL;
double *real_x=NULL, *real_result=NULL, *real_newindex=NULL, *real_index=NULL;
nr = nrows(x);
nc = ncols(x);
if( length(x)==0 )
return x;
dim = getAttrib(x, R_DimSymbol);
nrs = LENGTH(sr);
ncs = LENGTH(sc);
int *int_sr=NULL, *int_sc=NULL;
int_sr = INTEGER(sr);
int_sc = INTEGER(sc);
mode = TYPEOF(x);
result = allocVector(mode, nrs*ncs);
PROTECT(result);
if( mode==INTSXP ) {
int_x = INTEGER(x);
int_result = INTEGER(result);
} else
if( mode==REALSXP ) {
real_x = REAL(x);
real_result = REAL(result);
}
/* code to handle index of xts object efficiently */
SEXP index, newindex;
int indx;
index = getAttrib(x, install("index"));
PROTECT(index);
if(TYPEOF(index) == INTSXP) {
newindex = allocVector(INTSXP, LENGTH(sr));
PROTECT(newindex);
int_newindex = INTEGER(newindex);
int_index = INTEGER(index);
for(indx = 0; indx < nrs; indx++) {
int_newindex[indx] = int_index[ (int_sr[indx])-1];
}
copyAttributes(index, newindex);
setAttrib(result, install("index"), newindex);
UNPROTECT(1);
}
if(TYPEOF(index) == REALSXP) {
newindex = allocVector(REALSXP, LENGTH(sr));
PROTECT(newindex);
real_newindex = REAL(newindex);
real_index = REAL(index);
for(indx = 0; indx < nrs; indx++) {
real_newindex[indx] = real_index[ (int_sr[indx])-1 ];
}
copyAttributes(index, newindex);
setAttrib(result, install("index"), newindex);
UNPROTECT(1);
}
for (i = 0; i < nrs; i++) {
ii = int_sr[i];
if (ii != NA_INTEGER) {
if (ii < 1 || ii > nr)
error("i is out of range\n");
ii--;
}
/* Begin column loop */
for (j = 0; j < ncs; j++) {
//jj = INTEGER(sc)[j];
jj = int_sc[j];
if (jj != NA_INTEGER) {
if (jj < 1 || jj > nc)
error("j is out of range\n");
jj--;
}
ij = i + j * nrs;
if (ii == NA_INTEGER || jj == NA_INTEGER) {
switch ( mode ) {
case REALSXP:
real_result[ij] = NA_REAL;
break;
case LGLSXP:
case INTSXP:
int_result[ij] = NA_INTEGER;
break;
case CPLXSXP:
COMPLEX(result)[ij].r = NA_REAL;
COMPLEX(result)[ij].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(result, ij, NA_STRING);
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, R_NilValue);
break;
case RAWSXP:
RAW(result)[ij] = (Rbyte) 0;
break;
default:
error("xts subscripting not handled for this type");
break;
}
}
else {
iijj = ii + jj * nr;
switch ( mode ) {
case REALSXP:
real_result[ij] = real_x[iijj];
break;
case LGLSXP:
LOGICAL(result)[ij] = LOGICAL(x)[iijj];
break;
case INTSXP:
int_result[ij] = int_x[iijj];
break;
case CPLXSXP:
COMPLEX(result)[ij] = COMPLEX(x)[iijj];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj));
break;
case RAWSXP:
RAW(result)[ij] = RAW(x)[iijj];
break;
default:
error("matrix subscripting not handled for this type");
break;
}
}
} /* end of column loop */
} /* end of row loop */
if(nrs >= 0 && ncs >= 0 && !isNull(dim)) {
PROTECT(attr = allocVector(INTSXP, 2));
INTEGER(attr)[0] = nrs;
INTEGER(attr)[1] = ncs;
setAttrib(result, R_DimSymbol, attr);
UNPROTECT(1);
}
/* The matrix elements have been transferred. Now we need to */
/* transfer the attributes. Most importantly, we need to subset */
/* the dimnames of the returned value. */
if (nrs >= 0 && ncs >= 0 && !isNull(dim)) {
SEXP dimnames, dimnamesnames, newdimnames;
dimnames = getAttrib(x, R_DimNamesSymbol);
dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
if (!isNull(dimnames)) {
PROTECT(newdimnames = allocVector(VECSXP, 2));
if (TYPEOF(dimnames) == VECSXP) {
SET_VECTOR_ELT(newdimnames, 0,
xtsExtractSubset(VECTOR_ELT(dimnames, 0),
allocVector(STRSXP, nrs), sr));
SET_VECTOR_ELT(newdimnames, 1,
xtsExtractSubset(VECTOR_ELT(dimnames, 1),
allocVector(STRSXP, ncs), sc));
}
else {
SET_VECTOR_ELT(newdimnames, 0,
xtsExtractSubset(CAR(dimnames),
allocVector(STRSXP, nrs), sr));
SET_VECTOR_ELT(newdimnames, 1,
xtsExtractSubset(CADR(dimnames),
allocVector(STRSXP, ncs), sc));
}
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, newdimnames);
UNPROTECT(1);
}
}
copyAttributes(x, result);
if(ncs == 1 && LOGICAL(drop)[0])
setAttrib(result, R_DimSymbol, R_NilValue);
UNPROTECT(2);
return result;
}
SEXP df_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
SEXP sWhat, SEXP sColNames, SEXP sSkip, SEXP sNlines, SEXP sQuote) {
char sep;
int nsep, use_ncol, resilient, ncol;
long i, j, k, m, len, nmsep_flag, skip, quoteLen;
unsigned long nrow;
char num_buf[48];
const char *c, *c2, *sraw = 0, *send = 0, *quoteChars;
long nlines = asLong(sNlines, -1);
SEXP sOutput, tmp, sOutputNames, st, clv;
/* Parse inputs */
sep = CHAR(STRING_ELT(sSep, 0))[0];
nsep = (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0) ? ((int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0))) : -1;
nmsep_flag = (nsep > 0);
use_ncol = asInteger(sNcol);
resilient = asInteger(sResilient);
ncol = use_ncol; /* NOTE: "character" is prepended by the R code if nmsep is TRUE,
so ncol *does* include the key column */
skip = asLong(sSkip, 0);
/* parse quote information */
quoteChars = CHAR(STRING_ELT(sQuote, 0));
quoteLen = strlen(quoteChars);
/* count non-NA columns */
for (i = 0; i < use_ncol; i++)
if (TYPEOF(VECTOR_ELT(sWhat,i)) == NILSXP) ncol--;
/* check input */
if (TYPEOF(s) == RAWSXP) {
nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s);
sraw = (const char*) RAW(s);
send = sraw + XLENGTH(s);
if (nrow >= skip) {
unsigned long slen = XLENGTH(s);
nrow = nrow - skip;
i = 0;
while (i < skip && (sraw = memchr(sraw, '\n', slen))) { sraw++; i++; }
} else {
nrow = 0;
sraw = send;
}
} else if (TYPEOF(s) == STRSXP) {
nrow = XLENGTH(s);
if (nrow >= skip) {
nrow -= skip;
} else {
skip = nrow;
nrow = 0;
}
} else
Rf_error("invalid input to split - must be a raw or character vector");
if (nlines >= 0 && nrow > nlines) nrow = nlines;
/* allocate result */
PROTECT(sOutput = allocVector(VECSXP, ncol));
/* set names */
setAttrib(sOutput, R_NamesSymbol, sOutputNames = allocVector(STRSXP, ncol));
if (nrow > INT_MAX)
Rf_warning("R currently doesn't support large data frames, but we have %lu rows, returning a named list instead", nrow);
else {
/* set automatic row names */
PROTECT(tmp = allocVector(INTSXP, 2));
INTEGER(tmp)[0] = NA_INTEGER;
INTEGER(tmp)[1] = -nrow;
setAttrib(sOutput, R_RowNamesSymbol, tmp);
UNPROTECT(1);
/* set class */
classgets(sOutput, mkString("data.frame"));
}
/* Create SEXP for each element of the output */
j = 0;
for (i = 0; i < use_ncol; i++) {
if (TYPEOF(VECTOR_ELT(sWhat,i)) != NILSXP) /* copy col.name */
SET_STRING_ELT(sOutputNames, j, STRING_ELT(sColNames, i));
switch (TYPEOF(VECTOR_ELT(sWhat,i))) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
SET_VECTOR_ELT(sOutput, j++, allocVector(TYPEOF(VECTOR_ELT(sWhat,i)), nrow));
break;
case VECSXP:
SET_VECTOR_ELT(sOutput, j++, st = allocVector(REALSXP, nrow));
clv = PROTECT(allocVector(STRSXP, 2));
SET_STRING_ELT(clv, 0, mkChar("POSIXct"));
SET_STRING_ELT(clv, 1, mkChar("POSIXt"));
setAttrib(st, R_ClassSymbol, clv);
/* this is somewhat a security precaution such that users
don't get surprised -- if there is no TZ R will
render it in local time - which is correct but
may confuse people that didn't use GMT to start with */
setAttrib(st, install("tzone"), mkString("GMT"));
UNPROTECT(1);
break;
case NILSXP:
break;
default:
Rf_error("Unsupported input to what %u.", TYPEOF(VECTOR_ELT(sWhat,i)));
break;
}
}
/* Cycle through the rows and extract the data */
for (k = 0; k < nrow; k++) {
const char *l = 0, *le;
if (TYPEOF(s) == RAWSXP) {
l = sraw;
le = memchr(l, '\n', send - l);
if (!le) le = send;
sraw = le + 1;
if (*(le - 1) == '\r' ) le--; /* account for DOS-style '\r\n' */
} else {
l = CHAR(STRING_ELT(s, k + skip));
le = l + strlen(l); /* probably lame, but using strings is way inefficient anyway ;) */
}
if (nmsep_flag) {
c = memchr(l, nsep, le - l);
if (c) {
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, Rf_mkCharLen(l, c - l));
l = c + 1;
} else
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, R_BlankString);
}
i = nmsep_flag;
j = nmsep_flag;
while (l < le) {
if (!(c = memchr(l, sep, le - l)))
c = le;
if (i >= use_ncol) {
if (resilient) break;
Rf_error("line %lu: too many input columns (expected %u)", k, use_ncol);
}
switch(TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
len = (int) (c - l);
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
int tr = StringTrue(num_buf), fa = StringFalse(num_buf);
LOGICAL(VECTOR_ELT(sOutput, j))[k] = (tr || fa) ? tr : NA_INTEGER;
j++;
break;
case INTSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
INTEGER(VECTOR_ELT(sOutput, j))[k] = Strtoi(num_buf, 10);
j++;
break;
case REALSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
REAL(VECTOR_ELT(sOutput, j))[k] = R_atof(num_buf);
j++;
break;
case CPLXSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
COMPLEX(VECTOR_ELT(sOutput, j))[k] = strtoc(num_buf, TRUE);
j++;
break;
case STRSXP:
c2 = c;
if (quoteLen) {
for (m = 0; m < quoteLen; m++) {
if (*l == quoteChars[m]) {
l++;
if (!(c2 = memchr(l, quoteChars[m], le - l))) {
Rf_error("End of line within quoted string.");
} else {
if (!(c = memchr(c2, (unsigned char) sep, le - c2)))
c = le;
}
}
}
}
SET_STRING_ELT(VECTOR_ELT(sOutput, j), k, Rf_mkCharLen(l, c2 - l));
j++;
break;
case RAWSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
RAW(VECTOR_ELT(sOutput, j))[k] = strtoraw(num_buf);
j++;
break;
case VECSXP:
REAL(VECTOR_ELT(sOutput, j))[k] = parse_ts(l, c);
j++;
}
l = c + 1;
i++;
}
/* fill-up unused columns */
while (i < use_ncol) {
switch (TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
LOGICAL(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
break;
case INTSXP:
INTEGER(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
break;
case REALSXP:
case VECSXP:
REAL(VECTOR_ELT(sOutput, j++))[k] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(VECTOR_ELT(sOutput, j))[k].r = NA_REAL;
COMPLEX(VECTOR_ELT(sOutput, j++))[k].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(VECTOR_ELT(sOutput, j++), k, R_NaString);
break;
case RAWSXP:
RAW(VECTOR_ELT(sOutput, j))[k] = (Rbyte) 0;
break;
}
i++;
}
}
UNPROTECT(1); /* sOutput */
return(sOutput);
}
// xtsExtractSubset {{{
static SEXP xtsExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call)
{
int i, ii, n, nx, mode;
SEXP tmp, tmp2;
mode = TYPEOF(x);
n = LENGTH(indx);
nx = length(x);
tmp = result;
if (x == R_NilValue)
return x;
for (i = 0; i < n; i++) {
ii = INTEGER(indx)[i];
if (ii != NA_INTEGER)
ii--;
switch (mode) {
case LGLSXP:
if (0 <= ii && ii < nx && ii != NA_LOGICAL)
LOGICAL(result)[i] = LOGICAL(x)[ii];
else
LOGICAL(result)[i] = NA_LOGICAL;
break;
case INTSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
INTEGER(result)[i] = INTEGER(x)[ii];
else
INTEGER(result)[i] = NA_INTEGER;
break;
case REALSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
REAL(result)[i] = REAL(x)[ii];
else
REAL(result)[i] = NA_REAL;
break;
case CPLXSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
COMPLEX(result)[i] = COMPLEX(x)[ii];
}
else {
COMPLEX(result)[i].r = NA_REAL;
COMPLEX(result)[i].i = NA_REAL;
}
break;
case STRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_STRING_ELT(result, i, STRING_ELT(x, ii));
else
SET_STRING_ELT(result, i, NA_STRING);
break;
case VECSXP:
case EXPRSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
else
SET_VECTOR_ELT(result, i, R_NilValue);
break;
case LISTSXP:
/* cannot happen: pairlists are coerced to lists */
case LANGSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER) {
tmp2 = nthcdr(x, ii);
SETCAR(tmp, CAR(tmp2));
SET_TAG(tmp, TAG(tmp2));
}
else
SETCAR(tmp, R_NilValue);
tmp = CDR(tmp);
break;
case RAWSXP:
if (0 <= ii && ii < nx && ii != NA_INTEGER)
RAW(result)[i] = RAW(x)[ii];
else
RAW(result)[i] = (Rbyte) 0;
break;
default:
error("error in subset\n");
// errorcall(call, R_MSG_ob_nonsub, type2char(mode));
break;
}
}
return result;
} //}}}
SEXP
RGDAL_PutRasterData(SEXP sxpRasterBand, SEXP sxpData, SEXP at) {
GDALRasterBand *pRasterBand = getGDALRasterPtr(sxpRasterBand);
int rowsIn = nrows(sxpData);
int colsIn = ncols(sxpData);
GDALDataType eGDALType = GDT_Int32;
switch(pRasterBand->GetRasterDataType()) {
case GDT_Byte:
case GDT_UInt16:
case GDT_Int16:
case GDT_UInt32:
case GDT_Int32:
eGDALType = GDAL_INTEGER_TYPE;
PROTECT(sxpData = coerceVector(sxpData, INTSXP));
// Transpose data
// replication for 2.4.0 RSB 20060726
if(pRasterBand->RasterIO(GF_Write,
INTEGER(at)[1] - 1,
INTEGER(at)[0] - 1,
rowsIn, colsIn,
(void *)INTEGER(sxpData),
rowsIn, colsIn,
eGDALType,
0, 0)
== CE_Failure)
error("Failure during raster IO\n");
break;
case GDT_Float32:
case GDT_Float64:
eGDALType = GDAL_FLOAT_TYPE;
PROTECT(sxpData = coerceVector(sxpData, REALSXP));
// Transpose data
if(pRasterBand->RasterIO(GF_Write,
INTEGER(at)[1] - 1,
INTEGER(at)[0] - 1,
rowsIn, colsIn,
(void *)REAL(sxpData),
rowsIn, colsIn,
eGDALType,
0, 0)
== CE_Failure)
error("Failure during raster IO\n");
break;
case GDT_CInt16:
case GDT_CInt32:
case GDT_CFloat32:
case GDT_CFloat64:
eGDALType = GDAL_COMPLEX_TYPE;
PROTECT(sxpData = coerceVector(sxpData, CPLXSXP));
// Transpose data
if(pRasterBand->RasterIO(GF_Write,
INTEGER(at)[1] - 1,
INTEGER(at)[0] - 1,
rowsIn, colsIn,
(void *)COMPLEX(sxpData),
rowsIn, colsIn,
eGDALType,
0, 0)
== CE_Failure)
error("Failure during raster IO\n");
break;
default:
error("Raster data type unknown\n");
break;
}
UNPROTECT(1);
return(sxpRasterBand);
}
/* NOTE: R vectors of length 1 will yield a python list of length 1*/
int
to_Pyobj_vector(SEXP robj, PyObject **obj, int mode)
{
PyObject *it, *tmp;
SEXP names, dim;
int len, *integers, i, type;
const char *strings, *thislevel;
double *reals;
Rcomplex *complexes;
#ifdef WITH_NUMERIC
PyObject *array;
#endif
if (!robj)
{
// return -1; /* error */
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "robj does not exist"));
// PyObject_CallObject(my_callback, argslist);
// }
return 1;
}
if (robj == R_NilValue) {
Py_INCREF(Py_None);
*obj = Py_None;
return 1; /* succeed */
}
len = GET_LENGTH(robj);
tmp = PyList_New(len);
type = TYPEOF(robj);
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(si)", "robj length is ", len));
// PyObject_CallObject(my_callback, argslist);
// }
/// break for checking the R length and other aspects
for (i=0; i<len; i++) {
switch (type)
{
case LGLSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In LGLSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
integers = INTEGER(robj);
if(integers[i]==NA_INTEGER) /* watch out for NA's */
{
if (!(it = PyInt_FromLong(integers[i])))
//return -1;
tmp = Py_BuildValue("s", "failed in the PyInt_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//it = Py_None;
}
else if (!(it = PyBool_FromLong(integers[i])))
{
tmp = Py_BuildValue("s", "failed in the PyBool_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//return -1;
}
break;
case INTSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In INTSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
integers = INTEGER(robj);
if(isFactor(robj)) {
/* Watch for NA's! */
if(integers[i]==NA_INTEGER)
it = PyString_FromString(CHAR(NA_STRING));
else
{
thislevel = CHAR(STRING_ELT(GET_LEVELS(robj), integers[i]-1));
if (!(it = PyString_FromString(thislevel)))
{
tmp = Py_BuildValue("s", "failed in the PyString_FromString"); // we are at least getting an robj
*obj = tmp;
return 1;
}
//return -1;
}
}
else {
if (!(it = PyInt_FromLong(integers[i])))
{
tmp = Py_BuildValue("s", "failed in the PyInt_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//return -1;
}
}
break;
case REALSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In REALSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
reals = REAL(robj);
if (!(it = PyFloat_FromDouble(reals[i])))
{
// tmp = Py_BuildValue("s", "failed in the PyFloat_FromDouble"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case CPLXSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In CPLXSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
complexes = COMPLEX(robj);
if (!(it = PyComplex_FromDoubles(complexes[i].r,
complexes[i].i)))
{
// tmp = Py_BuildValue("s", "failed in PyComplex_FromDoubles!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case STRSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In STRSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if(STRING_ELT(robj, i)==R_NaString)
it = PyString_FromString(CHAR(NA_STRING));
else
{
strings = CHAR(STRING_ELT(robj, i));
if (!(it = PyString_FromString(strings)))
{
// tmp = Py_BuildValue("s", "failed in PyString_FromString!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
}
break;
case LISTSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In LISTSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if (!(it = to_Pyobj_with_mode(elt(robj, i), mode)))
{
// tmp = Py_BuildValue("s", "failed in to_Pyobj_with_mode LISTSXP!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case VECSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In VECSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if (!(it = to_Pyobj_with_mode(VECTOR_ELT(robj, i), mode)))
{
return -1;
}
break;
default:
Py_DECREF(tmp);
return 0; /* failed */
}
if (PyList_SetItem(tmp, i, it) < 0) // there was a failure in setting the item
{
// tmp = Py_BuildValue("s", "failed in PyList_SetItem!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
}
dim = GET_DIM(robj);
if (dim != R_NilValue) {
// #ifdef WITH_NUMERIC
// if(use_numeric)
// {
// array = to_PyNumericArray(tmp, dim);
// if (array) { /* If the conversion to Numeric succeed.. */
// *obj = array; /* we are done */
// Py_DECREF(tmp);
// return 1;
// }
// PyErr_Clear();
// }
// #endif
len = GET_LENGTH(dim);
*obj = to_PyArray(tmp, INTEGER(dim), len);
Py_DECREF(tmp);
return 1;
}
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(O)", tmp));
// PyObject_CallObject(my_callback, argslist);
// }
names = GET_NAMES(robj);
if (names == R_NilValue)
{
*obj = tmp;
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "returning as list (of lists)"));
// PyObject_CallObject(my_callback, argslist);
// }
}
else {
*obj = to_PyDict(tmp, names);
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "returning as dict"));
// PyObject_CallObject(my_callback, argslist);
// }
Py_DECREF(tmp);
}
return 1;
}
}};
/*
* MPI_OP_SUM
*/
ompi_predefined_op_t ompi_mpi_op_sum = {{
OPAL_OBJ_STATIC_INIT(opal_object_t),
"MPI_SUM",
FLAGS_NO_FLOAT,
{ C_INTEGER(sum),
FORTRAN_INTEGER(sum),
FLOATING_POINT(sum),
LOGICAL_NULL,
COMPLEX(sum),
BYTE_NULL,
TWOLOC_NULL },
-1,
{ C_INTEGER_3BUFF(sum),
FORTRAN_INTEGER_3BUFF(sum),
FLOATING_POINT_3BUFF(sum),
LOGICAL_NULL_3BUFF,
COMPLEX_3BUFF(sum),
BYTE_NULL_3BUFF,
TWOLOC_NULL_3BUFF }
}};
/*
* MPI_OP_PROD
BOOL PtEmtFiles::LDWB(SHORT Mi, FLOAT Delta, FLOAT Larmat)
{
m_bGrayOK = FALSE;
COMPLEX pdif1[TotalDetectNum], pdif0[TotalDetectNum], NormP[TotalDetectNum];
for(SHORT i = 0 ; i < TotalElement; i++)
m_MGray[i] = 0;
for(i = 0 ; i < TotalDetectNum; i++)
pdif0[i] = pdif1[i] = NormP[i] = 0;
for(i =0; i < TotalDetectNum; i++)
{
for(SHORT j = 0; j < TotalDirNum; j++)
{
for(SHORT k = 0; k < DetectorNum; k++)
{
COMPLEX T1 = m_PscoEmp[m_FieldType][j][k];
COMPLEX T2 = m_PscoFul[m_FieldType][j][k];
NormP[i] = (m_PData[j][k]-T1) / (T2 - T1);
}
}
}
for(SHORT l = 1; l <= Mi; l++)
{
for(SHORT j=0 ; j < TotalDetectNum; j++)
{
COMPLEX sum = COMPLEX(0.0, 0.0);
for(i=0 ; i < InsideElement; i++)
sum += m_SData[m_FieldType][i][j] * m_MGray[i];
pdif1[j] = NormP[j] - sum; //better
}
FLOAT Qdif = 0;
for(j = 0; j < TotalDetectNum; j++)
{
FLOAT tt = abs(pdif1[j] - pdif0[j]);
tt = tt * tt;
Qdif += tt;
}
if(l >= Mi) {
break;
}
if(Qdif <= Delta * Delta) {
break;
}
for(j = 0; j < TotalDetectNum; j++)
pdif0[j] = pdif1[j];
for(i = 0; i < InsideElement; i++)
{
COMPLEX sum = COMPLEX(0.0, 0.0);
FLOAT sum1 = 0;
for(j = 0; j < TotalDetectNum; j++)
{
sum = sum + m_SData[m_FieldType][i][j] * pdif1[j];
sum1 += abs(m_SData[m_FieldType][i][j]);
}
m_MGray[i] += Larmat * real(sum)/sum1; //(4) similar with (1)
if(m_MGray[i] < 0) {
m_MGray[i] = 0.0;
} else if (m_MGray[i] > 1.0) {
m_MGray[i] = 1.0;
}
}
}
m_bGrayOK = TRUE;
return m_bGrayOK;
}
static void test_stfun(){
rand_t rstat;
int seed=4;
double r0=0.2;
double dx=1./16;
long N=32;
long nx=N;
long ny=N;
long nframe=500;
seed_rand(&rstat, seed);
if(L0<9000){
dmat *rr=dlinspace(0, N*dx, N);
dmat *covvk=turbcov(rr, sqrt(2)*N*dx, r0, L0);
writebin(covvk, "cov_vk");
dfree(rr);
dfree(covvk);
}
/* return; */
{
map_t *atm=mapnew(nx+1, ny+1, dx, dx,NULL);
stfun_t *data=stfun_init(nx, ny, NULL);
zfarr *save=zfarr_init(nframe, 1, "fractal_atm.bin");
for(long i=0; i<nframe; i++){
for(long j=0; j<(nx+1)*(ny+1); j++){
atm->p[j]=randn(&rstat);
}
fractal_do((dmat*)atm, dx, r0,L0,ninit);
stfun_push(data, (dmat*)atm);
zfarr_dmat(save, i, (dmat*)atm);
if(i%100==0)
info("%ld of %ld\n", i, nframe);
}
zfarr_close(save);
dmat *st=stfun_finalize(data);
writebin(st, "stfun_fractal.bin");
ddraw("fractal", st, NULL,NULL, "Atmosphere","x","y","stfun");
}
/*exit(0); */
{
stfun_t *data=stfun_init(nx, ny, NULL);
dmat *spect=turbpsd(nx, ny, dx, r0, 100, 0, 0.5);
cmat *atm=cnew(nx, ny);
//cfft2plan(atm, -1);
dmat *atmr=dnew(atm->nx, atm->ny);
dmat *atmi=dnew(atm->nx, atm->ny);
spect->p[0]=0;
for(long ii=0; ii<nframe; ii+=2){
for(long i=0; i<atm->nx*atm->ny; i++){
atm->p[i]=COMPLEX(randn(&rstat), randn(&rstat))*spect->p[i];
}
cfft2(atm, -1);
for(long i=0; i<atm->nx*atm->ny; i++){
atmr->p[i]=creal(atm->p[i]);
atmi->p[i]=cimag(atm->p[i]);
}
stfun_push(data, atmr);
stfun_push(data, atmi);
if(ii%100==0)
info("%ld of %ld\n", ii, nframe);
}
dmat *st=stfun_finalize(data);
writebin(st, "stfun_fft.bin");
ddraw("fft", st, NULL,NULL, "Atmosphere","x","y","stfun");
}
}
BOOL PtEmtFiles::MNR(SHORT Mi, FLOAT Delta, FLOAT Larmat)
{
m_bGrayOK = FALSE;
//////////////////////////////////////////////////////////////////////////
// COMPLEX pdif1[TotalDetectNum], pdif0[TotalDetectNum], NormP[TotalDetectNum];
float Delta_Gray[InsideElement];//hm add
COMPLEX Delta_P[TotalDetectNum], S_Multi_ST[InsideElement][InsideElement], S_Mul_ST_Inv[InsideElement][InsideElement]; //hm add
COMPLEX S_ST_Inv_S[InsideElement][TotalDetectNum];//hm add
for(SHORT i = 0 ; i < TotalElement; i++)
m_MGray[i] = 0;
// for(i = 0 ; i < TotalDetectNum; i++)
// pdif0[i] = pdif1[i] = NormP[i] = 0;
/* for(i =0; i < TotalDetectNum; i++)
{
for(SHORT j = 0; j < TotalDirNum; j++)
{
for(SHORT k = 0; k < DetectorNum; k++)
{
COMPLEX T1 = m_PscoEmp[m_FieldType][j][k];
COMPLEX T2 = m_PscoFul[m_FieldType][j][k];
NormP[i] = (m_PData[j][k]-T1) / (T2 - T1);
}
}
}*/
//hm add: to give initial value to Delta_P
for(i =0; i < TotalDetectNum; i++)
{
Delta_P[i] = m_PData[i];
}
for(SHORT l = 1; l <= Mi; l++)
{
FLOAT Qdif = 0;
for(SHORT j = 0; j < TotalDetectNum; j++)
{
FLOAT tt = abs(Delta_P[j]);
tt = tt * tt;
Qdif += tt;
}
if(l >= Mi) {
break;
}
if(Qdif <= Delta * Delta) {
break;
}
// for(j = 0; j < TotalDetectNum; j++)
// pdif0[j] = pdif1[j];
for(i = 0; i < InsideElement; i++)
{
for(j = 0; j < InsideElement; j++)
{
for(SHORT k=0; k < TotalDetectNum; k++)
{
S_Multi_ST[i][j] += m_SData[m_FieldType][i][k] * m_SData[j][k];
}
}
S_Multi_ST[i][i] += Larmat;
}//hm 求St*S+rI存于S_Multi_ST中, 1024*1024
//求上述矩阵的逆，可引用求逆过程，结果存于S_Mul_ST_Inv, 1024*1024
for()
{
}
//S_ST_Inv_S:1024*128
for(i = 0; i < InsideElement; i++)
{
for(j = 0; j < TotalDetectNum; j++)
{
for(k = 0; k < InsideElement; k++)
{
S_ST_Inv_S[i][j] += S_Mul_ST_Inv[i][k] * m_SData[m_FieldType][k][j];
}
}
}
//Delta_P:128*1
for(i =0; i < TotalDetectNum; i++)
{
COMPLEX temp = COMPLEX(0.0, 0.0);
for(k =0; k < InsideElement; k++)
{
temp += m_SData[m_FieldType][k][i] * m_MGray[k];
}
Delta_P[i] = temp - m_PData[i];
}
for(i = 0; i < InsideElement; i++)
{
for(j =0; j < TotalDetectNum; j++)
{
Delta_Gray[i] += - S_ST_Inv_S[i][j] * Delta_P[j];
}
m_MGray[i] += Delta_Gray[i];
}
if(m_MGray[i] < 0) {
m_MGray[i] = 0.0;
} else if (m_MGray[i] > 1.0) {
m_MGray[i] = 1.0;
}
}
//////////////////////////////////////////////////////////////////////////
m_bGrayOK = TRUE;
return m_bGrayOK;
}
/*
Compute cxx on atm to compare against L2, invpsd, fractal.
*/
static void test_cxx(){
rand_t rstat;
int seed=4;
double r0=0.2;
double dx=1./4;
long N=16;
long nx=N;
long ny=N;
long nframe=40960;
seed_rand(&rstat, seed);
{
dmat *cxx=dnew(N*N,N*N);
map_t *atm=mapnew(nx+1, ny+1, dx, dx,NULL);
for(long i=0; i<nframe; i++){
info("%ld of %ld\n", i, nframe);
for(long j=0; j<(nx+1)*(ny+1); j++){
atm->p[j]=randn(&rstat);
}
fractal_do((dmat*)atm, dx, r0, L0, ninit);
dmat *sec=dsub((dmat*)atm, 0, nx, 0, ny);
dmat *atmvec=dref_reshape(sec, nx*ny, 1);
dmm(&cxx,1, atmvec,atmvec,"nt",1);
dfree(atmvec);
dfree(sec);
}
dscale(cxx, 1./nframe);
writebin(cxx, "cxx_fractal");
dfree(cxx);
mapfree(atm);
}
{
dmat *cxx=dnew(N*N,N*N);
dmat *spect=turbpsd(nx, ny, dx, r0, 100, 0, 0.5);
spect->p[0]=spect->p[1];
cmat *atm=cnew(nx, ny);
//cfft2plan(atm, -1);
dmat *atmr=dnew(nx*ny,1);
dmat *atmi=dnew(nx*ny,1);
for(long ii=0; ii<nframe; ii+=2){
info("%ld of %ld\n", ii, nframe);
for(long i=0; i<atm->nx*atm->ny; i++){
atm->p[i]=COMPLEX(randn(&rstat), randn(&rstat))*spect->p[i];
}
cfft2(atm, -1);
for(long i=0; i<atm->nx*atm->ny; i++){
atmr->p[i]=creal(atm->p[i]);
atmi->p[i]=cimag(atm->p[i]);
}
dmm(&cxx,1, atmr,atmr,"nt",1);
dmm(&cxx,1, atmi,atmi,"nt",1);
}
dscale(cxx, 1./nframe);
writebin(cxx, "cxx_fft");
dfree(cxx);
dfree(atmr);
dfree(atmi);
cfree(atm);
}
loc_t *loc=mksqloc_auto(16,16,1./4,1./4);
locwrite(loc,"loc");
dmat *B=stfun_kolmogorov(loc, r0);
writebin(B, "B_theory");
}
SEXP typeconvert(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP cvec, a, dup, levs, dims, names, dec;
SEXP rval = R_NilValue; /* -Wall */
int i, j, len, asIs;
Rboolean done = FALSE;
char *endp;
const char *tmp = NULL;
LocalData data = {NULL, 0, 0, '.', NULL, NO_COMCHAR, 0, NULL, FALSE,
FALSE, 0, FALSE, FALSE};
Typecvt_Info typeInfo; /* keep track of possible types of cvec */
typeInfo.islogical = TRUE; /* we can't rule anything out initially */
typeInfo.isinteger = TRUE;
typeInfo.isreal = TRUE;
typeInfo.iscomplex = TRUE;
data.NAstrings = R_NilValue;
args = CDR(args);
if (!isString(CAR(args)))
error(_("the first argument must be of mode character"));
data.NAstrings = CADR(args);
if (TYPEOF(data.NAstrings) != STRSXP)
error(_("invalid '%s' argument"), "na.strings");
asIs = asLogical(CADDR(args));
if (asIs == NA_LOGICAL) asIs = 0;
dec = CADDDR(args);
if (isString(dec) || isNull(dec)) {
if (length(dec) == 0)
data.decchar = '.';
else
data.decchar = translateChar(STRING_ELT(dec, 0))[0];
}
cvec = CAR(args);
len = length(cvec);
/* save the dim/dimnames attributes */
PROTECT(dims = getAttrib(cvec, R_DimSymbol));
if (isArray(cvec))
PROTECT(names = getAttrib(cvec, R_DimNamesSymbol));
else
PROTECT(names = getAttrib(cvec, R_NamesSymbol));
/* Use the first non-NA to screen */
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (!(STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp)))
break;
}
if (i < len) { /* not all entries are NA */
ruleout_types(tmp, &typeInfo, &data);
}
if (typeInfo.islogical) {
PROTECT(rval = allocVector(LGLSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
LOGICAL(rval)[i] = NA_LOGICAL;
else {
if (strcmp(tmp, "F") == 0 || strcmp(tmp, "FALSE") == 0)
LOGICAL(rval)[i] = 0;
else if(strcmp(tmp, "T") == 0 || strcmp(tmp, "TRUE") == 0)
LOGICAL(rval)[i] = 1;
else {
typeInfo.islogical = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if (typeInfo.islogical) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.isinteger) {
PROTECT(rval = allocVector(INTSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
INTEGER(rval)[i] = NA_INTEGER;
else {
INTEGER(rval)[i] = Strtoi(tmp, 10);
if (INTEGER(rval)[i] == NA_INTEGER) {
typeInfo.isinteger = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.isinteger) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.isreal) {
PROTECT(rval = allocVector(REALSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
REAL(rval)[i] = NA_REAL;
else {
REAL(rval)[i] = Strtod(tmp, &endp, FALSE, &data);
if (!isBlankString(endp)) {
typeInfo.isreal = FALSE;
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.isreal) done = TRUE; else UNPROTECT(1);
}
if (!done && typeInfo.iscomplex) {
PROTECT(rval = allocVector(CPLXSXP, len));
for (i = 0; i < len; i++) {
tmp = CHAR(STRING_ELT(cvec, i));
if (STRING_ELT(cvec, i) == NA_STRING || strlen(tmp) == 0
|| isNAstring(tmp, 1, &data) || isBlankString(tmp))
COMPLEX(rval)[i].r = COMPLEX(rval)[i].i = NA_REAL;
else {
COMPLEX(rval)[i] = strtoc(tmp, &endp, FALSE, &data);
if (!isBlankString(endp)) {
typeInfo.iscomplex = FALSE;
/* this is not needed, unless other cases are added */
ruleout_types(tmp, &typeInfo, &data);
break;
}
}
}
if(typeInfo.iscomplex) done = TRUE; else UNPROTECT(1);
}
if (!done) {
if (asIs) {
PROTECT(rval = duplicate(cvec));
for (i = 0; i < len; i++)
if(isNAstring(CHAR(STRING_ELT(rval, i)), 1, &data))
SET_STRING_ELT(rval, i, NA_STRING);
}
else {
PROTECT(dup = duplicated(cvec, FALSE));
j = 0;
for (i = 0; i < len; i++) {
/* <NA> is never to be a level here */
if (STRING_ELT(cvec, i) == NA_STRING) continue;
if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING_ELT(cvec, i)), 1, &data))
j++;
}
PROTECT(levs = allocVector(STRSXP,j));
j = 0;
for (i = 0; i < len; i++) {
if (STRING_ELT(cvec, i) == NA_STRING) continue;
if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING_ELT(cvec, i)), 1, &data))
SET_STRING_ELT(levs, j++, STRING_ELT(cvec, i));
}
/* We avoid an allocation by reusing dup,
* a LGLSXP of the right length
*/
rval = dup;
SET_TYPEOF(rval, INTSXP);
/* put the levels in lexicographic order */
sortVector(levs, FALSE);
PROTECT(a = matchE(levs, cvec, NA_INTEGER, env));
for (i = 0; i < len; i++)
INTEGER(rval)[i] = INTEGER(a)[i];
setAttrib(rval, R_LevelsSymbol, levs);
PROTECT(a = mkString("factor"));
setAttrib(rval, R_ClassSymbol, a);
UNPROTECT(3);
}
}
setAttrib(rval, R_DimSymbol, dims);
setAttrib(rval, isArray(cvec) ? R_DimNamesSymbol : R_NamesSymbol, names);
UNPROTECT(3);
return rval;
}
