SEXP FLQuant_pointer::Return(void)
{
SEXP Quant, v,
d1, d2, d3, d4, d5, d6,
dim, dimnames, names;
int j, iAge, iYear, iUnit, iArea, iSeason, iIter;
//Create new S4 object
PROTECT(Quant = NEW_OBJECT(MAKE_CLASS("FLQuant")));
//Create array for slot
//Set dimensions of array
PROTECT(dim = allocVector(INTSXP, 6));
INTEGER(dim)[0] = maxquant()-minquant() +1;
INTEGER(dim)[1] = maxyr() -minyr() +1;
INTEGER(dim)[2] = nunits();
INTEGER(dim)[3] = nseasons();
INTEGER(dim)[4] = nareas();
INTEGER(dim)[5] = niters();
//allocate memory
PROTECT(v = Rf_allocArray(REALSXP, dim));
//Create dimension names
PROTECT(dimnames = allocVector(VECSXP, 6));
PROTECT(d1 = allocVector(INTSXP, maxquant()-minquant() +1));
for (iAge=minquant(),j=0; iAge<=maxquant(); iAge++, j++)
INTEGER(d1)[j] = iAge;
SET_VECTOR_ELT(dimnames, 0, d1);
PROTECT(d2 = allocVector(INTSXP, maxyr()-minyr()+1));
for (iYear=minyr(), j=0; iYear<=maxyr(); iYear++, j++)
INTEGER(d2)[j] = iYear;
SET_VECTOR_ELT(dimnames, 1, d2);
if (nunits()==1)
{
PROTECT(d3 = allocVector(STRSXP, nunits()));
SET_STRING_ELT(d3, 0, mkChar("unique"));
}
else
{
PROTECT(d3 = allocVector(INTSXP, nunits()));
for (iUnit=1, j=0; iUnit<=nunits(); iUnit++, j++)
INTEGER(d3)[j] = iUnit;
}
SET_VECTOR_ELT(dimnames, 2, d3);
if (nseasons()==1)
{
PROTECT(d4 = allocVector(STRSXP, nseasons()));
SET_STRING_ELT(d4, 0, mkChar("all"));
}
else
{
PROTECT(d4 = allocVector(INTSXP, nseasons()));
for (iSeason=1, j=0; iSeason<=nseasons(); iSeason++, j++)
INTEGER(d4)[j] = iSeason;
}
SET_VECTOR_ELT(dimnames, 3, d4);
if (nareas()==1)
{
PROTECT(d5 = allocVector(STRSXP, nareas()));
SET_STRING_ELT(d5, 0, mkChar("unique"));
}
else
{
PROTECT(d5 = allocVector(INTSXP, nareas()));
for (iArea=1, j=0; iArea<=nareas(); iArea++, j++)
INTEGER(d5)[j] = iArea;
}
SET_VECTOR_ELT(dimnames, 4, d5);
PROTECT(d6 = allocVector(INTSXP, niters()));
for (iIter=1, j=0; iIter<=niters(); iIter++, j++)
INTEGER(d6)[j] = iIter;
SET_VECTOR_ELT(dimnames, 5, d6);
//Create names for dimensions
PROTECT(names = allocVector(STRSXP, 6));
SET_STRING_ELT(names, 0, mkChar("age"));
SET_STRING_ELT(names, 1, mkChar("year"));
SET_STRING_ELT(names, 2, mkChar("unit"));
SET_STRING_ELT(names, 3, mkChar("season"));
SET_STRING_ELT(names, 4, mkChar("area"));
SET_STRING_ELT(names, 5, mkChar("iter"));
setAttrib(dimnames, R_NamesSymbol, names);
setAttrib(v, R_DimNamesSymbol, dimnames);
//Set data
j=0;
for(iIter = 1; iIter <= niters(); iIter++)
for (iArea = 1; iArea <= nareas(); iArea++)
for (iSeason = 1; iSeason <= nseasons(); iSeason++)
for (iUnit = 1; iUnit <= nunits(); iUnit++)
for (iYear = minyr(); iYear <= maxyr(); iYear++)
for (iAge = minquant(); iAge <= maxquant(); iAge++)
REAL(v)[j++] = data[i(iAge,iYear,iUnit,iSeason,iArea,iIter)];
//Set slot
Quant = R_do_slot_assign(Quant, install(".Data"), v);
UNPROTECT(11);
return Quant;
}
// adapted from https://github.com/armgong/RJulia/blob/master/src/R_Julia.c
SEXP jr_array(jl_value_t *tt)
{
SEXP ans = R_NilValue;
//get Julia dims and set R array Dims
int len = jl_array_len(tt);
if (len == 0)
return ans;
jl_datatype_t *ty = jl_array_eltype(tt);
int ndims = jl_array_ndims(tt);
SEXP dims;
PROTECT(dims = Rf_allocVector(INTSXP, ndims));
for (size_t i = 0; i < ndims; i++)
INTEGER(dims)[i] = jl_array_dim(tt, i);
UNPROTECT(1);
// again, float64, int32 and int64 are most common
if (ty == jl_float64_type)
{
double *p = (double *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);;
}
else if (ty == jl_int32_type)
{
int32_t *p = (int32_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_int64_type)
{
int is_int32 = 1;
int64_t *p = (int64_t *) jl_array_data(tt);
for (size_t i=0;i<len;i++)
{
if (p[i]>INT32_MAX || p[i]<INT32_MIN)
{
is_int32 = 0;
break;
}
}
if (is_int32)
{
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else
{
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);
}
}
else if (ty == jl_bool_type)
{
bool *p = (bool *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(LGLSXP, dims));
for (size_t i = 0; i < len; i++)
LOGICAL(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_int8_type)
{
int8_t *p = (int8_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_uint8_type)
{
uint8_t *p = (uint8_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_int16_type)
{
int16_t *p = (int16_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_uint16_type)
{
uint16_t *p = (uint16_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_uint32_type)
{
int is_int32 = 1;
uint32_t *p = (uint32_t *) jl_array_data(tt);
for (size_t i=0;i<len;i++)
{
if (p[i]>INT32_MAX || p[i]<INT32_MIN)
{
is_int32 = 0;
break;
}
}
if (is_int32)
{
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else
{
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);
}
}
else if (ty == jl_uint64_type)
{
int is_int32 = 1;
uint64_t *p = (uint64_t *) jl_array_data(tt);
for (size_t i=0;i<len;i++)
{
if (p[i]>INT32_MAX || p[i]<INT32_MIN)
{
is_int32 = 0;
break;
}
}
if (is_int32)
{
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else
{
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);
}
}
//double
else if (ty == jl_float32_type)
{
float *p = (float *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);;
}
//utf8 string
else if (ty == jl_utf8_string_type)
{
PROTECT(ans = Rf_allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
SET_STRING_ELT(ans, i, Rf_mkCharCE(jl_string_data(jl_cellref(tt, i)), CE_UTF8));
UNPROTECT(1);
}
else if (ty == jl_ascii_string_type)
{
PROTECT(ans = Rf_allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
SET_STRING_ELT(ans, i, Rf_mkChar(jl_string_data(jl_cellref(tt, i))));
UNPROTECT(1);
}
return ans;
}
