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