static jl_value_t *R_Julia_MD_NA_Factor(SEXP Var, const char *VarName) { SEXP levels = getAttrib(Var, R_LevelsSymbol); if (levels == R_NilValue) return jl_nothing; //create string array for levels in julia jl_array_t *ret1 = jl_alloc_array_1d(jl_apply_array_type(jl_ascii_string_type, 1), LENGTH(levels)); jl_value_t **retData1 = jl_array_data(ret1); for (size_t i = 0; i < jl_array_len(ret1); i++) if (!IS_ASCII(Var)) retData1[i] = jl_cstr_to_string(translateChar0(STRING_ELT(levels, i))); else retData1[i] = jl_cstr_to_string(CHAR(STRING_ELT(levels, i))); if ((LENGTH(Var)) != 0) { switch (TYPEOF(Var)) { case INTSXP: { jl_array_t *ret = jl_alloc_array_1d(jl_apply_array_type(jl_uint32_type, 1), LENGTH(Var)); JL_GC_PUSH(&ret, &ret1); int *retData = (int *)jl_array_data(ret); for (size_t i = 0; i < jl_array_len(ret); i++) { if (INTEGER(Var)[i] == NA_INTEGER) { //NA in poolarray is 0 retData[i] = 0; } else { retData[i] = INTEGER(Var)[i]; } } JL_GC_POP(); return TransArrayToPoolDataArray(ret, ret1, LENGTH(Var), VarName); break; } default: return (jl_value_t *) jl_nothing; break; }//case end return (jl_value_t *) jl_nothing; }//if length !=0 return (jl_value_t *) jl_nothing; }
const char *EncodeString(SEXP s, int w, int quote, Rprt_adj justify) { int b, b0, i, j, cnt; const char *p; char *q, buf[11]; cetype_t ienc = CE_NATIVE; /* We have to do something like this as the result is returned, and passed on by EncodeElement -- so no way could be end user be responsible for freeing it. However, this is not thread-safe. */ static R_StringBuffer gBuffer = {NULL, 0, BUFSIZE}; R_StringBuffer *buffer = &gBuffer; if (s == NA_STRING) { p = quote ? CHAR(R_print.na_string) : CHAR(R_print.na_string_noquote); cnt = i = (int)(quote ? strlen(CHAR(R_print.na_string)) : strlen(CHAR(R_print.na_string_noquote))); quote = 0; } else { #ifdef Win32 if(WinUTF8out) { ienc = getCharCE(s); if(ienc == CE_UTF8) { p = CHAR(s); i = Rstrlen(s, quote); cnt = LENGTH(s); } else { p = translateChar0(s); if(p == CHAR(s)) { i = Rstrlen(s, quote); cnt = LENGTH(s); } else { cnt = strlen(p); i = Rstrwid(p, cnt, CE_NATIVE, quote); } ienc = CE_NATIVE; } } else #endif { if(IS_BYTES(s)) { p = CHAR(s); cnt = (int) strlen(p); const char *q; char *pp = R_alloc(4*cnt+1, 1), *qq = pp, buf[5]; for (q = p; *q; q++) { unsigned char k = (unsigned char) *q; if (k >= 0x20 && k < 0x80) { *qq++ = *q; if (quote && *q == '"') cnt++; } else { snprintf(buf, 5, "\\x%02x", k); for(j = 0; j < 4; j++) *qq++ = buf[j]; cnt += 3; } } *qq = '\0'; p = pp; i = cnt; } else { p = translateChar(s); if(p == CHAR(s)) { i = Rstrlen(s, quote); cnt = LENGTH(s); } else { cnt = (int) strlen(p); i = Rstrwid(p, cnt, CE_NATIVE, quote); } } } } /* We need enough space for the encoded string, including escapes. Octal encoding turns one byte into four. \u encoding can turn a multibyte into six or ten, but it turns 2/3 into 6, and 4 (and perhaps 5/6) into 10. Let's be wasteful here (the worst case appears to be an MBCS with one byte for an upper-plane Unicode point output as ten bytes, but I doubt that such an MBCS exists: two bytes is plausible). +2 allows for quotes, +6 for UTF_8 escapes. */ q = R_AllocStringBuffer(imax2(5*cnt+8, w), buffer); b = w - i - (quote ? 2 : 0); /* total amount of padding */ if(justify == Rprt_adj_none) b = 0; if(b > 0 && justify != Rprt_adj_left) { b0 = (justify == Rprt_adj_centre) ? b/2 : b; for(i = 0 ; i < b0 ; i++) *q++ = ' '; b -= b0; } if(quote) *q++ = (char) quote; if(mbcslocale || ienc == CE_UTF8) { int j, res; mbstate_t mb_st; wchar_t wc; unsigned int k; /* not wint_t as it might be signed */ #ifndef __STDC_ISO_10646__ Rboolean Unicode_warning = FALSE; #endif if(ienc != CE_UTF8) mbs_init(&mb_st); #ifdef Win32 else if(WinUTF8out) { memcpy(q, UTF8in, 3); q += 3; } #endif for (i = 0; i < cnt; i++) { res = (int)((ienc == CE_UTF8) ? utf8toucs(&wc, p): mbrtowc(&wc, p, MB_CUR_MAX, NULL)); if(res >= 0) { /* res = 0 is a terminator */ k = wc; /* To be portable, treat \0 explicitly */ if(res == 0) {k = 0; wc = L'\0';} if(0x20 <= k && k < 0x7f && iswprint(wc)) { switch(wc) { case L'\\': *q++ = '\\'; *q++ = '\\'; p++; break; case L'\'': case L'"': if(quote == *p) *q++ = '\\'; *q++ = *p++; break; default: for(j = 0; j < res; j++) *q++ = *p++; break; } } else if (k < 0x80) { /* ANSI Escapes */ switch(wc) { case L'\a': *q++ = '\\'; *q++ = 'a'; break; case L'\b': *q++ = '\\'; *q++ = 'b'; break; case L'\f': *q++ = '\\'; *q++ = 'f'; break; case L'\n': *q++ = '\\'; *q++ = 'n'; break; case L'\r': *q++ = '\\'; *q++ = 'r'; break; case L'\t': *q++ = '\\'; *q++ = 't'; break; case L'\v': *q++ = '\\'; *q++ = 'v'; break; case L'\0': *q++ = '\\'; *q++ = '0'; break; default: /* print in octal */ snprintf(buf, 5, "\\%03o", k); for(j = 0; j < 4; j++) *q++ = buf[j]; break; } p++; } else { if(iswprint(wc)) { /* The problem here is that wc may be printable according to the Unicode tables, but it may not be printable on the output device concerned. */ for(j = 0; j < res; j++) *q++ = *p++; } else { #ifndef Win32 # ifndef __STDC_ISO_10646__ Unicode_warning = TRUE; # endif if(k > 0xffff) snprintf(buf, 11, "\\U%08x", k); else #endif snprintf(buf, 11, "\\u%04x", k); j = (int) strlen(buf); memcpy(q, buf, j); q += j; p += res; } i += (res - 1); } } else { /* invalid char */ snprintf(q, 5, "\\x%02x", *((unsigned char *)p)); q += 4; p++; } } #ifndef __STDC_ISO_10646__ if(Unicode_warning) warning(_("it is not known that wchar_t is Unicode on this platform")); #endif } else for (i = 0; i < cnt; i++) { /* ASCII */ if((unsigned char) *p < 0x80) { if(*p != '\t' && isprint((int)*p)) { /* Windows has \t as printable */ switch(*p) { case '\\': *q++ = '\\'; *q++ = '\\'; break; case '\'': case '"': if(quote == *p) *q++ = '\\'; *q++ = *p; break; default: *q++ = *p; break; } } else switch(*p) { /* ANSI Escapes */ case '\a': *q++ = '\\'; *q++ = 'a'; break; case '\b': *q++ = '\\'; *q++ = 'b'; break; case '\f': *q++ = '\\'; *q++ = 'f'; break; case '\n': *q++ = '\\'; *q++ = 'n'; break; case '\r': *q++ = '\\'; *q++ = 'r'; break; case '\t': *q++ = '\\'; *q++ = 't'; break; case '\v': *q++ = '\\'; *q++ = 'v'; break; case '\0': *q++ = '\\'; *q++ = '0'; break; default: /* print in octal */ snprintf(buf, 5, "\\%03o", (unsigned char) *p); for(j = 0; j < 4; j++) *q++ = buf[j]; break; } p++; } else { /* 8 bit char */ #ifdef Win32 /* It seems Windows does not know what is printable! */ *q++ = *p++; #else if(!isprint((int)*p & 0xff)) { /* print in octal */ snprintf(buf, 5, "\\%03o", (unsigned char) *p); for(j = 0; j < 4; j++) *q++ = buf[j]; p++; } else *q++ = *p++; #endif } } #ifdef Win32 if(WinUTF8out && ienc == CE_UTF8) { memcpy(q, UTF8out, 3); q += 3; } #endif if(quote) *q++ = (char) quote; if(b > 0 && justify != Rprt_adj_right) { for(i = 0 ; i < b ; i++) *q++ = ' '; } *q = '\0'; return buffer->data; }
static jl_value_t *R_Julia_MD(SEXP Var, const char *VarName) { if ((LENGTH(Var)) != 0) { jl_tuple_t *dims = RDims_JuliaTuple(Var); switch (TYPEOF( Var)) { case LGLSXP: { jl_array_t *ret = CreateArray(jl_bool_type, jl_tuple_len(dims), dims); JL_GC_PUSH1(&ret); char *retData = (char *)jl_array_data(ret); for (size_t i = 0; i < jl_array_len(ret); i++) retData[i] = LOGICAL(Var)[i]; jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret); return (jl_value_t *) ret; JL_GC_POP(); break; }; case INTSXP: { jl_array_t *ret = CreateArray(jl_int32_type, jl_tuple_len(dims), dims); JL_GC_PUSH1(&ret); int *retData = (int *)jl_array_data(ret); for (size_t i = 0; i < jl_array_len(ret); i++) retData[i] = INTEGER(Var)[i]; jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret); return (jl_value_t *) ret; JL_GC_POP(); break; } case REALSXP: { jl_array_t *ret = CreateArray(jl_float64_type, jl_tuple_len(dims), dims); JL_GC_PUSH1(&ret); double *retData = (double *)jl_array_data(ret); for (size_t i = 0; i < jl_array_len(ret); i++) retData[i] = REAL(Var)[i]; jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret); JL_GC_POP(); return (jl_value_t *) ret; break; } case STRSXP: { jl_array_t *ret; if (!IS_ASCII(Var)) ret = CreateArray(jl_utf8_string_type, jl_tuple_len(dims), dims); else ret = CreateArray(jl_ascii_string_type, jl_tuple_len(dims), dims); JL_GC_PUSH1(&ret); jl_value_t **retData = jl_array_data(ret); for (size_t i = 0; i < jl_array_len(ret); i++) if (!IS_ASCII(Var)) retData[i] = jl_cstr_to_string(translateChar0(STRING_ELT(Var, i))); else retData[i] = jl_cstr_to_string(CHAR(STRING_ELT(Var, i))); jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret); JL_GC_POP(); return (jl_value_t *) ret; break; } case VECSXP: { char eltcmd[eltsize]; jl_tuple_t *ret = jl_alloc_tuple(length(Var)); JL_GC_PUSH1(&ret); for (int i = 0; i < length(Var); i++) { snprintf(eltcmd, eltsize, "%selement%d", VarName, i); jl_tupleset(ret, i, R_Julia_MD(VECTOR_ELT(Var, i), eltcmd)); } jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret); JL_GC_POP(); return (jl_value_t *) ret; } default: { return (jl_value_t *) jl_nothing; } break; } return (jl_value_t *) jl_nothing; } return (jl_value_t *) jl_nothing; }
static jl_value_t *R_Julia_MD_NA(SEXP Var, const char *VarName) { if ((LENGTH(Var)) != 0) { jl_tuple_t *dims = RDims_JuliaTuple(Var); switch (TYPEOF(Var)) { case LGLSXP: { jl_array_t *ret = CreateArray(jl_bool_type, jl_tuple_len(dims), dims); jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims); JL_GC_PUSH(&ret, &ret1); char *retData = (char *)jl_array_data(ret); bool *retData1 = (bool *)jl_array_data(ret1); for (size_t i = 0; i < jl_array_len(ret); i++) { if (LOGICAL(Var)[i] == NA_LOGICAL) { retData[i] = 1; retData1[i] = true; } else { retData[i] = LOGICAL(Var)[i]; retData1[i] = false; } } JL_GC_POP(); return TransArrayToDataArray(ret, ret1, VarName); break; }; case INTSXP: { jl_array_t *ret = CreateArray(jl_int32_type, jl_tuple_len(dims), dims); jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims); JL_GC_PUSH(&ret, &ret1); int *retData = (int *)jl_array_data(ret); bool *retData1 = (bool *)jl_array_data(ret1); for (size_t i = 0; i < jl_array_len(ret); i++) { if (INTEGER(Var)[i] == NA_INTEGER) { retData[i] = 999; retData1[i] = true; } else { retData[i] = INTEGER(Var)[i]; retData1[i] = false; } } JL_GC_POP(); return TransArrayToDataArray(ret, ret1, VarName); break; } case REALSXP: { jl_array_t *ret = CreateArray(jl_float64_type, jl_tuple_len(dims), dims); jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims); JL_GC_PUSH(&ret, &ret1); double *retData = (double *)jl_array_data(ret); bool *retData1 = (bool *)jl_array_data(ret1); for (size_t i = 0; i < jl_array_len(ret); i++) { if (ISNAN(REAL(Var)[i])) { retData[i] = 999.01; retData1[i] = true; } else { retData[i] = REAL(Var)[i]; retData1[i] = false; } } JL_GC_POP(); return TransArrayToDataArray(ret, ret1, VarName); break; } case STRSXP: { jl_array_t *ret; if (!IS_ASCII(Var)) ret = CreateArray(jl_utf8_string_type, jl_tuple_len(dims), dims); else ret = CreateArray(jl_ascii_string_type, jl_tuple_len(dims), dims); jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims); JL_GC_PUSH(&ret, &ret1); jl_value_t **retData = jl_array_data(ret); bool *retData1 = (bool *)jl_array_data(ret1); for (size_t i = 0; i < jl_array_len(ret); i++) { if (STRING_ELT(Var, i) == NA_STRING) { retData[i] = jl_cstr_to_string("999"); retData1[i] = true; } else { if (!IS_ASCII(Var)) retData[i] = jl_cstr_to_string(translateChar0(STRING_ELT(Var, i))); else retData[i] = jl_cstr_to_string(CHAR(STRING_ELT(Var, i))); retData1[i] = false; } } JL_GC_POP(); return TransArrayToDataArray(ret, ret1, VarName); break; } default: return (jl_value_t *) jl_nothing; break; }//case end return (jl_value_t *) jl_nothing; }//if length !=0 return (jl_value_t *) jl_nothing; }