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;
}
static jl_value_t *from_td_val(td_val_t *v)
{
td_tag_t tag = td_typeof(v);
switch (tag) {
case TD_INT8:
return jl_box_int8(td_int8(v));
case TD_UINT8:
return jl_box_uint8(td_uint8(v));
case TD_INT16:
return jl_box_int16(td_int16(v));
case TD_UINT16:
return jl_box_uint16(td_uint16(v));
case TD_INT32:
return jl_box_int32(td_int32(v));
case TD_UINT32:
return jl_box_uint32(td_uint32(v));
case TD_INT64:
return jl_box_int64(td_int64(v));
case TD_UINT64:
return jl_box_uint64(td_uint64(v));
case TD_FLOAT:
return jl_box_float32(td_float(v));
case TD_DOUBLE:
return jl_box_float64(td_double(v));
case TD_UTF8:
return jl_pchar_to_string(td_dataptr(v), td_length(v));
case TD_ARRAY:
return (jl_value_t*)
jl_ptr_to_array_1d((jl_value_t*)jl_apply_array_type((jl_datatype_t*)td_type_to_jl(td_eltype(v)), 1),
td_dataptr(v), td_length(v), 0);
default:
return jl_nothing;
}
}
int square(double a[],double b[])
{
// Init Julia
jl_init_with_image("/Users/fgans/julia/julia-4d1b751dda/lib/julia", "sys.ji");
JL_SET_STACK_BASE;
// Define Array Type for 1D Array
jl_value_t* array_type = jl_apply_array_type(jl_float64_type, 1);
// Connect C-Arrays to julia Arrays
jl_array_t *a_jl = jl_ptr_to_array_1d(array_type, a, 1, 0);
jl_array_t *b_jl = jl_ptr_to_array_1d(array_type, b, 1, 0);
// Load julia code
jl_eval_string("include(\"square.jl\")");
// Get function
jl_function_t *func = jl_get_function(jl_main_module, "square");
if (func==NULL) {
printf("Function not found!\n");
return -1;
}
// Apply function
jl_call2(func, (jl_value_t*)a_jl,(jl_value_t*)b_jl);
if (jl_exception_occurred()) printf("%s \n", jl_typeof_str(jl_exception_occurred()));
return 0;
}
ValueIfNotPtrArray<T> boxArray(T* data, size_t size)
{
log("boxArray(T*) - jl_ptr_to_array_1d");
jl_datatype_t* dataType = TypeTraits<UnqualifiedType<T>>::dataType();
JULIACPP_ASSERT(dataType != nullptr, "Data type not supported.");
jl_value_t* arrayType = jl_apply_array_type(dataType, 1);
jl_array_t* array = jl_ptr_to_array_1d(arrayType, data, size, 0);
return (jl_value_t*)array;
}
static jl_array_t *jl_alloc_int_1d(size_t np, size_t len)
{
jl_value_t *ty;
if (np < 0xFF) {
ty = jl_array_uint8_type;
}
else if (np < 0xFFFF) {
static jl_value_t *int16 = NULL;
if (int16 == NULL)
int16 = jl_apply_array_type(jl_uint16_type, 1);
ty = int16;
}
else {
assert(np < 0x7FFFFFFF);
static jl_value_t *int32 = NULL;
if (int32 == NULL)
int32 = jl_apply_array_type(jl_uint32_type, 1);
ty = int32;
}
jl_array_t *a = jl_alloc_array_1d(ty, len);
memset(a->data, 0, len * a->elsize);
return a;
}
ValueIfNotPtrArray<T> boxArray(const T* data, size_t size)
{
log("boxArray(const T*) - jl_alloc_array_1d and memcpy");
jl_datatype_t* dataType = TypeTraits<UnqualifiedType<T>>::dataType();
JULIACPP_ASSERT(dataType != nullptr, "Data type not supported.");
jl_value_t* arrayType = jl_apply_array_type(dataType, 1);
jl_array_t* array = jl_alloc_array_1d(arrayType, size);
std::memcpy(jl_array_data(array), data, sizeof(T) * size);
return (jl_value_t*)array;
}
CXX_WRAP_EXPORT jl_array_t* gc_protected()
{
static jl_array_t* m_arr = nullptr;
if (m_arr == nullptr)
{
#if JULIA_VERSION_MAJOR == 0 && JULIA_VERSION_MINOR > 4
jl_value_t* array_type = jl_apply_array_type(jl_any_type, 1);
m_arr = jl_alloc_array_1d(array_type, 0);
#else
m_arr = jl_alloc_cell_1d(0);
#endif
jl_set_const(g_cxx_wrap_module, jl_symbol("_gc_protected"), (jl_value_t*)m_arr);
}
return m_arr;
}
void juliaProblem::EucHessianEta(Variable *x, Vector *etax, Vector *exix) const
{
// x->Print("cpp hf x");//---
// etax->Print("cpp hf etax");//---
jl_value_t* array_type = jl_apply_array_type(jl_float64_type, 1);
double *xptr = x->ObtainWritePartialData();
jl_array_t *arrx = jl_ptr_to_array_1d(array_type, xptr, x->Getlength(), 0);
double *etaxptr = etax->ObtainWritePartialData();
jl_array_t *arretax = jl_ptr_to_array_1d(array_type, etaxptr, etax->Getlength(), 0);
jl_array_t *arrtmp = nullptr;
if(x->TempDataExist(("Tmp")))
{
const SharedSpace *Tmp = x->ObtainReadTempData("Tmp");
// Tmp->Print("cpp hf inTmp");//---
const double *tmpptr = Tmp->ObtainReadData();
arrtmp = jl_ptr_to_array_1d(array_type, const_cast<double *> (tmpptr), Tmp->Getlength(), 0);
} else
{
arrtmp = jl_ptr_to_array_1d(array_type, nullptr, 0, 0);
}
jl_value_t *retresult = jl_call3(jl_Hess, (jl_value_t *) arrx, (jl_value_t *) arrtmp, (jl_value_t *) arretax);
jl_array_t *jl_exix = (jl_array_t *) jl_get_nth_field(retresult, 0);
jl_array_t *outtmp = (jl_array_t *) jl_get_nth_field(retresult, 1);
if(jl_array_len(jl_exix) != etax->Getlength())
{
std::cout << "error: the size of the action of the Hessian is not correct!" << std::endl;
exit(EXIT_FAILURE);
}
integer exixlen = exix->Getlength();
double *exixptr = exix->ObtainWriteEntireData();
dcopy_(&exixlen, (double*)jl_array_data(jl_exix), &GLOBAL::IONE, exixptr, &GLOBAL::IONE);
// exix->Print("cpp hf exix:");//---
integer outtmplen = jl_array_len(outtmp);
if(outtmplen != 0)
{
SharedSpace *sharedouttmp = new SharedSpace(1, outtmplen);
double *outtmpptr = sharedouttmp->ObtainWriteEntireData();
dcopy_(&outtmplen, (double*)jl_array_data(outtmp), &GLOBAL::IONE, outtmpptr, &GLOBAL::IONE);
x->RemoveFromTempData("Tmp");
x->AddToTempData("Tmp", sharedouttmp);
}
};
ValueIfPtrArray<T> boxArray(const T* data, size_t size)
{
log("boxArray(const T*) - jl_alloc_array_1d and unbox per element");
jl_datatype_t* dataType = TypeTraits<UnqualifiedType<T>>::dataType();
JULIACPP_ASSERT(dataType != nullptr, "Data type not supported.");
jl_value_t* arrayType = jl_apply_array_type(dataType, 1);
jl_array_t* array = jl_alloc_array_1d(arrayType, size);
jl_value_t** arrayData = (jl_value_t**)jl_array_data(array);
for (size_t i = 0; i < size; i++)
{
arrayData[i] = box(data[i]);
}
return (jl_value_t*)array;
}
double juliaProblem::f(Variable *x) const
{
// x->Print("cpp f x");//---
jl_value_t* array_type = jl_apply_array_type(jl_float64_type, 1);
double *xptr = x->ObtainWritePartialData();
jl_array_t *arrx = jl_ptr_to_array_1d(array_type, xptr, x->Getlength(), 0);
jl_array_t *arrtmp = nullptr;
if(x->TempDataExist(("Tmp")))
{
const SharedSpace *Tmp = x->ObtainReadTempData("Tmp");
const double *tmpptr = Tmp->ObtainReadData();
arrtmp = jl_ptr_to_array_1d(array_type, const_cast<double *> (tmpptr), Tmp->Getlength(), 0);
} else
{
arrtmp = jl_ptr_to_array_1d(array_type, nullptr, 0, 0);
}
jl_value_t *retresult = jl_call2(jl_f, (jl_value_t *) arrx, (jl_value_t *) arrtmp);
jl_get_nth_field(retresult, 0);
jl_value_t *fx = jl_get_nth_field(retresult, 0);
jl_array_t *outtmp = (jl_array_t *) jl_get_nth_field(retresult, 1);
integer outtmplen = jl_array_len(outtmp);
SharedSpace *sharedouttmp = new SharedSpace(1, outtmplen);
double *outtmpptr = sharedouttmp->ObtainWriteEntireData();
dcopy_(&outtmplen, (double*)jl_array_data(outtmp), &GLOBAL::IONE, outtmpptr, &GLOBAL::IONE);
// sharedouttmp->Print("cpp f tmp:");//----
x->RemoveFromTempData("Tmp");
x->AddToTempData("Tmp", sharedouttmp);
if(jl_is_float64(fx))
{
double result = jl_unbox_float64(fx);
// std::cout << "cpp f fx:" << result << std::endl;//-----
return result;
}
std::cout << "Error: The objectve function must return a number of double precision!" << std::endl;
exit(EXIT_FAILURE);
};
Array(jl_datatype_t* applied_type, const size_t n = 0)
{
jl_value_t* array_type = jl_apply_array_type(applied_type, 1);
m_array = jl_alloc_array_1d(array_type, n);
}
Array(const size_t n = 0)
{
jl_value_t* array_type = jl_apply_array_type(static_type_mapping<ValueT>::julia_type(), 1);
m_array = jl_alloc_array_1d(array_type, n);
}
static jl_datatype_t* julia_type() { return (jl_datatype_t*)jl_apply_array_type(static_type_mapping<T>::julia_type(), Dim); }
int main()
{
jl_init(NULL);
{
// Simple running Julia code
jl_eval_string("println(sqrt(2.0))");
}
{
// Accessing the return value
jl_value_t *ret = jl_eval_string("sqrt(2.0)");
if (jl_is_float64(ret)) {
double retDouble = jl_unbox_float64(ret);
printf("sqrt(2.0) in C: %e\n", retDouble);
}
}
{
// Same as above but with function handle (more flexible)
jl_function_t *func = jl_get_function(jl_base_module, "sqrt");
jl_value_t* argument = jl_box_float64(2.0);
jl_value_t* ret = jl_call1(func, argument);
if (jl_is_float64(ret)) {
double retDouble = jl_unbox_float64(ret);
printf("sqrt(2.0) in C: %e\n", retDouble);
}
}
{
// 1D arrays
jl_value_t* array_type = jl_apply_array_type( jl_float64_type, 1 );
jl_array_t* x = jl_alloc_array_1d(array_type , 10);
JL_GC_PUSH1(&x);
double* xData = jl_array_data(x);
size_t i;
for(i=0; i<jl_array_len(x); i++)
xData[i] = i;
jl_function_t *func = jl_get_function(jl_base_module, "reverse!");
jl_call1(func, (jl_value_t*) x);
printf("x = [");
for(i=0; i<jl_array_len(x); i++)
printf("%e ", xData[i]);
printf("]\n");
JL_GC_POP();
}
{
// define julia function and call it
jl_eval_string("my_func(x) = 2*x");
jl_function_t *func = jl_get_function(jl_current_module, "my_func");
jl_value_t* arg = jl_box_float64(5.0);
double ret = jl_unbox_float64(jl_call1(func, arg));
printf("my_func(5.0) = %f\n", ret);
}
{
// call c function
jl_eval_string("println( ccall( :my_c_sqrt, Float64, (Float64,), 2.0 ) )");
}
{
// check for exceptions
jl_eval_string("this_function_does_not_exist()");
if (jl_exception_occurred()) {
jl_show(jl_stderr_obj(), jl_exception_occurred());
jl_printf(jl_stderr_stream(), "\n");
}
}
jl_atexit_hook();
return 0;
}
static jl_array_t *CreateArray(jl_datatype_t *type, size_t ndim, jl_tuple_t *dims)
{
return jl_new_array(jl_apply_array_type(type, ndim), dims);;
}
