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